/[cvs]/stack/stack.c
ViewVC logotype

Diff of /stack/stack.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.98 by masse, Sun Mar 10 09:13:36 2002 UTC revision 1.117 by teddy, Wed Mar 20 05:29:29 2002 UTC
# Line 1  Line 1 
1    /* -*- coding: utf-8; -*- */
2  /*  /*
3      stack - an interactive interpreter for a stack-based language      stack - an interactive interpreter for a stack-based language
4      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
# Line 20  Line 21 
21               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
22  */  */
23    
24    #define CAR(X) ((X)->content.c->car)
25    #define CDR(X) ((X)->content.c->cdr)
26    
27  /* printf, sscanf, fgets, fprintf, fopen, perror */  /* printf, sscanf, fgets, fprintf, fopen, perror */
28  #include <stdio.h>  #include <stdio.h>
29  /* exit, EXIT_SUCCESS, malloc, free */  /* exit, EXIT_SUCCESS, malloc, free */
# Line 34  Line 38 
38  #include <unistd.h>  #include <unistd.h>
39  /* EX_NOINPUT, EX_USAGE */  /* EX_NOINPUT, EX_USAGE */
40  #include <sysexits.h>  #include <sysexits.h>
41    /* assert */
42    #include <assert.h>
43    
44    #ifdef __linux__
45  /* mtrace, muntrace */  /* mtrace, muntrace */
46  #include <mcheck.h>  #include <mcheck.h>
47  /* ioctl */  /* ioctl */
48  #include <sys/ioctl.h>  #include <sys/ioctl.h>
49  /* KDMKTONE */  /* KDMKTONE */
50  #include <linux/kd.h>  #include <linux/kd.h>
51    #endif /* __linux__ */
52    
53  #include "stack.h"  #include "stack.h"
54    
# Line 48  void init_env(environment *env) Line 57  void init_env(environment *env)
57  {  {
58    int i;    int i;
59    
60    env->gc_limit= 200;    env->gc_limit= 400000;
61    env->gc_count= 0;    env->gc_count= 0;
62    env->gc_ref= NULL;    env->gc_ref= NULL;
63    
64    env->head= NULL;    env->head= new_val(env);
65    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
66      env->symbols[i]= NULL;      env->symbols[i]= NULL;
67    env->err= 0;    env->err= 0;
# Line 70  void printerr(const char* in_string) Line 79  void printerr(const char* in_string)
79  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
80  extern void toss(environment *env)  extern void toss(environment *env)
81  {  {
82    stackitem *temp= env->head;    if(env->head->type==empty) {
   
   if((env->head)==NULL) {  
83      printerr("Too Few Arguments");      printerr("Too Few Arguments");
84      env->err= 1;      env->err= 1;
85      return;      return;
86    }    }
87        
88    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 */  
   
   env->gc_limit--;  
89  }  }
90    
91  /* 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 120  value* new_val(environment *env) Line 124  value* new_val(environment *env)
124    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
125    
126    nval->content.ptr= NULL;    nval->content.ptr= NULL;
127      nval->type= empty;
128    
129    nitem->item= nval;    nitem->item= nval;
130    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
131    
132    env->gc_ref= nitem;    env->gc_ref= nitem;
133    
134    env->gc_count++;    env->gc_count += sizeof(value);
135    nval->gc_garb= 1;    nval->gc.flag.mark= 0;
136      nval->gc.flag.protect= 0;
137    
138    return nval;    return nval;
139  }  }
# Line 135  value* new_val(environment *env) Line 142  value* new_val(environment *env)
142     Marked values are not collected by the GC. */     Marked values are not collected by the GC. */
143  inline void gc_mark(value *val)  inline void gc_mark(value *val)
144  {  {
145    stackitem *iterator;    if(val==NULL || val->gc.flag.mark)
   
   if(val->gc_garb==0)  
146      return;      return;
147    
148    val->gc_garb= 0;    val->gc.flag.mark= 1;
149    
150    if(val->type==list) {    if(val->type==tcons) {
151      iterator= val->content.ptr;      gc_mark(CAR(val));
152        gc_mark(CDR(val));
     while(iterator!=NULL) {  
       gc_mark(iterator->item);  
       iterator= iterator->next;  
     }  
153    }    }
154  }  }
155    
# Line 163  inline void gc_maybe(environment *env) Line 164  inline void gc_maybe(environment *env)
164  /* Start GC */  /* Start GC */
165  extern void gc_init(environment *env)  extern void gc_init(environment *env)
166  {  {
167    stackitem *new_head= NULL, *titem, *iterator;    stackitem *new_head= NULL, *titem;
168    symbol *tsymb;    symbol *tsymb;
169    int i;    int i;
170    
171      if(env->interactive)
172        printf("Garbage collecting.");
173    
174    /* Mark values on stack */    /* Mark values on stack */
175    iterator= env->head;    gc_mark(env->head);
176    while(iterator!=NULL) {  
177      gc_mark(iterator->item);    if(env->interactive)
178      iterator= iterator->next;      printf(".");
179    }  
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)
     while(tsymb!=NULL) {  
184        if (tsymb->val != 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    while(env->gc_ref!=NULL) {    /* Sweep unused values */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
194    
195      if(env->gc_ref->item->gc_garb      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
        && !(env->gc_ref->item->gc_protect)) {  
196    
197        switch(env->gc_ref->item->type) { /* Remove content */        /* Remove content */
198          switch(env->gc_ref->item->type){
199        case string:        case string:
200          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
201          break;          break;
202        case list:        case tcons:
203          while(env->gc_ref->item->content.ptr!=NULL) {          free(env->gc_ref->item->content.c);
204            titem= env->gc_ref->item->content.ptr;          break;
205            env->gc_ref->item->content.ptr= titem->next;        case empty:
206            free(titem);        case integer:
207          }        case tfloat:
208        default:        case func:
209          case symb:
210            /* Symbol strings are freed when walking the hash table */
211        }        }
212    
213        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
214        titem= env->gc_ref->next;        titem= env->gc_ref->next;
215        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
216        env->gc_ref= titem;        env->gc_ref= titem;
217        continue;        continue;
218      }      }
219    #ifdef DEBUG
220        printf("Kept value (%p)", env->gc_ref->item);
221        if(env->gc_ref->item->gc.flag.mark)
222          printf(" (marked)");
223        if(env->gc_ref->item->gc.flag.protect)
224          printf(" (protected)");
225        switch(env->gc_ref->item->type){
226        case integer:
227          printf(" integer: %d", env->gc_ref->item->content.i);
228          break;
229        case func:
230          printf(" func: %p", env->gc_ref->item->content.ptr);
231          break;
232        case symb:
233          printf(" symb: %s", env->gc_ref->item->content.sym->id);
234          break;
235        case tcons:
236          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
237                 env->gc_ref->item->content.c->cdr);
238          break;
239        default:
240          printf(" <unknown %d>", (env->gc_ref->item->type));
241        }
242        printf("\n");
243    #endif /* DEBUG */
244    
245        /* Keep values */    
246        env->gc_count += sizeof(value);
247        if(env->gc_ref->item->type==string)
248          env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
249            
     /* Keep values */  
250      titem= env->gc_ref->next;      titem= env->gc_ref->next;
251      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
252      new_head= env->gc_ref;      new_head= env->gc_ref;
253      new_head->item->gc_garb= 1;      new_head->item->gc.flag.mark= 0;
254      env->gc_ref= titem;      env->gc_ref= titem;
     env->gc_count++;  
255    }    }
256    
257    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
258        env->gc_limit= env->gc_count*2;
259    
260    env->gc_ref= new_head;    env->gc_ref= new_head;
261    
262      if(env->interactive)
263        printf("done (%d bytes still allocated)\n", env->gc_count);
264    
265  }  }
266    
267  /* Protect values from GC */  /* Protect values from GC */
268  void protect(value *val)  void protect(value *val)
269  {  {
270    stackitem *iterator;    if(val==NULL || val->gc.flag.protect)
   
   if(val->gc_protect)  
271      return;      return;
272    
273    val->gc_protect= 1;    val->gc.flag.protect= 1;
274    
275    if(val->type==list) {    if(val->type==tcons) {
276      iterator= val->content.ptr;      protect(CAR(val));
277        protect(CDR(val));
     while(iterator!=NULL) {  
       protect(iterator->item);  
       iterator= iterator->next;  
     }  
278    }    }
279  }  }
280    
281  /* Unprotect values from GC */  /* Unprotect values from GC */
282  void unprotect(value *val)  void unprotect(value *val)
283  {  {
284    stackitem *iterator;    if(val==NULL || !(val->gc.flag.protect))
   
   if(!(val->gc_protect))  
285      return;      return;
286    
287    val->gc_protect= 0;    val->gc.flag.protect= 0;
   
   if(val->type==list) {  
     iterator= val->content.ptr;  
288    
289      while(iterator!=NULL) {    if(val->type==tcons) {
290        unprotect(iterator->item);      unprotect(CAR(val));
291        iterator= iterator->next;      unprotect(CDR(val));
     }  
292    }    }
293  }  }
294    
295  /* Push a value onto the stack */  /* Push a value onto the stack */
296  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
297  {  {
298    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
299    new_item->item= val;  
300    new_item->next= env->head;    new_value->content.c= malloc(sizeof(pair));
301    env->head= new_item;    assert(new_value->content.c!=NULL);
302      env->gc_count += sizeof(pair);
303      new_value->type= tcons;
304      CAR(new_value)= val;
305      CDR(new_value)= env->head;
306      env->head= new_value;
307  }  }
308    
309  /* Push an integer onto the stack */  /* Push an integer onto the stack */
# Line 298  void push_float(environment *env, float Line 332  void push_float(environment *env, float
332  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
333  {  {
334    value *new_value= new_val(env);    value *new_value= new_val(env);
335      int length= strlen(in_string)+1;
336    
337    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
338      env->gc_count += length;
339    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
340    new_value->type= string;    new_value->type= string;
341    
# Line 330  extern void mangle(environment *env) Line 366  extern void mangle(environment *env)
366  {  {
367    char *new_string;    char *new_string;
368    
369    if((env->head)==NULL) {    if(env->head->type==empty) {
370      printerr("Too Few Arguments");      printerr("Too Few Arguments");
371      env->err= 1;      env->err= 1;
372      return;      return;
373    }    }
374    
375    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
376      printerr("Bad Argument Type");      printerr("Bad Argument Type");
377      env->err= 2;      env->err= 2;
378      return;      return;
379    }    }
380    
381    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
382        mangle_str((const char *)(CAR(env->head)->content.ptr));
383    
384    toss(env);    toss(env);
385    if(env->err) return;    if(env->err) return;
# Line 426  extern void nl() Line 463  extern void nl()
463  /* Gets the type of a value */  /* Gets the type of a value */
464  extern void type(environment *env)  extern void type(environment *env)
465  {  {
466    int typenum;    if(env->head->type==empty) {
   
   if((env->head)==NULL) {  
467      printerr("Too Few Arguments");      printerr("Too Few Arguments");
468      env->err=1;      env->err= 1;
469      return;      return;
470    }    }
471    typenum=env->head->item->type;  
472    toss(env);    switch(CAR(env->head)->type){
473    switch(typenum){    case empty:
474        push_sym(env, "empty");
475        break;
476    case integer:    case integer:
477      push_sym(env, "integer");      push_sym(env, "integer");
478      break;      break;
# Line 451  extern void type(environment *env) Line 488  extern void type(environment *env)
488    case func:    case func:
489      push_sym(env, "function");      push_sym(env, "function");
490      break;      break;
491    case list:    case tcons:
492      push_sym(env, "list");      push_sym(env, "pair");
493      break;      break;
494    }    }
495      swap(env);
496      if (env->err) return;
497      toss(env);
498  }      }    
499    
500  /* Prints the top element of the stack. */  /* Print a value */
501  void print_h(stackitem *stack_head, int noquote)  void print_val(value *val, int noquote, stackitem *stack)
502  {  {
503    switch(stack_head->item->type) {    stackitem *titem, *tstack;
504      int depth;
505    
506      switch(val->type) {
507      case empty:
508        printf("[]");
509        break;
510    case integer:    case integer:
511      printf("%d", stack_head->item->content.i);      printf("%d", val->content.i);
512      break;      break;
513    case tfloat:    case tfloat:
514      printf("%f", stack_head->item->content.f);      printf("%f", val->content.f);
515      break;      break;
516    case string:    case string:
517      if(noquote)      if(noquote)
518        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)(val->content.ptr));
519      else      else
520        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)(val->content.ptr));
521      break;      break;
522    case symb:    case symb:
523      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", val->content.sym->id);
524      break;      break;
525    case func:    case func:
526      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(val->content.ptr));
527      break;      break;
528    case list:    case tcons:
     /* A list is just a stack, so make stack_head point to it */  
     stack_head=(stackitem *)(stack_head->item->content.ptr);  
529      printf("[ ");      printf("[ ");
530      while(stack_head != NULL) {      tstack= stack;
531        print_h(stack_head, noquote);      do {
532        printf(" ");        titem=malloc(sizeof(stackitem));
533        stack_head=stack_head->next;        titem->item=val;
534          titem->next=tstack;
535          tstack=titem;             /* Put it on the stack */
536          /* Search a stack of values being printed to see if we are already
537             printing this value */
538          titem=tstack;
539          depth=0;
540          while(titem != NULL && titem->item != CAR(val)){
541            titem=titem->next;
542            depth++;
543          }
544          if(titem != NULL){        /* If we found it on the stack, */
545            printf("#%d#", depth);  /* print a depth reference */
546          } else {
547            print_val(CAR(val), noquote, tstack);
548          }
549          val= CDR(val);
550          switch(val->type){
551          case empty:
552            break;
553          case tcons:
554            /* Search a stack of values being printed to see if we are already
555               printing this value */
556            titem=tstack;
557            depth=0;
558            while(titem != NULL && titem->item != val){
559              titem=titem->next;
560              depth++;
561            }
562            if(titem != NULL){      /* If we found it on the stack, */
563              printf(" . #%d#", depth); /* print a depth reference */
564            } else {
565              printf(" ");
566            }
567            break;
568          default:
569            printf(" . ");          /* Improper list */
570            print_val(val, noquote, tstack);
571          }
572        } while(val->type == tcons && titem == NULL);
573        titem=tstack;
574        while(titem != stack){
575          tstack=titem->next;
576          free(titem);
577          titem=tstack;
578      }      }
579      printf("]");      printf(" ]");
580      break;      break;
581    }    }
582  }  }
583    
584  extern void print_(environment *env)  extern void print_(environment *env)
585  {  {
586    if(env->head==NULL) {    if(env->head->type==empty) {
587      printerr("Too Few Arguments");      printerr("Too Few Arguments");
588      env->err=1;      env->err= 1;
589      return;      return;
590    }    }
591    print_h(env->head, 0);    print_val(CAR(env->head), 0, NULL);
592    nl();    nl();
593  }  }
594    
# Line 514  extern void print(environment *env) Line 602  extern void print(environment *env)
602    
603  extern void princ_(environment *env)  extern void princ_(environment *env)
604  {  {
605    if(env->head==NULL) {    if(env->head->type==empty) {
606      printerr("Too Few Arguments");      printerr("Too Few Arguments");
607      env->err=1;      env->err= 1;
608      return;      return;
609    }    }
610    print_h(env->head, 1);    print_val(CAR(env->head), 1, NULL);
611  }  }
612    
613  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack and then discards it. */
# Line 531  extern void princ(environment *env) Line 619  extern void princ(environment *env)
619  }  }
620    
621  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
622  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
623  {  {
624    if(stack_head->next != NULL)    if(CDR(stack_head)->type != empty)
625      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
626    printf("%ld: ", counter);    printf("%ld: ", counter);
627    print_h(stack_head, 0);    print_val(CAR(stack_head), 0, NULL);
628    nl();    nl();
629  }  }
630    
631  /* Prints the stack. */  /* Prints the stack. */
632  extern void printstack(environment *env)  extern void printstack(environment *env)
633  {  {
634    if(env->head == NULL) {    if(env->head->type == empty) {
635      printf("Stack Empty\n");      printf("Stack Empty\n");
636      return;      return;
637    }    }
# Line 554  extern void printstack(environment *env) Line 642  extern void printstack(environment *env)
642  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
643  extern void swap(environment *env)  extern void swap(environment *env)
644  {  {
645    stackitem *temp= env->head;    value *temp= env->head;
646        
647    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
648      printerr("Too Few Arguments");      printerr("Too Few Arguments");
649      env->err=1;      env->err=1;
650      return;      return;
651    }    }
652    
653    env->head= env->head->next;    env->head= CDR(env->head);
654    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
655    env->head->next= temp;    CDR(env->head)= temp;
656  }  }
657    
658  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
659  extern void rot(environment *env)  extern void rot(environment *env)
660  {  {
661    stackitem *temp= env->head;    value *temp= env->head;
662        
663    if(env->head==NULL || env->head->next==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
664        || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type == empty) {
665      printerr("Too Few Arguments");      printerr("Too Few Arguments");
666      env->err=1;      env->err= 1;
667      return;      return;
668    }    }
669      
670    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
671    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
672    env->head->next= temp;    CDR(env->head)= temp;
673  }  }
674    
675  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 589  extern void rcl(environment *env) Line 677  extern void rcl(environment *env)
677  {  {
678    value *val;    value *val;
679    
680    if(env->head == NULL) {    if(env->head->type==empty) {
681      printerr("Too Few Arguments");      printerr("Too Few Arguments");
682      env->err=1;      env->err= 1;
683      return;      return;
684    }    }
685    
686    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
687      printerr("Bad Argument Type");      printerr("Bad Argument Type");
688      env->err=2;      env->err= 2;
689      return;      return;
690    }    }
691    
692    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
693    if(val == NULL){    if(val == NULL){
694      printerr("Unbound Variable");      printerr("Unbound Variable");
695      env->err=3;      env->err= 3;
696      return;      return;
697    }    }
698    protect(val);    push_val(env, val);           /* Return the symbol's bound value */
699    toss(env);            /* toss the symbol */    swap(env);
700      if(env->err) return;
701      toss(env);                    /* toss the symbol */
702    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(val);  
703  }  }
704    
705  /* 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 621  extern void eval(environment *env) Line 709  extern void eval(environment *env)
709  {  {
710    funcp in_func;    funcp in_func;
711    value* temp_val;    value* temp_val;
712    stackitem* iterator;    value* iterator;
713    
714   eval_start:   eval_start:
715    
716    gc_maybe(env);    gc_maybe(env);
717    
718    if(env->head==NULL) {    if(env->head->type==empty) {
719      printerr("Too Few Arguments");      printerr("Too Few Arguments");
720      env->err=1;      env->err= 1;
721      return;      return;
722    }    }
723    
724    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
725      /* if it's a symbol */      /* if it's a symbol */
726    case symb:    case symb:
727      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
728      if(env->err) return;      if(env->err) return;
729      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
730        goto eval_start;        goto eval_start;
731      }      }
732      return;      return;
733    
734      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
735    case func:    case func:
736      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
737      toss(env);      toss(env);
738      if(env->err) return;      if(env->err) return;
739      return in_func(env);      return in_func(env);
740    
741      /* If it's a list */      /* If it's a list */
742    case list:    case tcons:
743      temp_val= env->head->item;      temp_val= CAR(env->head);
744      protect(temp_val);      protect(temp_val);
745    
746      toss(env); if(env->err) return;      toss(env); if(env->err) return;
747      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
748            
749      while(iterator!=NULL) {      while(iterator->type != empty) {
750        push_val(env, iterator->item);        push_val(env, CAR(iterator));
751                
752        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
753          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
754          toss(env);          toss(env);
755          if(env->err) return;          if(env->err) return;
756                    
757          if(iterator->next == NULL){          if(CDR(iterator)->type == empty){
758            goto eval_start;            goto eval_start;
759          }          }
760          eval(env);          eval(env);
761          if(env->err) return;          if(env->err) return;
762        }        }
763        iterator= iterator->next;        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
764            iterator= CDR(iterator);
765          else {
766            printerr("Bad Argument Type"); /* Improper list */
767            env->err= 2;
768            return;
769          }
770      }      }
771      unprotect(temp_val);      unprotect(temp_val);
772      return;      return;
773    
774    default:    case empty:
775      case integer:
776      case tfloat:
777      case string:
778      return;      return;
779    }    }
780  }  }
# Line 685  extern void eval(environment *env) Line 782  extern void eval(environment *env)
782  /* Reverse (flip) a list */  /* Reverse (flip) a list */
783  extern void rev(environment *env)  extern void rev(environment *env)
784  {  {
785    stackitem *old_head, *new_head, *item;    value *old_head, *new_head, *item;
786    
787    if((env->head)==NULL) {    if(env->head->type==empty) {
788      printerr("Too Few Arguments");      printerr("Too Few Arguments");
789      env->err= 1;      env->err= 1;
790      return;      return;
791    }    }
792    
793    if(env->head->item->type!=list) {    if(CAR(env->head)->type==empty)
794        return;                     /* Don't reverse an empty list */
795    
796      if(CAR(env->head)->type!=tcons) {
797      printerr("Bad Argument Type");      printerr("Bad Argument Type");
798      env->err= 2;      env->err= 2;
799      return;      return;
800    }    }
801    
802    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
803    new_head= NULL;    new_head= new_val(env);
804    while(old_head != NULL){    while(old_head->type != empty) {
805      item= old_head;      item= old_head;
806      old_head= old_head->next;      old_head= CDR(old_head);
807      item->next= new_head;      CDR(item)= new_head;
808      new_head= item;      new_head= item;
809    }    }
810    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
811  }  }
812    
813  /* Make a list. */  /* Make a list. */
814  extern void pack(environment *env)  extern void pack(environment *env)
815  {  {
816    stackitem *iterator, *temp;    value *iterator, *temp, *ending;
   value *pack;  
817    
818    iterator= env->head;    ending=new_val(env);
   pack= new_val(env);  
   protect(pack);  
819    
820    if(iterator==NULL    iterator= env->head;
821       || (iterator->item->type==symb    if(iterator->type == empty
822       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       || (CAR(iterator)->type==symb
823      temp= NULL;       && CAR(iterator)->content.sym->id[0]=='[')) {
824        temp= ending;
825      toss(env);      toss(env);
826    } else {    } else {
827      /* Search for first delimiter */      /* Search for first delimiter */
828      while(iterator->next!=NULL      while(CDR(iterator)->type != empty
829            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
830            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
831        iterator= iterator->next;        iterator= CDR(iterator);
832            
833      /* Extract list */      /* Extract list */
834      temp= env->head;      temp= env->head;
835      env->head= iterator->next;      env->head= CDR(iterator);
836      iterator->next= NULL;      CDR(iterator)= ending;
837    
838      pack->type= list;      if(env->head->type != empty)
     pack->content.ptr= temp;  
       
     if(env->head!=NULL)  
839        toss(env);        toss(env);
840    }    }
841    
842    /* Push list */    /* Push list */
843    
844    push_val(env, pack);    push_val(env, temp);
845    rev(env);    rev(env);
   
   unprotect(pack);  
846  }  }
847    
848  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
849  extern void expand(environment *env)  extern void expand(environment *env)
850  {  {
851    stackitem *temp, *new_head;    value *temp, *new_head;
852    
853    /* Is top element a list? */    /* Is top element a list? */
854    if(env->head==NULL) {    if(env->head->type==empty) {
855      printerr("Too Few Arguments");      printerr("Too Few Arguments");
856      env->err= 1;      env->err= 1;
857      return;      return;
858    }    }
859    if(env->head->item->type!=list) {  
860      if(CAR(env->head)->type!=tcons) {
861      printerr("Bad Argument Type");      printerr("Bad Argument Type");
862      env->err= 2;      env->err= 2;
863      return;      return;
# Line 775  extern void expand(environment *env) Line 869  extern void expand(environment *env)
869      return;      return;
870    
871    /* The first list element is the new stack head */    /* The first list element is the new stack head */
872    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
873    
874    toss(env);    toss(env);
875    
876    /* Find the end of the list */    /* Find the end of the list */
877    while(temp->next!=NULL)    while(CDR(temp)->type != empty) {
878      temp= temp->next;      if (CDR(temp)->type == tcons)
879          temp= CDR(temp);
880        else {
881          printerr("Bad Argument Type"); /* Improper list */
882          env->err= 2;
883          return;
884        }
885      }
886    
887    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
888    temp->next= env->head;    CDR(temp)= env->head;
889    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
890    
891  }  }
# Line 793  extern void expand(environment *env) Line 894  extern void expand(environment *env)
894  extern void eq(environment *env)  extern void eq(environment *env)
895  {  {
896    void *left, *right;    void *left, *right;
   int result;  
897    
898    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
899      printerr("Too Few Arguments");      printerr("Too Few Arguments");
900      env->err= 1;      env->err= 1;
901      return;      return;
902    }    }
903    
904    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
905    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
906    toss(env); toss(env);    toss(env); toss(env);
907    push_int(env, result);  
908      push_int(env, left==right);
909  }  }
910    
911  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 815  extern void not(environment *env) Line 913  extern void not(environment *env)
913  {  {
914    int val;    int val;
915    
916    if((env->head)==NULL) {    if(env->head->type==empty) {
917      printerr("Too Few Arguments");      printerr("Too Few Arguments");
918      env->err= 1;      env->err= 1;
919      return;      return;
920    }    }
921    
922    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
923      printerr("Bad Argument Type");      printerr("Bad Argument Type");
924      env->err= 2;      env->err= 2;
925      return;      return;
926    }    }
927    
928    val= env->head->item->content.i;    val= CAR(env->head)->content.i;
929    toss(env);    toss(env);
930    push_int(env, !val);    push_int(env, !val);
931  }  }
# Line 846  extern void def(environment *env) Line 944  extern void def(environment *env)
944    symbol *sym;    symbol *sym;
945    
946    /* 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 */
947    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
948      printerr("Too Few Arguments");      printerr("Too Few Arguments");
949      env->err= 1;      env->err= 1;
950      return;      return;
951    }    }
952    
953    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
954      printerr("Bad Argument Type");      printerr("Bad Argument Type");
955      env->err= 2;      env->err= 2;
956      return;      return;
957    }    }
958    
959    /* long names are a pain */    /* long names are a pain */
960    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
961    
962    /* Bind the symbol to the value */    /* Bind the symbol to the value */
963    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
964    
965    toss(env); toss(env);    toss(env); toss(env);
966  }  }
# Line 885  extern void quit(environment *env) Line 983  extern void quit(environment *env)
983    env->gc_limit= 0;    env->gc_limit= 0;
984    gc_maybe(env);    gc_maybe(env);
985    
986      words(env);
987    
988    if(env->free_string!=NULL)    if(env->free_string!=NULL)
989      free(env->free_string);      free(env->free_string);
990        
991    #ifdef __linux__
992    muntrace();    muntrace();
993    #endif
994    
995    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
996  }  }
# Line 896  extern void quit(environment *env) Line 998  extern void quit(environment *env)
998  /* Clear stack */  /* Clear stack */
999  extern void clear(environment *env)  extern void clear(environment *env)
1000  {  {
1001    while(env->head!=NULL)    while(env->head->type != empty)
1002      toss(env);      toss(env);
1003  }  }
1004    
# Line 909  extern void words(environment *env) Line 1011  extern void words(environment *env)
1011    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
1012      temp= env->symbols[i];      temp= env->symbols[i];
1013      while(temp!=NULL) {      while(temp!=NULL) {
1014    #ifdef DEBUG
1015          if (temp->val != NULL && temp->val->gc.flag.protect)
1016            printf("(protected) ");
1017    #endif /* DEBUG */
1018        printf("%s\n", temp->id);        printf("%s\n", temp->id);
1019        temp= temp->next;        temp= temp->next;
1020      }      }
# Line 931  void forget_sym(symbol **hash_entry) Line 1037  void forget_sym(symbol **hash_entry)
1037  extern void forget(environment *env)  extern void forget(environment *env)
1038  {  {
1039    char* sym_id;    char* sym_id;
   stackitem *stack_head= env->head;  
1040    
1041    if(stack_head==NULL) {    if(env->head->type==empty) {
1042      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1043      env->err=1;      env->err= 1;
1044      return;      return;
1045    }    }
1046        
1047    if(stack_head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
1048      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1049      env->err=2;      env->err= 2;
1050      return;      return;
1051    }    }
1052    
1053    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(env->head)->content.sym->id;
1054    toss(env);    toss(env);
1055    
1056    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 963  int main(int argc, char **argv) Line 1068  int main(int argc, char **argv)
1068    
1069    int c;                        /* getopt option character */    int c;                        /* getopt option character */
1070    
1071    #ifdef __linux__
1072    mtrace();    mtrace();
1073    #endif
1074    
1075    init_env(&myenv);    init_env(&myenv);
1076    
# Line 977  int main(int argc, char **argv) Line 1084  int main(int argc, char **argv)
1084          break;          break;
1085        case '?':        case '?':
1086          fprintf (stderr,          fprintf (stderr,
1087                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1088                   optopt);                   optopt);
1089          return EX_USAGE;          return EX_USAGE;
1090        default:        default:
# Line 996  int main(int argc, char **argv) Line 1103  int main(int argc, char **argv)
1103    if(myenv.interactive) {    if(myenv.interactive) {
1104      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1105  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1106  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1107  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1108  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1109    }    }
1110    
1111    while(1) {    while(1) {
# Line 1013  under certain conditions; type `copying; Line 1120  under certain conditions; type `copying;
1120        }        }
1121        myenv.err=0;        myenv.err=0;
1122      }      }
1123      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1124      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1125        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1126      } else if(myenv.head!=NULL        quit(&myenv);
1127                && myenv.head->item->type==symb      } else if(myenv.head->type!=empty
1128                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->type==symb
1129                  && CAR(myenv.head)->content.sym->id[0]
1130                  ==';') {
1131        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1132        eval(&myenv);        eval(&myenv);
1133      }      }
# Line 1037  extern void sx_2b(environment *env) Line 1146  extern void sx_2b(environment *env)
1146    char* new_string;    char* new_string;
1147    value *a_val, *b_val;    value *a_val, *b_val;
1148    
1149    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1150      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1151      env->err= 1;      env->err= 1;
1152      return;      return;
1153    }    }
1154    
1155    if(env->head->item->type==string    if(CAR(env->head)->type==string
1156       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1157      a_val= env->head->item;      a_val= CAR(env->head);
1158      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1159      protect(a_val); protect(b_val);      protect(a_val); protect(b_val);
1160      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1161      toss(env); if(env->err) return;      toss(env); if(env->err) return;
# Line 1061  extern void sx_2b(environment *env) Line 1170  extern void sx_2b(environment *env)
1170      return;      return;
1171    }    }
1172        
1173    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1174       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1175      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1176      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1177      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1178      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1179      push_int(env, b+a);      push_int(env, b+a);
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==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
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      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1189      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1190      push_float(env, fb+fa);      push_float(env, fb+fa);
1191            
1192      return;      return;
1193    }    }
1194    
1195    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1196       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1197      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1198      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1199      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1200      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1201      push_float(env, b+fa);      push_float(env, b+fa);
1202            
1203      return;      return;
1204    }    }
1205    
1206    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1207       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1208      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1209      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1210      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1211      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1212      push_float(env, fb+a);      push_float(env, fb+a);
1213    
# Line 1115  extern void sx_2d(environment *env) Line 1224  extern void sx_2d(environment *env)
1224    int a, b;    int a, b;
1225    float fa, fb;    float fa, fb;
1226    
1227    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1228      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1229      env->err=1;      env->err=1;
1230      return;      return;
1231    }    }
1232        
1233    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1234       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1235      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1236      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1237      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1238      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1239      push_int(env, b-a);      push_int(env, b-a);
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==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
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      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1249      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1250      push_float(env, fb-fa);      push_float(env, fb-fa);
1251            
1252      return;      return;
1253    }    }
1254    
1255    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1256       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1257      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1258      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1259      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1260      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1261      push_float(env, b-fa);      push_float(env, b-fa);
1262            
1263      return;      return;
1264    }    }
1265    
1266    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1267       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1268      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1269      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1270      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1271      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1272      push_float(env, fb-a);      push_float(env, fb-a);
1273    
# Line 1175  extern void sx_3e(environment *env) Line 1284  extern void sx_3e(environment *env)
1284    int a, b;    int a, b;
1285    float fa, fb;    float fa, fb;
1286    
1287    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1288      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1289      env->err=1;      env->err= 1;
1290      return;      return;
1291    }    }
1292        
1293    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1294       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1295      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1296      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1297      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1298      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1299      push_int(env, b>a);      push_int(env, b>a);
1300    
1301      return;      return;
1302    }    }
1303    
1304    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1305       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1306      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1307      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1308      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1309      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1310      push_int(env, fb>fa);      push_int(env, fb>fa);
1311            
1312      return;      return;
1313    }    }
1314    
1315    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1316       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1317      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1318      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1319      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1320      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1321      push_int(env, b>fa);      push_int(env, b>fa);
1322            
1323      return;      return;
1324    }    }
1325    
1326    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1327       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1328      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1329      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1330      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1331      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1332      push_int(env, fb>a);      push_int(env, fb>a);
1333    
# Line 1226  extern void sx_3e(environment *env) Line 1335  extern void sx_3e(environment *env)
1335    }    }
1336    
1337    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1338    env->err=2;    env->err= 2;
1339  }  }
1340    
1341  /* "<" */  /* "<" */
# Line 1253  extern void sx_3e3d(environment *env) Line 1362  extern void sx_3e3d(environment *env)
1362  /* Return copy of a value */  /* Return copy of a value */
1363  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
1364  {  {
   stackitem *old_item, *new_item, *prev_item;  
1365    value *new_value;    value *new_value;
1366    
1367      if(old_value==NULL)
1368        return NULL;
1369    
1370    protect(old_value);    protect(old_value);
1371    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
1372    new_value->type= old_value->type;    new_value->type= old_value->type;
1373    
1374    switch(old_value->type){    switch(old_value->type){
# Line 1266  value *copy_val(environment *env, value Line 1376  value *copy_val(environment *env, value
1376    case integer:    case integer:
1377    case func:    case func:
1378    case symb:    case symb:
1379      case empty:
1380      new_value->content= old_value->content;      new_value->content= old_value->content;
1381      break;      break;
1382    case string:    case string:
1383      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1384        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1385      break;      break;
1386    case list:    case tcons:
     new_value->content.ptr= NULL;  
1387    
1388      prev_item= NULL;      new_value->content.c= malloc(sizeof(pair));
1389      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
1390        env->gc_count += sizeof(pair);
1391    
1392      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1393        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;  
     }      
1394      break;      break;
1395    }    }
1396    
1397    unprotect(old_value); unprotect(new_value);    unprotect(old_value);
1398    
1399    return new_value;    return new_value;
1400  }  }
# Line 1301  value *copy_val(environment *env, value Line 1402  value *copy_val(environment *env, value
1402  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1403  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1404  {  {
1405    if((env->head)==NULL) {    if(env->head->type==empty) {
1406      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1407      env->err= 1;      env->err= 1;
1408      return;      return;
1409    }    }
1410    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1411  }  }
1412    
1413  /* "if", If-Then */  /* "if", If-Then */
# Line 1314  extern void sx_6966(environment *env) Line 1415  extern void sx_6966(environment *env)
1415  {  {
1416    int truth;    int truth;
1417    
1418    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1419      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1420      env->err= 1;      env->err= 1;
1421      return;      return;
1422    }    }
1423    
1424    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1425      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1426      env->err=2;      env->err= 2;
1427      return;      return;
1428    }    }
1429        
1430    swap(env);    swap(env);
1431    if(env->err) return;    if(env->err) return;
1432        
1433    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1434    
1435    toss(env);    toss(env);
1436    if(env->err) return;    if(env->err) return;
# Line 1345  extern void ifelse(environment *env) Line 1446  extern void ifelse(environment *env)
1446  {  {
1447    int truth;    int truth;
1448    
1449    if((env->head)==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1450       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1451      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1452      env->err=1;      env->err= 1;
1453      return;      return;
1454    }    }
1455    
1456    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1457      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1458      env->err=2;      env->err= 2;
1459      return;      return;
1460    }    }
1461        
1462    rot(env);    rot(env);
1463    if(env->err) return;    if(env->err) return;
1464        
1465    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1466    
1467    toss(env);    toss(env);
1468    if(env->err) return;    if(env->err) return;
# Line 1376  extern void ifelse(environment *env) Line 1477  extern void ifelse(environment *env)
1477    eval(env);    eval(env);
1478  }  }
1479    
1480    extern void sx_656c7365(environment *env)
1481    {
1482      if(env->head->type==empty || CDR(env->head)->type==empty
1483         || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1484         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1485        printerr("Too Few Arguments");
1486        env->err= 1;
1487        return;
1488      }
1489    
1490      if(CAR(CDR(env->head))->type!=symb
1491         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1492         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1493         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1494        printerr("Bad Argument Type");
1495        env->err= 2;
1496        return;
1497      }
1498    
1499      swap(env); toss(env); rot(env); toss(env);
1500      ifelse(env);
1501    }
1502    
1503    extern void then(environment *env)
1504    {
1505      if(env->head->type==empty || CDR(env->head)->type==empty
1506         || CDR(CDR(env->head))->type==empty) {
1507        printerr("Too Few Arguments");
1508        env->err= 1;
1509        return;
1510      }
1511    
1512      if(CAR(CDR(env->head))->type!=symb
1513         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1514        printerr("Bad Argument Type");
1515        env->err= 2;
1516        return;
1517      }
1518    
1519      swap(env); toss(env);
1520      sx_6966(env);
1521    }
1522    
1523  /* "while" */  /* "while" */
1524  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1525  {  {
1526    int truth;    int truth;
1527    value *loop, *test;    value *loop, *test;
1528    
1529    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1530      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1531      env->err=1;      env->err= 1;
1532      return;      return;
1533    }    }
1534    
1535    loop= env->head->item;    loop= CAR(env->head);
1536    protect(loop);    protect(loop);
1537    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1538    
1539    test= env->head->item;    test= CAR(env->head);
1540    protect(test);    protect(test);
1541    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1542    
# Line 1400  extern void sx_7768696c65(environment *e Line 1544  extern void sx_7768696c65(environment *e
1544      push_val(env, test);      push_val(env, test);
1545      eval(env);      eval(env);
1546            
1547      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1548        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1549        env->err= 2;        env->err= 2;
1550        return;        return;
1551      }      }
1552            
1553      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1554      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1555            
1556      if(truth) {      if(truth) {
# Line 1428  extern void sx_666f72(environment *env) Line 1572  extern void sx_666f72(environment *env)
1572    value *loop;    value *loop;
1573    int foo1, foo2;    int foo1, foo2;
1574    
1575    if(env->head==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1576       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1577      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1578      env->err= 1;      env->err= 1;
1579      return;      return;
1580    }    }
1581    
1582    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1583       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1584      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1585      env->err= 2;      env->err= 2;
1586      return;      return;
1587    }    }
1588    
1589    loop= env->head->item;    loop= CAR(env->head);
1590    protect(loop);    protect(loop);
1591    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1592    
1593    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1594    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1595    
1596    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1597    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1598    
1599    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1474  extern void sx_666f72(environment *env) Line 1618  extern void sx_666f72(environment *env)
1618  extern void foreach(environment *env)  extern void foreach(environment *env)
1619  {    {  
1620    value *loop, *foo;    value *loop, *foo;
1621    stackitem *iterator;    value *iterator;
1622        
1623    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1624      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1625      env->err= 1;      env->err= 1;
1626      return;      return;
1627    }    }
1628    
1629    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1630      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1631      env->err= 2;      env->err= 2;
1632      return;      return;
1633    }    }
1634    
1635    loop= env->head->item;    loop= CAR(env->head);
1636    protect(loop);    protect(loop);
1637    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1638    
1639    foo= env->head->item;    foo= CAR(env->head);
1640    protect(foo);    protect(foo);
1641    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1642    
1643    iterator= foo->content.ptr;    iterator= foo;
1644    
1645    while(iterator!=NULL) {    while(iterator!=NULL) {
1646      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1647      push_val(env, loop);      push_val(env, loop);
1648      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1649      iterator= iterator->next;      if (iterator->type == tcons){
1650          iterator= CDR(iterator);
1651        } else {
1652          printerr("Bad Argument Type"); /* Improper list */
1653          env->err= 2;
1654          break;
1655        }
1656    }    }
1657    unprotect(loop); unprotect(foo);    unprotect(loop); unprotect(foo);
1658  }  }
# Line 1511  extern void foreach(environment *env) Line 1661  extern void foreach(environment *env)
1661  extern void to(environment *env)  extern void to(environment *env)
1662  {  {
1663    int ending, start, i;    int ending, start, i;
1664    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
1665    
1666    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1667      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1668      env->err=1;      env->err= 1;
1669      return;      return;
1670    }    }
1671    
1672    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1673       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1674      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1675      env->err=2;      env->err= 2;
1676      return;      return;
1677    }    }
1678    
1679    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1680    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1681    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1682    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1683    
1684    push_sym(env, "[");    push_sym(env, "[");
# Line 1543  extern void to(environment *env) Line 1692  extern void to(environment *env)
1692    }    }
1693    
1694    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(pack);  
1695    
1696    if(iterator==NULL    if(iterator->type==empty
1697       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
1698       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1699      temp= NULL;      temp= NULL;
1700      toss(env);      toss(env);
1701    } else {    } else {
1702      /* Search for first delimiter */      /* Search for first delimiter */
1703      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
1704            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
1705            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1706        iterator= iterator->next;        iterator= CDR(iterator);
1707            
1708      /* Extract list */      /* Extract list */
1709      temp= env->head;      temp= env->head;
1710      env->head= iterator->next;      env->head= CDR(iterator);
1711      iterator->next= NULL;      CDR(iterator)= NULL;
1712    
     pack->type= list;  
     pack->content.ptr= temp;  
       
1713      if(env->head!=NULL)      if(env->head!=NULL)
1714        toss(env);        toss(env);
1715    }    }
1716    
1717    /* Push list */    /* Push list */
1718      push_val(env, temp);
   push_val(env, pack);  
   
   unprotect(pack);  
