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

Diff of /stack/stack.c

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

revision 1.94 by masse, Sat Mar 9 09:58:31 2002 UTC revision 1.105 by masse, Tue Mar 12 14:53:19 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 48  void init_env(environment *env) Line 51  void init_env(environment *env)
51  {  {
52    int i;    int i;
53    
54    env->gc_limit= 20;    env->gc_limit= 400000;
55    env->gc_count= 0;    env->gc_count= 0;
56    env->gc_ref= NULL;    env->gc_ref= NULL;
   env->gc_protect= NULL;  
57    
58    env->head= NULL;    env->head= NULL;
59    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
# Line 63  void init_env(environment *env) Line 65  void init_env(environment *env)
65    env->interactive= 1;    env->interactive= 1;
66  }  }
67    
68  void printerr(const char* in_string) {  void printerr(const char* in_string)
69    {
70    fprintf(stderr, "Err: %s\n", in_string);    fprintf(stderr, "Err: %s\n", in_string);
71  }  }
72    
73  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
74  extern void toss(environment *env)  extern void toss(environment *env)
75  {  {
76    stackitem *temp= env->head;    if(env->head==NULL) {
   
   if((env->head)==NULL) {  
77      printerr("Too Few Arguments");      printerr("Too Few Arguments");
78      env->err= 1;      env->err= 1;
79      return;      return;
80    }    }
81        
82    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);  
83  }  }
84    
85  /* 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 111  symbol **hash(hashtbl in_hashtbl, const
111    }    }
112  }  }
113    
114  value* new_val(environment *env) {  /* Create new value */
115    value* new_val(environment *env)
116    {
117    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
118    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
119    
# Line 121  value* new_val(environment *env) { Line 121  value* new_val(environment *env) {
121    
122    nitem->item= nval;    nitem->item= nval;
123    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
   env->gc_ref= nitem;  
124    
125    env->gc_count++;    env->gc_ref= nitem;
126    
127    protect(env, nval);    env->gc_count += sizeof(value);
128    gc_init(env);    nval->gc.flag.mark= 0;
129    unprotect(env);    nval->gc.flag.protect= 0;
130    
131    return nval;    return nval;
132  }  }
133    
134  void gc_mark(value *val) {  /* Mark values recursively.
135    stackitem *iterator;     Marked values are not collected by the GC. */
136    inline void gc_mark(value *val)
137    if(val==NULL || val->gc_garb==0)  {
138      if(val==NULL || val->gc.flag.mark)
139      return;      return;
140    
141    val->gc_garb= 0;    val->gc.flag.mark= 1;
142    
143    if(val->type==list) {    if(val->type==tcons) {
144      iterator= val->content.ptr;      gc_mark(CAR(val));
145        gc_mark(CDR(val));
     while(iterator!=NULL) {  
       gc_mark(iterator->item);  
       iterator= iterator->next;  
     }  
146    }    }
147  }  }
148    
149  extern void gc_init(environment *env) {  inline void gc_maybe(environment *env)
150    stackitem *new_head= NULL, *titem, *iterator;  {
151      if(env->gc_count < env->gc_limit)
152        return;
153      else
154        return gc_init(env);
155    }
156    
157    /* Start GC */
158    extern void gc_init(environment *env)
159    {
160      stackitem *new_head= NULL, *titem;
161      cons *iterator;
162    symbol *tsymb;    symbol *tsymb;
163    int i;    int i;
164    
165    if(env->gc_count < env->gc_limit)    if(env->interactive)
166      return;      printf("Garbage collecting.");
167    
168    /* Garb by default */    /* Mark values on stack */
169    iterator= env->gc_ref;    gc_mark(env->head);
   while(iterator!=NULL) {  
     iterator->item->gc_garb= 1;  
     iterator= iterator->next;  
   }  
170    
171    /* Mark protected values */    if(env->interactive)
172    iterator= env->gc_protect;      printf(".");
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
173    
   /* Mark values in stack */  
   iterator= env->head;  
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
174    
175    /* Mark values in hashtable */    /* Mark values in hashtable */
176    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++)
177      tsymb= env->symbols[i];      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
178      while(tsymb!=NULL) {        if (tsymb->val != NULL)
179        gc_mark(tsymb->val);          gc_mark(tsymb->val);
180        tsymb= tsymb->next;  
181      }  
182    }    if(env->interactive)
183        printf(".");
184    
185    
186    env->gc_count= 0;    env->gc_count= 0;
187    
188    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
   while(env->gc_ref!=NULL) {  
189    
190      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
191    
192        /* Remove content */        if(env->gc_ref->item->type==string) /* Remove content */
       switch(env->gc_ref->item->type) {  
       case string:  
193          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
194          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;  
       }  
195        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
196        titem= env->gc_ref->next;        titem= env->gc_ref->next;
197        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
198        env->gc_ref= titem;        env->gc_ref= titem;
199      } else {                    /* Save */        continue;
200        titem= env->gc_ref->next;      }
201        env->gc_ref->next= new_head;  
202        new_head= env->gc_ref;      /* Keep values */    
203        env->gc_ref= titem;      env->gc_count += sizeof(value);
204        env->gc_count++;      if(env->gc_ref->item->type==string)
205      }        env->gc_count += strlen(env->gc_ref->item->content.ptr);
206        
207        titem= env->gc_ref->next;
208        env->gc_ref->next= new_head;
209        new_head= env->gc_ref;
210        new_head->item->gc.flag.mark= 0;
211        env->gc_ref= titem;
212    }    }
213    
214    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
215        env->gc_limit= env->gc_count*2;
216    
217    env->gc_ref= new_head;    env->gc_ref= new_head;
218    
219      if(env->interactive)
220        printf("done\n");
221    
222  }  }
223    
224  void protect(environment *env, value *val)  /* Protect values from GC */
225    void protect(value *val)
226  {  {
227    stackitem *new_item= malloc(sizeof(stackitem));    if(val==NULL || val->gc.flag.protect)
228    new_item->item= val;      return;
229    new_item->next= env->gc_protect;  
230    env->gc_protect= new_item;    val->gc.flag.protect= 1;
231    
232      if(val->type==tcons) {
233        protect(CAR(val));
234        protect(CDR(val));
235      }
236  }  }
237    
238  void unprotect(environment *env)  /* Unprotect values from GC */
239    void unprotect(value *val)
240  {  {
241    stackitem *temp= env->gc_protect;    if(val==NULL || !(val->gc.flag.protect))
242    env->gc_protect= env->gc_protect->next;      return;
243    free(temp);  
244      val->gc.flag.protect= 0;
245    
246      if(val->type==tcons) {
247        unprotect(CAR(val));
248        unprotect(CDR(val));
249      }
250  }  }
251    
252  /* Push a value onto the stack */  /* Push a value onto the stack */
253  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
254  {  {
255    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
256    new_item->item= val;  
257    new_item->next= env->head;    new_value->content.c= malloc(sizeof(cons));
258    env->head= new_item;    new_value->type= tcons;
259      CAR(new_value)= val;
260      CDR(new_value)= env->head;
261      env->head= new_value;
262  }  }
263    
264  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
265  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
266  {  {
267    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 262  void push_int(environment *env, int in_v Line 272  void push_int(environment *env, int in_v
272    push_val(env, new_value);    push_val(env, new_value);
273  }  }
274    
275    /* Push a floating point number onto the stack */
276  void push_float(environment *env, float in_val)  void push_float(environment *env, float in_val)
277  {  {
278    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 276  void push_float(environment *env, float Line 287  void push_float(environment *env, float
287  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
288  {  {
289    value *new_value= new_val(env);    value *new_value= new_val(env);
290      int length= strlen(in_string)+1;
291    
292    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
293      env->gc_count += length;
294    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
295    new_value->type= string;    new_value->type= string;
296    
# Line 285  void push_cstring(environment *env, cons Line 298  void push_cstring(environment *env, cons
298  }  }
299    
300  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
301  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
302    {
303    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
304    char *new_string, *current;    char *new_string, *current;
305    
# Line 303  char *mangle_str(const char *old_string) Line 317  char *mangle_str(const char *old_string)
317    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
318  }  }
319    
320  extern void mangle(environment *env){  extern void mangle(environment *env)
321    {
322    char *new_string;    char *new_string;
323    
324    if((env->head)==NULL) {    if(env->head==NULL) {
325      printerr("Too Few Arguments");      printerr("Too Few Arguments");
326      env->err= 1;      env->err= 1;
327      return;      return;
328    }    }
329    
330    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
331      printerr("Bad Argument Type");      printerr("Bad Argument Type");
332      env->err= 2;      env->err= 2;
333      return;      return;
334    }    }
335    
336    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
337        mangle_str((const char *)(CAR(env->head)->content.ptr));
338    
339    toss(env);    toss(env);
340    if(env->err) return;    if(env->err) return;
# Line 342  void push_sym(environment *env, const ch Line 358  void push_sym(environment *env, const ch
358    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
359    
360    new_value= new_val(env);    new_value= new_val(env);
361    protect(env, new_value);    protect(new_value);
362    new_fvalue= new_val(env);    new_fvalue= new_val(env);
363    protect(env, new_fvalue);    protect(new_fvalue);
364    
365    /* The new value is a symbol */    /* The new value is a symbol */
366    new_value->type= symb;    new_value->type= symb;
# Line 372  void push_sym(environment *env, const ch Line 388  void push_sym(environment *env, const ch
388    
389      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
390      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
391      free(mangled);  
392      dlerr= dlerror();      dlerr= dlerror();
393      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
394        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
395        dlerr= dlerror();        dlerr= dlerror();
396      }      }
397    
398      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
399        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
400        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
401        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
402                                           function value */                                           function value */
403      }      }
404    
405        free(mangled);
406    }    }
407    
408    push_val(env, new_value);    push_val(env, new_value);
409    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
410  }  }
411    
412  /* Print newline. */  /* Print newline. */
# Line 396  extern void nl() Line 416  extern void nl()
416  }  }
417    
418  /* Gets the type of a value */  /* Gets the type of a value */
419  extern void type(environment *env){  extern void type(environment *env)
420    {
421    int typenum;    int typenum;
422    
423    if((env->head)==NULL) {    if(env->head==NULL) {
424      printerr("Too Few Arguments");      printerr("Too Few Arguments");
425      env->err=1;      env->err= 1;
426      return;      return;
427    }    }
428    typenum=env->head->item->type;  
429      typenum= CAR(env->head)->type;
430    toss(env);    toss(env);
431    switch(typenum){    switch(typenum){
432    case integer:    case integer:
# Line 422  extern void type(environment *env){ Line 444  extern void type(environment *env){
444    case func:    case func:
445      push_sym(env, "function");      push_sym(env, "function");
446      break;      break;
447    case list:    case tcons:
448      push_sym(env, "list");      push_sym(env, "list");
449      break;      break;
450    }    }
451  }      }    
452    
453  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
454  void print_h(stackitem *stack_head, int noquote)  void print_h(value *stack_head, int noquote)
455  {  {
456    switch(stack_head->item->type) {    switch(CAR(stack_head)->type) {
457    case integer:    case integer:
458      printf("%d", stack_head->item->content.i);      printf("%d", CAR(stack_head)->content.i);
459      break;      break;
460    case tfloat:    case tfloat:
461      printf("%f", stack_head->item->content.f);      printf("%f", CAR(stack_head)->content.f);
462      break;      break;
463    case string:    case string:
464      if(noquote)      if(noquote)
465        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)CAR(stack_head)->content.ptr);
466      else      else
467        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);
468      break;      break;
469    case symb:    case symb:
470      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
471      break;      break;
472    case func:    case func:
473      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
474      break;      break;
475    case list:    case tcons:
476      /* 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 */
477      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head= CAR(stack_head);
478      printf("[ ");      printf("[ ");
479      while(stack_head != NULL) {      while(stack_head != NULL) {
480        print_h(stack_head, noquote);        print_h(stack_head, noquote);
481        printf(" ");        printf(" ");
482        stack_head=stack_head->next;        stack_head= CDR(stack_head);
483      }      }
484      printf("]");      printf("]");
485      break;      break;
486    }    }
487  }  }
488    
489  extern void print_(environment *env) {  extern void print_(environment *env)
490    {
491    if(env->head==NULL) {    if(env->head==NULL) {
492      printerr("Too Few Arguments");      printerr("Too Few Arguments");
493      env->err=1;      env->err= 1;
494      return;      return;
495    }    }
496    print_h(env->head, 0);    print_h(env->head, 0);
# Line 482  extern void print(environment *env) Line 505  extern void print(environment *env)
505    toss(env);    toss(env);
506  }  }
507    
508  extern void princ_(environment *env) {  extern void princ_(environment *env)
509    {
510    if(env->head==NULL) {    if(env->head==NULL) {
511      printerr("Too Few Arguments");      printerr("Too Few Arguments");
512      env->err=1;      env->err= 1;
513      return;      return;
514    }    }
515    print_h(env->head, 1);    print_h(env->head, 1);
# Line 500  extern void princ(environment *env) Line 524  extern void princ(environment *env)
524  }  }
525    
526  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
527  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
528  {  {
529    if(stack_head->next != NULL)    if(CDR(stack_head) != NULL)
530      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
531    printf("%ld: ", counter);    printf("%ld: ", counter);
532    print_h(stack_head, 0);    print_h(stack_head, 0);
533    nl();    nl();
# Line 516  extern void printstack(environment *env) Line 540  extern void printstack(environment *env)
540      printf("Stack Empty\n");      printf("Stack Empty\n");
541      return;      return;
542    }    }
543    
544    print_st(env->head, 1);    print_st(env->head, 1);
545  }  }
546    
547  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
548  extern void swap(environment *env)  extern void swap(environment *env)
549  {  {
550    stackitem *temp= env->head;    value *temp= env->head;
551        
552    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
553      printerr("Too Few Arguments");      printerr("Too Few Arguments");
554      env->err=1;      env->err=1;
555      return;      return;
556    }    }
557    
558    env->head= env->head->next;    env->head= CDR(env->head);
559    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
560    env->head->next= temp;    CDR(env->head)= temp;
561  }  }
562    
563  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
564  extern void rot(environment *env)  extern void rot(environment *env)
565  {  {
566    stackitem *temp= env->head;    value *temp= env->head;
567        
568    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
569        || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
570      printerr("Too Few Arguments");      printerr("Too Few Arguments");
571      env->err=1;      env->err= 1;
572      return;      return;
573    }    }
574      
575    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
576    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
577    env->head->next= temp;    CDR(env->head)= temp;
578  }  }
579    
580  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 557  extern void rcl(environment *env) Line 582  extern void rcl(environment *env)
582  {  {
583    value *val;    value *val;
584    
585    if(env->head == NULL) {    if(env->head==NULL) {
586      printerr("Too Few Arguments");      printerr("Too Few Arguments");
587      env->err=1;      env->err= 1;
588      return;      return;
589    }    }
590    
591    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
592      printerr("Bad Argument Type");      printerr("Bad Argument Type");
593      env->err=2;      env->err= 2;
594      return;      return;
595    }    }
596    
597    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
598    if(val == NULL){    if(val == NULL){
599      printerr("Unbound Variable");      printerr("Unbound Variable");
600      env->err=3;      env->err= 3;
601      return;      return;
602    }    }
603    protect(env, val);    protect(val);
604    toss(env);            /* toss the symbol */    toss(env);            /* toss the symbol */
605    if(env->err) return;    if(env->err) return;
606    push_val(env, val); /* Return its bound value */    push_val(env, val); /* Return its bound value */
607    unprotect(env);    unprotect(val);
608  }  }
609    
610  /* 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 614  extern void eval(environment *env)
614  {  {
615    funcp in_func;    funcp in_func;
616    value* temp_val;    value* temp_val;
617    stackitem* iterator;    value* iterator;
618    
619   eval_start:   eval_start:
620    
621      gc_maybe(env);
622    
623    if(env->head==NULL) {    if(env->head==NULL) {
624      printerr("Too Few Arguments");      printerr("Too Few Arguments");
625      env->err=1;      env->err= 1;
626      return;      return;
627    }    }
628    
629    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
630      /* if it's a symbol */      /* if it's a symbol */
631    case symb:    case symb:
632      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
633      if(env->err) return;      if(env->err) return;
634      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
635        goto eval_start;        goto eval_start;
636      }      }
637      return;      return;
638    
639      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
640    case func:    case func:
641      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
642      toss(env);      toss(env);
643      if(env->err) return;      if(env->err) return;
644      return in_func(env);      return in_func(env);
645    
646      /* If it's a list */      /* If it's a list */
647    case list:    case tcons:
648      temp_val= env->head->item;      temp_val= CAR(env->head);
649      protect(env, temp_val);      protect(temp_val);
650    
651      toss(env); if(env->err) return;      toss(env); if(env->err) return;
652      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
653            
654      while(iterator!=NULL) {      while(iterator!=NULL) {
655        push_val(env, iterator->item);        push_val(env, CAR(iterator));
656                
657        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
658          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
659          toss(env);          toss(env);
660          if(env->err) return;          if(env->err) return;
661                    
662          if(iterator->next == NULL){          if(CDR(iterator)==NULL){
663            goto eval_start;            goto eval_start;
664          }          }
665          eval(env);          eval(env);
666          if(env->err) return;          if(env->err) return;
667        }        }
668        iterator= iterator->next;        if (CDR(iterator)->type == tcons)
669            iterator= CDR(iterator);
670          else {
671            printerr("Bad Argument Type"); /* Improper list */
672            env->err= 2;
673            return;
674          }
675      }      }
676      unprotect(env);      unprotect(temp_val);
677      return;      return;
678    
679    default:    default:
# Line 649  extern void eval(environment *env) Line 682  extern void eval(environment *env)
682  }  }
683    
684  /* Reverse (flip) a list */  /* Reverse (flip) a list */
685  extern void rev(environment *env){  extern void rev(environment *env)
686    stackitem *old_head, *new_head, *item;  {
687      value *old_head, *new_head, *item;
688    
689    if((env->head)==NULL) {    if(env->head==NULL) {
690      printerr("Too Few Arguments");      printerr("Too Few Arguments");
691      env->err= 1;      env->err= 1;
692      return;      return;
693    }    }
694    
695    if(env->head->item->type!=list) {    if(CAR(env->head)->type!=tcons) {
696      printerr("Bad Argument Type");      printerr("Bad Argument Type");
697      env->err= 2;      env->err= 2;
698      return;      return;
699    }    }
700    
701    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
702    new_head= NULL;    new_head= NULL;
703    while(old_head != NULL){    while(old_head!=NULL) {
704      item= old_head;      item= old_head;
705      old_head= old_head->next;      old_head= CDR(old_head);
706      item->next= new_head;      CDR(item)= new_head;
707      new_head= item;      new_head= item;
708    }    }
709    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
710  }  }
711    
712  /* Make a list. */  /* Make a list. */
713  extern void pack(environment *env)  extern void pack(environment *env)
714  {  {
715    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
716    
717    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(env, pack);  
   
718    if(iterator==NULL    if(iterator==NULL
719       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
720       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
721      temp= NULL;      temp= NULL;
722      toss(env);      toss(env);
723    } else {    } else {
724      /* Search for first delimiter */      /* Search for first delimiter */
725      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
726            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
727            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
728        iterator= iterator->next;        iterator= CDR(iterator);
729            
730      /* Extract list */      /* Extract list */
731      temp= env->head;      temp= env->head;
732      env->head= iterator->next;      env->head= CDR(iterator);
733      iterator->next= NULL;      CDR(iterator)= NULL;
734    
     pack->type= list;  
     pack->content.ptr= temp;  
       
735      if(env->head!=NULL)      if(env->head!=NULL)
736        toss(env);        toss(env);
737    }    }
738    
739    /* Push list */    /* Push list */
740    
741    push_val(env, pack);    push_val(env, temp);
742    rev(env);    rev(env);
   
   unprotect(env);  
743  }  }
744    
745  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
746  extern void expand(environment *env)  extern void expand(environment *env)
747  {  {
748    stackitem *temp, *new_head;    value *temp, *new_head;
749    
750    /* Is top element a list? */    /* Is top element a list? */
751    if(env->head==NULL) {    if(env->head==NULL) {
# Line 728  extern void expand(environment *env) Line 753  extern void expand(environment *env)
753      env->err= 1;      env->err= 1;
754      return;      return;
755    }    }
756    if(env->head->item->type!=list) {  
757      if(CAR(env->head)->type!=tcons) {
758      printerr("Bad Argument Type");      printerr("Bad Argument Type");
759      env->err= 2;      env->err= 2;
760      return;      return;
# Line 740  extern void expand(environment *env) Line 766  extern void expand(environment *env)
766      return;      return;
767    
768    /* The first list element is the new stack head */    /* The first list element is the new stack head */
769    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
770    
771    toss(env);    toss(env);
772    
773    /* Find the end of the list */    /* Find the end of the list */
774    while(temp->next!=NULL)    while(CDR(temp)->content.ptr != NULL) {
775      temp= temp->next;      if (CDR(temp)->type == tcons)
776          temp= CDR(temp);
777        else {
778          printerr("Bad Argument Type"); /* Improper list */
779          env->err= 2;
780          return;
781        }
782      }
783    
784    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
785    temp->next= env->head;    CDR(temp)= env->head;
786    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
787    
788  }  }
# Line 758  extern void expand(environment *env) Line 791  extern void expand(environment *env)
791  extern void eq(environment *env)  extern void eq(environment *env)
792  {  {
793    void *left, *right;    void *left, *right;
   int result;  
794    
795    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
796      printerr("Too Few Arguments");      printerr("Too Few Arguments");
797      env->err= 1;      env->err= 1;
798      return;      return;
799    }    }
800    
801    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
802    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
803    toss(env); toss(env);    toss(env); toss(env);
804    push_int(env, result);  
805      push_int(env, left==right);
806  }  }
807    
808  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 780  extern void not(environment *env) Line 810  extern void not(environment *env)
810  {  {
811    int val;    int val;
812    
813    if((env->head)==NULL) {    if(env->head==NULL) {
814      printerr("Too Few Arguments");      printerr("Too Few Arguments");
815      env->err= 1;      env->err= 1;
816      return;      return;
817    }    }
818    
819    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
820      printerr("Bad Argument Type");      printerr("Bad Argument Type");
821      env->err= 2;      env->err= 2;
822      return;      return;
823    }    }
824    
825    val= env->head->item->content.i;    val= CAR(env->head)->content.i;
826    toss(env);    toss(env);
827    push_int(env, !val);    push_int(env, !val);
828  }  }
# Line 811  extern void def(environment *env) Line 841  extern void def(environment *env)
841    symbol *sym;    symbol *sym;
842    
843    /* 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 */
844    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
845      printerr("Too Few Arguments");      printerr("Too Few Arguments");
846      env->err= 1;      env->err= 1;
847      return;      return;
848    }    }
849    
850    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
851      printerr("Bad Argument Type");      printerr("Bad Argument Type");
852      env->err= 2;      env->err= 2;
853      return;      return;
854    }    }
855    
856    /* long names are a pain */    /* long names are a pain */
857    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
858    
859    /* Bind the symbol to the value */    /* Bind the symbol to the value */
860    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
861    
862    toss(env); toss(env);    toss(env); toss(env);
863  }  }
# Line 835  extern void def(environment *env) Line 865  extern void def(environment *env)
865  /* Quit stack. */  /* Quit stack. */
866  extern void quit(environment *env)  extern void quit(environment *env)
867  {  {
868    long i;    int i;
869    
870    clear(env);    clear(env);
871    
# Line 848  extern void quit(environment *env) Line 878  extern void quit(environment *env)
878    }    }
879    
880    env->gc_limit= 0;    env->gc_limit= 0;
881    gc_init(env);    gc_maybe(env);
882    
883    if(env->free_string!=NULL)    if(env->free_string!=NULL)
884      free(env->free_string);      free(env->free_string);
# Line 881  extern void words(environment *env) Line 911  extern void words(environment *env)
911  }  }
912    
913  /* Internal forget function */  /* Internal forget function */
914  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
915    {
916    symbol *temp;    symbol *temp;
917    
918    temp= *hash_entry;    temp= *hash_entry;
# Line 895  void forget_sym(symbol **hash_entry) { Line 926  void forget_sym(symbol **hash_entry) {
926  extern void forget(environment *env)  extern void forget(environment *env)
927  {  {
928    char* sym_id;    char* sym_id;
929    stackitem *stack_head= env->head;    value *stack_head= env->head;
930    
931    if(stack_head==NULL) {    if(stack_head==NULL) {
932      printerr("Too Few Arguments");      printerr("Too Few Arguments");
933      env->err=1;      env->err= 1;
934      return;      return;
935    }    }
936        
937    if(stack_head->item->type!=symb) {    if(CAR(stack_head)->type!=symb) {
938      printerr("Bad Argument Type");      printerr("Bad Argument Type");
939      env->err=2;      env->err= 2;
940      return;      return;
941    }    }
942    
943    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(stack_head)->content.sym->id;
944    toss(env);    toss(env);
945    
946    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
947  }  }
948    
949  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
950  extern void errn(environment *env){  extern void errn(environment *env)
951    {
952    push_int(env, env->err);    push_int(env, env->err);
953  }  }
954    
# Line 980  under certain conditions; type `copying; Line 1012  under certain conditions; type `copying;
1012      if (myenv.err==4) {      if (myenv.err==4) {
1013        return EXIT_SUCCESS;      /* EOF */        return EXIT_SUCCESS;      /* EOF */
1014      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1015                && myenv.head->item->type==symb                && CAR(myenv.head)->type==symb
1016                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->content.sym->id[0]
1017                  ==';') {
1018        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1019        eval(&myenv);        eval(&myenv);
1020      }      }
1021      gc_init(&myenv);      gc_maybe(&myenv);
1022    }    }
1023    quit(&myenv);    quit(&myenv);
1024    return EXIT_FAILURE;    return EXIT_FAILURE;
1025  }  }
1026    
1027  /* "+" */  /* "+" */
1028  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1029    {
1030    int a, b;    int a, b;
1031    float fa, fb;    float fa, fb;
1032    size_t len;    size_t len;
1033    char* new_string;    char* new_string;
1034    value *a_val, *b_val;    value *a_val, *b_val;
1035    
1036    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1037      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1038      env->err= 1;      env->err= 1;
1039      return;      return;
1040    }    }
1041    
1042    if(env->head->item->type==string    if(CAR(env->head)->type==string
1043       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1044      a_val= env->head->item;      a_val= CAR(env->head);
1045      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1046      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1047      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1048      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1049      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 1051  extern void sx_2b(environment *env) {
1051      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1052      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1053      push_cstring(env, new_string);      push_cstring(env, new_string);
1054      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1055      free(new_string);      free(new_string);
1056            
1057      return;      return;
1058    }    }
1059        
1060    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1061       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1062      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1063      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1064      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1065      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1066      push_int(env, b+a);      push_int(env, b+a);
1067    
1068      return;      return;
1069    }    }
1070    
1071    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1072       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1073      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1074      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1075      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1076      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1077      push_float(env, fb+fa);      push_float(env, fb+fa);
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==integer) {       && CAR(CDR(env->head))->type==integer) {
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      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1087      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1088      push_float(env, b+fa);      push_float(env, b+fa);
1089            
1090      return;      return;
1091    }    }
1092    
1093    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1094       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1095      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1096      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1097      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1098      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1099      push_float(env, fb+a);      push_float(env, fb+a);
1100    
# Line 1072  extern void sx_2b(environment *env) { Line 1106  extern void sx_2b(environment *env) {
1106  }  }
1107    
1108  /* "-" */  /* "-" */
1109  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1110    {
1111    int a, b;    int a, b;
1112    float fa, fb;    float fa, fb;
1113    
1114    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1115      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1116      env->err=1;      env->err=1;
1117      return;      return;
1118    }    }
1119        
1120    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1121       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1122      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1123      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1124      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1125      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1126      push_int(env, b-a);      push_int(env, b-a);
1127    
1128      return;      return;
1129    }    }
1130    
1131    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1132       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1133      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1134      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1135      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1136      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1137      push_float(env, fb-fa);      push_float(env, fb-fa);
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==integer) {       && CAR(CDR(env->head))->type==integer) {
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      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1147      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1148      push_float(env, b-fa);      push_float(env, b-fa);
1149            
1150      return;      return;
1151    }    }
1152    
1153    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1154       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1155      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1156      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1157      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1158      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1159      push_float(env, fb-a);      push_float(env, fb-a);
1160    
# Line 1131  extern void sx_2d(environment *env) { Line 1166  extern void sx_2d(environment *env) {
1166  }  }
1167    
1168  /* ">" */  /* ">" */
1169  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1170    {
1171    int a, b;    int a, b;
1172    float fa, fb;    float fa, fb;
1173    
1174    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1175      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1176      env->err=1;      env->err= 1;
1177      return;      return;
1178    }    }
1179        
1180    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1181       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1182      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1183      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1184      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1185      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1186      push_int(env, b>a);      push_int(env, b>a);
1187    
1188      return;      return;
1189    }    }
1190    
1191    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1192       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1193      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1194      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1195      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1196      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1197      push_int(env, fb>fa);      push_int(env, fb>fa);
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==integer) {       && CAR(CDR(env->head))->type==integer) {
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      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1207      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1208      push_int(env, b>fa);      push_int(env, b>fa);
1209            
1210      return;      return;
1211    }    }
1212    
1213    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1214       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1215      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1216      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1217      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1218      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1219      push_int(env, fb>a);      push_int(env, fb>a);
1220    
# Line 1186  extern void sx_3e(environment *env) { Line 1222  extern void sx_3e(environment *env) {
1222    }    }
1223    
1224    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1225    env->err=2;    env->err= 2;
1226  }  }
1227    
1228  /* "<" */  /* "<" */
1229  extern void sx_3c(environment *env) {  extern void sx_3c(environment *env)
1230    {
1231    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1232    sx_3e(env);    sx_3e(env);
1233  }  }
1234    
1235  /* "<=" */  /* "<=" */
1236  extern void sx_3c3d(environment *env) {  extern void sx_3c3d(environment *env)
1237    {
1238    sx_3e(env); if(env->err) return;    sx_3e(env); if(env->err) return;
1239    not(env);    not(env);
1240  }  }
1241    
1242  /* ">=" */  /* ">=" */
1243  extern void sx_3e3d(environment *env) {  extern void sx_3e3d(environment *env)
1244    {
1245    sx_3c(env); if(env->err) return;    sx_3c(env); if(env->err) return;
1246    not(env);    not(env);
1247  }  }
1248    
1249  /* Return copy of a value */  /* Return copy of a value */
1250  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1251    stackitem *old_item, *new_item, *prev_item;  {
1252    value *new_value;    value *new_value;
1253    
1254    protect(env, old_value);    if(old_value==NULL)
1255        return NULL;
1256    
1257      protect(old_value);
1258    new_value= new_val(env);    new_value= new_val(env);
1259    protect(env, new_value);    protect(new_value);
1260    new_value->type= old_value->type;    new_value->type= old_value->type;
1261    
1262    switch(old_value->type){    switch(old_value->type){
# Line 1228  value *copy_val(environment *env, value Line 1270  value *copy_val(environment *env, value
1270      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1271        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1272      break;      break;
1273    case list:    case tcons:
1274      new_value->content.ptr= NULL;      new_value= NULL;
1275    
1276      prev_item= NULL;      new_value->content.c= malloc(sizeof(cons));
1277      old_item= (stackitem*)(old_value->content.ptr);      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1278        CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
     while(old_item != NULL) {   /* While list is not empty */  
       new_item= malloc(sizeof(stackitem));  
       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;  
     }      
1279      break;      break;
1280    }    }
1281    
1282    unprotect(env); unprotect(env);    unprotect(old_value); unprotect(new_value);
1283    
1284    return new_value;    return new_value;
1285  }  }
1286    
1287  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1288  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1289    if((env->head)==NULL) {  {
1290      if(env->head==NULL) {
1291      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1292      env->err= 1;      env->err= 1;
1293      return;      return;
1294    }    }
1295    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1296  }  }
1297    
1298  /* "if", If-Then */  /* "if", If-Then */
1299  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1300    {
1301    int truth;    int truth;
1302    
1303    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1304      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1305      env->err= 1;      env->err= 1;
1306      return;      return;
1307    }    }
1308    
1309    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1310      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1311      env->err=2;      env->err= 2;
1312      return;      return;
1313    }    }
1314        
1315    swap(env);    swap(env);
1316    if(env->err) return;    if(env->err) return;
1317        
1318    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1319    
1320    toss(env);    toss(env);
1321    if(env->err) return;    if(env->err) return;
# Line 1296  extern void sx_6966(environment *env) { Line 1327  extern void sx_6966(environment *env) {
1327  }  }
1328    
1329  /* If-Then-Else */  /* If-Then-Else */
1330  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1331    {
1332    int truth;    int truth;
1333    
1334    if((env->head)==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1335       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1336      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1337      env->err=1;      env->err= 1;
1338      return;      return;
1339    }    }
1340    
1341    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1342      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1343      env->err=2;      env->err= 2;
1344      return;      return;
1345    }    }
1346        
1347    rot(env);    rot(env);
1348    if(env->err) return;    if(env->err) return;
1349        
1350    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1351    
1352    toss(env);    toss(env);
1353    if(env->err) return;    if(env->err) return;
# Line 1332  extern void ifelse(environment *env) { Line 1363  extern void ifelse(environment *env) {
1363  }  }
1364    
1365  /* "while" */  /* "while" */
1366  extern void sx_7768696c65(environment *env) {  extern void sx_7768696c65(environment *env)
1367    {
1368    int truth;    int truth;
1369    value *loop, *test;    value *loop, *test;
1370    
1371    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1372      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1373      env->err=1;      env->err= 1;
1374      return;      return;
1375    }    }
1376    
1377    loop= env->head->item;    loop= CAR(env->head);
1378    protect(env, loop);    protect(loop);
1379    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1380    
1381    test= env->head->item;    test= CAR(env->head);
1382    protect(env, test);    protect(test);
1383    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1384    
1385    do {    do {
1386      push_val(env, test);      push_val(env, test);
1387      eval(env);      eval(env);
1388            
1389      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1390        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1391        env->err= 2;        env->err= 2;
1392        return;        return;
1393      }      }
1394            
1395      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1396      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1397            
1398      if(truth) {      if(truth) {
# Line 1373  extern void sx_7768696c65(environment *e Line 1404  extern void sx_7768696c65(environment *e
1404        
1405    } while(truth);    } while(truth);
1406    
1407    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1408  }  }
1409    
1410    
1411  /* "for"; for-loop */  /* "for"; for-loop */
1412  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1413    {
1414    value *loop;    value *loop;
1415    int foo1, foo2;    int foo1, foo2;
1416    
1417    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1418       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1419      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1420      env->err= 1;      env->err= 1;
1421      return;      return;
1422    }    }
1423    
1424    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1425       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1426      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1427      env->err= 2;      env->err= 2;
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    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1436    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1437    
1438    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1439    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1440    
1441    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1421  extern void sx_666f72(environment *env) Line 1453  extern void sx_666f72(environment *env)
1453        foo1--;        foo1--;
1454      }      }
1455    }    }
1456    unprotect(env);    unprotect(loop);
1457  }  }
1458    
1459  /* Variant of for-loop */  /* Variant of for-loop */
1460  extern void foreach(environment *env) {  extern void foreach(environment *env)
1461      {  
1462    value *loop, *foo;    value *loop, *foo;
1463    stackitem *iterator;    value *iterator;
1464        
1465    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1466      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1467      env->err= 1;      env->err= 1;
1468      return;      return;
1469    }    }
1470    
1471    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1472      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1473      env->err= 2;      env->err= 2;
1474      return;      return;
1475    }    }
1476    
1477    loop= env->head->item;    loop= CAR(env->head);
1478    protect(env, loop);    protect(loop);
1479    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1480    
1481    foo= env->head->item;    foo= CAR(env->head);
1482    protect(env, foo);    protect(foo);
1483    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1484    
1485    iterator= foo->content.ptr;    iterator= foo;
1486    
1487    while(iterator!=NULL) {    while(iterator!=NULL) {
1488      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1489      push_val(env, loop);      push_val(env, loop);
1490      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1491      iterator= iterator->next;      if (iterator->type == tcons){
1492          iterator= CDR(iterator);
1493        } else {
1494          printerr("Bad Argument Type"); /* Improper list */
1495          env->err= 2;
1496          break;
1497        }
1498    }    }
1499    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1500  }  }
1501    
1502  /* "to" */  /* "to" */
1503  extern void to(environment *env) {  extern void to(environment *env)
1504    int i, start, ending;  {
1505    stackitem *temp_head;    int ending, start, i;
1506    value *temp_val;    value *iterator, *temp;
1507      
1508    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1509      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1510      env->err=1;      env->err= 1;
1511      return;      return;
1512    }    }
1513    
1514    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1515       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1516      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1517      env->err=2;      env->err= 2;
1518      return;      return;
1519    }    }
1520    
1521    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1522    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1523    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1524    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1525    
1526    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1527    
1528    if(ending>=start) {    if(ending>=start) {
1529      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1496  extern void to(environment *env) { Line 1533  extern void to(environment *env) {
1533        push_int(env, i);        push_int(env, i);
1534    }    }
1535    
1536    temp_val= new_val(env);    iterator= env->head;
1537    protect(env, temp_val);  
1538      if(iterator==NULL
1539         || (CAR(iterator)->type==symb
1540             && CAR(iterator)->content.sym->id[0]=='[')) {
1541        temp= NULL;
1542        toss(env);
1543      } else {
1544        /* Search for first delimiter */
1545        while(CDR(iterator)!=NULL
1546              && (CAR(CDR(iterator))->type!=symb
1547                  || CAR(CDR(iterator))->content.sym->id[0]!='['))
1548          iterator= CDR(iterator);
1549        
1550        /* Extract list */
1551        temp= env->head;
1552        env->head= CDR(iterator);
1553        CDR(iterator)= NULL;
1554    
1555    temp_val->content.ptr= env->head;      if(env->head!=NULL)
1556    temp_val->type= list;        toss(env);
1557    env->head= temp_head;    }
   push_val(env, temp_val);  
1558    
1559    unprotect(env);    /* Push list */
1560      push_val(env, temp);
1561  }  }
1562    
1563  /* Read a string */  /* Read a string */
1564  extern void readline(environment *env) {  extern void readline(environment *env)
1565    {
1566    char in_string[101];    char in_string[101];
1567    
1568    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1518  extern void readline(environment *env) { Line 1572  extern void readline(environment *env) {
1572  }  }
1573    
1574  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1575  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1576    {
1577    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1578    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1579    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1541  extern void sx_72656164(environment *env Line 1596  extern void sx_72656164(environment *env
1596      }      }
1597      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1598    
1599      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1600        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1601        return;        return;
1602      }      }
1603            
1604      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1605      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1606      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1607      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1608    }    }
1609        
# Line 1597  extern void sx_72656164(environment *env Line 1652  extern void sx_72656164(environment *env
1652      return sx_72656164(env);      return sx_72656164(env);
1653  }  }
1654    
1655  extern void beep(environment *env) {  extern void beep(environment *env)
1656    {
1657    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1658    
1659    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1660      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1661      env->err=1;      env->err= 1;
1662      return;      return;
1663    }    }
1664    
1665    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1666       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1667      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1668      env->err=2;      env->err= 2;
1669      return;      return;
1670    }    }
1671    
1672    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1673    toss(env);    toss(env);
1674    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
1675    toss(env);    toss(env);
1676    
1677    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1678                                     length */                                     length */
1679    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1680                                     timer ticks */                                     timer ticks */
1681    
1682  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1683    
1684    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1685    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1686    case 0:    case 0:
1687      usleep(dur);      usleep(dur);
1688      return;      return;
1689    case -1:    case -1:
1690      perror("beep");      perror("beep");
1691      env->err=5;      env->err= 5;
1692      return;      return;
1693    default:    default:
1694      abort();      abort();
1695    }    }
1696  };  }
1697    
1698  /* "wait" */  /* "wait" */
1699  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1700    {
1701    int dur;    int dur;
1702    
1703    if((env->head)==NULL) {    if(env->head==NULL) {
1704      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1705      env->err=1;      env->err= 1;
1706      return;      return;
1707    }    }
1708    
1709    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1710      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1711      env->err=2;      env->err= 2;
1712      return;      return;
1713    }    }
1714    
1715    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1716    toss(env);    toss(env);
1717    
1718    usleep(dur);    usleep(dur);
1719  };  }
1720    
1721  extern void copying(environment *env){  extern void copying(environment *env)
1722    {
1723    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1724                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1725  \n\  \n\
# Line 1922  of preserving the free status of all der Line 1978  of preserving the free status of all der
1978  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
1979  }  }
1980    
1981  extern void warranty(environment *env){  extern void warranty(environment *env)
1982    {
1983    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
1984  \n\  \n\
1985    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 2009  extern void sx_2a(environment *env)
2009    int a, b;    int a, b;
2010    float fa, fb;    float fa, fb;
2011    
2012    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2013      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2014      env->err=1;      env->err= 1;
2015      return;      return;
2016    }    }
2017        
2018    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2019       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2020      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2021      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2022      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2023      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2024      push_int(env, b*a);      push_int(env, b*a);
2025    
2026      return;      return;
2027    }    }
2028    
2029    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2030       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2031      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2032      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2033      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2034      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2035      push_float(env, fb*fa);      push_float(env, fb*fa);
2036            
2037      return;      return;
2038    }    }
2039    
2040    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2041       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2042      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2043      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2044      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2045      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2046      push_float(env, b*fa);      push_float(env, b*fa);
2047            
2048      return;      return;
2049    }    }
2050    
2051    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2052       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2053      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2054      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2055      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2056      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2057      push_float(env, fb*a);      push_float(env, fb*a);
2058    
# Line 2003  extern void sx_2a(environment *env) Line 2060  extern void sx_2a(environment *env)
2060    }    }
2061    
2062    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2063    env->err=2;    env->err= 2;
2064  }  }
2065    
2066  /* "/" */  /* "/" */
# Line 2012  extern void sx_2f(environment *env) Line 2069  extern void sx_2f(environment *env)
2069    int a, b;    int a, b;
2070    float fa, fb;    float fa, fb;
2071    
2072    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2073      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2074      env->err=1;      env->err= 1;
2075      return;      return;
2076    }    }
2077        
2078    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2079       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2080      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2081      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2082      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2083      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2084      push_float(env, b/a);      push_float(env, b/a);
2085    
2086      return;      return;
2087    }    }
2088    
2089    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2090       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2091      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2092      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2093      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2094      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2095      push_float(env, fb/fa);      push_float(env, fb/fa);
2096            
2097      return;      return;
2098    }    }
2099    
2100    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2101       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2102      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2103      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2104      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2105      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2106      push_float(env, b/fa);      push_float(env, b/fa);
2107            
2108      return;      return;
2109    }    }
2110    
2111    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2112       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2113      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2114      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2115      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2116      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2117      push_float(env, fb/a);      push_float(env, fb/a);
2118    
# Line 2063  extern void sx_2f(environment *env) Line 2120  extern void sx_2f(environment *env)
2120    }    }
2121    
2122    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2123    env->err=2;    env->err= 2;
2124  }  }
2125    
2126  /* "mod" */  /* "mod" */
# Line 2071  extern void mod(environment *env) Line 2128  extern void mod(environment *env)
2128  {  {
2129    int a, b;    int a, b;
2130    
2131    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2132      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2133      env->err= 1;      env->err= 1;
2134      return;      return;
2135    }    }
2136        
2137    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2138       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2139      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2140      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2141      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2142      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2143      push_int(env, b%a);      push_int(env, b%a);
2144    
# Line 2089  extern void mod(environment *env) Line 2146  extern void mod(environment *env)
2146    }    }
2147    
2148    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2149    env->err=2;    env->err= 2;
2150  }  }
2151    
2152  /* "div" */  /* "div" */
# Line 2097  extern void sx_646976(environment *env) Line 2154  extern void sx_646976(environment *env)
2154  {  {
2155    int a, b;    int a, b;
2156        
2157    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2158      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2159      env->err= 1;      env->err= 1;
2160      return;      return;
2161    }    }
2162    
2163    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2164       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2165      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2166      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2167      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2168      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2169      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2170    
Legend:
Removed from v.1.94  
changed lines
  Added in v.1.105
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26