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