1719  }  }
1720    
1721  /* Read a string */  /* Read a string */
# Line 1604  extern void sx_72656164(environment *env Line 1745  extern void sx_72656164(environment *env
1745    int count= -1;    int count= -1;
1746    float ftemp;    float ftemp;
1747    static int depth= 0;    static int depth= 0;
1748    char *match, *ctemp;    char *match;
1749    size_t inlength;    size_t inlength;
1750    
1751    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1613  extern void sx_72656164(environment *env Line 1754  extern void sx_72656164(environment *env
1754      }      }
1755      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1756    
1757      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1758        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1759        return;        return;
1760      }      }
1761            
1762      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1763      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1764      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1765      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1766    }    }
1767        
# Line 1638  extern void sx_72656164(environment *env Line 1779  extern void sx_72656164(environment *env
1779      } else {      } else {
1780        push_float(env, ftemp);        push_float(env, ftemp);
1781      }      }
1782      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1783                && readlength != -1) {
1784        push_cstring(env, "");
1785    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1786              && readlength != -1) {              && readlength != -1) {
1787      push_cstring(env, match);      push_cstring(env, match);
# Line 1669  extern void sx_72656164(environment *env Line 1813  extern void sx_72656164(environment *env
1813      return sx_72656164(env);      return sx_72656164(env);
1814  }  }
1815    
1816    #ifdef __linux__
1817  extern void beep(environment *env)  extern void beep(environment *env)
1818  {  {
1819    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1820    
1821    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1822      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1823      env->err=1;      env->err= 1;
1824      return;      return;
1825    }    }
1826    
1827    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1828       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1829      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1830      env->err=2;      env->err= 2;
1831      return;      return;
1832    }    }
1833    
1834    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1835    toss(env);    toss(env);
1836    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
1837    toss(env);    toss(env);
1838    
1839    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1840                                     length */                                     length */
1841    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1842                                     timer ticks */                                     timer ticks */
1843    
1844  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1845    
1846    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1847    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1848    case 0:    case 0:
1849      usleep(dur);      usleep(dur);
1850      return;      return;
1851    case -1:    case -1:
1852      perror("beep");      perror("beep");
1853      env->err=5;      env->err= 5;
1854      return;      return;
1855    default:    default:
1856      abort();      abort();
1857    }    }
1858  }  }
1859    #endif /* __linux__ */
1860    
1861  /* "wait" */  /* "wait" */
1862  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
1863  {  {
1864    int dur;    int dur;
1865    
1866    if((env->head)==NULL) {    if(env->head->type==empty) {
1867      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1868      env->err=1;      env->err= 1;
1869      return;      return;
1870    }    }
1871    
1872    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1873      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1874      env->err=2;      env->err= 2;
1875      return;      return;
1876    }    }
1877    
1878    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1879    toss(env);    toss(env);
1880    
1881    usleep(dur);    usleep(dur);
# Line 1737  extern void sx_77616974(environment *env Line 1883  extern void sx_77616974(environment *env
1883    
1884  extern void copying(environment *env)  extern void copying(environment *env)
1885  {  {
1886    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1887                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1888  \n\  \n\
1889   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2026  extern void sx_2a(environment *env) Line 2172  extern void sx_2a(environment *env)
2172    int a, b;    int a, b;
2173    float fa, fb;    float fa, fb;
2174    
2175    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2176      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2177      env->err=1;      env->err= 1;
2178      return;      return;
2179    }    }
2180        
2181    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2182       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2183      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2184      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2185      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2186      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2187      push_int(env, b*a);      push_int(env, b*a);
2188    
2189      return;      return;
2190    }    }
2191    
2192    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2193       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2194      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2195      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2196      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2197      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2198      push_float(env, fb*fa);      push_float(env, fb*fa);
2199            
2200      return;      return;
2201    }    }
2202    
2203    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2204       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2205      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2206      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2207      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2208      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2209      push_float(env, b*fa);      push_float(env, b*fa);
2210            
2211      return;      return;
2212    }    }
2213    
2214    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2215       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2216      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2217      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2218      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2219      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2220      push_float(env, fb*a);      push_float(env, fb*a);
2221    
# Line 2077  extern void sx_2a(environment *env) Line 2223  extern void sx_2a(environment *env)
2223    }    }
2224    
2225    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2226    env->err=2;    env->err= 2;
2227  }  }
2228    
2229  /* "/" */  /* "/" */
# Line 2086  extern void sx_2f(environment *env) Line 2232  extern void sx_2f(environment *env)
2232    int a, b;    int a, b;
2233    float fa, fb;    float fa, fb;
2234    
2235    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2236      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2237      env->err=1;      env->err= 1;
2238      return;      return;
2239    }    }
2240        
2241    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2242       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2243      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2244      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2245      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2246      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2247      push_float(env, b/a);      push_float(env, b/a);
2248    
2249      return;      return;
2250    }    }
2251    
2252    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2253       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2254      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2255      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2256      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2257      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2258      push_float(env, fb/fa);      push_float(env, fb/fa);
2259            
2260      return;      return;
2261    }    }
2262    
2263    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2264       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2265      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2266      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2267      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2268      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2269      push_float(env, b/fa);      push_float(env, b/fa);
2270            
2271      return;      return;
2272    }    }
2273    
2274    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2275       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2276      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2277      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2278      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2279      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2280      push_float(env, fb/a);      push_float(env, fb/a);
2281    
# Line 2137  extern void sx_2f(environment *env) Line 2283  extern void sx_2f(environment *env)
2283    }    }
2284    
2285    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2286    env->err=2;    env->err= 2;
2287  }  }
2288    
2289  /* "mod" */  /* "mod" */
# Line 2145  extern void mod(environment *env) Line 2291  extern void mod(environment *env)
2291  {  {
2292    int a, b;    int a, b;
2293    
2294    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2295      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2296      env->err= 1;      env->err= 1;
2297      return;      return;
2298    }    }
2299        
2300    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2301       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2302      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2303      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2304      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2305      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2306      push_int(env, b%a);      push_int(env, b%a);
2307    
# Line 2163  extern void mod(environment *env) Line 2309  extern void mod(environment *env)
2309    }    }
2310    
2311    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2312    env->err=2;    env->err= 2;
2313  }  }
2314    
2315  /* "div" */  /* "div" */
# Line 2171  extern void sx_646976(environment *env) Line 2317  extern void sx_646976(environment *env)
2317  {  {
2318    int a, b;    int a, b;
2319        
2320    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2321      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2322      env->err= 1;      env->err= 1;
2323      return;      return;
2324    }    }
2325    
2326    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2327       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2328      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2329      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2330      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2331      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2332      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2333    
# Line 2191  extern void sx_646976(environment *env) Line 2337  extern void sx_646976(environment *env)
2337    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2338    env->err= 2;    env->err= 2;
2339  }  }
2340    
2341    extern void setcar(environment *env)
2342    {
2343      if(env->head->type==empty || CDR(env->head)->type==empty) {
2344        printerr("Too Few Arguments");
2345        env->err= 1;
2346        return;
2347      }
2348    
2349      if(CDR(env->head)->type!=tcons) {
2350        printerr("Bad Argument Type");
2351        env->err= 2;
2352        return;
2353      }
2354    
2355      CAR(CAR(CDR(env->head)))=CAR(env->head);
2356      toss(env);
2357    }
2358    
2359    extern void setcdr(environment *env)
2360    {
2361      if(env->head->type==empty || CDR(env->head)->type==empty) {
2362        printerr("Too Few Arguments");
2363        env->err= 1;
2364        return;
2365      }
2366    
2367      if(CDR(env->head)->type!=tcons) {
2368        printerr("Bad Argument Type");
2369        env->err= 2;
2370        return;
2371      }
2372    
2373      CDR(CAR(CDR(env->head)))=CAR(env->head);
2374      toss(env);
2375    }
2376    
2377    extern void car(environment *env)
2378    {
2379      if(env->head->type==empty) {
2380        printerr("Too Few Arguments");
2381        env->err= 1;
2382        return;
2383      }
2384    
2385      if(CAR(env->head)->type!=tcons) {
2386        printerr("Bad Argument Type");
2387        env->err= 2;
2388        return;
2389      }
2390    
2391      CAR(env->head)=CAR(CAR(env->head));
2392    }
2393    
2394    extern void cdr(environment *env)
2395    {
2396      if(env->head->type==empty) {
2397        printerr("Too Few Arguments");
2398        env->err= 1;
2399        return;
2400      }
2401    
2402      if(CAR(env->head)->type!=tcons) {
2403        printerr("Bad Argument Type");
2404        env->err= 2;
2405        return;
2406      }
2407    
2408      CAR(env->head)=CDR(CAR(env->head));
2409    }
2410    
2411    extern void cons(environment *env)
2412    {
2413      value *val;
2414    
2415      if(env->head->type==empty || CDR(env->head)->type==empty) {
2416        printerr("Too Few Arguments");
2417        env->err= 1;
2418        return;
2419      }
2420    
2421      val=new_val(env);
2422      val->content.c= malloc(sizeof(pair));
2423      assert(val->content.c!=NULL);
2424    
2425      env->gc_count += sizeof(pair);
2426      val->type=tcons;
2427    
2428      CAR(val)= CAR(CDR(env->head));
2429      CDR(val)= CAR(env->head);
2430    
2431      push_val(env, val);
2432    
2433      swap(env); if(env->err) return;
2434      toss(env); if(env->err) return;
2435      swap(env); if(env->err) return;
2436      toss(env); if(env->err) return;
2437    }
Legend:
Removed from v.1.98  
changed lines
  Added in v.1.117
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26