/[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.110 by teddy, Sat Mar 16 09:12:39 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    env->gc_count= 0;    env->gc_count= 0;
192    
193    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
   while(env->gc_ref!=NULL) {  
194    
195      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
196    
197        /* Remove content */        if(env->gc_ref->item->type==string) /* Remove content */
       switch(env->gc_ref->item->type) {  
       case string:  
198          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
199          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;  
       }  
200        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
201        titem= env->gc_ref->next;        titem= env->gc_ref->next;
202        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
203        env->gc_ref= titem;        env->gc_ref= titem;
204      } else {                    /* Save */        continue;
205        titem= env->gc_ref->next;      }
206        env->gc_ref->next= new_head;  #ifdef DEBUG
207        new_head= env->gc_ref;      printf("Kept value (%p)", env->gc_ref->item);
208        env->gc_ref= titem;      if(env->gc_ref->item->gc.flag.mark)
209        env->gc_count++;        printf(" (marked)");
210        if(env->gc_ref->item->gc.flag.protect)
211          printf(" (protected)");
212        switch(env->gc_ref->item->type){
213        case integer:
214          printf(" integer: %d", env->gc_ref->item->content.i);
215          break;
216        case func:
217          printf(" func: %p", env->gc_ref->item->content.ptr);
218          break;
219        case symb:
220          printf(" symb: %s", env->gc_ref->item->content.sym->id);
221          break;
222        case tcons:
223          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
224                 env->gc_ref->item->content.c->cdr);
225          break;
226        default:
227          printf(" <unknown %d>", (env->gc_ref->item->type));
228      }      }
229        printf("\n");
230    #endif /* DEBUG */
231    
232        /* Keep values */    
233        env->gc_count += sizeof(value);
234        if(env->gc_ref->item->type==string)
235          env->gc_count += strlen(env->gc_ref->item->content.ptr);
236        
237        titem= env->gc_ref->next;
238        env->gc_ref->next= new_head;
239        new_head= env->gc_ref;
240        new_head->item->gc.flag.mark= 0;
241        env->gc_ref= titem;
242    }    }
243    
244    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
245        env->gc_limit= env->gc_count*2;
246    
247    env->gc_ref= new_head;    env->gc_ref= new_head;
248    
249      if(env->interactive)
250        printf("done (%d bytes still allocated)\n", env->gc_count);
251    
252  }  }
253    
254  void protect(environment *env, value *val)  /* Protect values from GC */
255    void protect(value *val)
256  {  {
257    stackitem *new_item= malloc(sizeof(stackitem));    if(val==NULL || val->gc.flag.protect)
258    new_item->item= val;      return;
259    new_item->next= env->gc_protect;  
260    env->gc_protect= new_item;    val->gc.flag.protect= 1;
261    
262      if(val->type==tcons) {
263        protect(CAR(val));
264        protect(CDR(val));
265      }
266  }  }
267    
268  void unprotect(environment *env)  /* Unprotect values from GC */
269    void unprotect(value *val)
270  {  {
271    stackitem *temp= env->gc_protect;    if(val==NULL || !(val->gc.flag.protect))
272    env->gc_protect= env->gc_protect->next;      return;
273    free(temp);  
274      val->gc.flag.protect= 0;
275    
276      if(val->type==tcons) {
277        unprotect(CAR(val));
278        unprotect(CDR(val));
279      }
280  }  }
281    
282  /* Push a value onto the stack */  /* Push a value onto the stack */
283  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
284  {  {
285    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
286    new_item->item= val;  
287    new_item->next= env->head;    new_value->content.c= malloc(sizeof(cons));
288    env->head= new_item;    assert(new_value->content.c!=NULL);
289      new_value->type= tcons;
290      CAR(new_value)= val;
291      CDR(new_value)= env->head;
292      env->head= new_value;
293  }  }
294    
295  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
296  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
297  {  {
298    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 262  void push_int(environment *env, int in_v Line 303  void push_int(environment *env, int in_v
303    push_val(env, new_value);    push_val(env, new_value);
304  }  }
305    
306    /* Push a floating point number onto the stack */
307  void push_float(environment *env, float in_val)  void push_float(environment *env, float in_val)
308  {  {
309    value *new_value= new_val(env);    value *new_value= new_val(env);
# Line 276  void push_float(environment *env, float Line 318  void push_float(environment *env, float
318  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
319  {  {
320    value *new_value= new_val(env);    value *new_value= new_val(env);
321      int length= strlen(in_string)+1;
322    
323    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
324      env->gc_count += length;
325    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
326    new_value->type= string;    new_value->type= string;
327    
# Line 285  void push_cstring(environment *env, cons Line 329  void push_cstring(environment *env, cons
329  }  }
330    
331  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
332  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
333    {
334    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
335    char *new_string, *current;    char *new_string, *current;
336    
# Line 303  char *mangle_str(const char *old_string) Line 348  char *mangle_str(const char *old_string)
348    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
349  }  }
350    
351  extern void mangle(environment *env){  extern void mangle(environment *env)
352    {
353    char *new_string;    char *new_string;
354    
355    if((env->head)==NULL) {    if(env->head==NULL) {
356      printerr("Too Few Arguments");      printerr("Too Few Arguments");
357      env->err= 1;      env->err= 1;
358      return;      return;
359    }    }
360    
361    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
362      printerr("Bad Argument Type");      printerr("Bad Argument Type");
363      env->err= 2;      env->err= 2;
364      return;      return;
365    }    }
366    
367    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
368        mangle_str((const char *)(CAR(env->head)->content.ptr));
369    
370    toss(env);    toss(env);
371    if(env->err) return;    if(env->err) return;
# Line 342  void push_sym(environment *env, const ch Line 389  void push_sym(environment *env, const ch
389    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
390    
391    new_value= new_val(env);    new_value= new_val(env);
392    protect(env, new_value);    protect(new_value);
393    new_fvalue= new_val(env);    new_fvalue= new_val(env);
394    protect(env, new_fvalue);    protect(new_fvalue);
395    
396    /* The new value is a symbol */    /* The new value is a symbol */
397    new_value->type= symb;    new_value->type= symb;
# Line 372  void push_sym(environment *env, const ch Line 419  void push_sym(environment *env, const ch
419    
420      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
421      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
422      free(mangled);  
423      dlerr= dlerror();      dlerr= dlerror();
424      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
425        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
426        dlerr= dlerror();        dlerr= dlerror();
427      }      }
428    
429      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
430        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
431        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
432        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
433                                           function value */                                           function value */
434      }      }
435    
436        free(mangled);
437    }    }
438    
439    push_val(env, new_value);    push_val(env, new_value);
440    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
441  }  }
442    
443  /* Print newline. */  /* Print newline. */
# Line 396  extern void nl() Line 447  extern void nl()
447  }  }
448    
449  /* Gets the type of a value */  /* Gets the type of a value */
450  extern void type(environment *env){  extern void type(environment *env)
451    {
452    int typenum;    int typenum;
453    
454    if((env->head)==NULL) {    if(env->head==NULL) {
455      printerr("Too Few Arguments");      printerr("Too Few Arguments");
456      env->err=1;      env->err= 1;
457      return;      return;
458    }    }
459    typenum=env->head->item->type;  
460      typenum= CAR(env->head)->type;
461    toss(env);    toss(env);
462    switch(typenum){    switch(typenum){
463    case integer:    case integer:
# Line 422  extern void type(environment *env){ Line 475  extern void type(environment *env){
475    case func:    case func:
476      push_sym(env, "function");      push_sym(env, "function");
477      break;      break;
478    case list:    case tcons:
479      push_sym(env, "list");      push_sym(env, "list");
480      break;      break;
481    }    }
482  }      }    
483    
484  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
485  void print_h(stackitem *stack_head, int noquote)  void print_h(value *stack_head, int noquote)
486  {  {
487    switch(stack_head->item->type) {    switch(CAR(stack_head)->type) {
488    case integer:    case integer:
489      printf("%d", stack_head->item->content.i);      printf("%d", CAR(stack_head)->content.i);
490      break;      break;
491    case tfloat:    case tfloat:
492      printf("%f", stack_head->item->content.f);      printf("%f", CAR(stack_head)->content.f);
493      break;      break;
494    case string:    case string:
495      if(noquote)      if(noquote)
496        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)CAR(stack_head)->content.ptr);
497      else      else
498        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);
499      break;      break;
500    case symb:    case symb:
501      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
502      break;      break;
503    case func:    case func:
504      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
505      break;      break;
506    case list:    case tcons:
507      /* 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 */
508      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head= CAR(stack_head);
509      printf("[ ");      printf("[ ");
510      while(stack_head != NULL) {      while(stack_head != NULL) {
511        print_h(stack_head, noquote);        print_h(stack_head, noquote);
512        printf(" ");        printf(" ");
513        stack_head=stack_head->next;        stack_head= CDR(stack_head);
514      }      }
515      printf("]");      printf("]");
516      break;      break;
517    }    }
518  }  }
519    
520  extern void print_(environment *env) {  extern void print_(environment *env)
521    {
522    if(env->head==NULL) {    if(env->head==NULL) {
523      printerr("Too Few Arguments");      printerr("Too Few Arguments");
524      env->err=1;      env->err= 1;
525      return;      return;
526    }    }
527    print_h(env->head, 0);    print_h(env->head, 0);
# Line 482  extern void print(environment *env) Line 536  extern void print(environment *env)
536    toss(env);    toss(env);
537  }  }
538    
539  extern void princ_(environment *env) {  extern void princ_(environment *env)
540    {
541    if(env->head==NULL) {    if(env->head==NULL) {
542      printerr("Too Few Arguments");      printerr("Too Few Arguments");
543      env->err=1;      env->err= 1;
544      return;      return;
545    }    }
546    print_h(env->head, 1);    print_h(env->head, 1);
# Line 500  extern void princ(environment *env) Line 555  extern void princ(environment *env)
555  }  }
556    
557  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
558  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
559  {  {
560    if(stack_head->next != NULL)    if(CDR(stack_head) != NULL)
561      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
562    printf("%ld: ", counter);    printf("%ld: ", counter);
563    print_h(stack_head, 0);    print_h(stack_head, 0);
564    nl();    nl();
# Line 516  extern void printstack(environment *env) Line 571  extern void printstack(environment *env)
571      printf("Stack Empty\n");      printf("Stack Empty\n");
572      return;      return;
573    }    }
574    
575    print_st(env->head, 1);    print_st(env->head, 1);
576  }  }
577    
578  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
579  extern void swap(environment *env)  extern void swap(environment *env)
580  {  {
581    stackitem *temp= env->head;    value *temp= env->head;
582        
583    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
584      printerr("Too Few Arguments");      printerr("Too Few Arguments");
585      env->err=1;      env->err=1;
586      return;      return;
587    }    }
588    
589    env->head= env->head->next;    env->head= CDR(env->head);
590    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
591    env->head->next= temp;    CDR(env->head)= temp;
592  }  }
593    
594  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
595  extern void rot(environment *env)  extern void rot(environment *env)
596  {  {
597    stackitem *temp= env->head;    value *temp= env->head;
598        
599    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
600        || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
601      printerr("Too Few Arguments");      printerr("Too Few Arguments");
602      env->err=1;      env->err= 1;
603      return;      return;
604    }    }
605      
606    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
607    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
608    env->head->next= temp;    CDR(env->head)= temp;
609  }  }
610    
611  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 557  extern void rcl(environment *env) Line 613  extern void rcl(environment *env)
613  {  {
614    value *val;    value *val;
615    
616    if(env->head == NULL) {    if(env->head==NULL) {
617      printerr("Too Few Arguments");      printerr("Too Few Arguments");
618      env->err=1;      env->err= 1;
619      return;      return;
620    }    }
621    
622    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
623      printerr("Bad Argument Type");      printerr("Bad Argument Type");
624      env->err=2;      env->err= 2;
625      return;      return;
626    }    }
627    
628    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
629    if(val == NULL){    if(val == NULL){
630      printerr("Unbound Variable");      printerr("Unbound Variable");
631      env->err=3;      env->err= 3;
632      return;      return;
633    }    }
634    protect(env, val);    push_val(env, val);           /* Return the symbol's bound value */
635    toss(env);            /* toss the symbol */    swap(env);
636      if(env->err) return;
637      toss(env);                    /* toss the symbol */
638    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(env);  
639  }  }
640    
641  /* 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 645  extern void eval(environment *env)
645  {  {
646    funcp in_func;    funcp in_func;
647    value* temp_val;    value* temp_val;
648    stackitem* iterator;    value* iterator;
649    
650   eval_start:   eval_start:
651    
652      gc_maybe(env);
653    
654    if(env->head==NULL) {    if(env->head==NULL) {
655      printerr("Too Few Arguments");      printerr("Too Few Arguments");
656      env->err=1;      env->err= 1;
657      return;      return;
658    }    }
659    
660    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
661      /* if it's a symbol */      /* if it's a symbol */
662    case symb:    case symb:
663      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
664      if(env->err) return;      if(env->err) return;
665      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
666        goto eval_start;        goto eval_start;
667      }      }
668      return;      return;
669    
670      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
671    case func:    case func:
672      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
673      toss(env);      toss(env);
674      if(env->err) return;      if(env->err) return;
675      return in_func(env);      return in_func(env);
676    
677      /* If it's a list */      /* If it's a list */
678    case list:    case tcons:
679      temp_val= env->head->item;      temp_val= CAR(env->head);
680      protect(env, temp_val);      protect(temp_val);
681    
682      toss(env); if(env->err) return;      toss(env); if(env->err) return;
683      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
684            
685      while(iterator!=NULL) {      while(iterator!=NULL) {
686        push_val(env, iterator->item);        push_val(env, CAR(iterator));
687                
688        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
689          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
690          toss(env);          toss(env);
691          if(env->err) return;          if(env->err) return;
692                    
693          if(iterator->next == NULL){          if(CDR(iterator)==NULL){
694            goto eval_start;            goto eval_start;
695          }          }
696          eval(env);          eval(env);
697          if(env->err) return;          if(env->err) return;
698        }        }
699        iterator= iterator->next;        if (CDR(iterator)==NULL || CDR(iterator)->type == tcons)
700            iterator= CDR(iterator);
701          else {
702            printerr("Bad Argument Type"); /* Improper list */
703            env->err= 2;
704            return;
705          }
706      }      }
707      unprotect(env);      unprotect(temp_val);
708      return;      return;
709    
710    default:    default:
# Line 649  extern void eval(environment *env) Line 713  extern void eval(environment *env)
713  }  }
714    
715  /* Reverse (flip) a list */  /* Reverse (flip) a list */
716  extern void rev(environment *env){  extern void rev(environment *env)
717    stackitem *old_head, *new_head, *item;  {
718      value *old_head, *new_head, *item;
719    
720    if((env->head)==NULL) {    if(env->head==NULL) {
721      printerr("Too Few Arguments");      printerr("Too Few Arguments");
722      env->err= 1;      env->err= 1;
723      return;      return;
724    }    }
725    
726    if(env->head->item->type!=list) {    if(CAR(env->head)->type!=tcons) {
727      printerr("Bad Argument Type");      printerr("Bad Argument Type");
728      env->err= 2;      env->err= 2;
729      return;      return;
730    }    }
731    
732    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
733    new_head= NULL;    new_head= NULL;
734    while(old_head != NULL){    while(old_head!=NULL) {
735      item= old_head;      item= old_head;
736      old_head= old_head->next;      old_head= CDR(old_head);
737      item->next= new_head;      CDR(item)= new_head;
738      new_head= item;      new_head= item;
739    }    }
740    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
741  }  }
742    
743  /* Make a list. */  /* Make a list. */
744  extern void pack(environment *env)  extern void pack(environment *env)
745  {  {
746    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
747    
748    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(env, pack);  
   
749    if(iterator==NULL    if(iterator==NULL
750       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
751       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
752      temp= NULL;      temp= NULL;
753      toss(env);      toss(env);
754    } else {    } else {
755      /* Search for first delimiter */      /* Search for first delimiter */
756      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
757            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
758            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
759        iterator= iterator->next;        iterator= CDR(iterator);
760            
761      /* Extract list */      /* Extract list */
762      temp= env->head;      temp= env->head;
763      env->head= iterator->next;      env->head= CDR(iterator);
764      iterator->next= NULL;      CDR(iterator)= NULL;
765    
     pack->type= list;  
     pack->content.ptr= temp;  
       
766      if(env->head!=NULL)      if(env->head!=NULL)
767        toss(env);        toss(env);
768    }    }
769    
770    /* Push list */    /* Push list */
771    
772    push_val(env, pack);    push_val(env, temp);
773    rev(env);    rev(env);
   
   unprotect(env);  
774  }  }
775    
776  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
777  extern void expand(environment *env)  extern void expand(environment *env)
778  {  {
779    stackitem *temp, *new_head;    value *temp, *new_head;
780    
781    /* Is top element a list? */    /* Is top element a list? */
782    if(env->head==NULL) {    if(env->head==NULL) {
# Line 728  extern void expand(environment *env) Line 784  extern void expand(environment *env)
784      env->err= 1;      env->err= 1;
785      return;      return;
786    }    }
787    if(env->head->item->type!=list) {  
788      if(CAR(env->head)->type!=tcons) {
789      printerr("Bad Argument Type");      printerr("Bad Argument Type");
790      env->err= 2;      env->err= 2;
791      return;      return;
# Line 740  extern void expand(environment *env) Line 797  extern void expand(environment *env)
797      return;      return;
798    
799    /* The first list element is the new stack head */    /* The first list element is the new stack head */
800    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
801    
802    toss(env);    toss(env);
803    
804    /* Find the end of the list */    /* Find the end of the list */
805    while(temp->next!=NULL)    while(CDR(temp)->content.ptr != NULL) {
806      temp= temp->next;      if (CDR(temp)->type == tcons)
807          temp= CDR(temp);
808        else {
809          printerr("Bad Argument Type"); /* Improper list */
810          env->err= 2;
811          return;
812        }
813      }
814    
815    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
816    temp->next= env->head;    CDR(temp)= env->head;
817    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
818    
819  }  }
# Line 758  extern void expand(environment *env) Line 822  extern void expand(environment *env)
822  extern void eq(environment *env)  extern void eq(environment *env)
823  {  {
824    void *left, *right;    void *left, *right;
   int result;  
825    
826    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
827      printerr("Too Few Arguments");      printerr("Too Few Arguments");
828      env->err= 1;      env->err= 1;
829      return;      return;
830    }    }
831    
832    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
833    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
834    toss(env); toss(env);    toss(env); toss(env);
835    push_int(env, result);  
836      push_int(env, left==right);
837  }  }
838    
839  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 780  extern void not(environment *env) Line 841  extern void not(environment *env)
841  {  {
842    int val;    int val;
843    
844    if((env->head)==NULL) {    if(env->head==NULL) {
845      printerr("Too Few Arguments");      printerr("Too Few Arguments");
846      env->err= 1;      env->err= 1;
847      return;      return;
848    }    }
849    
850    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
851      printerr("Bad Argument Type");      printerr("Bad Argument Type");
852      env->err= 2;      env->err= 2;
853      return;      return;
854    }    }
855    
856    val= env->head->item->content.i;    val= CAR(env->head)->content.i;
857    toss(env);    toss(env);
858    push_int(env, !val);    push_int(env, !val);
859  }  }
# Line 811  extern void def(environment *env) Line 872  extern void def(environment *env)
872    symbol *sym;    symbol *sym;
873    
874    /* 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 */
875    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
876      printerr("Too Few Arguments");      printerr("Too Few Arguments");
877      env->err= 1;      env->err= 1;
878      return;      return;
879    }    }
880    
881    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
882      printerr("Bad Argument Type");      printerr("Bad Argument Type");
883      env->err= 2;      env->err= 2;
884      return;      return;
885    }    }
886    
887    /* long names are a pain */    /* long names are a pain */
888    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
889    
890    /* Bind the symbol to the value */    /* Bind the symbol to the value */
891    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
892    
893    toss(env); toss(env);    toss(env); toss(env);
894  }  }
# Line 835  extern void def(environment *env) Line 896  extern void def(environment *env)
896  /* Quit stack. */  /* Quit stack. */
897  extern void quit(environment *env)  extern void quit(environment *env)
898  {  {
899    long i;    int i;
900    
901    clear(env);    clear(env);
902    
# Line 848  extern void quit(environment *env) Line 909  extern void quit(environment *env)
909    }    }
910    
911    env->gc_limit= 0;    env->gc_limit= 0;
912    gc_init(env);    gc_maybe(env);
913    
914      words(env);
915    
916    if(env->free_string!=NULL)    if(env->free_string!=NULL)
917      free(env->free_string);      free(env->free_string);
918        
919    #ifdef __linux__
920    muntrace();    muntrace();
921    #endif
922    
923    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
924  }  }
# Line 874  extern void words(environment *env) Line 939  extern void words(environment *env)
939    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
940      temp= env->symbols[i];      temp= env->symbols[i];
941      while(temp!=NULL) {      while(temp!=NULL) {
942    #ifdef DEBUG
943          if (temp->val != NULL && temp->val->gc.flag.protect)
944            printf("(protected) ");
945    #endif /* DEBUG */
946        printf("%s\n", temp->id);        printf("%s\n", temp->id);
947        temp= temp->next;        temp= temp->next;
948      }      }
# Line 881  extern void words(environment *env) Line 950  extern void words(environment *env)
950  }  }
951    
952  /* Internal forget function */  /* Internal forget function */
953  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
954    {
955    symbol *temp;    symbol *temp;
956    
957    temp= *hash_entry;    temp= *hash_entry;
# Line 895  void forget_sym(symbol **hash_entry) { Line 965  void forget_sym(symbol **hash_entry) {
965  extern void forget(environment *env)  extern void forget(environment *env)
966  {  {
967    char* sym_id;    char* sym_id;
968    stackitem *stack_head= env->head;    value *stack_head= env->head;
969    
970    if(stack_head==NULL) {    if(stack_head==NULL) {
971      printerr("Too Few Arguments");      printerr("Too Few Arguments");
972      env->err=1;      env->err= 1;
973      return;      return;
974    }    }
975        
976    if(stack_head->item->type!=symb) {    if(CAR(stack_head)->type!=symb) {
977      printerr("Bad Argument Type");      printerr("Bad Argument Type");
978      env->err=2;      env->err= 2;
979      return;      return;
980    }    }
981    
982    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(stack_head)->content.sym->id;
983    toss(env);    toss(env);
984    
985    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
986  }  }
987    
988  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
989  extern void errn(environment *env){  extern void errn(environment *env)
990    {
991    push_int(env, env->err);    push_int(env, env->err);
992  }  }
993    
# Line 926  int main(int argc, char **argv) Line 997  int main(int argc, char **argv)
997    
998    int c;                        /* getopt option character */    int c;                        /* getopt option character */
999    
1000    #ifdef __linux__
1001    mtrace();    mtrace();
1002    #endif
1003    
1004    init_env(&myenv);    init_env(&myenv);
1005    
# Line 940  int main(int argc, char **argv) Line 1013  int main(int argc, char **argv)
1013          break;          break;
1014        case '?':        case '?':
1015          fprintf (stderr,          fprintf (stderr,
1016                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1017                   optopt);                   optopt);
1018          return EX_USAGE;          return EX_USAGE;
1019        default:        default:
# Line 959  int main(int argc, char **argv) Line 1032  int main(int argc, char **argv)
1032    if(myenv.interactive) {    if(myenv.interactive) {
1033      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1034  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1035  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1036  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1037  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1038    }    }
1039    
1040    while(1) {    while(1) {
# Line 976  under certain conditions; type `copying; Line 1049  under certain conditions; type `copying;
1049        }        }
1050        myenv.err=0;        myenv.err=0;
1051      }      }
1052      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1053      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1054        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1055          quit(&myenv);
1056      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1057                && myenv.head->item->type==symb                && CAR(myenv.head)->type==symb
1058                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->content.sym->id[0]
1059                  ==';') {
1060        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1061        eval(&myenv);        eval(&myenv);
1062      }      }
1063      gc_init(&myenv);      gc_maybe(&myenv);
1064    }    }
1065    quit(&myenv);    quit(&myenv);
1066    return EXIT_FAILURE;    return EXIT_FAILURE;
1067  }  }
1068    
1069  /* "+" */  /* "+" */
1070  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1071    {
1072    int a, b;    int a, b;
1073    float fa, fb;    float fa, fb;
1074    size_t len;    size_t len;
1075    char* new_string;    char* new_string;
1076    value *a_val, *b_val;    value *a_val, *b_val;
1077    
1078    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1079      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1080      env->err= 1;      env->err= 1;
1081      return;      return;
1082    }    }
1083    
1084    if(env->head->item->type==string    if(CAR(env->head)->type==string
1085       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1086      a_val= env->head->item;      a_val= CAR(env->head);
1087      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1088      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1089      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1090      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1091      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 1093  extern void sx_2b(environment *env) {
1093      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1094      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1095      push_cstring(env, new_string);      push_cstring(env, new_string);
1096      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1097      free(new_string);      free(new_string);
1098            
1099      return;      return;
1100    }    }
1101        
1102    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1103       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1104      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1105      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1106      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1107      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1108      push_int(env, b+a);      push_int(env, b+a);
1109    
1110      return;      return;
1111    }    }
1112    
1113    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1114       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1115      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1116      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1117      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1118      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1119      push_float(env, fb+fa);      push_float(env, fb+fa);
1120            
1121      return;      return;
1122    }    }
1123    
1124    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1125       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1126      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1127      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1128      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1129      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1130      push_float(env, b+fa);      push_float(env, b+fa);
1131            
1132      return;      return;
1133    }    }
1134    
1135    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1136       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1137      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1138      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1139      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1140      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1141      push_float(env, fb+a);      push_float(env, fb+a);
1142    
# Line 1072  extern void sx_2b(environment *env) { Line 1148  extern void sx_2b(environment *env) {
1148  }  }
1149    
1150  /* "-" */  /* "-" */
1151  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1152    {
1153    int a, b;    int a, b;
1154    float fa, fb;    float fa, fb;
1155    
1156    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1157      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1158      env->err=1;      env->err=1;
1159      return;      return;
1160    }    }
1161        
1162    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1163       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1164      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1165      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1166      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1167      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1168      push_int(env, b-a);      push_int(env, b-a);
1169    
1170      return;      return;
1171    }    }
1172    
1173    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1174       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1175      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1176      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1177      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1178      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1179      push_float(env, fb-fa);      push_float(env, fb-fa);
1180            
1181      return;      return;
1182    }    }
1183    
1184    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1185       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1186      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1187      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1188      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1189      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1190      push_float(env, b-fa);      push_float(env, b-fa);
1191            
1192      return;      return;
1193    }    }
1194    
1195    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1196       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1197      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1198      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1199      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1200      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1201      push_float(env, fb-a);      push_float(env, fb-a);
1202    
# Line 1131  extern void sx_2d(environment *env) { Line 1208  extern void sx_2d(environment *env) {
1208  }  }
1209    
1210  /* ">" */  /* ">" */
1211  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1212    {
1213    int a, b;    int a, b;
1214    float fa, fb;    float fa, fb;
1215    
1216    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1217      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1218      env->err=1;      env->err= 1;
1219      return;      return;
1220    }    }
1221        
1222    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1223       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1224      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1225      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1226      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1227      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1228      push_int(env, b>a);      push_int(env, b>a);
1229    
1230      return;      return;
1231    }    }
1232    
1233    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1234       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1235      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1236      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1237      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1238      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1239      push_int(env, fb>fa);      push_int(env, fb>fa);
1240            
1241      return;      return;
1242    }    }
1243    
1244    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1245       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1246      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1247      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1248      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1249      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1250      push_int(env, b>fa);      push_int(env, b>fa);
1251            
1252      return;      return;
1253    }    }
1254    
1255    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1256       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1257      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1258      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1259      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1260      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1261      push_int(env, fb>a);      push_int(env, fb>a);
1262    
# Line 1186  extern void sx_3e(environment *env) { Line 1264  extern void sx_3e(environment *env) {
1264    }    }
1265    
1266    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1267    env->err=2;    env->err= 2;
1268  }  }
1269    
1270  /* "<" */  /* "<" */
1271  extern void sx_3c(environment *env) {  extern void sx_3c(environment *env)
1272    {
1273    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1274    sx_3e(env);    sx_3e(env);
1275  }  }
1276    
1277  /* "<=" */  /* "<=" */
1278  extern void sx_3c3d(environment *env) {  extern void sx_3c3d(environment *env)
1279    {
1280    sx_3e(env); if(env->err) return;    sx_3e(env); if(env->err) return;
1281    not(env);    not(env);
1282  }  }
1283    
1284  /* ">=" */  /* ">=" */
1285  extern void sx_3e3d(environment *env) {  extern void sx_3e3d(environment *env)
1286    {
1287    sx_3c(env); if(env->err) return;    sx_3c(env); if(env->err) return;
1288    not(env);    not(env);
1289  }  }
1290    
1291  /* Return copy of a value */  /* Return copy of a value */
1292  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1293    stackitem *old_item, *new_item, *prev_item;  {
1294    value *new_value;    value *new_value;
1295    
1296    protect(env, old_value);    if(old_value==NULL)
1297        return NULL;
1298    
1299      protect(old_value);
1300    new_value= new_val(env);    new_value= new_val(env);
   protect(env, new_value);  
1301    new_value->type= old_value->type;    new_value->type= old_value->type;
1302    
1303    switch(old_value->type){    switch(old_value->type){
# Line 1228  value *copy_val(environment *env, value Line 1311  value *copy_val(environment *env, value
1311      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1312        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1313      break;      break;
1314    case list:    case tcons:
     new_value->content.ptr= NULL;  
1315    
1316      prev_item= NULL;      new_value->content.c= malloc(sizeof(cons));
1317      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
1318    
1319      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1320        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;  
     }      
1321      break;      break;
1322    }    }
1323    
1324    unprotect(env); unprotect(env);    unprotect(old_value);
1325    
1326    return new_value;    return new_value;
1327  }  }
1328    
1329  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1330  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1331    if((env->head)==NULL) {  {
1332      if(env->head==NULL) {
1333      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1334      env->err= 1;      env->err= 1;
1335      return;      return;
1336    }    }
1337    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1338  }  }
1339    
1340  /* "if", If-Then */  /* "if", If-Then */
1341  extern void sx_6966(environment *env) {  extern void sx_6966(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      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1347      env->err= 1;      env->err= 1;
1348      return;      return;
1349    }    }
1350    
1351    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1352      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1353      env->err=2;      env->err= 2;
1354      return;      return;
1355    }    }
1356        
1357    swap(env);    swap(env);
1358    if(env->err) return;    if(env->err) return;
1359        
1360    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1361    
1362    toss(env);    toss(env);
1363    if(env->err) return;    if(env->err) return;
# Line 1296  extern void sx_6966(environment *env) { Line 1369  extern void sx_6966(environment *env) {
1369  }  }
1370    
1371  /* If-Then-Else */  /* If-Then-Else */
1372  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1373    {
1374    int truth;    int truth;
1375    
1376    if((env->head)==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1377       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1378      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1379      env->err=1;      env->err= 1;
1380      return;      return;
1381    }    }
1382    
1383    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1384      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1385      env->err=2;      env->err= 2;
1386      return;      return;
1387    }    }
1388        
1389    rot(env);    rot(env);
1390    if(env->err) return;    if(env->err) return;
1391        
1392    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1393    
1394    toss(env);    toss(env);
1395    if(env->err) return;    if(env->err) return;
# Line 1331  extern void ifelse(environment *env) { Line 1404  extern void ifelse(environment *env) {
1404    eval(env);    eval(env);
1405  }  }
1406    
1407  /* "while" */  extern void sx_656c7365(environment *env)
1408  extern void sx_7768696c65(environment *env) {  {
1409      if(env->head==NULL || CDR(env->head)==NULL
1410         || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL
1411         || CDR(CDR(CDR(CDR(env->head))))==NULL) {
1412        printerr("Too Few Arguments");
1413        env->err= 1;
1414        return;
1415      }
1416    
1417      if(CAR(CDR(env->head))->type!=symb
1418         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1419         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1420         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1421        printerr("Bad Argument Type");
1422        env->err= 2;
1423        return;
1424      }
1425    
1426      swap(env); toss(env); rot(env); toss(env);
1427      ifelse(env);
1428    }
1429    
1430    extern void then(environment *env)
1431    {
1432      if(env->head==NULL || CDR(env->head)==NULL
1433         || CDR(CDR(env->head))==NULL) {
1434        printerr("Too Few Arguments");
1435        env->err= 1;
1436        return;
1437      }
1438    
1439      if(CAR(CDR(env->head))->type!=symb
1440         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1441        printerr("Bad Argument Type");
1442        env->err= 2;
1443        return;
1444      }
1445    
1446      swap(env); toss(env);
1447      sx_6966(env);
1448    }
1449    
1450    /* "while" */
1451    extern void sx_7768696c65(environment *env)
1452    {
1453    int truth;    int truth;
1454    value *loop, *test;    value *loop, *test;
1455    
1456    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1457      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1458      env->err=1;      env->err= 1;
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    test= env->head->item;    test= CAR(env->head);
1467    protect(env, test);    protect(test);
1468    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1469    
1470    do {    do {
1471      push_val(env, test);      push_val(env, test);
1472      eval(env);      eval(env);
1473            
1474      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1475        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1476        env->err= 2;        env->err= 2;
1477        return;        return;
1478      }      }
1479            
1480      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1481      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1482            
1483      if(truth) {      if(truth) {
# Line 1373  extern void sx_7768696c65(environment *e Line 1489  extern void sx_7768696c65(environment *e
1489        
1490    } while(truth);    } while(truth);
1491    
1492    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1493  }  }
1494    
1495    
1496  /* "for"; for-loop */  /* "for"; for-loop */
1497  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1498    {
1499    value *loop;    value *loop;
1500    int foo1, foo2;    int foo1, foo2;
1501    
1502    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1503       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1504      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1505      env->err= 1;      env->err= 1;
1506      return;      return;
1507    }    }
1508    
1509    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1510       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1511      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1512      env->err= 2;      env->err= 2;
1513      return;      return;
1514    }    }
1515    
1516    loop= env->head->item;    loop= CAR(env->head);
1517    protect(env, loop);    protect(loop);
1518    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1519    
1520    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1521    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1522    
1523    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1524    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1525    
1526    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1421  extern void sx_666f72(environment *env) Line 1538  extern void sx_666f72(environment *env)
1538        foo1--;        foo1--;
1539      }      }
1540    }    }
1541    unprotect(env);    unprotect(loop);
1542  }  }
1543    
1544  /* Variant of for-loop */  /* Variant of for-loop */
1545  extern void foreach(environment *env) {  extern void foreach(environment *env)
1546      {  
1547    value *loop, *foo;    value *loop, *foo;
1548    stackitem *iterator;    value *iterator;
1549        
1550    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1551      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1552      env->err= 1;      env->err= 1;
1553      return;      return;
1554    }    }
1555    
1556    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1557      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1558      env->err= 2;      env->err= 2;
1559      return;      return;
1560    }    }
1561    
1562    loop= env->head->item;    loop= CAR(env->head);
1563    protect(env, loop);    protect(loop);
1564    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1565    
1566    foo= env->head->item;    foo= CAR(env->head);
1567    protect(env, foo);    protect(foo);
1568    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1569    
1570    iterator= foo->content.ptr;    iterator= foo;
1571    
1572    while(iterator!=NULL) {    while(iterator!=NULL) {
1573      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1574      push_val(env, loop);      push_val(env, loop);
1575      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1576      iterator= iterator->next;      if (iterator->type == tcons){
1577          iterator= CDR(iterator);
1578        } else {
1579          printerr("Bad Argument Type"); /* Improper list */
1580          env->err= 2;
1581          break;
1582        }
1583    }    }
1584    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1585  }  }
1586    
1587  /* "to" */  /* "to" */
1588  extern void to(environment *env) {  extern void to(environment *env)
1589    int i, start, ending;  {
1590    stackitem *temp_head;    int ending, start, i;
1591    value *temp_val;    value *iterator, *temp;
1592      
1593    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1594      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1595      env->err=1;      env->err= 1;
1596      return;      return;
1597    }    }
1598    
1599    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1600       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1601      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1602      env->err=2;      env->err= 2;
1603      return;      return;
1604    }    }
1605    
1606    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1607    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1608    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1609    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1610    
1611    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1612    
1613    if(ending>=start) {    if(ending>=start) {
1614      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1496  extern void to(environment *env) { Line 1618  extern void to(environment *env) {
1618        push_int(env, i);        push_int(env, i);
1619    }    }
1620    
1621    temp_val= new_val(env);    iterator= env->head;
1622    protect(env, temp_val);  
1623      if(iterator==NULL
1624         || (CAR(iterator)->type==symb
1625             && CAR(iterator)->content.sym->id[0]=='[')) {
1626        temp= NULL;
1627        toss(env);
1628      } else {
1629        /* Search for first delimiter */
1630        while(CDR(iterator)!=NULL
1631              && (CAR(CDR(iterator))->type!=symb
1632                  || CAR(CDR(iterator))->content.sym->id[0]!='['))
1633          iterator= CDR(iterator);
1634        
1635        /* Extract list */
1636        temp= env->head;
1637        env->head= CDR(iterator);
1638        CDR(iterator)= NULL;
1639    
1640    temp_val->content.ptr= env->head;      if(env->head!=NULL)
1641    temp_val->type= list;        toss(env);
1642    env->head= temp_head;    }
   push_val(env, temp_val);  
1643    
1644    unprotect(env);    /* Push list */
1645      push_val(env, temp);
1646  }  }
1647    
1648  /* Read a string */  /* Read a string */
1649  extern void readline(environment *env) {  extern void readline(environment *env)
1650    {
1651    char in_string[101];    char in_string[101];
1652    
1653    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1518  extern void readline(environment *env) { Line 1657  extern void readline(environment *env) {
1657  }  }
1658    
1659  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1660  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1661    {
1662    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1663    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1664    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1541  extern void sx_72656164(environment *env Line 1681  extern void sx_72656164(environment *env
1681      }      }
1682      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1683    
1684      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1685        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1686        return;        return;
1687      }      }
1688            
1689      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1690      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1691      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1692      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1693    }    }
1694        
# Line 1597  extern void sx_72656164(environment *env Line 1737  extern void sx_72656164(environment *env
1737      return sx_72656164(env);      return sx_72656164(env);
1738  }  }
1739    
1740  extern void beep(environment *env) {  #ifdef __linux__
1741    extern void beep(environment *env)
1742    {
1743    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1744    
1745    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1746      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1747      env->err=1;      env->err= 1;
1748      return;      return;
1749    }    }
1750    
1751    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1752       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1753      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1754      env->err=2;      env->err= 2;
1755      return;      return;
1756    }    }
1757    
1758    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1759    toss(env);    toss(env);
1760    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
1761    toss(env);    toss(env);
1762    
1763    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1764                                     length */                                     length */
1765    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1766                                     timer ticks */                                     timer ticks */
1767    
1768  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1769    
1770    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1771    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1772    case 0:    case 0:
1773      usleep(dur);      usleep(dur);
1774      return;      return;
1775    case -1:    case -1:
1776      perror("beep");      perror("beep");
1777      env->err=5;      env->err= 5;
1778      return;      return;
1779    default:    default:
1780      abort();      abort();
1781    }    }
1782  };  }
1783    #endif /* __linux__ */
1784    
1785  /* "wait" */  /* "wait" */
1786  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1787    {
1788    int dur;    int dur;
1789    
1790    if((env->head)==NULL) {    if(env->head==NULL) {
1791      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1792      env->err=1;      env->err= 1;
1793      return;      return;
1794    }    }
1795    
1796    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1797      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1798      env->err=2;      env->err= 2;
1799      return;      return;
1800    }    }
1801    
1802    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1803    toss(env);    toss(env);
1804    
1805    usleep(dur);    usleep(dur);
1806  };  }
1807    
1808  extern void copying(environment *env){  extern void copying(environment *env)
1809    {
1810    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1811                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1812  \n\  \n\
# Line 1922  of preserving the free status of all der Line 2065  of preserving the free status of all der
2065  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
2066  }  }
2067    
2068  extern void warranty(environment *env){  extern void warranty(environment *env)
2069    {
2070    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
2071  \n\  \n\
2072    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 2096  extern void sx_2a(environment *env)
2096    int a, b;    int a, b;
2097    float fa, fb;    float fa, fb;
2098    
2099    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2100      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2101      env->err=1;      env->err= 1;
2102      return;      return;
2103    }    }
2104        
2105    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2106       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2107      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2108      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2109      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2110      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2111      push_int(env, b*a);      push_int(env, b*a);
2112    
2113      return;      return;
2114    }    }
2115    
2116    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2117       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2118      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2119      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2120      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2121      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2122      push_float(env, fb*fa);      push_float(env, fb*fa);
2123            
2124      return;      return;
2125    }    }
2126    
2127    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2128       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2129      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2130      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2131      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2132      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2133      push_float(env, b*fa);      push_float(env, b*fa);
2134            
2135      return;      return;
2136    }    }
2137    
2138    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2139       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2140      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2141      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2142      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2143      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2144      push_float(env, fb*a);      push_float(env, fb*a);
2145    
# Line 2003  extern void sx_2a(environment *env) Line 2147  extern void sx_2a(environment *env)
2147    }    }
2148    
2149    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2150    env->err=2;    env->err= 2;
2151  }  }
2152    
2153  /* "/" */  /* "/" */
# Line 2012  extern void sx_2f(environment *env) Line 2156  extern void sx_2f(environment *env)
2156    int a, b;    int a, b;
2157    float fa, fb;    float fa, fb;
2158    
2159    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2160      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2161      env->err=1;      env->err= 1;
2162      return;      return;
2163    }    }
2164        
2165    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2166       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2167      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2168      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2169      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2170      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2171      push_float(env, b/a);      push_float(env, b/a);
2172    
2173      return;      return;
2174    }    }
2175    
2176    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2177       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2178      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2179      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2180      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2181      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2182      push_float(env, fb/fa);      push_float(env, fb/fa);
2183            
2184      return;      return;
2185    }    }
2186    
2187    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2188       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2189      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2190      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2191      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2192      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2193      push_float(env, b/fa);      push_float(env, b/fa);
2194            
2195      return;      return;
2196    }    }
2197    
2198    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2199       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2200      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2201      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2202      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2203      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2204      push_float(env, fb/a);      push_float(env, fb/a);
2205    
# Line 2063  extern void sx_2f(environment *env) Line 2207  extern void sx_2f(environment *env)
2207    }    }
2208    
2209    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2210    env->err=2;    env->err= 2;
2211  }  }
2212    
2213  /* "mod" */  /* "mod" */
# Line 2071  extern void mod(environment *env) Line 2215  extern void mod(environment *env)
2215  {  {
2216    int a, b;    int a, b;
2217    
2218    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2219      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2220      env->err= 1;      env->err= 1;
2221      return;      return;
2222    }    }
2223        
2224    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2225       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2226      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2227      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2228      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2229      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2230      push_int(env, b%a);      push_int(env, b%a);
2231    
# Line 2089  extern void mod(environment *env) Line 2233  extern void mod(environment *env)
2233    }    }
2234    
2235    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2236    env->err=2;    env->err= 2;
2237  }  }
2238    
2239  /* "div" */  /* "div" */
# Line 2097  extern void sx_646976(environment *env) Line 2241  extern void sx_646976(environment *env)
2241  {  {
2242    int a, b;    int a, b;
2243        
2244    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2245      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2246      env->err= 1;      env->err= 1;
2247      return;      return;
2248    }    }
2249    
2250    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2251       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2252      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2253      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2254      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2255      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2256      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2257    
Legend:
Removed from v.1.94  
changed lines
  Added in v.1.110
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26