/[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.106 by masse, Tue Mar 12 15:13:48 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;
   
     prev_item= NULL;  
     old_item= (stackitem*)(old_value->content.ptr);  
1275    
1276      while(old_item != NULL) {   /* While list is not empty */      new_value->content.c= malloc(sizeof(cons));
1277        new_item= malloc(sizeof(stackitem));      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1278        new_item->item= copy_val(env, old_item->item); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* 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 1331  extern void ifelse(environment *env) { Line 1362  extern void ifelse(environment *env) {
1362    eval(env);    eval(env);
1363  }  }
1364    
1365  /* "while" */  extern void sx_656c7365(environment *env)
1366  extern void sx_7768696c65(environment *env) {  {
1367      if(env->head==NULL || CDR(env->head)==NULL
1368         || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL) {
1369        printerr("Too Few Arguments");
1370        env->err= 1;
1371        return;
1372      }
1373    
1374      if(CAR(CDR(env->head))->type!=symb
1375         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1376        printerr("Bad Argument Type");
1377        env->err= 2;
1378        return;
1379      }
1380    
1381      swap(env); toss(env);
1382      ifelse(env);
1383    }
1384    
1385    /* "while" */
1386    extern void sx_7768696c65(environment *env)
1387    {
1388    int truth;    int truth;
1389    value *loop, *test;    value *loop, *test;
1390    
1391    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1392      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1393      env->err=1;      env->err= 1;
1394      return;      return;
1395    }    }
1396    
1397    loop= env->head->item;    loop= CAR(env->head);
1398    protect(env, loop);    protect(loop);
1399    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1400    
1401    test= env->head->item;    test= CAR(env->head);
1402    protect(env, test);    protect(test);
1403    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1404    
1405    do {    do {
1406      push_val(env, test);      push_val(env, test);
1407      eval(env);      eval(env);
1408            
1409      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1410        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1411        env->err= 2;        env->err= 2;
1412        return;        return;
1413      }      }
1414            
1415      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1416      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1417            
1418      if(truth) {      if(truth) {
# Line 1373  extern void sx_7768696c65(environment *e Line 1424  extern void sx_7768696c65(environment *e
1424        
1425    } while(truth);    } while(truth);
1426    
1427    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1428  }  }
1429    
1430    
1431  /* "for"; for-loop */  /* "for"; for-loop */
1432  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1433    {
1434    value *loop;    value *loop;
1435    int foo1, foo2;    int foo1, foo2;
1436    
1437    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1438       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1439      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1440      env->err= 1;      env->err= 1;
1441      return;      return;
1442    }    }
1443    
1444    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1445       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1446      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1447      env->err= 2;      env->err= 2;
1448      return;      return;
1449    }    }
1450    
1451    loop= env->head->item;    loop= CAR(env->head);
1452    protect(env, loop);    protect(loop);
1453    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1454    
1455    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1456    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1457    
1458    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1459    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1460    
1461    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1421  extern void sx_666f72(environment *env) Line 1473  extern void sx_666f72(environment *env)
1473        foo1--;        foo1--;
1474      }      }
1475    }    }
1476    unprotect(env);    unprotect(loop);
1477  }  }
1478    
1479  /* Variant of for-loop */  /* Variant of for-loop */
1480  extern void foreach(environment *env) {  extern void foreach(environment *env)
1481      {  
1482    value *loop, *foo;    value *loop, *foo;
1483    stackitem *iterator;    value *iterator;
1484        
1485    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1486      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1487      env->err= 1;      env->err= 1;
1488      return;      return;
1489    }    }
1490    
1491    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1492      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1493      env->err= 2;      env->err= 2;
1494      return;      return;
1495    }    }
1496    
1497    loop= env->head->item;    loop= CAR(env->head);
1498    protect(env, loop);    protect(loop);
1499    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1500    
1501    foo= env->head->item;    foo= CAR(env->head);
1502    protect(env, foo);    protect(foo);
1503    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1504    
1505    iterator= foo->content.ptr;    iterator= foo;
1506    
1507    while(iterator!=NULL) {    while(iterator!=NULL) {
1508      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1509      push_val(env, loop);      push_val(env, loop);
1510      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1511      iterator= iterator->next;      if (iterator->type == tcons){
1512          iterator= CDR(iterator);
1513        } else {
1514          printerr("Bad Argument Type"); /* Improper list */
1515          env->err= 2;
1516          break;
1517        }
1518    }    }
1519    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1520  }  }
1521    
1522  /* "to" */  /* "to" */
1523  extern void to(environment *env) {  extern void to(environment *env)
1524    int i, start, ending;  {
1525    stackitem *temp_head;    int ending, start, i;
1526    value *temp_val;    value *iterator, *temp;
1527      
1528    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1529      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1530      env->err=1;      env->err= 1;
1531      return;      return;
1532    }    }
1533    
1534    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1535       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1536      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1537      env->err=2;      env->err= 2;
1538      return;      return;
1539    }    }
1540    
1541    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1542    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1543    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1544    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1545    
1546    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1547    
1548    if(ending>=start) {    if(ending>=start) {
1549      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1496  extern void to(environment *env) { Line 1553  extern void to(environment *env) {
1553        push_int(env, i);        push_int(env, i);
1554    }    }
1555    
1556    temp_val= new_val(env);    iterator= env->head;
   protect(env, temp_val);  
1557    
1558    temp_val->content.ptr= env->head;    if(iterator==NULL
1559    temp_val->type= list;       || (CAR(iterator)->type==symb
1560    env->head= temp_head;           && CAR(iterator)->content.sym->id[0]=='[')) {
1561    push_val(env, temp_val);      temp= NULL;
1562        toss(env);
1563      } else {
1564        /* Search for first delimiter */
1565        while(CDR(iterator)!=NULL
1566              && (CAR(CDR(iterator))->type!=symb
1567                  || CAR(CDR(iterator))->content.sym->id[0]!='['))
1568          iterator= CDR(iterator);
1569        
1570        /* Extract list */
1571        temp= env->head;
1572        env->head= CDR(iterator);
1573        CDR(iterator)= NULL;
1574    
1575        if(env->head!=NULL)
1576          toss(env);
1577      }
1578    
1579    unprotect(env);    /* Push list */
1580      push_val(env, temp);
1581  }  }
1582    
1583  /* Read a string */  /* Read a string */
1584  extern void readline(environment *env) {  extern void readline(environment *env)
1585    {
1586    char in_string[101];    char in_string[101];
1587    
1588    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1518  extern void readline(environment *env) { Line 1592  extern void readline(environment *env) {
1592  }  }
1593    
1594  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1595  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1596    {
1597    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1598    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1599    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1541  extern void sx_72656164(environment *env Line 1616  extern void sx_72656164(environment *env
1616      }      }
1617      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1618    
1619      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1620        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1621        return;        return;
1622      }      }
1623            
1624      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1625      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1626      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1627      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1628    }    }
1629        
# Line 1597  extern void sx_72656164(environment *env Line 1672  extern void sx_72656164(environment *env
1672      return sx_72656164(env);      return sx_72656164(env);
1673  }  }
1674    
1675  extern void beep(environment *env) {  extern void beep(environment *env)
1676    {
1677    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1678    
1679    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1680      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1681      env->err=1;      env->err= 1;
1682      return;      return;
1683    }    }
1684    
1685    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1686       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1687      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1688      env->err=2;      env->err= 2;
1689      return;      return;
1690    }    }
1691    
1692    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1693    toss(env);    toss(env);
1694    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
1695    toss(env);    toss(env);
1696    
1697    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1698                                     length */                                     length */
1699    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1700                                     timer ticks */                                     timer ticks */
1701    
1702  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1703    
1704    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1705    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1706    case 0:    case 0:
1707      usleep(dur);      usleep(dur);
1708      return;      return;
1709    case -1:    case -1:
1710      perror("beep");      perror("beep");
1711      env->err=5;      env->err= 5;
1712      return;      return;
1713    default:    default:
1714      abort();      abort();
1715    }    }
1716  };  }
1717    
1718  /* "wait" */  /* "wait" */
1719  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1720    {
1721    int dur;    int dur;
1722    
1723    if((env->head)==NULL) {    if(env->head==NULL) {
1724      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1725      env->err=1;      env->err= 1;
1726      return;      return;
1727    }    }
1728    
1729    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1730      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1731      env->err=2;      env->err= 2;
1732      return;      return;
1733    }    }
1734    
1735    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1736    toss(env);    toss(env);
1737    
1738    usleep(dur);    usleep(dur);
1739  };  }
1740    
1741  extern void copying(environment *env){  extern void copying(environment *env)
1742    {
1743    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1744                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1745  \n\  \n\
# Line 1922  of preserving the free status of all der Line 1998  of preserving the free status of all der
1998  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
1999  }  }
2000    
2001  extern void warranty(environment *env){  extern void warranty(environment *env)
2002    {
2003    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
2004  \n\  \n\
2005    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 2029  extern void sx_2a(environment *env)
2029    int a, b;    int a, b;
2030    float fa, fb;    float fa, fb;
2031    
2032    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2033      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2034      env->err=1;      env->err= 1;
2035      return;      return;
2036    }    }
2037        
2038    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2039       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2040      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2041      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2042      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2043      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2044      push_int(env, b*a);      push_int(env, b*a);
2045    
2046      return;      return;
2047    }    }
2048    
2049    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2050       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2051      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2052      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2053      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2054      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2055      push_float(env, fb*fa);      push_float(env, fb*fa);
2056            
2057      return;      return;
2058    }    }
2059    
2060    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2061       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2062      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2063      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2064      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2065      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2066      push_float(env, b*fa);      push_float(env, b*fa);
2067            
2068      return;      return;
2069    }    }
2070    
2071    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2072       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2073      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2074      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2075      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2076      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2077      push_float(env, fb*a);      push_float(env, fb*a);
2078    
# Line 2003  extern void sx_2a(environment *env) Line 2080  extern void sx_2a(environment *env)
2080    }    }
2081    
2082    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2083    env->err=2;    env->err= 2;
2084  }  }
2085    
2086  /* "/" */  /* "/" */
# Line 2012  extern void sx_2f(environment *env) Line 2089  extern void sx_2f(environment *env)
2089    int a, b;    int a, b;
2090    float fa, fb;    float fa, fb;
2091    
2092    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2093      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2094      env->err=1;      env->err= 1;
2095      return;      return;
2096    }    }
2097        
2098    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2099       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2100      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2101      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2102      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2103      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2104      push_float(env, b/a);      push_float(env, b/a);
2105    
2106      return;      return;
2107    }    }
2108    
2109    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2110       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2111      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2112      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2113      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2114      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2115      push_float(env, fb/fa);      push_float(env, fb/fa);
2116            
2117      return;      return;
2118    }    }
2119    
2120    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2121       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2122      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2123      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2124      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2125      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2126      push_float(env, b/fa);      push_float(env, b/fa);
2127            
2128      return;      return;
2129    }    }
2130    
2131    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2132       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2133      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2134      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2135      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2136      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2137      push_float(env, fb/a);      push_float(env, fb/a);
2138    
# Line 2063  extern void sx_2f(environment *env) Line 2140  extern void sx_2f(environment *env)
2140    }    }
2141    
2142    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2143    env->err=2;    env->err= 2;
2144  }  }
2145    
2146  /* "mod" */  /* "mod" */
# Line 2071  extern void mod(environment *env) Line 2148  extern void mod(environment *env)
2148  {  {
2149    int a, b;    int a, b;
2150    
2151    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2152      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2153      env->err= 1;      env->err= 1;
2154      return;      return;
2155    }    }
2156        
2157    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2158       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2159      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2160      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2161      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2162      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2163      push_int(env, b%a);      push_int(env, b%a);
2164    
# Line 2089  extern void mod(environment *env) Line 2166  extern void mod(environment *env)
2166    }    }
2167    
2168    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2169    env->err=2;    env->err= 2;
2170  }  }
2171    
2172  /* "div" */  /* "div" */
# Line 2097  extern void sx_646976(environment *env) Line 2174  extern void sx_646976(environment *env)
2174  {  {
2175    int a, b;    int a, b;
2176        
2177    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2178      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2179      env->err= 1;      env->err= 1;
2180      return;      return;
2181    }    }
2182    
2183    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2184       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2185      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2186      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2187      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2188      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2189      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2190    
Legend:
Removed from v.1.94  
changed lines
  Added in v.1.106
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26