/[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.103 by teddy, Mon Mar 11 08:52:59 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=stack_head->car->content.c;
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.ptr==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;        if (iterator->cdr->type == tcons)
670            iterator= iterator->cdr->content.c;
671          else {
672            printerr("Bad Argument Type"); /* Improper list */
673            env->err= 2;
674            return;
675          }
676      }      }
677      unprotect(env);      unprotect(temp_val);
678      return;      return;
679    
680    default:    default:
# Line 649  extern void eval(environment *env) Line 683  extern void eval(environment *env)
683  }  }
684    
685  /* Reverse (flip) a list */  /* Reverse (flip) a list */
686  extern void rev(environment *env){  extern void rev(environment *env)
687    stackitem *old_head, *new_head, *item;  {
688      cons *old_head, *new_head, *item;
689    
690    if((env->head)==NULL) {    if((env->head)==NULL) {
691      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 658  extern void rev(environment *env){ Line 693  extern void rev(environment *env){
693      return;      return;
694    }    }
695    
696    if(env->head->item->type!=list) {    if(env->head->car->type!=tcons) {
697      printerr("Bad Argument Type");      printerr("Bad Argument Type");
698      env->err= 2;      env->err= 2;
699      return;      return;
700    }    }
701    
702    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= env->head->car->content.c;
703    new_head= NULL;    new_head= NULL;
704    while(old_head != NULL){    while(old_head!=NULL) {
705      item= old_head;      item= old_head;
706      old_head= old_head->next;      old_head= old_head->cdr->content.c;
707      item->next= new_head;      item->cdr->content.c= new_head;
708      new_head= item;      new_head= item;
709    }    }
710    env->head->item->content.ptr= new_head;    env->head->car->content.ptr= new_head;
711  }  }
712    
713  /* Make a list. */  /* Make a list. */
714  extern void pack(environment *env)  extern void pack(environment *env)
715  {  {
716    stackitem *iterator, *temp;    cons *iterator, *temp;
717    value *pack;    value *pack;
718    
719    iterator= env->head;    iterator= env->head;
720    pack= new_val(env);    pack= new_val(env);
721    protect(env, pack);    protect(pack);
722    
723    if(iterator==NULL    if(iterator==NULL
724       || (iterator->item->type==symb       || (iterator->car->type==symb
725       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) {
726      temp= NULL;      temp= NULL;
727      toss(env);      toss(env);
728    } else {    } else {
729      /* Search for first delimiter */      /* Search for first delimiter */
730      while(iterator->next!=NULL      while(iterator->cdr->content.c!=NULL
731            && (iterator->next->item->type!=symb            && (iterator->cdr->content.c->car->type!=symb
732            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))                || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0]
733        iterator= iterator->next;                !='['))
734          iterator= iterator->cdr->content.c;
735            
736      /* Extract list */      /* Extract list */
737      temp= env->head;      temp= env->head;
738      env->head= iterator->next;      env->head= iterator->cdr->content.c;
739      iterator->next= NULL;      iterator->cdr->content.c= NULL;
740    
741      pack->type= list;      pack->type= tcons;
742      pack->content.ptr= temp;      pack->content.ptr= temp;
743            
744      if(env->head!=NULL)      if(env->head!=NULL)
# Line 714  extern void pack(environment *env) Line 750  extern void pack(environment *env)
750    push_val(env, pack);    push_val(env, pack);
751    rev(env);    rev(env);
752    
753    unprotect(env);    unprotect(pack);
754  }  }
755    
756  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
757  extern void expand(environment *env)  extern void expand(environment *env)
758  {  {
759    stackitem *temp, *new_head;    cons *temp, *new_head;
760    
761    /* Is top element a list? */    /* Is top element a list? */
762    if(env->head==NULL) {    if(env->head==NULL) {
# Line 728  extern void expand(environment *env) Line 764  extern void expand(environment *env)
764      env->err= 1;      env->err= 1;
765      return;      return;
766    }    }
767    if(env->head->item->type!=list) {    if(env->head->car->type!=tcons) {
768      printerr("Bad Argument Type");      printerr("Bad Argument Type");
769      env->err= 2;      env->err= 2;
770      return;      return;
# Line 740  extern void expand(environment *env) Line 776  extern void expand(environment *env)
776      return;      return;
777    
778    /* The first list element is the new stack head */    /* The first list element is the new stack head */
779    new_head= temp= env->head->item->content.ptr;    new_head= temp= env->head->car->content.c;
780    
781    toss(env);    toss(env);
782    
783    /* Find the end of the list */    /* Find the end of the list */
784    while(temp->next!=NULL)    while(temp->cdr->content.ptr != NULL) {
785      temp= temp->next;      if (temp->cdr->type == tcons)
786          temp= temp->cdr->content.c;
787        else {
788          printerr("Bad Argument Type"); /* Improper list */
789          env->err= 2;
790          return;
791        }
792      }
793    
794    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
795    temp->next= env->head;    temp->cdr->content.c= env->head;
796    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
797    
798  }  }
# Line 758  extern void expand(environment *env) Line 801  extern void expand(environment *env)
801  extern void eq(environment *env)  extern void eq(environment *env)
802  {  {
803    void *left, *right;    void *left, *right;
   int result;  
804    
805    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
806      printerr("Too Few Arguments");      printerr("Too Few Arguments");
807      env->err= 1;      env->err= 1;
808      return;      return;
809    }    }
810    
811    left= env->head->item->content.ptr;    left= env->head->car->content.ptr;
812    swap(env);    swap(env);
813    right= env->head->item->content.ptr;    right= env->head->car->content.ptr;
   result= (left==right);  
     
814    toss(env); toss(env);    toss(env); toss(env);
815    push_int(env, result);  
816      push_int(env, left==right);
817  }  }
818    
819  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 780  extern void not(environment *env) Line 821  extern void not(environment *env)
821  {  {
822    int val;    int val;
823    
824    if((env->head)==NULL) {    if(env->head==NULL) {
825      printerr("Too Few Arguments");      printerr("Too Few Arguments");
826      env->err= 1;      env->err= 1;
827      return;      return;
828    }    }
829    
830    if(env->head->item->type!=integer) {    if(env->head->car->type!=integer) {
831      printerr("Bad Argument Type");      printerr("Bad Argument Type");
832      env->err= 2;      env->err= 2;
833      return;      return;
834    }    }
835    
836    val= env->head->item->content.i;    val= env->head->car->content.i;
837    toss(env);    toss(env);
838    push_int(env, !val);    push_int(env, !val);
839  }  }
# Line 811  extern void def(environment *env) Line 852  extern void def(environment *env)
852    symbol *sym;    symbol *sym;
853    
854    /* 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 */
855    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
856      printerr("Too Few Arguments");      printerr("Too Few Arguments");
857      env->err= 1;      env->err= 1;
858      return;      return;
859    }    }
860    
861    if(env->head->item->type!=symb) {    if(env->head->car->type!=symb) {
862      printerr("Bad Argument Type");      printerr("Bad Argument Type");
863      env->err= 2;      env->err= 2;
864      return;      return;
865    }    }
866    
867    /* long names are a pain */    /* long names are a pain */
868    sym= env->head->item->content.ptr;    sym= env->head->car->content.ptr;
869    
870    /* Bind the symbol to the value */    /* Bind the symbol to the value */
871    sym->val= env->head->next->item;    sym->val= env->head->cdr->content.c->car;
872    
873    toss(env); toss(env);    toss(env); toss(env);
874  }  }
# Line 835  extern void def(environment *env) Line 876  extern void def(environment *env)
876  /* Quit stack. */  /* Quit stack. */
877  extern void quit(environment *env)  extern void quit(environment *env)
878  {  {
879    long i;    int i;
880    
881    clear(env);    clear(env);
882    
# Line 848  extern void quit(environment *env) Line 889  extern void quit(environment *env)
889    }    }
890    
891    env->gc_limit= 0;    env->gc_limit= 0;
892    gc_init(env);    gc_maybe(env);
893    
894    if(env->free_string!=NULL)    if(env->free_string!=NULL)
895      free(env->free_string);      free(env->free_string);
# Line 881  extern void words(environment *env) Line 922  extern void words(environment *env)
922  }  }
923    
924  /* Internal forget function */  /* Internal forget function */
925  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
926    {
927    symbol *temp;    symbol *temp;
928    
929    temp= *hash_entry;    temp= *hash_entry;
# Line 895  void forget_sym(symbol **hash_entry) { Line 937  void forget_sym(symbol **hash_entry) {
937  extern void forget(environment *env)  extern void forget(environment *env)
938  {  {
939    char* sym_id;    char* sym_id;
940    stackitem *stack_head= env->head;    cons *stack_head= env->head;
941    
942    if(stack_head==NULL) {    if(stack_head==NULL) {
943      printerr("Too Few Arguments");      printerr("Too Few Arguments");
944      env->err=1;      env->err= 1;
945      return;      return;
946    }    }
947        
948    if(stack_head->item->type!=symb) {    if(stack_head->car->type!=symb) {
949      printerr("Bad Argument Type");      printerr("Bad Argument Type");
950      env->err=2;      env->err= 2;
951      return;      return;
952    }    }
953    
954    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= ((symbol*)(stack_head->car->content.ptr))->id;
955    toss(env);    toss(env);
956    
957    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
958  }  }
959    
960  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
961  extern void errn(environment *env){  extern void errn(environment *env)
962    {
963    push_int(env, env->err);    push_int(env, env->err);
964  }  }
965    
# Line 980  under certain conditions; type `copying; Line 1023  under certain conditions; type `copying;
1023      if (myenv.err==4) {      if (myenv.err==4) {
1024        return EXIT_SUCCESS;      /* EOF */        return EXIT_SUCCESS;      /* EOF */
1025      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1026                && myenv.head->item->type==symb                && myenv.head->car->type==symb
1027                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && ((symbol*)(myenv.head->car->content.ptr))->id[0]==';') {
1028        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1029        eval(&myenv);        eval(&myenv);
1030      }      }
1031      gc_init(&myenv);      gc_maybe(&myenv);
1032    }    }
1033    quit(&myenv);    quit(&myenv);
1034    return EXIT_FAILURE;    return EXIT_FAILURE;
1035  }  }
1036    
1037  /* "+" */  /* "+" */
1038  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1039    {
1040    int a, b;    int a, b;
1041    float fa, fb;    float fa, fb;
1042    size_t len;    size_t len;
1043    char* new_string;    char* new_string;
1044    value *a_val, *b_val;    value *a_val, *b_val;
1045    
1046    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1047      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1048      env->err= 1;      env->err= 1;
1049      return;      return;
1050    }    }
1051    
1052    if(env->head->item->type==string    if(env->head->car->type==string
1053       && env->head->next->item->type==string) {       && env->head->cdr->content.c->car->type==string) {
1054      a_val= env->head->item;      a_val= env->head->car;
1055      b_val= env->head->next->item;      b_val= env->head->cdr->content.c->car;
1056      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1057      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1058      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1059      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 1061  extern void sx_2b(environment *env) {
1061      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1062      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1063      push_cstring(env, new_string);      push_cstring(env, new_string);
1064      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1065      free(new_string);      free(new_string);
1066            
1067      return;      return;
1068    }    }
1069        
1070    if(env->head->item->type==integer    if(env->head->car->type==integer
1071       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1072      a=env->head->item->content.i;      a= env->head->car->content.i;
1073      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1074      b=env->head->item->content.i;      b= env->head->car->content.i;
1075      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1076      push_int(env, b+a);      push_int(env, b+a);
1077    
1078      return;      return;
1079    }    }
1080    
1081    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1082       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1083      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1084      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1085      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1086      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1087      push_float(env, fb+fa);      push_float(env, fb+fa);
1088            
1089      return;      return;
1090    }    }
1091    
1092    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1093       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1094      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1095      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1096      b= env->head->item->content.i;      b= env->head->car->content.i;
1097      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1098      push_float(env, b+fa);      push_float(env, b+fa);
1099            
1100      return;      return;
1101    }    }
1102    
1103    if(env->head->item->type==integer    if(env->head->car->type==integer
1104       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1105      a= env->head->item->content.i;      a= env->head->car->content.i;
1106      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1107      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1108      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1109      push_float(env, fb+a);      push_float(env, fb+a);
1110    
# Line 1072  extern void sx_2b(environment *env) { Line 1116  extern void sx_2b(environment *env) {
1116  }  }
1117    
1118  /* "-" */  /* "-" */
1119  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1120    {
1121    int a, b;    int a, b;
1122    float fa, fb;    float fa, fb;
1123    
1124    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1125      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1126      env->err=1;      env->err=1;
1127      return;      return;
1128    }    }
1129        
1130    if(env->head->item->type==integer    if(env->head->car->type==integer
1131       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1132      a=env->head->item->content.i;      a= env->head->car->content.i;
1133      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1134      b=env->head->item->content.i;      b= env->head->car->content.i;
1135      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1136      push_int(env, b-a);      push_int(env, b-a);
1137    
1138      return;      return;
1139    }    }
1140    
1141    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1142       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1143      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1144      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1145      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1146      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1147      push_float(env, fb-fa);      push_float(env, fb-fa);
1148            
1149      return;      return;
1150    }    }
1151    
1152    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1153       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1154      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1155      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1156      b= env->head->item->content.i;      b= env->head->car->content.i;
1157      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1158      push_float(env, b-fa);      push_float(env, b-fa);
1159            
1160      return;      return;
1161    }    }
1162    
1163    if(env->head->item->type==integer    if(env->head->car->type==integer
1164       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1165      a= env->head->item->content.i;      a= env->head->car->content.i;
1166      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1167      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1168      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1169      push_float(env, fb-a);      push_float(env, fb-a);
1170    
# Line 1131  extern void sx_2d(environment *env) { Line 1176  extern void sx_2d(environment *env) {
1176  }  }
1177    
1178  /* ">" */  /* ">" */
1179  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1180    {
1181    int a, b;    int a, b;
1182    float fa, fb;    float fa, fb;
1183    
1184    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1185      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1186      env->err=1;      env->err= 1;
1187      return;      return;
1188    }    }
1189        
1190    if(env->head->item->type==integer    if(env->head->car->type==integer
1191       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1192      a=env->head->item->content.i;      a=env->head->car->content.i;
1193      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1194      b=env->head->item->content.i;      b=env->head->car->content.i;
1195      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1196      push_int(env, b>a);      push_int(env, b>a);
1197    
1198      return;      return;
1199    }    }
1200    
1201    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1202       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1203      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1204      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1205      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1206      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1207      push_int(env, fb>fa);      push_int(env, fb>fa);
1208            
1209      return;      return;
1210    }    }
1211    
1212    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1213       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1214      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1215      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1216      b= env->head->item->content.i;      b= env->head->car->content.i;
1217      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1218      push_int(env, b>fa);      push_int(env, b>fa);
1219            
1220      return;      return;
1221    }    }
1222    
1223    if(env->head->item->type==integer    if(env->head->car->type==integer
1224       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1225      a= env->head->item->content.i;      a= env->head->car->content.i;
1226      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1227      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1228      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1229      push_int(env, fb>a);      push_int(env, fb>a);
1230    
# Line 1190  extern void sx_3e(environment *env) { Line 1236  extern void sx_3e(environment *env) {
1236  }  }
1237    
1238  /* "<" */  /* "<" */
1239  extern void sx_3c(environment *env) {  extern void sx_3c(environment *env)
1240    {
1241    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1242    sx_3e(env);    sx_3e(env);
1243  }  }
1244    
1245  /* "<=" */  /* "<=" */
1246  extern void sx_3c3d(environment *env) {  extern void sx_3c3d(environment *env)
1247    {
1248    sx_3e(env); if(env->err) return;    sx_3e(env); if(env->err) return;
1249    not(env);    not(env);
1250  }  }
1251    
1252  /* ">=" */  /* ">=" */
1253  extern void sx_3e3d(environment *env) {  extern void sx_3e3d(environment *env)
1254    {
1255    sx_3c(env); if(env->err) return;    sx_3c(env); if(env->err) return;
1256    not(env);    not(env);
1257  }  }
1258    
1259  /* Return copy of a value */  /* Return copy of a value */
1260  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1261    stackitem *old_item, *new_item, *prev_item;  {
1262      cons *old_item, *new_item, *prev_item;
1263    value *new_value;    value *new_value;
1264    
1265    protect(env, old_value);    protect(old_value);
1266    new_value= new_val(env);    new_value= new_val(env);
1267    protect(env, new_value);    protect(new_value);
1268    new_value->type= old_value->type;    new_value->type= old_value->type;
1269    
1270    switch(old_value->type){    switch(old_value->type){
# Line 1228  value *copy_val(environment *env, value Line 1278  value *copy_val(environment *env, value
1278      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1279        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1280      break;      break;
1281    case list:    case tcons:
1282      new_value->content.ptr= NULL;      new_value->content.ptr= NULL;
1283    
1284      prev_item= NULL;      prev_item= NULL;
1285      old_item= (stackitem*)(old_value->content.ptr);      old_item= old_value->content.c;
1286    
1287      while(old_item != NULL) {   /* While list is not empty */      if(old_value->content.ptr != NULL) { /* if list is not empty */
1288        new_item= malloc(sizeof(stackitem));        new_item= malloc(sizeof(cons));
1289        new_item->item= copy_val(env, old_item->item); /* recurse */        new_item->car= copy_val(env, old_item->car); /* recurse */
1290        new_item->next= NULL;        new_item->cdr= copy_val(env, old_item->cdr); /* recurse */
1291        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;  
     }      
1292      break;      break;
1293    }    }
1294    
1295    unprotect(env); unprotect(env);    unprotect(old_value); unprotect(new_value);
1296    
1297    return new_value;    return new_value;
1298  }  }
1299    
1300  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1301  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1302    if((env->head)==NULL) {  {
1303      if(env->head==NULL) {
1304      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1305      env->err= 1;      env->err= 1;
1306      return;      return;
1307    }    }
1308    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, env->head->car));
1309  }  }
1310    
1311  /* "if", If-Then */  /* "if", If-Then */
1312  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1313    {
1314    int truth;    int truth;
1315    
1316    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1317      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1318      env->err= 1;      env->err= 1;
1319      return;      return;
1320    }    }
1321    
1322    if(env->head->next->item->type != integer) {    if(env->head->cdr->content.c->car->type != integer) {
1323      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1324      env->err=2;      env->err= 2;
1325      return;      return;
1326    }    }
1327        
1328    swap(env);    swap(env);
1329    if(env->err) return;    if(env->err) return;
1330        
1331    truth=env->head->item->content.i;    truth=env->head->car->content.i;
1332    
1333    toss(env);    toss(env);
1334    if(env->err) return;    if(env->err) return;
# Line 1296  extern void sx_6966(environment *env) { Line 1340  extern void sx_6966(environment *env) {
1340  }  }
1341    
1342  /* If-Then-Else */  /* If-Then-Else */
1343  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1344    {
1345    int truth;    int truth;
1346    
1347    if((env->head)==NULL || env->head->next==NULL    if(env->head==NULL || env->head->cdr->content.c==NULL
1348       || env->head->next->next==NULL) {       || env->head->cdr->content.c->cdr->content.c==NULL) {
1349      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1350      env->err=1;      env->err= 1;
1351      return;      return;
1352    }    }
1353    
1354    if(env->head->next->next->item->type != integer) {    if(env->head->cdr->content.c->cdr->content.c->car->type!=integer) {
1355      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1356      env->err=2;      env->err= 2;
1357      return;      return;
1358    }    }
1359        
1360    rot(env);    rot(env);
1361    if(env->err) return;    if(env->err) return;
1362        
1363    truth=env->head->item->content.i;    truth= env->head->car->content.i;
1364    
1365    toss(env);    toss(env);
1366    if(env->err) return;    if(env->err) return;
# Line 1332  extern void ifelse(environment *env) { Line 1376  extern void ifelse(environment *env) {
1376  }  }
1377    
1378  /* "while" */  /* "while" */
1379  extern void sx_7768696c65(environment *env) {  extern void sx_7768696c65(environment *env)
1380    {
1381    int truth;    int truth;
1382    value *loop, *test;    value *loop, *test;
1383    
1384    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1385      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1386      env->err=1;      env->err= 1;
1387      return;      return;
1388    }    }
1389    
1390    loop= env->head->item;    loop= env->head->car;
1391    protect(env, loop);    protect(loop);
1392    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1393    
1394    test= env->head->item;    test= env->head->car;
1395    protect(env, test);    protect(test);
1396    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1397    
1398    do {    do {
1399      push_val(env, test);      push_val(env, test);
1400      eval(env);      eval(env);
1401            
1402      if(env->head->item->type != integer) {      if(env->head->car->type != integer) {
1403        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1404        env->err= 2;        env->err= 2;
1405        return;        return;
1406      }      }
1407            
1408      truth= env->head->item->content.i;      truth= env->head->car->content.i;
1409      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1410            
1411      if(truth) {      if(truth) {
# Line 1373  extern void sx_7768696c65(environment *e Line 1417  extern void sx_7768696c65(environment *e
1417        
1418    } while(truth);    } while(truth);
1419    
1420    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1421  }  }
1422    
1423    
1424  /* "for"; for-loop */  /* "for"; for-loop */
1425  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1426    {
1427    value *loop;    value *loop;
1428    int foo1, foo2;    int foo1, foo2;
1429    
1430    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || env->head->cdr->content.c==NULL
1431       || env->head->next->next==NULL) {       || env->head->cdr->content.c->cdr->content.c==NULL) {
1432      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1433      env->err= 1;      env->err= 1;
1434      return;      return;
1435    }    }
1436    
1437    if(env->head->next->item->type!=integer    if(env->head->cdr->content.c->car->type!=integer
1438       || env->head->next->next->item->type!=integer) {       || env->head->cdr->content.c->cdr->content.c->car->type!=integer) {
1439      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1440      env->err= 2;      env->err= 2;
1441      return;      return;
1442    }    }
1443    
1444    loop= env->head->item;    loop= env->head->car;
1445    protect(env, loop);    protect(loop);
1446    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1447    
1448    foo2= env->head->item->content.i;    foo2= env->head->car->content.i;
1449    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1450    
1451    foo1= env->head->item->content.i;    foo1= env->head->car->content.i;
1452    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1453    
1454    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1421  extern void sx_666f72(environment *env) Line 1466  extern void sx_666f72(environment *env)
1466        foo1--;        foo1--;
1467      }      }
1468    }    }
1469    unprotect(env);    unprotect(loop);
1470  }  }
1471    
1472  /* Variant of for-loop */  /* Variant of for-loop */
1473  extern void foreach(environment *env) {  extern void foreach(environment *env)
1474      {  
1475    value *loop, *foo;    value *loop, *foo;
1476    stackitem *iterator;    cons *iterator;
1477        
1478    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1479      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1480      env->err= 1;      env->err= 1;
1481      return;      return;
1482    }    }
1483    
1484    if(env->head->next->item->type != list) {    if(env->head->cdr->content.c->car->type!=tcons) {
1485      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1486      env->err= 2;      env->err= 2;
1487      return;      return;
1488    }    }
1489    
1490    loop= env->head->item;    loop= env->head->car;
1491    protect(env, loop);    protect(loop);
1492    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1493    
1494    foo= env->head->item;    foo= env->head->car;
1495    protect(env, foo);    protect(foo);
1496    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1497    
1498    iterator= foo->content.ptr;    iterator= foo->content.c;
1499    
1500    while(iterator!=NULL) {    while(iterator!=NULL) {
1501      push_val(env, iterator->item);      push_val(env, iterator->car);
1502      push_val(env, loop);      push_val(env, loop);
1503      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1504      iterator= iterator->next;      if (iterator->cdr->type == tcons){
1505          iterator= iterator->cdr->content.c;
1506        } else {
1507          printerr("Bad Argument Type"); /* Improper list */
1508          env->err= 2;
1509          break;
1510        }
1511    }    }
1512    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1513  }  }
1514    
1515  /* "to" */  /* "to" */
1516  extern void to(environment *env) {  extern void to(environment *env)
1517    int i, start, ending;  {
1518    stackitem *temp_head;    int ending, start, i;
1519    value *temp_val;    cons *iterator, *temp;
1520        value *pack;
1521    if((env->head)==NULL || env->head->next==NULL) {  
1522      if(env->head==NULL || env->head->cdr->content.c==NULL) {
1523      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1524      env->err=1;      env->err= 1;
1525      return;      return;
1526    }    }
1527    
1528    if(env->head->item->type!=integer    if(env->head->car->type!=integer
1529       || env->head->next->item->type!=integer) {       || env->head->cdr->content.c->car->type!=integer) {
1530      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1531      env->err=2;      env->err= 2;
1532      return;      return;
1533    }    }
1534    
1535    ending= env->head->item->content.i;    ending= env->head->car->content.i;
1536    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1537    start= env->head->item->content.i;    start= env->head->car->content.i;
1538    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1539    
1540    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1541    
1542    if(ending>=start) {    if(ending>=start) {
1543      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1496  extern void to(environment *env) { Line 1547  extern void to(environment *env) {
1547        push_int(env, i);        push_int(env, i);
1548    }    }
1549    
1550    temp_val= new_val(env);    iterator= env->head;
1551    protect(env, temp_val);    pack= new_val(env);
1552      protect(pack);
1553    
1554      if(iterator==NULL
1555         || (iterator->car->type==symb
1556             && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) {
1557        temp= NULL;
1558        toss(env);
1559      } else {
1560        /* Search for first delimiter */
1561        while(iterator->cdr->content.c!=NULL
1562              && (iterator->cdr->content.c->car->type!=symb
1563                  || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0]
1564                  !='['))
1565          iterator= iterator->cdr->content.ptr;
1566        
1567        /* Extract list */
1568        temp= env->head;
1569        env->head= iterator->cdr->content.c;
1570        iterator->cdr->content.c= NULL;
1571    
1572        pack->type= tcons;
1573        pack->content.ptr= temp;
1574        
1575        if(env->head!=NULL)
1576          toss(env);
1577      }
1578    
1579    temp_val->content.ptr= env->head;    /* Push list */
   temp_val->type= list;  
   env->head= temp_head;  
   push_val(env, temp_val);  
1580    
1581    unprotect(env);    push_val(env, pack);
1582    
1583      unprotect(pack);
1584  }  }
1585    
1586  /* Read a string */  /* Read a string */
1587  extern void readline(environment *env) {  extern void readline(environment *env)
1588    {
1589    char in_string[101];    char in_string[101];
1590    
1591    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1518  extern void readline(environment *env) { Line 1595  extern void readline(environment *env) {
1595  }  }
1596    
1597  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1598  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1599    {
1600    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1601    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1602    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1541  extern void sx_72656164(environment *env Line 1619  extern void sx_72656164(environment *env
1619      }      }
1620      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1621    
1622      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(env->head->car->content.ptr))[0]=='\0'){
1623        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1624        return;        return;
1625      }      }
1626            
1627      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(env->head->car->content.ptr)+1);
1628      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1629      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, env->head->car->content.ptr);
1630      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1631    }    }
1632        
# Line 1597  extern void sx_72656164(environment *env Line 1675  extern void sx_72656164(environment *env
1675      return sx_72656164(env);      return sx_72656164(env);
1676  }  }
1677    
1678  extern void beep(environment *env) {  extern void beep(environment *env)
1679    {
1680    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1681    
1682    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1683      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1684      env->err=1;      env->err= 1;
1685      return;      return;
1686    }    }
1687    
1688    if(env->head->item->type!=integer    if(env->head->car->type!=integer
1689       || env->head->next->item->type!=integer) {       || env->head->cdr->content.c->car->type!=integer) {
1690      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1691      env->err=2;      env->err= 2;
1692      return;      return;
1693    }    }
1694    
1695    dur=env->head->item->content.i;    dur= env->head->car->content.i;
1696    toss(env);    toss(env);
1697    freq=env->head->item->content.i;    freq= env->head->car->content.i;
1698    toss(env);    toss(env);
1699    
1700    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1701                                     length */                                     length */
1702    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1703                                     timer ticks */                                     timer ticks */
1704    
1705  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1706    
1707    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1708    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1709    case 0:    case 0:
1710      usleep(dur);      usleep(dur);
1711      return;      return;
1712    case -1:    case -1:
1713      perror("beep");      perror("beep");
1714      env->err=5;      env->err= 5;
1715      return;      return;
1716    default:    default:
1717      abort();      abort();
1718    }    }
1719  };  }
1720    
1721  /* "wait" */  /* "wait" */
1722  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1723    {
1724    int dur;    int dur;
1725    
1726    if((env->head)==NULL) {    if(env->head==NULL) {
1727      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1728      env->err=1;      env->err= 1;
1729      return;      return;
1730    }    }
1731    
1732    if(env->head->item->type!=integer) {    if(env->head->car->type!=integer) {
1733      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1734      env->err=2;      env->err= 2;
1735      return;      return;
1736    }    }
1737    
1738    dur=env->head->item->content.i;    dur=env->head->car->content.i;
1739    toss(env);    toss(env);
1740    
1741    usleep(dur);    usleep(dur);
1742  };  }
1743    
1744  extern void copying(environment *env){  extern void copying(environment *env)
1745    {
1746    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1747                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1748  \n\  \n\
# Line 1922  of preserving the free status of all der Line 2001  of preserving the free status of all der
2001  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
2002  }  }
2003    
2004  extern void warranty(environment *env){  extern void warranty(environment *env)
2005    {
2006    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
2007  \n\  \n\
2008    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 2032  extern void sx_2a(environment *env)
2032    int a, b;    int a, b;
2033    float fa, fb;    float fa, fb;
2034    
2035    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
2036      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2037      env->err=1;      env->err= 1;
2038      return;      return;
2039    }    }
2040        
2041    if(env->head->item->type==integer    if(env->head->car->type==integer
2042       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2043      a=env->head->item->content.i;      a= env->head->car->content.i;
2044      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2045      b=env->head->item->content.i;      b= env->head->car->content.i;
2046      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2047      push_int(env, b*a);      push_int(env, b*a);
2048    
2049      return;      return;
2050    }    }
2051    
2052    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
2053       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
2054      fa= env->head->item->content.f;      fa= env->head->car->content.f;
2055      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2056      fb= env->head->item->content.f;      fb= env->head->car->content.f;
2057      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2058      push_float(env, fb*fa);      push_float(env, fb*fa);
2059            
2060      return;      return;
2061    }    }
2062    
2063    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
2064       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2065      fa= env->head->item->content.f;      fa= env->head->car->content.f;
2066      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2067      b= env->head->item->content.i;      b= env->head->car->content.i;
2068      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2069      push_float(env, b*fa);      push_float(env, b*fa);
2070            
2071      return;      return;
2072    }    }
2073    
2074    if(env->head->item->type==integer    if(env->head->car->type==integer
2075       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
2076      a= env->head->item->content.i;      a= env->head->car->content.i;
2077      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2078      fb= env->head->item->content.f;      fb= env->head->car->content.f;
2079      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2080      push_float(env, fb*a);      push_float(env, fb*a);
2081    
# Line 2003  extern void sx_2a(environment *env) Line 2083  extern void sx_2a(environment *env)
2083    }    }
2084    
2085    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2086    env->err=2;    env->err= 2;
2087  }  }
2088    
2089  /* "/" */  /* "/" */
# Line 2012  extern void sx_2f(environment *env) Line 2092  extern void sx_2f(environment *env)
2092    int a, b;    int a, b;
2093    float fa, fb;    float fa, fb;
2094    
2095    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
2096      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2097      env->err=1;      env->err= 1;
2098      return;      return;
2099    }    }
2100        
2101    if(env->head->item->type==integer    if(env->head->car->type==integer
2102       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2103      a=env->head->item->content.i;      a= env->head->car->content.i;
2104      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2105      b=env->head->item->content.i;      b= env->head->car->content.i;
2106      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2107      push_float(env, b/a);      push_float(env, b/a);
2108    
2109      return;      return;
2110    }    }
2111    
2112    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
2113       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
2114      fa= env->head->item->content.f;      fa= env->head->car->content.f;
2115      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2116      fb= env->head->item->content.f;      fb= env->head->car->content.f;
2117      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2118      push_float(env, fb/fa);      push_float(env, fb/fa);
2119            
2120      return;      return;
2121    }    }
2122    
2123    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
2124       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2125      fa= env->head->item->content.f;      fa= env->head->car->content.f;
2126      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2127      b= env->head->item->content.i;      b= env->head->car->content.i;
2128      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2129      push_float(env, b/fa);      push_float(env, b/fa);
2130            
2131      return;      return;
2132    }    }
2133    
2134    if(env->head->item->type==integer    if(env->head->car->type==integer
2135       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
2136      a= env->head->item->content.i;      a= env->head->car->content.i;
2137      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2138      fb= env->head->item->content.f;      fb= env->head->car->content.f;
2139      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2140      push_float(env, fb/a);      push_float(env, fb/a);
2141    
# Line 2063  extern void sx_2f(environment *env) Line 2143  extern void sx_2f(environment *env)
2143    }    }
2144    
2145    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2146    env->err=2;    env->err= 2;
2147  }  }
2148    
2149  /* "mod" */  /* "mod" */
# Line 2071  extern void mod(environment *env) Line 2151  extern void mod(environment *env)
2151  {  {
2152    int a, b;    int a, b;
2153    
2154    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
2155      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2156      env->err= 1;      env->err= 1;
2157      return;      return;
2158    }    }
2159        
2160    if(env->head->item->type==integer    if(env->head->car->type==integer
2161       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2162      a= env->head->item->content.i;      a= env->head->car->content.i;
2163      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2164      b= env->head->item->content.i;      b= env->head->car->content.i;
2165      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2166      push_int(env, b%a);      push_int(env, b%a);
2167    
# Line 2089  extern void mod(environment *env) Line 2169  extern void mod(environment *env)
2169    }    }
2170    
2171    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2172    env->err=2;    env->err= 2;
2173  }  }
2174    
2175  /* "div" */  /* "div" */
# Line 2097  extern void sx_646976(environment *env) Line 2177  extern void sx_646976(environment *env)
2177  {  {
2178    int a, b;    int a, b;
2179        
2180    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
2181      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2182      env->err= 1;      env->err= 1;
2183      return;      return;
2184    }    }
2185    
2186    if(env->head->item->type==integer    if(env->head->car->type==integer
2187       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2188      a= env->head->item->content.i;      a= env->head->car->content.i;
2189      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2190      b= env->head->item->content.i;      b= env->head->car->content.i;
2191      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2192      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2193    
Legend:
Removed from v.1.94  
changed lines
  Added in v.1.103
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26