/[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.107 by masse, Tue Mar 12 21:05:11 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    
41    #ifdef __linux__
42  /* mtrace, muntrace */  /* mtrace, muntrace */
43  #include <mcheck.h>  #include <mcheck.h>
44  /* ioctl */  /* ioctl */
45  #include <sys/ioctl.h>  #include <sys/ioctl.h>
46  /* KDMKTONE */  /* KDMKTONE */
47  #include <linux/kd.h>  #include <linux/kd.h>
48    #endif /* __linux__ */
49    
50  #include "stack.h"  #include "stack.h"
51    
# Line 48  void init_env(environment *env) Line 54  void init_env(environment *env)
54  {  {
55    int i;    int i;
56    
57    env->gc_limit= 20;    env->gc_limit= 400000;
58    env->gc_count= 0;    env->gc_count= 0;
59    env->gc_ref= NULL;    env->gc_ref= NULL;
   env->gc_protect= NULL;  
60    
61    env->head= NULL;    env->head= NULL;
62    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
# Line 63  void init_env(environment *env) Line 68  void init_env(environment *env)
68    env->interactive= 1;    env->interactive= 1;
69  }  }
70    
71  void printerr(const char* in_string) {  void printerr(const char* in_string)
72    {
73    fprintf(stderr, "Err: %s\n", in_string);    fprintf(stderr, "Err: %s\n", in_string);
74  }  }
75    
76  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
77  extern void toss(environment *env)  extern void toss(environment *env)
78  {  {
79    stackitem *temp= env->head;    if(env->head==NULL) {
   
   if((env->head)==NULL) {  
80      printerr("Too Few Arguments");      printerr("Too Few Arguments");
81      env->err= 1;      env->err= 1;
82      return;      return;
83    }    }
84        
85    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);  
86  }  }
87    
88  /* 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 114  symbol **hash(hashtbl in_hashtbl, const
114    }    }
115  }  }
116    
117  value* new_val(environment *env) {  /* Create new value */
118    value* new_val(environment *env)
119    {
120    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
121    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
122    
# Line 121  value* new_val(environment *env) { Line 124  value* new_val(environment *env) {
124    
125    nitem->item= nval;    nitem->item= nval;
126    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
   env->gc_ref= nitem;  
127    
128    env->gc_count++;    env->gc_ref= nitem;
129    
130    protect(env, nval);    env->gc_count += sizeof(value);
131    gc_init(env);    nval->gc.flag.mark= 0;
132    unprotect(env);    nval->gc.flag.protect= 0;
133    
134    return nval;    return nval;
135  }  }
136    
137  void gc_mark(value *val) {  /* Mark values recursively.
138    stackitem *iterator;     Marked values are not collected by the GC. */
139    inline void gc_mark(value *val)
140    if(val==NULL || val->gc_garb==0)  {
141      if(val==NULL || val->gc.flag.mark)
142      return;      return;
143    
144    val->gc_garb= 0;    val->gc.flag.mark= 1;
   
   if(val->type==list) {  
     iterator= val->content.ptr;  
145    
146      while(iterator!=NULL) {    if(val->type==tcons) {
147        gc_mark(iterator->item);      gc_mark(CAR(val));
148        iterator= iterator->next;      gc_mark(CDR(val));
     }  
149    }    }
150  }  }
151    
152  extern void gc_init(environment *env) {  inline void gc_maybe(environment *env)
153    stackitem *new_head= NULL, *titem, *iterator;  {
154      if(env->gc_count < env->gc_limit)
155        return;
156      else
157        return gc_init(env);
158    }
159    
160    /* Start GC */
161    extern void gc_init(environment *env)
162    {
163      stackitem *new_head= NULL, *titem;
164      cons *iterator;
165    symbol *tsymb;    symbol *tsymb;
166    int i;    int i;
167    
168    if(env->gc_count < env->gc_limit)    if(env->interactive)
169      return;      printf("Garbage collecting.");
170    
171    /* Garb by default */    /* Mark values on stack */
172    iterator= env->gc_ref;    gc_mark(env->head);
   while(iterator!=NULL) {  
     iterator->item->gc_garb= 1;  
     iterator= iterator->next;  
   }  
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) {
236        protect(CAR(val));
237        protect(CDR(val));
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) {
250        unprotect(CAR(val));
251        unprotect(CDR(val));
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));    value *new_value= new_val(env);
259    new_item->item= val;  
260    new_item->next= env->head;    new_value->content.c= malloc(sizeof(cons));
261    env->head= new_item;    new_value->type= tcons;
262      CAR(new_value)= val;
263      CDR(new_value)= env->head;
264      env->head= new_value;
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) {
328      printerr("Too Few Arguments");      printerr("Too Few Arguments");
329      env->err= 1;      env->err= 1;
330      return;      return;
331    }    }
332    
333    if(env->head->item->type!=string) {    if(CAR(env->head)->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=
340        mangle_str((const char *)(CAR(env->head)->content.ptr));
341    
342    toss(env);    toss(env);
343    if(env->err) return;    if(env->err) return;
# Line 342  void push_sym(environment *env, const ch Line 361  void push_sym(environment *env, const ch
361    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
362    
363    new_value= new_val(env);    new_value= new_val(env);
364    protect(env, new_value);    protect(new_value);
365    new_fvalue= new_val(env);    new_fvalue= new_val(env);
366    protect(env, new_fvalue);    protect(new_fvalue);
367    
368    /* The new value is a symbol */    /* The new value is a symbol */
369    new_value->type= symb;    new_value->type= symb;
# Line 372  void push_sym(environment *env, const ch Line 391  void push_sym(environment *env, const ch
391    
392      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
393      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
394      free(mangled);  
395      dlerr= dlerror();      dlerr= dlerror();
396      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
397        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
398        dlerr= dlerror();        dlerr= dlerror();
399      }      }
400    
401      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
402        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
403        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
404        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
405                                           function value */                                           function value */
406      }      }
407    
408        free(mangled);
409    }    }
410    
411    push_val(env, new_value);    push_val(env, new_value);
412    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
413  }  }
414    
415  /* Print newline. */  /* Print newline. */
# Line 396  extern void nl() Line 419  extern void nl()
419  }  }
420    
421  /* Gets the type of a value */  /* Gets the type of a value */
422  extern void type(environment *env){  extern void type(environment *env)
423    {
424    int typenum;    int typenum;
425    
426    if((env->head)==NULL) {    if(env->head==NULL) {
427      printerr("Too Few Arguments");      printerr("Too Few Arguments");
428      env->err=1;      env->err= 1;
429      return;      return;
430    }    }
431    typenum=env->head->item->type;  
432      typenum= CAR(env->head)->type;
433    toss(env);    toss(env);
434    switch(typenum){    switch(typenum){
435    case integer:    case integer:
# Line 422  extern void type(environment *env){ Line 447  extern void type(environment *env){
447    case func:    case func:
448      push_sym(env, "function");      push_sym(env, "function");
449      break;      break;
450    case list:    case tcons:
451      push_sym(env, "list");      push_sym(env, "list");
452      break;      break;
453    }    }
454  }      }    
455    
456  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
457  void print_h(stackitem *stack_head, int noquote)  void print_h(value *stack_head, int noquote)
458  {  {
459    switch(stack_head->item->type) {    switch(CAR(stack_head)->type) {
460    case integer:    case integer:
461      printf("%d", stack_head->item->content.i);      printf("%d", CAR(stack_head)->content.i);
462      break;      break;
463    case tfloat:    case tfloat:
464      printf("%f", stack_head->item->content.f);      printf("%f", CAR(stack_head)->content.f);
465      break;      break;
466    case string:    case string:
467      if(noquote)      if(noquote)
468        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)CAR(stack_head)->content.ptr);
469      else      else
470        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);
471      break;      break;
472    case symb:    case symb:
473      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
474      break;      break;
475    case func:    case func:
476      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
477      break;      break;
478    case list:    case tcons:
479      /* 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 */
480      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head= CAR(stack_head);
481      printf("[ ");      printf("[ ");
482      while(stack_head != NULL) {      while(stack_head != NULL) {
483        print_h(stack_head, noquote);        print_h(stack_head, noquote);
484        printf(" ");        printf(" ");
485        stack_head=stack_head->next;        stack_head= CDR(stack_head);
486      }      }
487      printf("]");      printf("]");
488      break;      break;
489    }    }
490  }  }
491    
492  extern void print_(environment *env) {  extern void print_(environment *env)
493    {
494    if(env->head==NULL) {    if(env->head==NULL) {
495      printerr("Too Few Arguments");      printerr("Too Few Arguments");
496      env->err=1;      env->err= 1;
497      return;      return;
498    }    }
499    print_h(env->head, 0);    print_h(env->head, 0);
# Line 482  extern void print(environment *env) Line 508  extern void print(environment *env)
508    toss(env);    toss(env);
509  }  }
510    
511  extern void princ_(environment *env) {  extern void princ_(environment *env)
512    {
513    if(env->head==NULL) {    if(env->head==NULL) {
514      printerr("Too Few Arguments");      printerr("Too Few Arguments");
515      env->err=1;      env->err= 1;
516      return;      return;
517    }    }
518    print_h(env->head, 1);    print_h(env->head, 1);
# Line 500  extern void princ(environment *env) Line 527  extern void princ(environment *env)
527  }  }
528    
529  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
530  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
531  {  {
532    if(stack_head->next != NULL)    if(CDR(stack_head) != NULL)
533      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
534    printf("%ld: ", counter);    printf("%ld: ", counter);
535    print_h(stack_head, 0);    print_h(stack_head, 0);
536    nl();    nl();
# Line 516  extern void printstack(environment *env) Line 543  extern void printstack(environment *env)
543      printf("Stack Empty\n");      printf("Stack Empty\n");
544      return;      return;
545    }    }
546    
547    print_st(env->head, 1);    print_st(env->head, 1);
548  }  }
549    
550  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
551  extern void swap(environment *env)  extern void swap(environment *env)
552  {  {
553    stackitem *temp= env->head;    value *temp= env->head;
554        
555    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
556      printerr("Too Few Arguments");      printerr("Too Few Arguments");
557      env->err=1;      env->err=1;
558      return;      return;
559    }    }
560    
561    env->head= env->head->next;    env->head= CDR(env->head);
562    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
563    env->head->next= temp;    CDR(env->head)= temp;
564  }  }
565    
566  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
567  extern void rot(environment *env)  extern void rot(environment *env)
568  {  {
569    stackitem *temp= env->head;    value *temp= env->head;
570        
571    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
572        || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
573      printerr("Too Few Arguments");      printerr("Too Few Arguments");
574      env->err=1;      env->err= 1;
575      return;      return;
576    }    }
577      
578    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
579    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
580    env->head->next= temp;    CDR(env->head)= temp;
581  }  }
582    
583  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 557  extern void rcl(environment *env) Line 585  extern void rcl(environment *env)
585  {  {
586    value *val;    value *val;
587    
588    if(env->head == NULL) {    if(env->head==NULL) {
589      printerr("Too Few Arguments");      printerr("Too Few Arguments");
590      env->err=1;      env->err= 1;
591      return;      return;
592    }    }
593    
594    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
595      printerr("Bad Argument Type");      printerr("Bad Argument Type");
596      env->err=2;      env->err= 2;
597      return;      return;
598    }    }
599    
600    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
601    if(val == NULL){    if(val == NULL){
602      printerr("Unbound Variable");      printerr("Unbound Variable");
603      env->err=3;      env->err= 3;
604      return;      return;
605    }    }
606    protect(env, val);    protect(val);
607    toss(env);            /* toss the symbol */    toss(env);            /* toss the symbol */
608    if(env->err) return;    if(env->err) return;
609    push_val(env, val); /* Return its bound value */    push_val(env, val); /* Return its bound value */
610    unprotect(env);    unprotect(val);
611  }  }
612    
613  /* 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 617  extern void eval(environment *env)
617  {  {
618    funcp in_func;    funcp in_func;
619    value* temp_val;    value* temp_val;
620    stackitem* iterator;    value* iterator;
621    
622   eval_start:   eval_start:
623    
624      gc_maybe(env);
625    
626    if(env->head==NULL) {    if(env->head==NULL) {
627      printerr("Too Few Arguments");      printerr("Too Few Arguments");
628      env->err=1;      env->err= 1;
629      return;      return;
630    }    }
631    
632    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
633      /* if it's a symbol */      /* if it's a symbol */
634    case symb:    case symb:
635      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
636      if(env->err) return;      if(env->err) return;
637      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
638        goto eval_start;        goto eval_start;
639      }      }
640      return;      return;
641    
642      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
643    case func:    case func:
644      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
645      toss(env);      toss(env);
646      if(env->err) return;      if(env->err) return;
647      return in_func(env);      return in_func(env);
648    
649      /* If it's a list */      /* If it's a list */
650    case list:    case tcons:
651      temp_val= env->head->item;      temp_val= CAR(env->head);
652      protect(env, temp_val);      protect(temp_val);
653    
654      toss(env); if(env->err) return;      toss(env); if(env->err) return;
655      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
656            
657      while(iterator!=NULL) {      while(iterator!=NULL) {
658        push_val(env, iterator->item);        push_val(env, CAR(iterator));
659                
660        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
661          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
662          toss(env);          toss(env);
663          if(env->err) return;          if(env->err) return;
664                    
665          if(iterator->next == NULL){          if(CDR(iterator)==NULL){
666            goto eval_start;            goto eval_start;
667          }          }
668          eval(env);          eval(env);
669          if(env->err) return;          if(env->err) return;
670        }        }
671        iterator= iterator->next;        if (CDR(iterator)->type == tcons)
672            iterator= CDR(iterator);
673          else {
674            printerr("Bad Argument Type"); /* Improper list */
675            env->err= 2;
676            return;
677          }
678      }      }
679      unprotect(env);      unprotect(temp_val);
680      return;      return;
681    
682    default:    default:
# Line 649  extern void eval(environment *env) Line 685  extern void eval(environment *env)
685  }  }
686    
687  /* Reverse (flip) a list */  /* Reverse (flip) a list */
688  extern void rev(environment *env){  extern void rev(environment *env)
689    stackitem *old_head, *new_head, *item;  {
690      value *old_head, *new_head, *item;
691    
692    if((env->head)==NULL) {    if(env->head==NULL) {
693      printerr("Too Few Arguments");      printerr("Too Few Arguments");
694      env->err= 1;      env->err= 1;
695      return;      return;
696    }    }
697    
698    if(env->head->item->type!=list) {    if(CAR(env->head)->type!=tcons) {
699      printerr("Bad Argument Type");      printerr("Bad Argument Type");
700      env->err= 2;      env->err= 2;
701      return;      return;
702    }    }
703    
704    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
705    new_head= NULL;    new_head= NULL;
706    while(old_head != NULL){    while(old_head!=NULL) {
707      item= old_head;      item= old_head;
708      old_head= old_head->next;      old_head= CDR(old_head);
709      item->next= new_head;      CDR(item)= new_head;
710      new_head= item;      new_head= item;
711    }    }
712    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
713  }  }
714    
715  /* Make a list. */  /* Make a list. */
716  extern void pack(environment *env)  extern void pack(environment *env)
717  {  {
718    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
719    
720    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(env, pack);  
   
721    if(iterator==NULL    if(iterator==NULL
722       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
723       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
724      temp= NULL;      temp= NULL;
725      toss(env);      toss(env);
726    } else {    } else {
727      /* Search for first delimiter */      /* Search for first delimiter */
728      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
729            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
730            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
731        iterator= iterator->next;        iterator= CDR(iterator);
732            
733      /* Extract list */      /* Extract list */
734      temp= env->head;      temp= env->head;
735      env->head= iterator->next;      env->head= CDR(iterator);
736      iterator->next= NULL;      CDR(iterator)= NULL;
737    
     pack->type= list;  
     pack->content.ptr= temp;  
       
738      if(env->head!=NULL)      if(env->head!=NULL)
739        toss(env);        toss(env);
740    }    }
741    
742    /* Push list */    /* Push list */
743    
744    push_val(env, pack);    push_val(env, temp);
745    rev(env);    rev(env);
   
   unprotect(env);  
746  }  }
747    
748  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
749  extern void expand(environment *env)  extern void expand(environment *env)
750  {  {
751    stackitem *temp, *new_head;    value *temp, *new_head;
752    
753    /* Is top element a list? */    /* Is top element a list? */
754    if(env->head==NULL) {    if(env->head==NULL) {
# Line 728  extern void expand(environment *env) Line 756  extern void expand(environment *env)
756      env->err= 1;      env->err= 1;
757      return;      return;
758    }    }
759    if(env->head->item->type!=list) {  
760      if(CAR(env->head)->type!=tcons) {
761      printerr("Bad Argument Type");      printerr("Bad Argument Type");
762      env->err= 2;      env->err= 2;
763      return;      return;
# Line 740  extern void expand(environment *env) Line 769  extern void expand(environment *env)
769      return;      return;
770    
771    /* The first list element is the new stack head */    /* The first list element is the new stack head */
772    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
773    
774    toss(env);    toss(env);
775    
776    /* Find the end of the list */    /* Find the end of the list */
777    while(temp->next!=NULL)    while(CDR(temp)->content.ptr != NULL) {
778      temp= temp->next;      if (CDR(temp)->type == tcons)
779          temp= CDR(temp);
780        else {
781          printerr("Bad Argument Type"); /* Improper list */
782          env->err= 2;
783          return;
784        }
785      }
786    
787    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
788    temp->next= env->head;    CDR(temp)= env->head;
789    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
790    
791  }  }
# Line 758  extern void expand(environment *env) Line 794  extern void expand(environment *env)
794  extern void eq(environment *env)  extern void eq(environment *env)
795  {  {
796    void *left, *right;    void *left, *right;
   int result;  
797    
798    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
799      printerr("Too Few Arguments");      printerr("Too Few Arguments");
800      env->err= 1;      env->err= 1;
801      return;      return;
802    }    }
803    
804    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
805    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
806    toss(env); toss(env);    toss(env); toss(env);
807    push_int(env, result);  
808      push_int(env, left==right);
809  }  }
810    
811  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 780  extern void not(environment *env) Line 813  extern void not(environment *env)
813  {  {
814    int val;    int val;
815    
816    if((env->head)==NULL) {    if(env->head==NULL) {
817      printerr("Too Few Arguments");      printerr("Too Few Arguments");
818      env->err= 1;      env->err= 1;
819      return;      return;
820    }    }
821    
822    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
823      printerr("Bad Argument Type");      printerr("Bad Argument Type");
824      env->err= 2;      env->err= 2;
825      return;      return;
826    }    }
827    
828    val= env->head->item->content.i;    val= CAR(env->head)->content.i;
829    toss(env);    toss(env);
830    push_int(env, !val);    push_int(env, !val);
831  }  }
# Line 811  extern void def(environment *env) Line 844  extern void def(environment *env)
844    symbol *sym;    symbol *sym;
845    
846    /* 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 */
847    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
848      printerr("Too Few Arguments");      printerr("Too Few Arguments");
849      env->err= 1;      env->err= 1;
850      return;      return;
851    }    }
852    
853    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
854      printerr("Bad Argument Type");      printerr("Bad Argument Type");
855      env->err= 2;      env->err= 2;
856      return;      return;
857    }    }
858    
859    /* long names are a pain */    /* long names are a pain */
860    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
861    
862    /* Bind the symbol to the value */    /* Bind the symbol to the value */
863    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
864    
865    toss(env); toss(env);    toss(env); toss(env);
866  }  }
# Line 835  extern void def(environment *env) Line 868  extern void def(environment *env)
868  /* Quit stack. */  /* Quit stack. */
869  extern void quit(environment *env)  extern void quit(environment *env)
870  {  {
871    long i;    int i;
872    
873    clear(env);    clear(env);
874    
# Line 848  extern void quit(environment *env) Line 881  extern void quit(environment *env)
881    }    }
882    
883    env->gc_limit= 0;    env->gc_limit= 0;
884    gc_init(env);    gc_maybe(env);
885    
886    if(env->free_string!=NULL)    if(env->free_string!=NULL)
887      free(env->free_string);      free(env->free_string);
888        
889    #ifdef __linux__
890    muntrace();    muntrace();
891    #endif
892    
893    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
894  }  }
# Line 881  extern void words(environment *env) Line 916  extern void words(environment *env)
916  }  }
917    
918  /* Internal forget function */  /* Internal forget function */
919  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
920    {
921    symbol *temp;    symbol *temp;
922    
923    temp= *hash_entry;    temp= *hash_entry;
# Line 895  void forget_sym(symbol **hash_entry) { Line 931  void forget_sym(symbol **hash_entry) {
931  extern void forget(environment *env)  extern void forget(environment *env)
932  {  {
933    char* sym_id;    char* sym_id;
934    stackitem *stack_head= env->head;    value *stack_head= env->head;
935    
936    if(stack_head==NULL) {    if(stack_head==NULL) {
937      printerr("Too Few Arguments");      printerr("Too Few Arguments");
938      env->err=1;      env->err= 1;
939      return;      return;
940    }    }
941        
942    if(stack_head->item->type!=symb) {    if(CAR(stack_head)->type!=symb) {
943      printerr("Bad Argument Type");      printerr("Bad Argument Type");
944      env->err=2;      env->err= 2;
945      return;      return;
946    }    }
947    
948    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(stack_head)->content.sym->id;
949    toss(env);    toss(env);
950    
951    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
952  }  }
953    
954  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
955  extern void errn(environment *env){  extern void errn(environment *env)
956    {
957    push_int(env, env->err);    push_int(env, env->err);
958  }  }
959    
# Line 926  int main(int argc, char **argv) Line 963  int main(int argc, char **argv)
963    
964    int c;                        /* getopt option character */    int c;                        /* getopt option character */
965    
966    #ifdef __linux__
967    mtrace();    mtrace();
968    #endif
969    
970    init_env(&myenv);    init_env(&myenv);
971    
# Line 980  under certain conditions; type `copying; Line 1019  under certain conditions; type `copying;
1019      if (myenv.err==4) {      if (myenv.err==4) {
1020        return EXIT_SUCCESS;      /* EOF */        return EXIT_SUCCESS;      /* EOF */
1021      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1022                && myenv.head->item->type==symb                && CAR(myenv.head)->type==symb
1023                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->content.sym->id[0]
1024                  ==';') {
1025        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1026        eval(&myenv);        eval(&myenv);
1027      }      }
1028      gc_init(&myenv);      gc_maybe(&myenv);
1029    }    }
1030    quit(&myenv);    quit(&myenv);
1031    return EXIT_FAILURE;    return EXIT_FAILURE;
1032  }  }
1033    
1034  /* "+" */  /* "+" */
1035  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1036    {
1037    int a, b;    int a, b;
1038    float fa, fb;    float fa, fb;
1039    size_t len;    size_t len;
1040    char* new_string;    char* new_string;
1041    value *a_val, *b_val;    value *a_val, *b_val;
1042    
1043    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1044      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1045      env->err= 1;      env->err= 1;
1046      return;      return;
1047    }    }
1048    
1049    if(env->head->item->type==string    if(CAR(env->head)->type==string
1050       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1051      a_val= env->head->item;      a_val= CAR(env->head);
1052      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1053      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1054      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1055      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1056      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 1058  extern void sx_2b(environment *env) {
1058      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1059      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1060      push_cstring(env, new_string);      push_cstring(env, new_string);
1061      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1062      free(new_string);      free(new_string);
1063            
1064      return;      return;
1065    }    }
1066        
1067    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1068       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1069      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1070      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1071      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1072      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1073      push_int(env, b+a);      push_int(env, b+a);
1074    
1075      return;      return;
1076    }    }
1077    
1078    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1079       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1080      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1081      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1082      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1083      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1084      push_float(env, fb+fa);      push_float(env, fb+fa);
1085            
1086      return;      return;
1087    }    }
1088    
1089    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1090       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1091      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1092      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1093      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1094      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1095      push_float(env, b+fa);      push_float(env, b+fa);
1096            
1097      return;      return;
1098    }    }
1099    
1100    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1101       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1102      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1103      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1104      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1105      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1106      push_float(env, fb+a);      push_float(env, fb+a);
1107    
# Line 1072  extern void sx_2b(environment *env) { Line 1113  extern void sx_2b(environment *env) {
1113  }  }
1114    
1115  /* "-" */  /* "-" */
1116  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1117    {
1118    int a, b;    int a, b;
1119    float fa, fb;    float fa, fb;
1120    
1121    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1122      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1123      env->err=1;      env->err=1;
1124      return;      return;
1125    }    }
1126        
1127    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1128       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1129      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1130      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1131      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1132      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1133      push_int(env, b-a);      push_int(env, b-a);
1134    
1135      return;      return;
1136    }    }
1137    
1138    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1139       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1140      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1141      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1142      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1143      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1144      push_float(env, fb-fa);      push_float(env, fb-fa);
1145            
1146      return;      return;
1147    }    }
1148    
1149    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1150       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1151      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1152      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1153      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1154      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1155      push_float(env, b-fa);      push_float(env, b-fa);
1156            
1157      return;      return;
1158    }    }
1159    
1160    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1161       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1162      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1163      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1164      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1165      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1166      push_float(env, fb-a);      push_float(env, fb-a);
1167    
# Line 1131  extern void sx_2d(environment *env) { Line 1173  extern void sx_2d(environment *env) {
1173  }  }
1174    
1175  /* ">" */  /* ">" */
1176  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1177    {
1178    int a, b;    int a, b;
1179    float fa, fb;    float fa, fb;
1180    
1181    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1182      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1183      env->err=1;      env->err= 1;
1184      return;      return;
1185    }    }
1186        
1187    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1188       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1189      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1190      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1191      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1192      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1193      push_int(env, b>a);      push_int(env, b>a);
1194    
1195      return;      return;
1196    }    }
1197    
1198    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1199       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1200      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1201      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1202      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1203      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1204      push_int(env, fb>fa);      push_int(env, fb>fa);
1205            
1206      return;      return;
1207    }    }
1208    
1209    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1210       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1211      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1212      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1213      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1214      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1215      push_int(env, b>fa);      push_int(env, b>fa);
1216            
1217      return;      return;
1218    }    }
1219    
1220    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1221       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1222      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1223      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1224      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1225      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1226      push_int(env, fb>a);      push_int(env, fb>a);
1227    
# Line 1186  extern void sx_3e(environment *env) { Line 1229  extern void sx_3e(environment *env) {
1229    }    }
1230    
1231    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1232    env->err=2;    env->err= 2;
1233  }  }
1234    
1235  /* "<" */  /* "<" */
1236  extern void sx_3c(environment *env) {  extern void sx_3c(environment *env)
1237    {
1238    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1239    sx_3e(env);    sx_3e(env);
1240  }  }
1241    
1242  /* "<=" */  /* "<=" */
1243  extern void sx_3c3d(environment *env) {  extern void sx_3c3d(environment *env)
1244    {
1245    sx_3e(env); if(env->err) return;    sx_3e(env); if(env->err) return;
1246    not(env);    not(env);
1247  }  }
1248    
1249  /* ">=" */  /* ">=" */
1250  extern void sx_3e3d(environment *env) {  extern void sx_3e3d(environment *env)
1251    {
1252    sx_3c(env); if(env->err) return;    sx_3c(env); if(env->err) return;
1253    not(env);    not(env);
1254  }  }
1255    
1256  /* Return copy of a value */  /* Return copy of a value */
1257  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1258    stackitem *old_item, *new_item, *prev_item;  {
1259    value *new_value;    value *new_value;
1260    
1261    protect(env, old_value);    if(old_value==NULL)
1262        return NULL;
1263    
1264      protect(old_value);
1265    new_value= new_val(env);    new_value= new_val(env);
1266    protect(env, new_value);    protect(new_value);
1267    new_value->type= old_value->type;    new_value->type= old_value->type;
1268    
1269    switch(old_value->type){    switch(old_value->type){
# Line 1228  value *copy_val(environment *env, value Line 1277  value *copy_val(environment *env, value
1277      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1278        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1279      break;      break;
1280    case list:    case tcons:
1281      new_value->content.ptr= NULL;      new_value= NULL;
   
     prev_item= NULL;  
     old_item= (stackitem*)(old_value->content.ptr);  
1282    
1283      while(old_item != NULL) {   /* While list is not empty */      new_value->content.c= malloc(sizeof(cons));
1284        new_item= malloc(sizeof(stackitem));      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1285        new_item->item= copy_val(env, old_item->item); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
       new_item->next= NULL;  
       if(prev_item != NULL)     /* If this wasn't the first item */  
         prev_item->next= new_item; /* point the previous item to the  
                                      new item */  
       else  
         new_value->content.ptr= new_item;  
       old_item= old_item->next;  
       prev_item= new_item;  
     }      
1286      break;      break;
1287    }    }
1288    
1289    unprotect(env); unprotect(env);    unprotect(old_value); unprotect(new_value);
1290    
1291    return new_value;    return new_value;
1292  }  }
1293    
1294  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1295  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1296    if((env->head)==NULL) {  {
1297      if(env->head==NULL) {
1298      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1299      env->err= 1;      env->err= 1;
1300      return;      return;
1301    }    }
1302    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1303  }  }
1304    
1305  /* "if", If-Then */  /* "if", If-Then */
1306  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1307    {
1308    int truth;    int truth;
1309    
1310    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1311      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1312      env->err= 1;      env->err= 1;
1313      return;      return;
1314    }    }
1315    
1316    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1317      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1318      env->err=2;      env->err= 2;
1319      return;      return;
1320    }    }
1321        
1322    swap(env);    swap(env);
1323    if(env->err) return;    if(env->err) return;
1324        
1325    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1326    
1327    toss(env);    toss(env);
1328    if(env->err) return;    if(env->err) return;
# Line 1296  extern void sx_6966(environment *env) { Line 1334  extern void sx_6966(environment *env) {
1334  }  }
1335    
1336  /* If-Then-Else */  /* If-Then-Else */
1337  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1338    {
1339    int truth;    int truth;
1340    
1341    if((env->head)==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1342       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1343      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1344      env->err=1;      env->err= 1;
1345      return;      return;
1346    }    }
1347    
1348    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1349      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1350      env->err=2;      env->err= 2;
1351      return;      return;
1352    }    }
1353        
1354    rot(env);    rot(env);
1355    if(env->err) return;    if(env->err) return;
1356        
1357    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1358    
1359    toss(env);    toss(env);
1360    if(env->err) return;    if(env->err) return;
# Line 1331  extern void ifelse(environment *env) { Line 1369  extern void ifelse(environment *env) {
1369    eval(env);    eval(env);
1370  }  }
1371    
1372  /* "while" */  extern void sx_656c7365(environment *env)
1373  extern void sx_7768696c65(environment *env) {  {
1374      if(env->head==NULL || CDR(env->head)==NULL
1375         || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL) {
1376        printerr("Too Few Arguments");
1377        env->err= 1;
1378        return;
1379      }
1380    
1381      if(CAR(CDR(env->head))->type!=symb
1382         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1383        printerr("Bad Argument Type");
1384        env->err= 2;
1385        return;
1386      }
1387    
1388      swap(env); toss(env);
1389      ifelse(env);
1390    }
1391    
1392    /* "while" */
1393    extern void sx_7768696c65(environment *env)
1394    {
1395    int truth;    int truth;
1396    value *loop, *test;    value *loop, *test;
1397    
1398    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1399      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1400      env->err=1;      env->err= 1;
1401      return;      return;
1402    }    }
1403    
1404    loop= env->head->item;    loop= CAR(env->head);
1405    protect(env, loop);    protect(loop);
1406    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1407    
1408    test= env->head->item;    test= CAR(env->head);
1409    protect(env, test);    protect(test);
1410    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1411    
1412    do {    do {
1413      push_val(env, test);      push_val(env, test);
1414      eval(env);      eval(env);
1415            
1416      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1417        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1418        env->err= 2;        env->err= 2;
1419        return;        return;
1420      }      }
1421            
1422      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1423      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1424            
1425      if(truth) {      if(truth) {
# Line 1373  extern void sx_7768696c65(environment *e Line 1431  extern void sx_7768696c65(environment *e
1431        
1432    } while(truth);    } while(truth);
1433    
1434    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1435  }  }
1436    
1437    
1438  /* "for"; for-loop */  /* "for"; for-loop */
1439  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1440    {
1441    value *loop;    value *loop;
1442    int foo1, foo2;    int foo1, foo2;
1443    
1444    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1445       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1446      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1447      env->err= 1;      env->err= 1;
1448      return;      return;
1449    }    }
1450    
1451    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1452       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1453      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1454      env->err= 2;      env->err= 2;
1455      return;      return;
1456    }    }
1457    
1458    loop= env->head->item;    loop= CAR(env->head);
1459    protect(env, loop);    protect(loop);
1460    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1461    
1462    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1463    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1464    
1465    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1466    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1467    
1468    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1421  extern void sx_666f72(environment *env) Line 1480  extern void sx_666f72(environment *env)
1480        foo1--;        foo1--;
1481      }      }
1482    }    }
1483    unprotect(env);    unprotect(loop);
1484  }  }
1485    
1486  /* Variant of for-loop */  /* Variant of for-loop */
1487  extern void foreach(environment *env) {  extern void foreach(environment *env)
1488      {  
1489    value *loop, *foo;    value *loop, *foo;
1490    stackitem *iterator;    value *iterator;
1491        
1492    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1493      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1494      env->err= 1;      env->err= 1;
1495      return;      return;
1496    }    }
1497    
1498    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1499      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1500      env->err= 2;      env->err= 2;
1501      return;      return;
1502    }    }
1503    
1504    loop= env->head->item;    loop= CAR(env->head);
1505    protect(env, loop);    protect(loop);
1506    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1507    
1508    foo= env->head->item;    foo= CAR(env->head);
1509    protect(env, foo);    protect(foo);
1510    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1511    
1512    iterator= foo->content.ptr;    iterator= foo;
1513    
1514    while(iterator!=NULL) {    while(iterator!=NULL) {
1515      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1516      push_val(env, loop);      push_val(env, loop);
1517      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1518      iterator= iterator->next;      if (iterator->type == tcons){
1519          iterator= CDR(iterator);
1520        } else {
1521          printerr("Bad Argument Type"); /* Improper list */
1522          env->err= 2;
1523          break;
1524        }
1525    }    }
1526    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1527  }  }
1528    
1529  /* "to" */  /* "to" */
1530  extern void to(environment *env) {  extern void to(environment *env)
1531    int i, start, ending;  {
1532    stackitem *temp_head;    int ending, start, i;
1533    value *temp_val;    value *iterator, *temp;
1534      
1535    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1536      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1537      env->err=1;      env->err= 1;
1538      return;      return;
1539    }    }
1540    
1541    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1542       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1543      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1544      env->err=2;      env->err= 2;
1545      return;      return;
1546    }    }
1547    
1548    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1549    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1550    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1551    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1552    
1553    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1554    
1555    if(ending>=start) {    if(ending>=start) {
1556      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1496  extern void to(environment *env) { Line 1560  extern void to(environment *env) {
1560        push_int(env, i);        push_int(env, i);
1561    }    }
1562    
1563    temp_val= new_val(env);    iterator= env->head;
   protect(env, temp_val);  
1564    
1565    temp_val->content.ptr= env->head;    if(iterator==NULL
1566    temp_val->type= list;       || (CAR(iterator)->type==symb
1567    env->head= temp_head;           && CAR(iterator)->content.sym->id[0]=='[')) {
1568    push_val(env, temp_val);      temp= NULL;
1569        toss(env);
1570      } else {
1571        /* Search for first delimiter */
1572        while(CDR(iterator)!=NULL
1573              && (CAR(CDR(iterator))->type!=symb
1574                  || CAR(CDR(iterator))->content.sym->id[0]!='['))
1575          iterator= CDR(iterator);
1576        
1577        /* Extract list */
1578        temp= env->head;
1579        env->head= CDR(iterator);
1580        CDR(iterator)= NULL;
1581    
1582        if(env->head!=NULL)
1583          toss(env);
1584      }
1585    
1586    unprotect(env);    /* Push list */
1587      push_val(env, temp);
1588  }  }
1589    
1590  /* Read a string */  /* Read a string */
1591  extern void readline(environment *env) {  extern void readline(environment *env)
1592    {
1593    char in_string[101];    char in_string[101];
1594    
1595    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1518  extern void readline(environment *env) { Line 1599  extern void readline(environment *env) {
1599  }  }
1600    
1601  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1602  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1603    {
1604    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1605    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1606    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1541  extern void sx_72656164(environment *env Line 1623  extern void sx_72656164(environment *env
1623      }      }
1624      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1625    
1626      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1627        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1628        return;        return;
1629      }      }
1630            
1631      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1632      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1633      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1634      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1635    }    }
1636        
# Line 1597  extern void sx_72656164(environment *env Line 1679  extern void sx_72656164(environment *env
1679      return sx_72656164(env);      return sx_72656164(env);
1680  }  }
1681    
1682  extern void beep(environment *env) {  #ifdef __linux__
1683    extern void beep(environment *env)
1684    {
1685    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1686    
1687    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1688      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1689      env->err=1;      env->err= 1;
1690      return;      return;
1691    }    }
1692    
1693    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1694       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1695      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1696      env->err=2;      env->err= 2;
1697      return;      return;
1698    }    }
1699    
1700    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1701    toss(env);    toss(env);
1702    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
1703    toss(env);    toss(env);
1704    
1705    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1706                                     length */                                     length */
1707    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1708                                     timer ticks */                                     timer ticks */
1709    
1710  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1711    
1712    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1713    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1714    case 0:    case 0:
1715      usleep(dur);      usleep(dur);
1716      return;      return;
1717    case -1:    case -1:
1718      perror("beep");      perror("beep");
1719      env->err=5;      env->err= 5;
1720      return;      return;
1721    default:    default:
1722      abort();      abort();
1723    }    }
1724  };  }
1725    #endif /* __linux__ */
1726    
1727  /* "wait" */  /* "wait" */
1728  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1729    {
1730    int dur;    int dur;
1731    
1732    if((env->head)==NULL) {    if(env->head==NULL) {
1733      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1734      env->err=1;      env->err= 1;
1735      return;      return;
1736    }    }
1737    
1738    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1739      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1740      env->err=2;      env->err= 2;
1741      return;      return;
1742    }    }
1743    
1744    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1745    toss(env);    toss(env);
1746    
1747    usleep(dur);    usleep(dur);
1748  };  }
1749    
1750  extern void copying(environment *env){  extern void copying(environment *env)
1751    {
1752    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1753                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1754  \n\  \n\
# Line 1922  of preserving the free status of all der Line 2007  of preserving the free status of all der
2007  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
2008  }  }
2009    
2010  extern void warranty(environment *env){  extern void warranty(environment *env)
2011    {
2012    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
2013  \n\  \n\
2014    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 2038  extern void sx_2a(environment *env)
2038    int a, b;    int a, b;
2039    float fa, fb;    float fa, fb;
2040    
2041    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2042      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2043      env->err=1;      env->err= 1;
2044      return;      return;
2045    }    }
2046        
2047    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2048       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2049      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2050      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2051      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2052      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2053      push_int(env, b*a);      push_int(env, b*a);
2054    
2055      return;      return;
2056    }    }
2057    
2058    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2059       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2060      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2061      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2062      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2063      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2064      push_float(env, fb*fa);      push_float(env, fb*fa);
2065            
2066      return;      return;
2067    }    }
2068    
2069    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2070       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2071      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2072      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2073      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2074      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2075      push_float(env, b*fa);      push_float(env, b*fa);
2076            
2077      return;      return;
2078    }    }
2079    
2080    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2081       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2082      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2083      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2084      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2085      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2086      push_float(env, fb*a);      push_float(env, fb*a);
2087    
# Line 2003  extern void sx_2a(environment *env) Line 2089  extern void sx_2a(environment *env)
2089    }    }
2090    
2091    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2092    env->err=2;    env->err= 2;
2093  }  }
2094    
2095  /* "/" */  /* "/" */
# Line 2012  extern void sx_2f(environment *env) Line 2098  extern void sx_2f(environment *env)
2098    int a, b;    int a, b;
2099    float fa, fb;    float fa, fb;
2100    
2101    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2102      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2103      env->err=1;      env->err= 1;
2104      return;      return;
2105    }    }
2106        
2107    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2108       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2109      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2110      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2111      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2112      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2113      push_float(env, b/a);      push_float(env, b/a);
2114    
2115      return;      return;
2116    }    }
2117    
2118    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2119       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2120      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2121      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2122      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2123      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2124      push_float(env, fb/fa);      push_float(env, fb/fa);
2125            
2126      return;      return;
2127    }    }
2128    
2129    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2130       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2131      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2132      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2133      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2134      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2135      push_float(env, b/fa);      push_float(env, b/fa);
2136            
2137      return;      return;
2138    }    }
2139    
2140    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2141       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2142      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2143      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2144      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2145      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2146      push_float(env, fb/a);      push_float(env, fb/a);
2147    
# Line 2063  extern void sx_2f(environment *env) Line 2149  extern void sx_2f(environment *env)
2149    }    }
2150    
2151    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2152    env->err=2;    env->err= 2;
2153  }  }
2154    
2155  /* "mod" */  /* "mod" */
# Line 2071  extern void mod(environment *env) Line 2157  extern void mod(environment *env)
2157  {  {
2158    int a, b;    int a, b;
2159    
2160    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2161      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2162      env->err= 1;      env->err= 1;
2163      return;      return;
2164    }    }
2165        
2166    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2167       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2168      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2169      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2170      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2171      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2172      push_int(env, b%a);      push_int(env, b%a);
2173    
# Line 2089  extern void mod(environment *env) Line 2175  extern void mod(environment *env)
2175    }    }
2176    
2177    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2178    env->err=2;    env->err= 2;
2179  }  }
2180    
2181  /* "div" */  /* "div" */
# Line 2097  extern void sx_646976(environment *env) Line 2183  extern void sx_646976(environment *env)
2183  {  {
2184    int a, b;    int a, b;
2185        
2186    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2187      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2188      env->err= 1;      env->err= 1;
2189      return;      return;
2190    }    }
2191    
2192    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2193       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2194      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2195      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2196      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2197      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2198      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2199    
Legend:
Removed from v.1.94  
changed lines
  Added in v.1.107
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26