/[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.102 by masse, Sun Mar 10 20:08:47 2002 UTC
# Line 48  void init_env(environment *env) Line 48  void init_env(environment *env)
48  {  {
49    int i;    int i;
50    
51    env->gc_limit= 20;    env->gc_limit= 400000;
52    env->gc_count= 0;    env->gc_count= 0;
53    env->gc_ref= NULL;    env->gc_ref= NULL;
   env->gc_protect= NULL;  
54    
55    env->head= NULL;    env->head= NULL;
56    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
# Line 63  void init_env(environment *env) Line 62  void init_env(environment *env)
62    env->interactive= 1;    env->interactive= 1;
63  }  }
64    
65  void printerr(const char* in_string) {  void printerr(const char* in_string)
66    {
67    fprintf(stderr, "Err: %s\n", in_string);    fprintf(stderr, "Err: %s\n", in_string);
68  }  }
69    
70  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
71  extern void toss(environment *env)  extern void toss(environment *env)
72  {  {
73    stackitem *temp= env->head;    cons *temp= env->head;
74    
75    if((env->head)==NULL) {    if(env->head==NULL) {
76      printerr("Too Few Arguments");      printerr("Too Few Arguments");
77      env->err= 1;      env->err= 1;
78      return;      return;
79    }    }
80        
81    env->head= env->head->next;   /* Remove the top stack item */    env->head= env->head->cdr->content.c; /* Remove the top stack item */
82    free(temp);                   /* Free the old 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 && val->content.c!=NULL) {
144      iterator= val->content.ptr;      gc_mark(val->content.c->car);
145        gc_mark(val->content.c->cdr);
     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;    if(env->head!=NULL) {
170    while(iterator!=NULL) {      gc_mark(env->head->car);
171      iterator->item->gc_garb= 1;      gc_mark(env->head->cdr);
     iterator= iterator->next;  
172    }    }
173    
174    /* Mark protected values */    if(env->interactive)
175    iterator= env->gc_protect;      printf(".");
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
176    
   /* Mark values in stack */  
   iterator= env->head;  
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
177    
178    /* Mark values in hashtable */    /* Mark values in hashtable */
179    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++)
180      tsymb= env->symbols[i];      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
181      while(tsymb!=NULL) {        if (tsymb->val != NULL)
182        gc_mark(tsymb->val);          gc_mark(tsymb->val);
183        tsymb= tsymb->next;  
184      }  
185    }    if(env->interactive)
186        printf(".");
187    
188    
189    env->gc_count= 0;    env->gc_count= 0;
190    
191    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
   while(env->gc_ref!=NULL) {  
192    
193      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
194    
195        /* Remove content */        if(env->gc_ref->item->type==string) /* Remove content */
       switch(env->gc_ref->item->type) {  
       case string:  
196          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
197          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;  
       }  
198        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
199        titem= env->gc_ref->next;        titem= env->gc_ref->next;
200        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
201        env->gc_ref= titem;        env->gc_ref= titem;
202      } else {                    /* Save */        continue;
203        titem= env->gc_ref->next;      }
204        env->gc_ref->next= new_head;  
205        new_head= env->gc_ref;      /* Keep values */    
206        env->gc_ref= titem;      env->gc_count += sizeof(value);
207        env->gc_count++;      if(env->gc_ref->item->type==string)
208      }        env->gc_count += strlen(env->gc_ref->item->content.ptr);
209        
210        titem= env->gc_ref->next;
211        env->gc_ref->next= new_head;
212        new_head= env->gc_ref;
213        new_head->item->gc.flag.mark= 0;
214        env->gc_ref= titem;
215    }    }
216    
217    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
218        env->gc_limit= env->gc_count*2;
219    
220    env->gc_ref= new_head;    env->gc_ref= new_head;
221    
222      if(env->interactive)
223        printf("done\n");
224    
225  }  }
226    
227  void protect(environment *env, value *val)  /* Protect values from GC */
228    void protect(value *val)
229  {  {
230    stackitem *new_item= malloc(sizeof(stackitem));    if(val==NULL || val->gc.flag.protect)
231    new_item->item= val;      return;
232    new_item->next= env->gc_protect;  
233    env->gc_protect= new_item;    val->gc.flag.protect= 1;
234    
235      if(val->type==tcons && val->content.c!=NULL) {
236        protect(val->content.c->car);
237        protect(val->content.c->cdr);
238      }
239  }  }
240    
241  void unprotect(environment *env)  /* Unprotect values from GC */
242    void unprotect(value *val)
243  {  {
244    stackitem *temp= env->gc_protect;    if(val==NULL || !(val->gc.flag.protect))
245    env->gc_protect= env->gc_protect->next;      return;
246    free(temp);  
247      val->gc.flag.protect= 0;
248    
249      if(val->type==tcons && val->content.c!=NULL) {
250        unprotect(val->content.c->car);
251        unprotect(val->content.c->cdr);
252      }
253  }  }
254    
255  /* Push a value onto the stack */  /* Push a value onto the stack */
256  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
257  {  {
258    stackitem *new_item= malloc(sizeof(stackitem));    cons *new_item= malloc(sizeof(cons));
259    new_item->item= val;    new_item->car= val;
260    new_item->next= env->head;  
261      new_item->cdr= new_val(env);
262      new_item->cdr->type= tcons;
263      new_item->cdr->content.c= env->head;
264    env->head= new_item;    env->head= new_item;
265  }  }
266    
267  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
268  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
269  {  {
270    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 262  void push_int(environment *env, int in_v Line 275  void push_int(environment *env, int in_v
275    push_val(env, new_value);    push_val(env, new_value);
276  }  }
277    
278    /* Push a floating point number onto the stack */
279  void push_float(environment *env, float in_val)  void push_float(environment *env, float in_val)
280  {  {
281    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 276  void push_float(environment *env, float Line 290  void push_float(environment *env, float
290  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
291  {  {
292    value *new_value= new_val(env);    value *new_value= new_val(env);
293      int length= strlen(in_string)+1;
294    
295    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
296      env->gc_count += length;
297    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
298    new_value->type= string;    new_value->type= string;
299    
# Line 285  void push_cstring(environment *env, cons Line 301  void push_cstring(environment *env, cons
301  }  }
302    
303  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
304  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
305    {
306    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
307    char *new_string, *current;    char *new_string, *current;
308    
# Line 303  char *mangle_str(const char *old_string) Line 320  char *mangle_str(const char *old_string)
320    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
321  }  }
322    
323  extern void mangle(environment *env){  extern void mangle(environment *env)
324    {
325    char *new_string;    char *new_string;
326    
327    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 312  extern void mangle(environment *env){ Line 330  extern void mangle(environment *env){
330      return;      return;
331    }    }
332    
333    if(env->head->item->type!=string) {    if(env->head->car->type!=string) {
334      printerr("Bad Argument Type");      printerr("Bad Argument Type");
335      env->err= 2;      env->err= 2;
336      return;      return;
337    }    }
338    
339    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string= mangle_str((const char *)(env->head->car->content.ptr));
340    
341    toss(env);    toss(env);
342    if(env->err) return;    if(env->err) return;
# Line 342  void push_sym(environment *env, const ch Line 360  void push_sym(environment *env, const ch
360    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
361    
362    new_value= new_val(env);    new_value= new_val(env);
363    protect(env, new_value);    protect(new_value);
364    new_fvalue= new_val(env);    new_fvalue= new_val(env);
365    protect(env, new_fvalue);    protect(new_fvalue);
366    
367    /* The new value is a symbol */    /* The new value is a symbol */
368    new_value->type= symb;    new_value->type= symb;
# Line 372  void push_sym(environment *env, const ch Line 390  void push_sym(environment *env, const ch
390    
391      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
392      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
393      free(mangled);  
394      dlerr= dlerror();      dlerr= dlerror();
395      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
396        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
397        dlerr= dlerror();        dlerr= dlerror();
398      }      }
399    
400      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
401        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
402        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
403        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
404                                           function value */                                           function value */
405      }      }
406    
407        free(mangled);
408    }    }
409    
410    push_val(env, new_value);    push_val(env, new_value);
411    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
412  }  }
413    
414  /* Print newline. */  /* Print newline. */
# Line 396  extern void nl() Line 418  extern void nl()
418  }  }
419    
420  /* Gets the type of a value */  /* Gets the type of a value */
421  extern void type(environment *env){  extern void type(environment *env)
422    {
423    int typenum;    int typenum;
424    
425    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 404  extern void type(environment *env){ Line 427  extern void type(environment *env){
427      env->err=1;      env->err=1;
428      return;      return;
429    }    }
430    typenum=env->head->item->type;    typenum=env->head->car->type;
431    toss(env);    toss(env);
432    switch(typenum){    switch(typenum){
433    case integer:    case integer:
# Line 422  extern void type(environment *env){ Line 445  extern void type(environment *env){
445    case func:    case func:
446      push_sym(env, "function");      push_sym(env, "function");
447      break;      break;
448    case list:    case tcons:
449      push_sym(env, "list");      push_sym(env, "list");
450      break;      break;
451    }    }
452  }      }    
453    
454  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
455  void print_h(stackitem *stack_head, int noquote)  void print_h(cons *stack_head, int noquote)
456  {  {
457    switch(stack_head->item->type) {    switch(stack_head->car->type) {
458    case integer:    case integer:
459      printf("%d", stack_head->item->content.i);      printf("%d", stack_head->car->content.i);
460      break;      break;
461    case tfloat:    case tfloat:
462      printf("%f", stack_head->item->content.f);      printf("%f", stack_head->car->content.f);
463      break;      break;
464    case string:    case string:
465      if(noquote)      if(noquote)
466        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)stack_head->car->content.ptr);
467      else      else
468        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)stack_head->car->content.ptr);
469      break;      break;
470    case symb:    case symb:
471      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", ((symbol *)(stack_head->car->content.ptr))->id);
472      break;      break;
473    case func:    case func:
474      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(stack_head->car->content.ptr));
475      break;      break;
476    case list:    case tcons:
477      /* 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 */
478      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head=(cons*)(stack_head->car->content.ptr);
479      printf("[ ");      printf("[ ");
480      while(stack_head != NULL) {      while(stack_head != NULL) {
481        print_h(stack_head, noquote);        print_h(stack_head, noquote);
482        printf(" ");        printf(" ");
483        stack_head=stack_head->next;        stack_head= stack_head->cdr->content.c;
484      }      }
485      printf("]");      printf("]");
486      break;      break;
487    }    }
488  }  }
489    
490  extern void print_(environment *env) {  extern void print_(environment *env)
491    {
492    if(env->head==NULL) {    if(env->head==NULL) {
493      printerr("Too Few Arguments");      printerr("Too Few Arguments");
494      env->err=1;      env->err=1;
# Line 482  extern void print(environment *env) Line 506  extern void print(environment *env)
506    toss(env);    toss(env);
507  }  }
508    
509  extern void princ_(environment *env) {  extern void princ_(environment *env)
510    {
511    if(env->head==NULL) {    if(env->head==NULL) {
512      printerr("Too Few Arguments");      printerr("Too Few Arguments");
513      env->err=1;      env->err=1;
# Line 500  extern void princ(environment *env) Line 525  extern void princ(environment *env)
525  }  }
526    
527  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
528  void print_st(stackitem *stack_head, long counter)  void print_st(cons *stack_head, long counter)
529  {  {
530    if(stack_head->next != NULL)    if(stack_head->cdr->content.c != NULL)
531      print_st(stack_head->next, counter+1);      print_st(stack_head->cdr->content.c, counter+1);
532    printf("%ld: ", counter);    printf("%ld: ", counter);
533    print_h(stack_head, 0);    print_h(stack_head, 0);
534    nl();    nl();
# Line 516  extern void printstack(environment *env) Line 541  extern void printstack(environment *env)
541      printf("Stack Empty\n");      printf("Stack Empty\n");
542      return;      return;
543    }    }
544    
545    print_st(env->head, 1);    print_st(env->head, 1);
546  }  }
547    
548  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
549  extern void swap(environment *env)  extern void swap(environment *env)
550  {  {
551    stackitem *temp= env->head;    cons *temp= env->head;
552        
553    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
554      printerr("Too Few Arguments");      printerr("Too Few Arguments");
555      env->err=1;      env->err=1;
556      return;      return;
557    }    }
558    
559    env->head= env->head->next;    env->head= env->head->cdr->content.c;
560    temp->next= env->head->next;    temp->cdr->content.c= env->head->cdr->content.c;
561    env->head->next= temp;    env->head->cdr->content.c= temp;
562  }  }
563    
564  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
565  extern void rot(environment *env)  extern void rot(environment *env)
566  {  {
567    stackitem *temp= env->head;    cons *temp= env->head;
568        
569    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || env->head->cdr->content.c==NULL
570        || env->head->next->next==NULL) {        || env->head->cdr->content.c->cdr->content.c==NULL) {
571      printerr("Too Few Arguments");      printerr("Too Few Arguments");
572      env->err=1;      env->err=1;
573      return;      return;
574    }    }
575    
576    env->head= env->head->next->next;    env->head= env->head->cdr->content.c->cdr->content.c;
577    temp->next->next= env->head->next;    temp->cdr->content.c->cdr->content.c= env->head->cdr->content.c;
578    env->head->next= temp;    env->head->cdr->content.c= temp;
579  }  }
580    
581  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 557  extern void rcl(environment *env) Line 583  extern void rcl(environment *env)
583  {  {
584    value *val;    value *val;
585    
586    if(env->head == NULL) {    if(env->head==NULL) {
587      printerr("Too Few Arguments");      printerr("Too Few Arguments");
588      env->err=1;      env->err= 1;
589      return;      return;
590    }    }
591    
592    if(env->head->item->type!=symb) {    if(env->head->car->type!=symb) {
593      printerr("Bad Argument Type");      printerr("Bad Argument Type");
594      env->err=2;      env->err= 2;
595      return;      return;
596    }    }
597    
598    val=((symbol *)(env->head->item->content.ptr))->val;    val= ((symbol *)(env->head->car->content.ptr))->val;
599    if(val == NULL){    if(val == NULL){
600      printerr("Unbound Variable");      printerr("Unbound Variable");
601      env->err=3;      env->err= 3;
602      return;      return;
603    }    }
604    protect(env, val);    protect(val);
605    toss(env);            /* toss the symbol */    toss(env);            /* toss the symbol */
606    if(env->err) return;    if(env->err) return;
607    push_val(env, val); /* Return its bound value */    push_val(env, val); /* Return its bound value */
608    unprotect(env);    unprotect(val);
609  }  }
610    
611  /* 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 615  extern void eval(environment *env)
615  {  {
616    funcp in_func;    funcp in_func;
617    value* temp_val;    value* temp_val;
618    stackitem* iterator;    cons* iterator;
619    
620   eval_start:   eval_start:
621    
622      gc_maybe(env);
623    
624    if(env->head==NULL) {    if(env->head==NULL) {
625      printerr("Too Few Arguments");      printerr("Too Few Arguments");
626      env->err=1;      env->err= 1;
627      return;      return;
628    }    }
629    
630    switch(env->head->item->type) {    switch(env->head->car->type) {
631      /* if it's a symbol */      /* if it's a symbol */
632    case symb:    case symb:
633      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
634      if(env->err) return;      if(env->err) return;
635      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(env->head->car->type!=symb){ /* don't recurse symbols */
636        goto eval_start;        goto eval_start;
637      }      }
638      return;      return;
639    
640      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
641    case func:    case func:
642      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(env->head->car->content.ptr);
643      toss(env);      toss(env);
644      if(env->err) return;      if(env->err) return;
645      return in_func(env);      return in_func(env);
646    
647      /* If it's a list */      /* If it's a list */
648    case list:    case tcons:
649      temp_val= env->head->item;      temp_val= env->head->car;
650      protect(env, temp_val);      protect(temp_val);
651    
652      toss(env); if(env->err) return;      toss(env); if(env->err) return;
653      iterator= (stackitem*)temp_val->content.ptr;      iterator= (cons*)temp_val->content.ptr;
654            
655      while(iterator!=NULL) {      while(iterator!=NULL) {
656        push_val(env, iterator->item);        push_val(env, iterator->car);
657                
658        if(env->head->item->type==symb        if(env->head->car->type==symb
659          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && (((symbol*)(env->head->car->content.ptr))->id[0] == ';')) {
660          toss(env);          toss(env);
661          if(env->err) return;          if(env->err) return;
662                    
663          if(iterator->next == NULL){          if(iterator->cdr->content.c==NULL){
664            goto eval_start;            goto eval_start;
665          }          }
666          eval(env);          eval(env);
667          if(env->err) return;          if(env->err) return;
668        }        }
669        iterator= iterator->next;        iterator= iterator->cdr->content.c;
670      }      }
671      unprotect(env);      unprotect(temp_val);
672      return;      return;
673    
674    default:    default:
# Line 649  extern void eval(environment *env) Line 677  extern void eval(environment *env)
677  }  }
678    
679  /* Reverse (flip) a list */  /* Reverse (flip) a list */
680  extern void rev(environment *env){  extern void rev(environment *env)
681    stackitem *old_head, *new_head, *item;  {
682      cons *old_head, *new_head, *item;
683    
684    if((env->head)==NULL) {    if((env->head)==NULL) {
685      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 658  extern void rev(environment *env){ Line 687  extern void rev(environment *env){
687      return;      return;
688    }    }
689    
690    if(env->head->item->type!=list) {    if(env->head->car->type!=tcons) {
691      printerr("Bad Argument Type");      printerr("Bad Argument Type");
692      env->err= 2;      env->err= 2;
693      return;      return;
694    }    }
695    
696    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= (cons*)(env->head->car->content.ptr);
697    new_head= NULL;    new_head= NULL;
698    while(old_head != NULL){    while(old_head!=NULL) {
699      item= old_head;      item= old_head;
700      old_head= old_head->next;      old_head= old_head->cdr->content.c;
701      item->next= new_head;      item->cdr->content.c= new_head;
702      new_head= item;      new_head= item;
703    }    }
704    env->head->item->content.ptr= new_head;    env->head->car->content.ptr= new_head;
705  }  }
706    
707  /* Make a list. */  /* Make a list. */
708  extern void pack(environment *env)  extern void pack(environment *env)
709  {  {
710    stackitem *iterator, *temp;    cons *iterator, *temp;
711    value *pack;    value *pack;
712    
713    iterator= env->head;    iterator= env->head;
714    pack= new_val(env);    pack= new_val(env);
715    protect(env, pack);    protect(pack);
716    
717    if(iterator==NULL    if(iterator==NULL
718       || (iterator->item->type==symb       || (iterator->car->type==symb
719       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) {
720      temp= NULL;      temp= NULL;
721      toss(env);      toss(env);
722    } else {    } else {
723      /* Search for first delimiter */      /* Search for first delimiter */
724      while(iterator->next!=NULL      while(iterator->cdr->content.c!=NULL
725            && (iterator->next->item->type!=symb            && (iterator->cdr->content.c->car->type!=symb
726            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))            || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0]
727        iterator= iterator->next;                !='['))
728          iterator= iterator->cdr->content.c;
729            
730      /* Extract list */      /* Extract list */
731      temp= env->head;      temp= env->head;
732      env->head= iterator->next;      env->head= iterator->cdr->content.c;
733      iterator->next= NULL;      iterator->cdr->content.c= NULL;
734    
735      pack->type= list;      pack->type= tcons;
736      pack->content.ptr= temp;      pack->content.ptr= temp;
737            
738      if(env->head!=NULL)      if(env->head!=NULL)
# Line 714  extern void pack(environment *env) Line 744  extern void pack(environment *env)
744    push_val(env, pack);    push_val(env, pack);
745    rev(env);    rev(env);
746    
747    unprotect(env);    unprotect(pack);
748  }  }
749    
750  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
751  extern void expand(environment *env)  extern void expand(environment *env)
752  {  {
753    stackitem *temp, *new_head;    cons *temp, *new_head;
754    
755    /* Is top element a list? */    /* Is top element a list? */
756    if(env->head==NULL) {    if(env->head==NULL) {
# Line 728  extern void expand(environment *env) Line 758  extern void expand(environment *env)
758      env->err= 1;      env->err= 1;
759      return;      return;
760    }    }
761    if(env->head->item->type!=list) {    if(env->head->car->type!=tcons) {
762      printerr("Bad Argument Type");      printerr("Bad Argument Type");
763      env->err= 2;      env->err= 2;
764      return;      return;
# Line 740  extern void expand(environment *env) Line 770  extern void expand(environment *env)
770      return;      return;
771    
772    /* The first list element is the new stack head */    /* The first list element is the new stack head */
773    new_head= temp= env->head->item->content.ptr;    new_head= temp= env->head->car->content.ptr;
774    
775    toss(env);    toss(env);
776    
777    /* Find the end of the list */    /* Find the end of the list */
778    while(temp->next!=NULL)    while(temp->cdr->content.c!=NULL)
779      temp= temp->next;      temp= temp->cdr->content.c;
780    
781    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
782    temp->next= env->head;    temp->cdr->content.c= env->head;
783    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
784    
785  }  }
# Line 758  extern void expand(environment *env) Line 788  extern void expand(environment *env)
788  extern void eq(environment *env)  extern void eq(environment *env)
789  {  {
790    void *left, *right;    void *left, *right;
   int result;  
791    
792    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
793      printerr("Too Few Arguments");      printerr("Too Few Arguments");
794      env->err= 1;      env->err= 1;
795      return;      return;
796    }    }
797    
798    left= env->head->item->content.ptr;    left= env->head->car->content.ptr;
799    swap(env);    swap(env);
800    right= env->head->item->content.ptr;    right= env->head->car->content.ptr;
   result= (left==right);  
     
801    toss(env); toss(env);    toss(env); toss(env);
802    push_int(env, result);  
803      push_int(env, left==right);
804  }  }
805    
806  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 780  extern void not(environment *env) Line 808  extern void not(environment *env)
808  {  {
809    int val;    int val;
810    
811    if((env->head)==NULL) {    if(env->head==NULL) {
812      printerr("Too Few Arguments");      printerr("Too Few Arguments");
813      env->err= 1;      env->err= 1;
814      return;      return;
815    }    }
816    
817    if(env->head->item->type!=integer) {    if(env->head->car->type!=integer) {
818      printerr("Bad Argument Type");      printerr("Bad Argument Type");
819      env->err= 2;      env->err= 2;
820      return;      return;
821    }    }
822    
823    val= env->head->item->content.i;    val= env->head->car->content.i;
824    toss(env);    toss(env);
825    push_int(env, !val);    push_int(env, !val);
826  }  }
# Line 811  extern void def(environment *env) Line 839  extern void def(environment *env)
839    symbol *sym;    symbol *sym;
840    
841    /* 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 */
842    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
843      printerr("Too Few Arguments");      printerr("Too Few Arguments");
844      env->err= 1;      env->err= 1;
845      return;      return;
846    }    }
847    
848    if(env->head->item->type!=symb) {    if(env->head->car->type!=symb) {
849      printerr("Bad Argument Type");      printerr("Bad Argument Type");
850      env->err= 2;      env->err= 2;
851      return;      return;
852    }    }
853    
854    /* long names are a pain */    /* long names are a pain */
855    sym= env->head->item->content.ptr;    sym= env->head->car->content.ptr;
856    
857    /* Bind the symbol to the value */    /* Bind the symbol to the value */
858    sym->val= env->head->next->item;    sym->val= env->head->cdr->content.c->car;
859    
860    toss(env); toss(env);    toss(env); toss(env);
861  }  }
# Line 835  extern void def(environment *env) Line 863  extern void def(environment *env)
863  /* Quit stack. */  /* Quit stack. */
864  extern void quit(environment *env)  extern void quit(environment *env)
865  {  {
866    long i;    int i;
867    
868    clear(env);    clear(env);
869    
# Line 848  extern void quit(environment *env) Line 876  extern void quit(environment *env)
876    }    }
877    
878    env->gc_limit= 0;    env->gc_limit= 0;
879    gc_init(env);    gc_maybe(env);
880    
881    if(env->free_string!=NULL)    if(env->free_string!=NULL)
882      free(env->free_string);      free(env->free_string);
# Line 881  extern void words(environment *env) Line 909  extern void words(environment *env)
909  }  }
910    
911  /* Internal forget function */  /* Internal forget function */
912  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
913    {
914    symbol *temp;    symbol *temp;
915    
916    temp= *hash_entry;    temp= *hash_entry;
# Line 895  void forget_sym(symbol **hash_entry) { Line 924  void forget_sym(symbol **hash_entry) {
924  extern void forget(environment *env)  extern void forget(environment *env)
925  {  {
926    char* sym_id;    char* sym_id;
927    stackitem *stack_head= env->head;    cons *stack_head= env->head;
928    
929    if(stack_head==NULL) {    if(stack_head==NULL) {
930      printerr("Too Few Arguments");      printerr("Too Few Arguments");
931      env->err=1;      env->err= 1;
932      return;      return;
933    }    }
934        
935    if(stack_head->item->type!=symb) {    if(stack_head->car->type!=symb) {
936      printerr("Bad Argument Type");      printerr("Bad Argument Type");
937      env->err=2;      env->err= 2;
938      return;      return;
939    }    }
940    
941    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= ((symbol*)(stack_head->car->content.ptr))->id;
942    toss(env);    toss(env);
943    
944    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
945  }  }
946    
947  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
948  extern void errn(environment *env){  extern void errn(environment *env)
949    {
950    push_int(env, env->err);    push_int(env, env->err);
951  }  }
952    
# Line 980  under certain conditions; type `copying; Line 1010  under certain conditions; type `copying;
1010      if (myenv.err==4) {      if (myenv.err==4) {
1011        return EXIT_SUCCESS;      /* EOF */        return EXIT_SUCCESS;      /* EOF */
1012      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1013                && myenv.head->item->type==symb                && myenv.head->car->type==symb
1014                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && ((symbol*)(myenv.head->car->content.ptr))->id[0]==';') {
1015        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1016        eval(&myenv);        eval(&myenv);
1017      }      }
1018      gc_init(&myenv);      gc_maybe(&myenv);
1019    }    }
1020    quit(&myenv);    quit(&myenv);
1021    return EXIT_FAILURE;    return EXIT_FAILURE;
1022  }  }
1023    
1024  /* "+" */  /* "+" */
1025  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1026    {
1027    int a, b;    int a, b;
1028    float fa, fb;    float fa, fb;
1029    size_t len;    size_t len;
1030    char* new_string;    char* new_string;
1031    value *a_val, *b_val;    value *a_val, *b_val;
1032    
1033    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1034      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1035      env->err= 1;      env->err= 1;
1036      return;      return;
1037    }    }
1038    
1039    if(env->head->item->type==string    if(env->head->car->type==string
1040       && env->head->next->item->type==string) {       && env->head->cdr->content.c->car->type==string) {
1041      a_val= env->head->item;      a_val= env->head->car;
1042      b_val= env->head->next->item;      b_val= env->head->cdr->content.c->car;
1043      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1044      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1045      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1046      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 1048  extern void sx_2b(environment *env) {
1048      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1049      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1050      push_cstring(env, new_string);      push_cstring(env, new_string);
1051      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1052      free(new_string);      free(new_string);
1053            
1054      return;      return;
1055    }    }
1056        
1057    if(env->head->item->type==integer    if(env->head->car->type==integer
1058       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1059      a=env->head->item->content.i;      a= env->head->car->content.i;
1060      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1061      b=env->head->item->content.i;      b= env->head->car->content.i;
1062      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1063      push_int(env, b+a);      push_int(env, b+a);
1064    
1065      return;      return;
1066    }    }
1067    
1068    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1069       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1070      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1071      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1072      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1073      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1074      push_float(env, fb+fa);      push_float(env, fb+fa);
1075            
1076      return;      return;
1077    }    }
1078    
1079    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1080       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1081      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1082      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1083      b= env->head->item->content.i;      b= env->head->car->content.i;
1084      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1085      push_float(env, b+fa);      push_float(env, b+fa);
1086            
1087      return;      return;
1088    }    }
1089    
1090    if(env->head->item->type==integer    if(env->head->car->type==integer
1091       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1092      a= env->head->item->content.i;      a= env->head->car->content.i;
1093      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1094      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1095      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1096      push_float(env, fb+a);      push_float(env, fb+a);
1097    
# Line 1072  extern void sx_2b(environment *env) { Line 1103  extern void sx_2b(environment *env) {
1103  }  }
1104    
1105  /* "-" */  /* "-" */
1106  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1107    {
1108    int a, b;    int a, b;
1109    float fa, fb;    float fa, fb;
1110    
1111    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1112      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1113      env->err=1;      env->err=1;
1114      return;      return;
1115    }    }
1116        
1117    if(env->head->item->type==integer    if(env->head->car->type==integer
1118       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1119      a=env->head->item->content.i;      a= env->head->car->content.i;
1120      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1121      b=env->head->item->content.i;      b= env->head->car->content.i;
1122      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1123      push_int(env, b-a);      push_int(env, b-a);
1124    
1125      return;      return;
1126    }    }
1127    
1128    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1129       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1130      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1131      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1132      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1133      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1134      push_float(env, fb-fa);      push_float(env, fb-fa);
1135            
1136      return;      return;
1137    }    }
1138    
1139    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1140       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1141      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1142      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1143      b= env->head->item->content.i;      b= env->head->car->content.i;
1144      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1145      push_float(env, b-fa);      push_float(env, b-fa);
1146            
1147      return;      return;
1148    }    }
1149    
1150    if(env->head->item->type==integer    if(env->head->car->type==integer
1151       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1152      a= env->head->item->content.i;      a= env->head->car->content.i;
1153      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1154      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1155      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1156      push_float(env, fb-a);      push_float(env, fb-a);
1157    
# Line 1131  extern void sx_2d(environment *env) { Line 1163  extern void sx_2d(environment *env) {
1163  }  }
1164    
1165  /* ">" */  /* ">" */
1166  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1167    {
1168    int a, b;    int a, b;
1169    float fa, fb;    float fa, fb;
1170    
1171    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1172      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1173      env->err=1;      env->err= 1;
1174      return;      return;
1175    }    }
1176        
1177    if(env->head->item->type==integer    if(env->head->car->type==integer
1178       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1179      a=env->head->item->content.i;      a=env->head->car->content.i;
1180      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1181      b=env->head->item->content.i;      b=env->head->car->content.i;
1182      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1183      push_int(env, b>a);      push_int(env, b>a);
1184    
1185      return;      return;
1186    }    }
1187    
1188    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1189       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1190      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1191      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1192      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1193      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1194      push_int(env, fb>fa);      push_int(env, fb>fa);
1195            
1196      return;      return;
1197    }    }
1198    
1199    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1200       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1201      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1202      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1203      b= env->head->item->content.i;      b= env->head->car->content.i;
1204      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1205      push_int(env, b>fa);      push_int(env, b>fa);
1206            
1207      return;      return;
1208    }    }
1209    
1210    if(env->head->item->type==integer    if(env->head->car->type==integer
1211       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1212      a= env->head->item->content.i;      a= env->head->car->content.i;
1213      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1214      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1215      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1216      push_int(env, fb>a);      push_int(env, fb>a);
1217    
# Line 1190  extern void sx_3e(environment *env) { Line 1223  extern void sx_3e(environment *env) {
1223  }  }
1224    
1225  /* "<" */  /* "<" */
1226  extern void sx_3c(environment *env) {  extern void sx_3c(environment *env)
1227    {
1228    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1229    sx_3e(env);    sx_3e(env);
1230  }  }
1231    
1232  /* "<=" */  /* "<=" */
1233  extern void sx_3c3d(environment *env) {  extern void sx_3c3d(environment *env)
1234    {
1235    sx_3e(env); if(env->err) return;    sx_3e(env); if(env->err) return;
1236    not(env);    not(env);
1237  }  }
1238    
1239  /* ">=" */  /* ">=" */
1240  extern void sx_3e3d(environment *env) {  extern void sx_3e3d(environment *env)
1241    {
1242    sx_3c(env); if(env->err) return;    sx_3c(env); if(env->err) return;
1243    not(env);    not(env);
1244  }  }
1245    
1246  /* Return copy of a value */  /* Return copy of a value */
1247  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1248    stackitem *old_item, *new_item, *prev_item;  {
1249      cons *old_item, *new_item, *prev_item;
1250    value *new_value;    value *new_value;
1251    
1252    protect(env, old_value);    protect(old_value);
1253    new_value= new_val(env);    new_value= new_val(env);
1254    protect(env, new_value);    protect(new_value);
1255    new_value->type= old_value->type;    new_value->type= old_value->type;
1256    
1257    switch(old_value->type){    switch(old_value->type){
# Line 1228  value *copy_val(environment *env, value Line 1265  value *copy_val(environment *env, value
1265      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1266        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1267      break;      break;
1268    case list:    case tcons:
1269      new_value->content.ptr= NULL;      new_value->content.ptr= NULL;
1270    
1271      prev_item= NULL;      prev_item= NULL;
1272      old_item= (stackitem*)(old_value->content.ptr);      old_item= (cons*)(old_value->content.ptr);
1273    
1274      while(old_item != NULL) {   /* While list is not empty */      while(old_item != NULL) {   /* While list is not empty */
1275        new_item= malloc(sizeof(stackitem));        new_item= malloc(sizeof(cons));
1276        new_item->item= copy_val(env, old_item->item); /* recurse */        new_item->car= copy_val(env, old_item->car); /* recurse */
1277        new_item->next= NULL;        new_item->cdr= new_val(env);
1278          new_item->cdr->type= tcons;
1279          new_item->cdr->content.c= NULL;
1280        if(prev_item != NULL)     /* If this wasn't the first item */        if(prev_item != NULL)     /* If this wasn't the first item */
1281          prev_item->next= new_item; /* point the previous item to the          prev_item->cdr->content.c= new_item; /* point the previous item to the
1282                                       new item */                                       new item */
1283        else        else
1284          new_value->content.ptr= new_item;          new_value->content.ptr= new_item;
1285        old_item= old_item->next;        old_item= old_item->cdr->content.c;
1286        prev_item= new_item;        prev_item= new_item;
1287      }          }    
1288      break;      break;
1289    }    }
1290    
1291    unprotect(env); unprotect(env);    unprotect(old_value); unprotect(new_value);
1292    
1293    return new_value;    return new_value;
1294  }  }
1295    
1296  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1297  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1298    if((env->head)==NULL) {  {
1299      if(env->head==NULL) {
1300      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1301      env->err= 1;      env->err= 1;
1302      return;      return;
1303    }    }
1304    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, env->head->car));
1305  }  }
1306    
1307  /* "if", If-Then */  /* "if", If-Then */
1308  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1309    {
1310    int truth;    int truth;
1311    
1312    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1313      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1314      env->err= 1;      env->err= 1;
1315      return;      return;
1316    }    }
1317    
1318    if(env->head->next->item->type != integer) {    if(env->head->cdr->content.c->car->type != integer) {
1319      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1320      env->err=2;      env->err= 2;
1321      return;      return;
1322    }    }
1323        
1324    swap(env);    swap(env);
1325    if(env->err) return;    if(env->err) return;
1326        
1327    truth=env->head->item->content.i;    truth=env->head->car->content.i;
1328    
1329    toss(env);    toss(env);
1330    if(env->err) return;    if(env->err) return;
# Line 1296  extern void sx_6966(environment *env) { Line 1336  extern void sx_6966(environment *env) {
1336  }  }
1337    
1338  /* If-Then-Else */  /* If-Then-Else */
1339  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1340    {
1341    int truth;    int truth;
1342    
1343    if((env->head)==NULL || env->head->next==NULL    if(env->head==NULL || env->head->cdr->content.c==NULL
1344       || env->head->next->next==NULL) {       || env->head->cdr->content.c->cdr->content.c==NULL) {
1345      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1346      env->err=1;      env->err= 1;
1347      return;      return;
1348    }    }
1349    
1350    if(env->head->next->next->item->type != integer) {    if(env->head->cdr->content.c->cdr->content.c->car->type!=integer) {
1351      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1352      env->err=2;      env->err= 2;
1353      return;      return;
1354    }    }
1355        
1356    rot(env);    rot(env);
1357    if(env->err) return;    if(env->err) return;
1358        
1359    truth=env->head->item->content.i;    truth= env->head->car->content.i;
1360    
1361    toss(env);    toss(env);
1362    if(env->err) return;    if(env->err) return;
# Line 1332  extern void ifelse(environment *env) { Line 1372  extern void ifelse(environment *env) {
1372  }  }
1373    
1374  /* "while" */  /* "while" */
1375  extern void sx_7768696c65(environment *env) {  extern void sx_7768696c65(environment *env)
1376    {
1377    int truth;    int truth;
1378    value *loop, *test;    value *loop, *test;
1379    
1380    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1381      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1382      env->err=1;      env->err= 1;
1383      return;      return;
1384    }    }
1385    
1386    loop= env->head->item;    loop= env->head->car;
1387    protect(env, loop);    protect(loop);
1388    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1389    
1390    test= env->head->item;    test= env->head->car;
1391    protect(env, test);    protect(test);
1392    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1393    
1394    do {    do {
1395      push_val(env, test);      push_val(env, test);
1396      eval(env);      eval(env);
1397            
1398      if(env->head->item->type != integer) {      if(env->head->car->type != integer) {
1399        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1400        env->err= 2;        env->err= 2;
1401        return;        return;
1402      }      }
1403            
1404      truth= env->head->item->content.i;      truth= env->head->car->content.i;
1405      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1406            
1407      if(truth) {      if(truth) {
# Line 1373  extern void sx_7768696c65(environment *e Line 1413  extern void sx_7768696c65(environment *e
1413        
1414    } while(truth);    } while(truth);
1415    
1416    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1417  }  }
1418    
1419    
1420  /* "for"; for-loop */  /* "for"; for-loop */
1421  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1422    {
1423    value *loop;    value *loop;
1424    int foo1, foo2;    int foo1, foo2;
1425    
1426    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || env->head->cdr->content.c==NULL
1427       || env->head->next->next==NULL) {       || env->head->cdr->content.c->cdr->content.c==NULL) {
1428      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1429      env->err= 1;      env->err= 1;
1430      return;      return;
1431    }    }
1432    
1433    if(env->head->next->item->type!=integer    if(env->head->cdr->content.c->car->type!=integer
1434       || env->head->next->next->item->type!=integer) {       || env->head->cdr->content.c->cdr->content.c->car->type!=integer) {
1435      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1436      env->err= 2;      env->err= 2;
1437      return;      return;
1438    }    }
1439    
1440    loop= env->head->item;    loop= env->head->car;
1441    protect(env, loop);    protect(loop);
1442    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1443    
1444    foo2= env->head->item->content.i;    foo2= env->head->car->content.i;
1445    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1446    
1447    foo1= env->head->item->content.i;    foo1= env->head->car->content.i;
1448    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1449    
1450    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1421  extern void sx_666f72(environment *env) Line 1462  extern void sx_666f72(environment *env)
1462        foo1--;        foo1--;
1463      }      }
1464    }    }
1465    unprotect(env);    unprotect(loop);
1466  }  }
1467    
1468  /* Variant of for-loop */  /* Variant of for-loop */
1469  extern void foreach(environment *env) {  extern void foreach(environment *env)
1470      {  
1471    value *loop, *foo;    value *loop, *foo;
1472    stackitem *iterator;    cons *iterator;
1473        
1474    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1475      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1476      env->err= 1;      env->err= 1;
1477      return;      return;
1478    }    }
1479    
1480    if(env->head->next->item->type != list) {    if(env->head->cdr->content.c->car->type!=tcons) {
1481      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1482      env->err= 2;      env->err= 2;
1483      return;      return;
1484    }    }
1485    
1486    loop= env->head->item;    loop= env->head->car;
1487    protect(env, loop);    protect(loop);
1488    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1489    
1490    foo= env->head->item;    foo= env->head->car;
1491    protect(env, foo);    protect(foo);
1492    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1493    
1494    iterator= foo->content.ptr;    iterator= foo->content.ptr;
1495    
1496    while(iterator!=NULL) {    while(iterator!=NULL) {
1497      push_val(env, iterator->item);      push_val(env, iterator->car);
1498      push_val(env, loop);      push_val(env, loop);
1499      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1500      iterator= iterator->next;      iterator= iterator->cdr->content.c;
1501    }    }
1502    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1503  }  }
1504    
1505  /* "to" */  /* "to" */
1506  extern void to(environment *env) {  extern void to(environment *env)
1507    int i, start, ending;  {
1508    stackitem *temp_head;    int ending, start, i;
1509    value *temp_val;    cons *iterator, *temp;
1510        value *pack;
1511    if((env->head)==NULL || env->head->next==NULL) {  
1512      if(env->head==NULL || env->head->cdr->content.c==NULL) {
1513      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1514      env->err=1;      env->err= 1;
1515      return;      return;
1516    }    }
1517    
1518    if(env->head->item->type!=integer    if(env->head->car->type!=integer
1519       || env->head->next->item->type!=integer) {       || env->head->cdr->content.c->car->type!=integer) {
1520      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1521      env->err=2;      env->err= 2;
1522      return;      return;
1523    }    }
1524    
1525    ending= env->head->item->content.i;    ending= env->head->car->content.i;
1526    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1527    start= env->head->item->content.i;    start= env->head->car->content.i;
1528    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1529    
1530    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1531    
1532    if(ending>=start) {    if(ending>=start) {
1533      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1496  extern void to(environment *env) { Line 1537  extern void to(environment *env) {
1537        push_int(env, i);        push_int(env, i);
1538    }    }
1539    
1540    temp_val= new_val(env);    iterator= env->head;
1541    protect(env, temp_val);    pack= new_val(env);
1542      protect(pack);
1543    
1544      if(iterator==NULL
1545         || (iterator->car->type==symb
1546         && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) {
1547        temp= NULL;
1548        toss(env);
1549      } else {
1550        /* Search for first delimiter */
1551        while(iterator->cdr->content.c!=NULL
1552              && (iterator->cdr->content.c->car->type!=symb
1553              || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0]
1554                  !='['))
1555          iterator= iterator->cdr->content.c;
1556        
1557        /* Extract list */
1558        temp= env->head;
1559        env->head= iterator->cdr->content.c;
1560        iterator->cdr->content.c= NULL;
1561    
1562        pack->type= tcons;
1563        pack->content.ptr= temp;
1564        
1565        if(env->head!=NULL)
1566          toss(env);
1567      }
1568    
1569      /* Push list */
1570    
1571    temp_val->content.ptr= env->head;    push_val(env, pack);
   temp_val->type= list;  
   env->head= temp_head;  
   push_val(env, temp_val);  
1572    
1573    unprotect(env);    unprotect(pack);
1574  }  }
1575    
1576  /* Read a string */  /* Read a string */
1577  extern void readline(environment *env) {  extern void readline(environment *env)
1578    {
1579    char in_string[101];    char in_string[101];
1580    
1581    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1518  extern void readline(environment *env) { Line 1585  extern void readline(environment *env) {
1585  }  }
1586    
1587  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1588  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1589    {
1590    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1591    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1592    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1541  extern void sx_72656164(environment *env Line 1609  extern void sx_72656164(environment *env
1609      }      }
1610      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1611    
1612      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(env->head->car->content.ptr))[0]=='\0'){
1613        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1614        return;        return;
1615      }      }
1616            
1617      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(env->head->car->content.ptr)+1);
1618      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1619      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, env->head->car->content.ptr);
1620      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1621    }    }
1622        
# Line 1597  extern void sx_72656164(environment *env Line 1665  extern void sx_72656164(environment *env
1665      return sx_72656164(env);      return sx_72656164(env);
1666  }  }
1667    
1668  extern void beep(environment *env) {  extern void beep(environment *env)
1669    {
1670    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1671    
1672    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1673      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1674      env->err=1;      env->err= 1;
1675      return;      return;
1676    }    }
1677    
1678    if(env->head->item->type!=integer    if(env->head->car->type!=integer
1679       || env->head->next->item->type!=integer) {       || env->head->cdr->content.c->car->type!=integer) {
1680      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1681      env->err=2;      env->err= 2;
1682      return;      return;
1683    }    }
1684    
1685    dur=env->head->item->content.i;    dur= env->head->car->content.i;
1686    toss(env);    toss(env);
1687    freq=env->head->item->content.i;    freq= env->head->car->content.i;
1688    toss(env);    toss(env);
1689    
1690    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1691                                     length */                                     length */
1692    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1693                                     timer ticks */                                     timer ticks */
1694    
1695  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1696    
1697    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1698    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1699    case 0:    case 0:
1700      usleep(dur);      usleep(dur);
1701      return;      return;
1702    case -1:    case -1:
1703      perror("beep");      perror("beep");
1704      env->err=5;      env->err= 5;
1705      return;      return;
1706    default:    default:
1707      abort();      abort();
1708    }    }
1709  };  }
1710    
1711  /* "wait" */  /* "wait" */
1712  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1713    {
1714    int dur;    int dur;
1715    
1716    if((env->head)==NULL) {    if(env->head==NULL) {
1717      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1718      env->err=1;      env->err= 1;
1719      return;      return;
1720    }    }
1721    
1722    if(env->head->item->type!=integer) {    if(env->head->car->type!=integer) {
1723      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1724      env->err=2;      env->err= 2;
1725      return;      return;
1726    }    }
1727    
1728    dur=env->head->item->content.i;    dur=env->head->car->content.i;
1729    toss(env);    toss(env);
1730    
1731    usleep(dur);    usleep(dur);
1732  };  }
1733    
1734  extern void copying(environment *env){  extern void copying(environment *env)
1735    {
1736    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1737                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1738  \n\  \n\
# Line 1922  of preserving the free status of all der Line 1991  of preserving the free status of all der
1991  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
1992  }  }
1993    
1994  extern void warranty(environment *env){  extern void warranty(environment *env)
1995    {
1996    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
1997  \n\  \n\
1998    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 2022  extern void sx_2a(environment *env)
2022    int a, b;    int a, b;
2023    float fa, fb;    float fa, fb;
2024    
2025    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
2026      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2027      env->err=1;      env->err= 1;
2028      return;      return;
2029    }    }
2030        
2031    if(env->head->item->type==integer    if(env->head->car->type==integer
2032       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2033      a=env->head->item->content.i;      a= env->head->car->content.i;
2034      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2035      b=env->head->item->content.i;      b= env->head->car->content.i;
2036      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2037      push_int(env, b*a);      push_int(env, b*a);
2038    
2039      return;      return;
2040    }    }
2041    
2042    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
2043       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
2044      fa= env->head->item->content.f;      fa= env->head->car->content.f;
2045      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2046      fb= env->head->item->content.f;      fb= env->head->car->content.f;
2047      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2048      push_float(env, fb*fa);      push_float(env, fb*fa);
2049            
2050      return;      return;
2051    }    }
2052    
2053    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
2054       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2055      fa= env->head->item->content.f;      fa= env->head->car->content.f;
2056      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2057      b= env->head->item->content.i;      b= env->head->car->content.i;
2058      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2059      push_float(env, b*fa);      push_float(env, b*fa);
2060            
2061      return;      return;
2062    }    }
2063    
2064    if(env->head->item->type==integer    if(env->head->car->type==integer
2065       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
2066      a= env->head->item->content.i;      a= env->head->car->content.i;
2067      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2068      fb= env->head->item->content.f;      fb= env->head->car->content.f;
2069      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2070      push_float(env, fb*a);      push_float(env, fb*a);
2071    
# Line 2003  extern void sx_2a(environment *env) Line 2073  extern void sx_2a(environment *env)
2073    }    }
2074    
2075    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2076    env->err=2;    env->err= 2;
2077  }  }
2078    
2079  /* "/" */  /* "/" */
# Line 2012  extern void sx_2f(environment *env) Line 2082  extern void sx_2f(environment *env)
2082    int a, b;    int a, b;
2083    float fa, fb;    float fa, fb;
2084    
2085    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
2086      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2087      env->err=1;      env->err= 1;
2088      return;      return;
2089    }    }
2090        
2091    if(env->head->item->type==integer    if(env->head->car->type==integer
2092       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2093      a=env->head->item->content.i;      a= env->head->car->content.i;
2094      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2095      b=env->head->item->content.i;      b= env->head->car->content.i;
2096      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2097      push_float(env, b/a);      push_float(env, b/a);
2098    
2099      return;      return;
2100    }    }
2101    
2102    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
2103       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
2104      fa= env->head->item->content.f;      fa= env->head->car->content.f;
2105      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2106      fb= env->head->item->content.f;      fb= env->head->car->content.f;
2107      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2108      push_float(env, fb/fa);      push_float(env, fb/fa);
2109            
2110      return;      return;
2111    }    }
2112    
2113    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
2114       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2115      fa= env->head->item->content.f;      fa= env->head->car->content.f;
2116      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2117      b= env->head->item->content.i;      b= env->head->car->content.i;
2118      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2119      push_float(env, b/fa);      push_float(env, b/fa);
2120            
2121      return;      return;
2122    }    }
2123    
2124    if(env->head->item->type==integer    if(env->head->car->type==integer
2125       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
2126      a= env->head->item->content.i;      a= env->head->car->content.i;
2127      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2128      fb= env->head->item->content.f;      fb= env->head->car->content.f;
2129      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2130      push_float(env, fb/a);      push_float(env, fb/a);
2131    
# Line 2063  extern void sx_2f(environment *env) Line 2133  extern void sx_2f(environment *env)
2133    }    }
2134    
2135    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2136    env->err=2;    env->err= 2;
2137  }  }
2138    
2139  /* "mod" */  /* "mod" */
# Line 2071  extern void mod(environment *env) Line 2141  extern void mod(environment *env)
2141  {  {
2142    int a, b;    int a, b;
2143    
2144    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
2145      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2146      env->err= 1;      env->err= 1;
2147      return;      return;
2148    }    }
2149        
2150    if(env->head->item->type==integer    if(env->head->car->type==integer
2151       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2152      a= env->head->item->content.i;      a= env->head->car->content.i;
2153      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2154      b= env->head->item->content.i;      b= env->head->car->content.i;
2155      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2156      push_int(env, b%a);      push_int(env, b%a);
2157    
# Line 2089  extern void mod(environment *env) Line 2159  extern void mod(environment *env)
2159    }    }
2160    
2161    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2162    env->err=2;    env->err= 2;
2163  }  }
2164    
2165  /* "div" */  /* "div" */
# Line 2097  extern void sx_646976(environment *env) Line 2167  extern void sx_646976(environment *env)
2167  {  {
2168    int a, b;    int a, b;
2169        
2170    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
2171      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2172      env->err= 1;      env->err= 1;
2173      return;      return;
2174    }    }
2175    
2176    if(env->head->item->type==integer    if(env->head->car->type==integer
2177       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2178      a= env->head->item->content.i;      a= env->head->car->content.i;
2179      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2180      b= env->head->item->content.i;      b= env->head->car->content.i;
2181      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2182      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2183    
Legend:
Removed from v.1.94  
changed lines
  Added in v.1.102
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26