/[cvs]/stack/stack.c
ViewVC logotype

Diff of /stack/stack.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.93 by masse, Fri Mar 8 16:09:30 2002 UTC revision 1.109 by masse, Thu Mar 14 10:39:11 2002 UTC
# Line 20  Line 20 
20               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
21  */  */
22    
23    #define CAR(X) X->content.c->car
24    #define CDR(X) X->content.c->cdr
25    
26  /* printf, sscanf, fgets, fprintf, fopen, perror */  /* printf, sscanf, fgets, fprintf, fopen, perror */
27  #include <stdio.h>  #include <stdio.h>
28  /* exit, EXIT_SUCCESS, malloc, free */  /* exit, EXIT_SUCCESS, malloc, free */
# Line 34  Line 37 
37  #include <unistd.h>  #include <unistd.h>
38  /* EX_NOINPUT, EX_USAGE */  /* EX_NOINPUT, EX_USAGE */
39  #include <sysexits.h>  #include <sysexits.h>
40    /* assert */
41    #include <assert.h>
42    
43    #ifdef __linux__
44  /* mtrace, muntrace */  /* mtrace, muntrace */
45  #include <mcheck.h>  #include <mcheck.h>
46  /* ioctl */  /* ioctl */
47  #include <sys/ioctl.h>  #include <sys/ioctl.h>
48  /* KDMKTONE */  /* KDMKTONE */
49  #include <linux/kd.h>  #include <linux/kd.h>
50    #endif /* __linux__ */
51    
52  #include "stack.h"  #include "stack.h"
53    
# Line 48  void init_env(environment *env) Line 56  void init_env(environment *env)
56  {  {
57    int i;    int i;
58    
59    env->gc_limit= 20;    env->gc_limit= 400000;
60    env->gc_count= 0;    env->gc_count= 0;
61    env->gc_ref= NULL;    env->gc_ref= NULL;
   env->gc_protect= NULL;  
62    
63    env->head= NULL;    env->head= NULL;
64    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
# Line 63  void init_env(environment *env) Line 70  void init_env(environment *env)
70    env->interactive= 1;    env->interactive= 1;
71  }  }
72    
73  void printerr(const char* in_string) {  void printerr(const char* in_string)
74    {
75    fprintf(stderr, "Err: %s\n", in_string);    fprintf(stderr, "Err: %s\n", in_string);
76  }  }
77    
78  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
79  extern void toss(environment *env)  extern void toss(environment *env)
80  {  {
81    stackitem *temp= env->head;    if(env->head==NULL) {
   
   if((env->head)==NULL) {  
82      printerr("Too Few Arguments");      printerr("Too Few Arguments");
83      env->err= 1;      env->err= 1;
84      return;      return;
85    }    }
86        
87    env->head= env->head->next;   /* Remove the top stack item */    env->head= CDR(env->head); /* Remove the top stack item */
   free(temp);                   /* Free the old top stack item */  
   
   gc_init(env);  
88  }  }
89    
90  /* Returns a pointer to a pointer to an element in the hash table. */  /* Returns a pointer to a pointer to an element in the hash table. */
# Line 113  symbol **hash(hashtbl in_hashtbl, const Line 116  symbol **hash(hashtbl in_hashtbl, const
116    }    }
117  }  }
118    
119  value* new_val(environment *env) {  /* Create new value */
120    value* new_val(environment *env)
121    {
122    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
123    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
124    
125    nval->content.ptr= NULL;    nval->content.ptr= NULL;
126      nval->type= integer;
127    
128    nitem->item= nval;    nitem->item= nval;
129    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
   env->gc_ref= nitem;  
130    
131    env->gc_count++;    env->gc_ref= nitem;
132    
133    protect(env, nval);    env->gc_count += sizeof(value);
134    gc_init(env);    nval->gc.flag.mark= 0;
135    unprotect(env);    nval->gc.flag.protect= 0;
136    
137    return nval;    return nval;
138  }  }
139    
140  void gc_mark(value *val) {  /* Mark values recursively.
141    stackitem *iterator;     Marked values are not collected by the GC. */
142    inline void gc_mark(value *val)
143    if(val==NULL || val->gc_garb==0)  {
144      if(val==NULL || val->gc.flag.mark)
145      return;      return;
146    
147    val->gc_garb= 0;    val->gc.flag.mark= 1;
   
   if(val->type==list) {  
     iterator= val->content.ptr;  
148    
149      while(iterator!=NULL) {    if(val->type==tcons) {
150        gc_mark(iterator->item);      gc_mark(CAR(val));
151        iterator= iterator->next;      gc_mark(CDR(val));
     }  
152    }    }
153  }  }
154    
155  extern void gc_init(environment *env) {  inline void gc_maybe(environment *env)
156    stackitem *new_head= NULL, *titem, *iterator;  {
157      if(env->gc_count < env->gc_limit)
158        return;
159      else
160        return gc_init(env);
161    }
162    
163    /* Start GC */
164    extern void gc_init(environment *env)
165    {
166      stackitem *new_head= NULL, *titem;
167      cons *iterator;
168    symbol *tsymb;    symbol *tsymb;
169    int i;    int i;
170    
171    if(env->gc_count < env->gc_limit)    if(env->interactive)
172      return;      printf("Garbage collecting.");
173    
174    /* Garb by default */    /* Mark values on stack */
175    iterator= env->gc_ref;    gc_mark(env->head);
   while(iterator!=NULL) {  
     iterator->item->gc_garb= 1;  
     iterator= iterator->next;  
   }  
176    
177    /* Mark protected values */    if(env->interactive)
178    iterator= env->gc_protect;      printf(".");
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
179    
   /* Mark values in stack */  
   iterator= env->head;  
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
180    
181    /* Mark values in hashtable */    /* Mark values in hashtable */
182    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++)
183      tsymb= env->symbols[i];      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
184      while(tsymb!=NULL) {        if (tsymb->val != NULL)
185        gc_mark(tsymb->val);          gc_mark(tsymb->val);
186        tsymb= tsymb->next;  
187      }  
188    }    if(env->interactive)
189        printf(".");
190    
191    
192    env->gc_count= 0;    env->gc_count= 0;
193    
194    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
   while(env->gc_ref!=NULL) {  
195    
196      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
197    
198        /* Remove content */        if(env->gc_ref->item->type==string) /* Remove content */
       switch(env->gc_ref->item->type) {  
       case string:  
199          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
200          break;  
       case list:  
         while(env->gc_ref->item->content.ptr!=NULL) {  
           titem= env->gc_ref->item->content.ptr;  
           env->gc_ref->item->content.ptr= titem->next;  
           free(titem);  
         }  
         break;  
       default:  
         break;  
       }  
201        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
202        titem= env->gc_ref->next;        titem= env->gc_ref->next;
203        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
204        env->gc_ref= titem;        env->gc_ref= titem;
205      } else {                    /* Save */        continue;
206        titem= env->gc_ref->next;      }
207        env->gc_ref->next= new_head;  
208        new_head= env->gc_ref;      /* Keep values */    
209        env->gc_ref= titem;      env->gc_count += sizeof(value);
210        env->gc_count++;      if(env->gc_ref->item->type==string)
211      }        env->gc_count += strlen(env->gc_ref->item->content.ptr);
212        
213        titem= env->gc_ref->next;
214        env->gc_ref->next= new_head;
215        new_head= env->gc_ref;
216        new_head->item->gc.flag.mark= 0;
217        env->gc_ref= titem;
218    }    }
219    
220    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
221        env->gc_limit= env->gc_count*2;
222    
223    env->gc_ref= new_head;    env->gc_ref= new_head;
224    
225      if(env->interactive)
226        printf("done\n");
227    
228  }  }
229    
230  void protect(environment *env, value *val)  /* Protect values from GC */
231    void protect(value *val)
232  {  {
233    stackitem *new_item= malloc(sizeof(stackitem));    if(val==NULL || val->gc.flag.protect)
234    new_item->item= val;      return;
235    new_item->next= env->gc_protect;  
236    env->gc_protect= new_item;    val->gc.flag.protect= 1;
237    
238      if(val->type==tcons) {
239        protect(CAR(val));
240        protect(CDR(val));
241      }
242  }  }
243    
244  void unprotect(environment *env)  /* Unprotect values from GC */
245    void unprotect(value *val)
246  {  {
247    stackitem *temp= env->gc_protect;    if(val==NULL || !(val->gc.flag.protect))
248    env->gc_protect= env->gc_protect->next;      return;
249    free(temp);  
250      val->gc.flag.protect= 0;
251    
252      if(val->type==tcons) {
253        unprotect(CAR(val));
254        unprotect(CDR(val));
255      }
256  }  }
257    
258  /* Push a value onto the stack */  /* Push a value onto the stack */
259  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
260  {  {
261    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
262    new_item->item= val;  
263    new_item->next= env->head;    new_value->content.c= malloc(sizeof(cons));
264    env->head= new_item;    assert(new_value->content.c!=NULL);
265      new_value->type= tcons;
266      CAR(new_value)= val;
267      CDR(new_value)= env->head;
268      env->head= new_value;
269  }  }
270    
271  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
272  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
273  {  {
274    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 262  void push_int(environment *env, int in_v Line 279  void push_int(environment *env, int in_v
279    push_val(env, new_value);    push_val(env, new_value);
280  }  }
281    
282    /* Push a floating point number onto the stack */
283  void push_float(environment *env, float in_val)  void push_float(environment *env, float in_val)
284  {  {
285    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 276  void push_float(environment *env, float Line 294  void push_float(environment *env, float
294  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
295  {  {
296    value *new_value= new_val(env);    value *new_value= new_val(env);
297      int length= strlen(in_string)+1;
298    
299    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
300      env->gc_count += length;
301    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
302    new_value->type= string;    new_value->type= string;
303    
# Line 285  void push_cstring(environment *env, cons Line 305  void push_cstring(environment *env, cons
305  }  }
306    
307  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
308  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
309    {
310    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
311    char *new_string, *current;    char *new_string, *current;
312    
# Line 303  char *mangle_str(const char *old_string) Line 324  char *mangle_str(const char *old_string)
324    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
325  }  }
326    
327  extern void mangle(environment *env){  extern void mangle(environment *env)
328    {
329    char *new_string;    char *new_string;
330    
331    if((env->head)==NULL) {    if(env->head==NULL) {
332      printerr("Too Few Arguments");      printerr("Too Few Arguments");
333      env->err= 1;      env->err= 1;
334      return;      return;
335    }    }
336    
337    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
338      printerr("Bad Argument Type");      printerr("Bad Argument Type");
339      env->err= 2;      env->err= 2;
340      return;      return;
341    }    }
342    
343    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
344        mangle_str((const char *)(CAR(env->head)->content.ptr));
345    
346    toss(env);    toss(env);
347    if(env->err) return;    if(env->err) return;
# Line 342  void push_sym(environment *env, const ch Line 365  void push_sym(environment *env, const ch
365    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
366    
367    new_value= new_val(env);    new_value= new_val(env);
368    protect(env, new_value);    protect(new_value);
369    new_fvalue= new_val(env);    new_fvalue= new_val(env);
370    protect(env, new_fvalue);    protect(new_fvalue);
371    
372    /* The new value is a symbol */    /* The new value is a symbol */
373    new_value->type= symb;    new_value->type= symb;
# Line 372  void push_sym(environment *env, const ch Line 395  void push_sym(environment *env, const ch
395    
396      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
397      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
398      free(mangled);  
399      dlerr= dlerror();      dlerr= dlerror();
400      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
401        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
402        dlerr= dlerror();        dlerr= dlerror();
403      }      }
404    
405      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
406        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
407        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
408        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
409                                           function value */                                           function value */
410      }      }
411    
412        free(mangled);
413    }    }
414    
415    push_val(env, new_value);    push_val(env, new_value);
416    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
417  }  }
418    
419  /* Print newline. */  /* Print newline. */
# Line 396  extern void nl() Line 423  extern void nl()
423  }  }
424    
425  /* Gets the type of a value */  /* Gets the type of a value */
426  extern void type(environment *env){  extern void type(environment *env)
427    {
428    int typenum;    int typenum;
429    
430    if((env->head)==NULL) {    if(env->head==NULL) {
431      printerr("Too Few Arguments");      printerr("Too Few Arguments");
432      env->err=1;      env->err= 1;
433      return;      return;
434    }    }
435    typenum=env->head->item->type;  
436      typenum= CAR(env->head)->type;
437    toss(env);    toss(env);
438    switch(typenum){    switch(typenum){
439    case integer:    case integer:
# Line 422  extern void type(environment *env){ Line 451  extern void type(environment *env){
451    case func:    case func:
452      push_sym(env, "function");      push_sym(env, "function");
453      break;      break;
454    case list:    case tcons:
455      push_sym(env, "list");      push_sym(env, "list");
456      break;      break;
457    }    }
458  }      }    
459    
460  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
461  void print_h(stackitem *stack_head, int noquote)  void print_h(value *stack_head, int noquote)
462  {  {
463    switch(stack_head->item->type) {    switch(CAR(stack_head)->type) {
464    case integer:    case integer:
465      printf("%d", stack_head->item->content.i);      printf("%d", CAR(stack_head)->content.i);
466      break;      break;
467    case tfloat:    case tfloat:
468      printf("%f", stack_head->item->content.f);      printf("%f", CAR(stack_head)->content.f);
469      break;      break;
470    case string:    case string:
471      if(noquote)      if(noquote)
472        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)CAR(stack_head)->content.ptr);
473      else      else
474        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);
475      break;      break;
476    case symb:    case symb:
477      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
478      break;      break;
479    case func:    case func:
480      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
481      break;      break;
482    case list:    case tcons:
483      /* A list is just a stack, so make stack_head point to it */      /* A list is just a stack, so make stack_head point to it */
484      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head= CAR(stack_head);
485      printf("[ ");      printf("[ ");
486      while(stack_head != NULL) {      while(stack_head != NULL) {
487        print_h(stack_head, noquote);        print_h(stack_head, noquote);
488        printf(" ");        printf(" ");
489        stack_head=stack_head->next;        stack_head= CDR(stack_head);
490      }      }
491      printf("]");      printf("]");
492      break;      break;
493    }    }
494  }  }
495    
496  extern void print_(environment *env) {  extern void print_(environment *env)
497    {
498    if(env->head==NULL) {    if(env->head==NULL) {
499      printerr("Too Few Arguments");      printerr("Too Few Arguments");
500      env->err=1;      env->err= 1;
501      return;      return;
502    }    }
503    print_h(env->head, 0);    print_h(env->head, 0);
# Line 482  extern void print(environment *env) Line 512  extern void print(environment *env)
512    toss(env);    toss(env);
513  }  }
514    
515  extern void princ_(environment *env) {  extern void princ_(environment *env)
516    {
517    if(env->head==NULL) {    if(env->head==NULL) {
518      printerr("Too Few Arguments");      printerr("Too Few Arguments");
519      env->err=1;      env->err= 1;
520      return;      return;
521    }    }
522    print_h(env->head, 1);    print_h(env->head, 1);
# Line 500  extern void princ(environment *env) Line 531  extern void princ(environment *env)
531  }  }
532    
533  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
534  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
535  {  {
536    if(stack_head->next != NULL)    if(CDR(stack_head) != NULL)
537      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
538    printf("%ld: ", counter);    printf("%ld: ", counter);
539    print_h(stack_head, 0);    print_h(stack_head, 0);
540    nl();    nl();
# Line 516  extern void printstack(environment *env) Line 547  extern void printstack(environment *env)
547      printf("Stack Empty\n");      printf("Stack Empty\n");
548      return;      return;
549    }    }
550    
551    print_st(env->head, 1);    print_st(env->head, 1);
552  }  }
553    
554  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
555  extern void swap(environment *env)  extern void swap(environment *env)
556  {  {
557    stackitem *temp= env->head;    value *temp= env->head;
558        
559    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
560      printerr("Too Few Arguments");      printerr("Too Few Arguments");
561      env->err=1;      env->err=1;
562      return;      return;
563    }    }
564    
565    env->head= env->head->next;    env->head= CDR(env->head);
566    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
567    env->head->next= temp;    CDR(env->head)= temp;
568  }  }
569    
570  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
571  extern void rot(environment *env)  extern void rot(environment *env)
572  {  {
573    stackitem *temp= env->head;    value *temp= env->head;
574        
575    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
576        || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
577      printerr("Too Few Arguments");      printerr("Too Few Arguments");
578      env->err=1;      env->err= 1;
579      return;      return;
580    }    }
581      
582    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
583    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
584    env->head->next= temp;    CDR(env->head)= temp;
585  }  }
586    
587  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 557  extern void rcl(environment *env) Line 589  extern void rcl(environment *env)
589  {  {
590    value *val;    value *val;
591    
592    if(env->head == NULL) {    if(env->head==NULL) {
593      printerr("Too Few Arguments");      printerr("Too Few Arguments");
594      env->err=1;      env->err= 1;
595      return;      return;
596    }    }
597    
598    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
599      printerr("Bad Argument Type");      printerr("Bad Argument Type");
600      env->err=2;      env->err= 2;
601      return;      return;
602    }    }
603    
604    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
605    if(val == NULL){    if(val == NULL){
606      printerr("Unbound Variable");      printerr("Unbound Variable");
607      env->err=3;      env->err= 3;
608      return;      return;
609    }    }
610    protect(env, val);    protect(val);
611    toss(env);            /* toss the symbol */    toss(env);            /* toss the symbol */
612    if(env->err) return;    if(env->err) return;
613    push_val(env, val); /* Return its bound value */    push_val(env, val); /* Return its bound value */
614    unprotect(env);    unprotect(val);
615  }  }
616    
617  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
# Line 589  extern void eval(environment *env) Line 621  extern void eval(environment *env)
621  {  {
622    funcp in_func;    funcp in_func;
623    value* temp_val;    value* temp_val;
624    stackitem* iterator;    value* iterator;
625    
626   eval_start:   eval_start:
627    
628      gc_maybe(env);
629    
630    if(env->head==NULL) {    if(env->head==NULL) {
631      printerr("Too Few Arguments");      printerr("Too Few Arguments");
632      env->err=1;      env->err= 1;
633      return;      return;
634    }    }
635    
636    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
637      /* if it's a symbol */      /* if it's a symbol */
638    case symb:    case symb:
639      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
640      if(env->err) return;      if(env->err) return;
641      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
642        goto eval_start;        goto eval_start;
643      }      }
644      return;      return;
645    
646      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
647    case func:    case func:
648      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
649      toss(env);      toss(env);
650      if(env->err) return;      if(env->err) return;
651      return in_func(env);      return in_func(env);
652    
653      /* If it's a list */      /* If it's a list */
654    case list:    case tcons:
655      temp_val= env->head->item;      temp_val= CAR(env->head);
656      protect(env, temp_val);      protect(temp_val);
657    
658      toss(env); if(env->err) return;      toss(env); if(env->err) return;
659      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
660            
661      while(iterator!=NULL) {      while(iterator!=NULL) {
662        push_val(env, iterator->item);        push_val(env, CAR(iterator));
663                
664        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
665          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
666          toss(env);          toss(env);
667          if(env->err) return;          if(env->err) return;
668                    
669          if(iterator->next == NULL){          if(CDR(iterator)==NULL){
670            goto eval_start;            goto eval_start;
671          }          }
672          eval(env);          eval(env);
673          if(env->err) return;          if(env->err) return;
674        }        }
675        iterator= iterator->next;        if (CDR(iterator)->type == tcons)
676            iterator= CDR(iterator);
677          else {
678            printerr("Bad Argument Type"); /* Improper list */
679            env->err= 2;
680            return;
681          }
682      }      }
683      unprotect(env);      unprotect(temp_val);
684      return;      return;
685    
686    default:    default:
# Line 649  extern void eval(environment *env) Line 689  extern void eval(environment *env)
689  }  }
690    
691  /* Reverse (flip) a list */  /* Reverse (flip) a list */
692  extern void rev(environment *env){  extern void rev(environment *env)
693    stackitem *old_head, *new_head, *item;  {
694      value *old_head, *new_head, *item;
695    
696    if((env->head)==NULL) {    if(env->head==NULL) {
697      printerr("Too Few Arguments");      printerr("Too Few Arguments");
698      env->err= 1;      env->err= 1;
699      return;      return;
700    }    }
701    
702    if(env->head->item->type!=list) {    if(CAR(env->head)->type!=tcons) {
703      printerr("Bad Argument Type");      printerr("Bad Argument Type");
704      env->err= 2;      env->err= 2;
705      return;      return;
706    }    }
707    
708    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
709    new_head= NULL;    new_head= NULL;
710    while(old_head != NULL){    while(old_head!=NULL) {
711      item= old_head;      item= old_head;
712      old_head= old_head->next;      old_head= CDR(old_head);
713      item->next= new_head;      CDR(item)= new_head;
714      new_head= item;      new_head= item;
715    }    }
716    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
717  }  }
718    
719  /* Make a list. */  /* Make a list. */
720  extern void pack(environment *env)  extern void pack(environment *env)
721  {  {
722    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
723    
724    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(env, pack);  
   
725    if(iterator==NULL    if(iterator==NULL
726       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
727       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
728      temp= NULL;      temp= NULL;
729      toss(env);      toss(env);
730    } else {    } else {
731      /* Search for first delimiter */      /* Search for first delimiter */
732      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
733            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
734            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
735        iterator= iterator->next;        iterator= CDR(iterator);
736            
737      /* Extract list */      /* Extract list */
738      temp= env->head;      temp= env->head;
739      env->head= iterator->next;      env->head= CDR(iterator);
740      iterator->next= NULL;      CDR(iterator)= NULL;
741    
     pack->type= list;  
     pack->content.ptr= temp;  
       
742      if(env->head!=NULL)      if(env->head!=NULL)
743        toss(env);        toss(env);
744    }    }
745    
746    /* Push list */    /* Push list */
747    
748    push_val(env, pack);    push_val(env, temp);
749    rev(env);    rev(env);
   
   unprotect(env);  
750  }  }
751    
752  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
753  extern void expand(environment *env)  extern void expand(environment *env)
754  {  {
755    stackitem *temp, *new_head;    value *temp, *new_head;
756    
757    /* Is top element a list? */    /* Is top element a list? */
758    if(env->head==NULL) {    if(env->head==NULL) {
# Line 728  extern void expand(environment *env) Line 760  extern void expand(environment *env)
760      env->err= 1;      env->err= 1;
761      return;      return;
762    }    }
763    if(env->head->item->type!=list) {  
764      if(CAR(env->head)->type!=tcons) {
765      printerr("Bad Argument Type");      printerr("Bad Argument Type");
766      env->err= 2;      env->err= 2;
767      return;      return;
# Line 740  extern void expand(environment *env) Line 773  extern void expand(environment *env)
773      return;      return;
774    
775    /* The first list element is the new stack head */    /* The first list element is the new stack head */
776    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
777    
778    toss(env);    toss(env);
779    
780    /* Find the end of the list */    /* Find the end of the list */
781    while(temp->next!=NULL)    while(CDR(temp)->content.ptr != NULL) {
782      temp= temp->next;      if (CDR(temp)->type == tcons)
783          temp= CDR(temp);
784        else {
785          printerr("Bad Argument Type"); /* Improper list */
786          env->err= 2;
787          return;
788        }
789      }
790    
791    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
792    temp->next= env->head;    CDR(temp)= env->head;
793    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
794    
795  }  }
# Line 758  extern void expand(environment *env) Line 798  extern void expand(environment *env)
798  extern void eq(environment *env)  extern void eq(environment *env)
799  {  {
800    void *left, *right;    void *left, *right;
   int result;  
801    
802    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
803      printerr("Too Few Arguments");      printerr("Too Few Arguments");
804      env->err= 1;      env->err= 1;
805      return;      return;
806    }    }
807    
808    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
809    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
810    toss(env); toss(env);    toss(env); toss(env);
811    push_int(env, result);  
812      push_int(env, left==right);
813  }  }
814    
815  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 780  extern void not(environment *env) Line 817  extern void not(environment *env)
817  {  {
818    int val;    int val;
819    
820    if((env->head)==NULL) {    if(env->head==NULL) {
821      printerr("Too Few Arguments");      printerr("Too Few Arguments");
822      env->err= 1;      env->err= 1;
823      return;      return;
824    }    }
825    
826    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
827      printerr("Bad Argument Type");      printerr("Bad Argument Type");
828      env->err= 2;      env->err= 2;
829      return;      return;
830    }    }
831    
832    val= env->head->item->content.i;    val= CAR(env->head)->content.i;
833    toss(env);    toss(env);
834    push_int(env, !val);    push_int(env, !val);
835  }  }
# Line 811  extern void def(environment *env) Line 848  extern void def(environment *env)
848    symbol *sym;    symbol *sym;
849    
850    /* Needs two values on the stack, the top one must be a symbol */    /* Needs two values on the stack, the top one must be a symbol */
851    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
852      printerr("Too Few Arguments");      printerr("Too Few Arguments");
853      env->err= 1;      env->err= 1;
854      return;      return;
855    }    }
856    
857    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
858      printerr("Bad Argument Type");      printerr("Bad Argument Type");
859      env->err= 2;      env->err= 2;
860      return;      return;
861    }    }
862    
863    /* long names are a pain */    /* long names are a pain */
864    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
865    
866    /* Bind the symbol to the value */    /* Bind the symbol to the value */
867    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
868    
869    toss(env); toss(env);    toss(env); toss(env);
870  }  }
# Line 835  extern void def(environment *env) Line 872  extern void def(environment *env)
872  /* Quit stack. */  /* Quit stack. */
873  extern void quit(environment *env)  extern void quit(environment *env)
874  {  {
875    long i;    int i;
876    
877    clear(env);    clear(env);
878    
# Line 848  extern void quit(environment *env) Line 885  extern void quit(environment *env)
885    }    }
886    
887    env->gc_limit= 0;    env->gc_limit= 0;
888    gc_init(env);    gc_maybe(env);
889    
890    if(env->free_string!=NULL)    if(env->free_string!=NULL)
891      free(env->free_string);      free(env->free_string);
892        
893    #ifdef __linux__
894    muntrace();    muntrace();
895    #endif
896    
897    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
898  }  }
# Line 881  extern void words(environment *env) Line 920  extern void words(environment *env)
920  }  }
921    
922  /* Internal forget function */  /* Internal forget function */
923  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
924    {
925    symbol *temp;    symbol *temp;
926    
927    temp= *hash_entry;    temp= *hash_entry;
# Line 895  void forget_sym(symbol **hash_entry) { Line 935  void forget_sym(symbol **hash_entry) {
935  extern void forget(environment *env)  extern void forget(environment *env)
936  {  {
937    char* sym_id;    char* sym_id;
938    stackitem *stack_head= env->head;    value *stack_head= env->head;
939    
940    if(stack_head==NULL) {    if(stack_head==NULL) {
941      printerr("Too Few Arguments");      printerr("Too Few Arguments");
942      env->err=1;      env->err= 1;
943      return;      return;
944    }    }
945        
946    if(stack_head->item->type!=symb) {    if(CAR(stack_head)->type!=symb) {
947      printerr("Bad Argument Type");      printerr("Bad Argument Type");
948      env->err=2;      env->err= 2;
949      return;      return;
950    }    }
951    
952    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(stack_head)->content.sym->id;
953    toss(env);    toss(env);
954    
955    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
956  }  }
957    
958  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
959  extern void errn(environment *env){  extern void errn(environment *env)
960    {
961    push_int(env, env->err);    push_int(env, env->err);
962  }  }
963    
# Line 926  int main(int argc, char **argv) Line 967  int main(int argc, char **argv)
967    
968    int c;                        /* getopt option character */    int c;                        /* getopt option character */
969    
970    #ifdef __linux__
971    mtrace();    mtrace();
972    #endif
973    
974    init_env(&myenv);    init_env(&myenv);
975    
# Line 980  under certain conditions; type `copying; Line 1023  under certain conditions; type `copying;
1023      if (myenv.err==4) {      if (myenv.err==4) {
1024        return EXIT_SUCCESS;      /* EOF */        return EXIT_SUCCESS;      /* EOF */
1025      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1026                && myenv.head->item->type==symb                && CAR(myenv.head)->type==symb
1027                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->content.sym->id[0]
1028                  ==';') {
1029        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1030        eval(&myenv);        eval(&myenv);
1031      }      }
1032      gc_init(&myenv);      gc_maybe(&myenv);
1033    }    }
1034    quit(&myenv);    quit(&myenv);
1035    return EXIT_FAILURE;    return EXIT_FAILURE;
1036  }  }
1037    
1038  /* "+" */  /* "+" */
1039  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1040    {
1041    int a, b;    int a, b;
1042    float fa, fb;    float fa, fb;
1043    size_t len;    size_t len;
1044    char* new_string;    char* new_string;
1045    value *a_val, *b_val;    value *a_val, *b_val;
1046    
1047    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1048      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1049      env->err= 1;      env->err= 1;
1050      return;      return;
1051    }    }
1052    
1053    if(env->head->item->type==string    if(CAR(env->head)->type==string
1054       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1055      a_val= env->head->item;      a_val= CAR(env->head);
1056      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1057      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1058      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1059      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1060      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
# Line 1017  extern void sx_2b(environment *env) { Line 1062  extern void sx_2b(environment *env) {
1062      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1063      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1064      push_cstring(env, new_string);      push_cstring(env, new_string);
1065      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1066      free(new_string);      free(new_string);
1067            
1068      return;      return;
1069    }    }
1070        
1071    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1072       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1073      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1074      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1075      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1076      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1077      push_int(env, b+a);      push_int(env, b+a);
1078    
1079      return;      return;
1080    }    }
1081    
1082    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1083       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1084      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1085      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1086      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1087      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1088      push_float(env, fb+fa);      push_float(env, fb+fa);
1089            
1090      return;      return;
1091    }    }
1092    
1093    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1094       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1095      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1096      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1097      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1098      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1099      push_float(env, b+fa);      push_float(env, b+fa);
1100            
1101      return;      return;
1102    }    }
1103    
1104    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1105       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1106      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1107      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1108      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1109      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1110      push_float(env, fb+a);      push_float(env, fb+a);
1111    
# Line 1072  extern void sx_2b(environment *env) { Line 1117  extern void sx_2b(environment *env) {
1117  }  }
1118    
1119  /* "-" */  /* "-" */
1120  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1121    {
1122    int a, b;    int a, b;
1123    float fa, fb;    float fa, fb;
1124    
1125    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1126      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1127      env->err=1;      env->err=1;
1128      return;      return;
1129    }    }
1130        
1131    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1132       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1133      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1134      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1135      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1136      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1137      push_int(env, b-a);      push_int(env, b-a);
1138    
1139      return;      return;
1140    }    }
1141    
1142    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1143       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1144      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1145      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1146      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1147      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1148      push_float(env, fb-fa);      push_float(env, fb-fa);
1149            
1150      return;      return;
1151    }    }
1152    
1153    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1154       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1155      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1156      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1157      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1158      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1159      push_float(env, b-fa);      push_float(env, b-fa);
1160            
1161      return;      return;
1162    }    }
1163    
1164    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1165       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1166      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1167      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1168      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1169      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1170      push_float(env, fb-a);      push_float(env, fb-a);
1171    
# Line 1131  extern void sx_2d(environment *env) { Line 1177  extern void sx_2d(environment *env) {
1177  }  }
1178    
1179  /* ">" */  /* ">" */
1180  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1181    {
1182    int a, b;    int a, b;
1183    float fa, fb;    float fa, fb;
1184    
1185    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1186      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1187      env->err=1;      env->err= 1;
1188      return;      return;
1189    }    }
1190        
1191    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1192       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1193      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1194      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1195      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1196      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1197      push_int(env, b>a);      push_int(env, b>a);
1198    
1199      return;      return;
1200    }    }
1201    
1202    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1203       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1204      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1205      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1206      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1207      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1208      push_int(env, fb>fa);      push_int(env, fb>fa);
1209            
1210      return;      return;
1211    }    }
1212    
1213    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1214       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1215      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1216      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1217      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1218      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1219      push_int(env, b>fa);      push_int(env, b>fa);
1220            
1221      return;      return;
1222    }    }
1223    
1224    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1225       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1226      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1227      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1228      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1229      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1230      push_int(env, fb>a);      push_int(env, fb>a);
1231    
# Line 1186  extern void sx_3e(environment *env) { Line 1233  extern void sx_3e(environment *env) {
1233    }    }
1234    
1235    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1236    env->err=2;    env->err= 2;
1237  }  }
1238    
1239  /* "<" */  /* "<" */
1240  extern void sx_3c(environment *env) {  extern void sx_3c(environment *env)
1241    {
1242    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1243    sx_3e(env);    sx_3e(env);
1244  }  }
1245    
1246  /* "<=" */  /* "<=" */
1247  extern void sx_3c3d(environment *env) {  extern void sx_3c3d(environment *env)
1248    {
1249    sx_3e(env); if(env->err) return;    sx_3e(env); if(env->err) return;
1250    not(env);    not(env);
1251  }  }
1252    
1253  /* ">=" */  /* ">=" */
1254  extern void sx_3e3d(environment *env) {  extern void sx_3e3d(environment *env)
1255    {
1256    sx_3c(env); if(env->err) return;    sx_3c(env); if(env->err) return;
1257    not(env);    not(env);
1258  }  }
1259    
1260  /* Return copy of a value */  /* Return copy of a value */
1261  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1262    stackitem *old_item, *new_item, *prev_item;  {
1263    value *new_value;    value *new_value;
1264    
1265    protect(env, old_value);    if(old_value==NULL)
1266        return NULL;
1267    
1268      protect(old_value);
1269    new_value= new_val(env);    new_value= new_val(env);
   protect(env, new_value);  
1270    new_value->type= old_value->type;    new_value->type= old_value->type;
1271    
1272    switch(old_value->type){    switch(old_value->type){
# Line 1228  value *copy_val(environment *env, value Line 1280  value *copy_val(environment *env, value
1280      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1281        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1282      break;      break;
1283    case list:    case tcons:
     new_value->content.ptr= NULL;  
1284    
1285      prev_item= NULL;      new_value->content.c= malloc(sizeof(cons));
1286      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
1287    
1288      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1289        new_item= malloc(sizeof(stackitem));      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
       new_item->item= copy_val(env, old_item->item); /* recurse */  
       new_item->next= NULL;  
       if(prev_item != NULL)     /* If this wasn't the first item */  
         prev_item->next= new_item; /* point the previous item to the  
                                      new item */  
       else  
         new_value->content.ptr= new_item;  
       old_item= old_item->next;  
       prev_item= new_item;  
     }      
1290      break;      break;
1291    }    }
1292    
1293    unprotect(env); unprotect(env);    unprotect(old_value);
1294    
1295    return new_value;    return new_value;
1296  }  }
1297    
1298  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1299  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1300    if((env->head)==NULL) {  {
1301      if(env->head==NULL) {
1302      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1303      env->err= 1;      env->err= 1;
1304      return;      return;
1305    }    }
1306    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1307  }  }
1308    
1309  /* "if", If-Then */  /* "if", If-Then */
1310  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1311    {
1312    int truth;    int truth;
1313    
1314    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1315      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1316      env->err= 1;      env->err= 1;
1317      return;      return;
1318    }    }
1319    
1320    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1321      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1322      env->err=2;      env->err= 2;
1323      return;      return;
1324    }    }
1325        
1326    swap(env);    swap(env);
1327    if(env->err) return;    if(env->err) return;
1328        
1329    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1330    
1331    toss(env);    toss(env);
1332    if(env->err) return;    if(env->err) return;
# Line 1296  extern void sx_6966(environment *env) { Line 1338  extern void sx_6966(environment *env) {
1338  }  }
1339    
1340  /* If-Then-Else */  /* If-Then-Else */
1341  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1342    {
1343    int truth;    int truth;
1344    
1345    if((env->head)==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1346       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1347      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1348      env->err=1;      env->err= 1;
1349      return;      return;
1350    }    }
1351    
1352    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1353      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1354      env->err=2;      env->err= 2;
1355      return;      return;
1356    }    }
1357        
1358    rot(env);    rot(env);
1359    if(env->err) return;    if(env->err) return;
1360        
1361    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1362    
1363    toss(env);    toss(env);
1364    if(env->err) return;    if(env->err) return;
# Line 1331  extern void ifelse(environment *env) { Line 1373  extern void ifelse(environment *env) {
1373    eval(env);    eval(env);
1374  }  }
1375    
1376  /* "while" */  extern void sx_656c7365(environment *env)
1377  extern void sx_7768696c65(environment *env) {  {
1378      if(env->head==NULL || CDR(env->head)==NULL
1379         || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL
1380         || CDR(CDR(CDR(CDR(env->head))))==NULL) {
1381        printerr("Too Few Arguments");
1382        env->err= 1;
1383        return;
1384      }
1385    
1386      if(CAR(CDR(env->head))->type!=symb
1387         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1388         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1389         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1390        printerr("Bad Argument Type");
1391        env->err= 2;
1392        return;
1393      }
1394    
1395      swap(env); toss(env); rot(env); toss(env);
1396      ifelse(env);
1397    }
1398    
1399    extern void then(environment *env)
1400    {
1401      if(env->head==NULL || CDR(env->head)==NULL
1402         || CDR(CDR(env->head))==NULL) {
1403        printerr("Too Few Arguments");
1404        env->err= 1;
1405        return;
1406      }
1407    
1408      if(CAR(CDR(env->head))->type!=symb
1409         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1410        printerr("Bad Argument Type");
1411        env->err= 2;
1412        return;
1413      }
1414    
1415      swap(env); toss(env);
1416      sx_6966(env);
1417    }
1418    
1419    /* "while" */
1420    extern void sx_7768696c65(environment *env)
1421    {
1422    int truth;    int truth;
1423    value *loop, *test;    value *loop, *test;
1424    
1425    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1426      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1427      env->err=1;      env->err= 1;
1428      return;      return;
1429    }    }
1430    
1431    loop= env->head->item;    loop= CAR(env->head);
1432    protect(env, loop);    protect(loop);
1433    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1434    
1435    test= env->head->item;    test= CAR(env->head);
1436    protect(env, test);    protect(test);
1437    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1438    
1439    do {    do {
1440      push_val(env, test);      push_val(env, test);
1441      eval(env);      eval(env);
1442            
1443      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1444        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1445        env->err= 2;        env->err= 2;
1446        return;        return;
1447      }      }
1448            
1449      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1450      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1451            
1452      if(truth) {      if(truth) {
# Line 1373  extern void sx_7768696c65(environment *e Line 1458  extern void sx_7768696c65(environment *e
1458        
1459    } while(truth);    } while(truth);
1460    
1461    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1462  }  }
1463    
1464    
1465  /* "for"; for-loop */  /* "for"; for-loop */
1466  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1467    {
1468    value *loop;    value *loop;
1469    int foo1, foo2;    int foo1, foo2;
1470    
1471    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1472       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1473      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1474      env->err= 1;      env->err= 1;
1475      return;      return;
1476    }    }
1477    
1478    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1479       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1480      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1481      env->err= 2;      env->err= 2;
1482      return;      return;
1483    }    }
1484    
1485    loop= env->head->item;    loop= CAR(env->head);
1486    protect(env, loop);    protect(loop);
1487    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1488    
1489    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1490    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1491    
1492    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1493    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1494    
1495    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1421  extern void sx_666f72(environment *env) Line 1507  extern void sx_666f72(environment *env)
1507        foo1--;        foo1--;
1508      }      }
1509    }    }
1510    unprotect(env);    unprotect(loop);
1511  }  }
1512    
1513  /* Variant of for-loop */  /* Variant of for-loop */
1514  extern void foreach(environment *env) {  extern void foreach(environment *env)
1515      {  
1516    value *loop, *foo;    value *loop, *foo;
1517    stackitem *iterator;    value *iterator;
1518        
1519    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1520      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1521      env->err= 1;      env->err= 1;
1522      return;      return;
1523    }    }
1524    
1525    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1526      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1527      env->err= 2;      env->err= 2;
1528      return;      return;
1529    }    }
1530    
1531    loop= env->head->item;    loop= CAR(env->head);
1532    protect(env, loop);    protect(loop);
1533    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1534    
1535    foo= env->head->item;    foo= CAR(env->head);
1536    protect(env, foo);    protect(foo);
1537    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1538    
1539    iterator= foo->content.ptr;    iterator= foo;
1540    
1541    while(iterator!=NULL) {    while(iterator!=NULL) {
1542      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1543      push_val(env, loop);      push_val(env, loop);
1544      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1545      iterator= iterator->next;      if (iterator->type == tcons){
1546          iterator= CDR(iterator);
1547        } else {
1548          printerr("Bad Argument Type"); /* Improper list */
1549          env->err= 2;
1550          break;
1551        }
1552    }    }
1553    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1554  }  }
1555    
1556  /* "to" */  /* "to" */
1557  extern void to(environment *env) {  extern void to(environment *env)
1558    int i, start, ending;  {
1559    stackitem *temp_head;    int ending, start, i;
1560    value *temp_val;    value *iterator, *temp;
1561      
1562    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1563      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1564      env->err=1;      env->err= 1;
1565      return;      return;
1566    }    }
1567    
1568    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1569       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1570      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1571      env->err=2;      env->err= 2;
1572      return;      return;
1573    }    }
1574    
1575    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1576    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1577    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1578    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1579    
1580    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1581    
1582    if(ending>=start) {    if(ending>=start) {
1583      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1496  extern void to(environment *env) { Line 1587  extern void to(environment *env) {
1587        push_int(env, i);        push_int(env, i);
1588    }    }
1589    
1590    temp_val= new_val(env);    iterator= env->head;
   protect(env, temp_val);  
1591    
1592    temp_val->content.ptr= env->head;    if(iterator==NULL
1593    temp_val->type= list;       || (CAR(iterator)->type==symb
1594    env->head= temp_head;           && CAR(iterator)->content.sym->id[0]=='[')) {
1595    push_val(env, temp_val);      temp= NULL;
1596        toss(env);
1597      } else {
1598        /* Search for first delimiter */
1599        while(CDR(iterator)!=NULL
1600              && (CAR(CDR(iterator))->type!=symb
1601                  || CAR(CDR(iterator))->content.sym->id[0]!='['))
1602          iterator= CDR(iterator);
1603        
1604        /* Extract list */
1605        temp= env->head;
1606        env->head= CDR(iterator);
1607        CDR(iterator)= NULL;
1608    
1609        if(env->head!=NULL)
1610          toss(env);
1611      }
1612    
1613    unprotect(env);    /* Push list */
1614      push_val(env, temp);
1615  }  }
1616    
1617  /* Read a string */  /* Read a string */
1618  extern void readline(environment *env) {  extern void readline(environment *env)
1619    {
1620    char in_string[101];    char in_string[101];
1621    
1622    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1518  extern void readline(environment *env) { Line 1626  extern void readline(environment *env) {
1626  }  }
1627    
1628  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1629  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1630    {
1631    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1632    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1633    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1541  extern void sx_72656164(environment *env Line 1650  extern void sx_72656164(environment *env
1650      }      }
1651      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1652    
1653      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1654        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1655        return;        return;
1656      }      }
1657            
1658      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1659      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1660      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1661      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1662    }    }
1663        
# Line 1597  extern void sx_72656164(environment *env Line 1706  extern void sx_72656164(environment *env
1706      return sx_72656164(env);      return sx_72656164(env);
1707  }  }
1708    
1709  extern void beep(environment *env) {  #ifdef __linux__
1710    extern void beep(environment *env)
1711    {
1712    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1713    
1714    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1715      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1716      env->err=1;      env->err= 1;
1717      return;      return;
1718    }    }
1719    
1720    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1721       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1722      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1723      env->err=2;      env->err= 2;
1724      return;      return;
1725    }    }
1726    
1727    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1728    toss(env);    toss(env);
1729    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
1730    toss(env);    toss(env);
1731    
1732    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1733                                     length */                                     length */
1734    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1735                                     timer ticks */                                     timer ticks */
1736    
1737  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1738    
1739    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1740    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1741    case 0:    case 0:
1742      usleep(dur);      usleep(dur);
1743      return;      return;
1744    case -1:    case -1:
1745      perror("beep");      perror("beep");
1746      env->err=5;      env->err= 5;
1747      return;      return;
1748    default:    default:
1749      abort();      abort();
1750    }    }
1751  };  }
1752    #endif /* __linux__ */
1753    
1754  /* "wait" */  /* "wait" */
1755  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1756    {
1757    int dur;    int dur;
1758    
1759    if((env->head)==NULL) {    if(env->head==NULL) {
1760      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1761      env->err=1;      env->err= 1;
1762      return;      return;
1763    }    }
1764    
1765    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1766      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1767      env->err=2;      env->err= 2;
1768      return;      return;
1769    }    }
1770    
1771    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1772    toss(env);    toss(env);
1773    
1774    usleep(dur);    usleep(dur);
1775  };  }
1776    
1777  extern void copying(environment *env){  extern void copying(environment *env)
1778    {
1779    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1780                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1781  \n\  \n\
# Line 1922  of preserving the free status of all der Line 2034  of preserving the free status of all der
2034  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
2035  }  }
2036    
2037  extern void warranty(environment *env){  extern void warranty(environment *env)
2038    {
2039    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
2040  \n\  \n\
2041    11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\    11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\
# Line 1952  extern void sx_2a(environment *env) Line 2065  extern void sx_2a(environment *env)
2065    int a, b;    int a, b;
2066    float fa, fb;    float fa, fb;
2067    
2068    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2069      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2070      env->err=1;      env->err= 1;
2071      return;      return;
2072    }    }
2073        
2074    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2075       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2076      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2077      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2078      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2079      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2080      push_int(env, b*a);      push_int(env, b*a);
2081    
2082      return;      return;
2083    }    }
2084    
2085    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2086       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2087      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2088      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2089      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2090      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2091      push_float(env, fb*fa);      push_float(env, fb*fa);
2092            
2093      return;      return;
2094    }    }
2095    
2096    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2097       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2098      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2099      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2100      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2101      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2102      push_float(env, b*fa);      push_float(env, b*fa);
2103            
2104      return;      return;
2105    }    }
2106    
2107    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2108       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2109      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2110      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2111      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2112      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2113      push_float(env, fb*a);      push_float(env, fb*a);
2114    
# Line 2003  extern void sx_2a(environment *env) Line 2116  extern void sx_2a(environment *env)
2116    }    }
2117    
2118    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2119    env->err=2;    env->err= 2;
2120  }  }
2121    
2122  /* "/" */  /* "/" */
# Line 2012  extern void sx_2f(environment *env) Line 2125  extern void sx_2f(environment *env)
2125    int a, b;    int a, b;
2126    float fa, fb;    float fa, fb;
2127    
2128    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2129      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2130      env->err=1;      env->err= 1;
2131      return;      return;
2132    }    }
2133        
2134    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2135       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2136      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2137      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2138      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2139      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2140      push_float(env, b/a);      push_float(env, b/a);
2141    
2142      return;      return;
2143    }    }
2144    
2145    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2146       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2147      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2148      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2149      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2150      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2151      push_float(env, fb/fa);      push_float(env, fb/fa);
2152            
2153      return;      return;
2154    }    }
2155    
2156    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2157       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2158      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2159      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2160      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2161      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2162      push_float(env, b/fa);      push_float(env, b/fa);
2163            
2164      return;      return;
2165    }    }
2166    
2167    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2168       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2169      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2170      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2171      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2172      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2173      push_float(env, fb/a);      push_float(env, fb/a);
2174    
# Line 2063  extern void sx_2f(environment *env) Line 2176  extern void sx_2f(environment *env)
2176    }    }
2177    
2178    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2179    env->err=2;    env->err= 2;
2180  }  }
2181    
2182  /* "mod" */  /* "mod" */
# Line 2071  extern void mod(environment *env) Line 2184  extern void mod(environment *env)
2184  {  {
2185    int a, b;    int a, b;
2186    
2187    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2188      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2189      env->err=1;      env->err= 1;
2190      return;      return;
2191    }    }
2192        
2193    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2194       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2195      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2196      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2197      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2198      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2199      push_int(env, b%a);      push_int(env, b%a);
2200    
# Line 2089  extern void mod(environment *env) Line 2202  extern void mod(environment *env)
2202    }    }
2203    
2204    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2205    env->err=2;    env->err= 2;
2206    }
2207    
2208    /* "div" */
2209    extern void sx_646976(environment *env)
2210    {
2211      int a, b;
2212      
2213      if(env->head==NULL || CDR(env->head)==NULL) {
2214        printerr("Too Few Arguments");
2215        env->err= 1;
2216        return;
2217      }
2218    
2219      if(CAR(env->head)->type==integer
2220         && CAR(CDR(env->head))->type==integer) {
2221        a= CAR(env->head)->content.i;
2222        toss(env); if(env->err) return;
2223        b= CAR(env->head)->content.i;
2224        toss(env); if(env->err) return;
2225        push_int(env, (int)b/a);
2226    
2227        return;
2228      }
2229    
2230      printerr("Bad Argument Type");
2231      env->err= 2;
2232  }  }
Legend:
Removed from v.1.93  
changed lines
  Added in v.1.109
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26