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

Diff of /stack/stack.c

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

revision 1.95 by masse, Sun Mar 10 06:34:01 2002 UTC revision 1.116 by teddy, Sun Mar 17 12:49:27 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= 20;    env->gc_limit= 400000;
61    env->gc_count= 0;    env->gc_count= 0;
62    env->gc_ref= NULL;    env->gc_ref= NULL;
   env->gc_protect= NULL;  
63    
64    env->head= NULL;    env->head= new_val(env);
65      env->head->type= empty;
66    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
67      env->symbols[i]= NULL;      env->symbols[i]= NULL;
68    env->err= 0;    env->err= 0;
# Line 71  void printerr(const char* in_string) Line 80  void printerr(const char* in_string)
80  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
81  extern void toss(environment *env)  extern void toss(environment *env)
82  {  {
83    stackitem *temp= env->head;    if(env->head->type==empty) {
   
   if((env->head)==NULL) {  
84      printerr("Too Few Arguments");      printerr("Too Few Arguments");
85      env->err= 1;      env->err= 1;
86      return;      return;
87    }    }
88        
89    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--;  
   gc_init(env);  
90  }  }
91    
92  /* 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 122  value* new_val(environment *env) Line 125  value* new_val(environment *env)
125    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
126    
127    nval->content.ptr= NULL;    nval->content.ptr= NULL;
128      nval->type= integer;
129    
130    nitem->item= nval;    nitem->item= nval;
131    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
   env->gc_ref= nitem;  
132    
133    env->gc_count++;    env->gc_ref= nitem;
134    
135    protect(env, nval);    env->gc_count += sizeof(value);
136    gc_init(env);    nval->gc.flag.mark= 0;
137    unprotect(env);    nval->gc.flag.protect= 0;
138    
139    return nval;    return nval;
140  }  }
141    
142  /* Mark values recursively.  /* Mark values recursively.
143     Marked values are not collected by the GC. */     Marked values are not collected by the GC. */
144  void gc_mark(value *val)  inline void gc_mark(value *val)
145  {  {
146    stackitem *iterator;    if(val==NULL || val->gc.flag.mark)
   
   if(val==NULL || val->gc_garb==0)  
147      return;      return;
148    
149    val->gc_garb= 0;    val->gc.flag.mark= 1;
   
   if(val->type==list) {  
     iterator= val->content.ptr;  
150    
151      while(iterator!=NULL) {    if(val->type==tcons) {
152        gc_mark(iterator->item);      gc_mark(CAR(val));
153        iterator= iterator->next;      gc_mark(CDR(val));
     }  
154    }    }
155  }  }
156    
157    inline void gc_maybe(environment *env)
158    {
159      if(env->gc_count < env->gc_limit)
160        return;
161      else
162        return gc_init(env);
163    }
164    
165  /* Start GC */  /* Start GC */
166  extern void gc_init(environment *env)  extern void gc_init(environment *env)
167  {  {
168    stackitem *new_head= NULL, *titem, *iterator;    stackitem *new_head= NULL, *titem;
169    symbol *tsymb;    symbol *tsymb;
170    int i;    int i;
171    
172    if(env->gc_count < env->gc_limit)    if(env->interactive)
173      return;      printf("Garbage collecting.");
174    
175    /* Garb by default */    /* Mark values on stack */
176    iterator= env->gc_ref;    gc_mark(env->head);
   while(iterator!=NULL) {  
     iterator->item->gc_garb= 1;  
     iterator= iterator->next;  
   }  
177    
178    /* Mark protected values */    if(env->interactive)
179    iterator= env->gc_protect;      printf(".");
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
180    
   /* Mark values on stack */  
   iterator= env->head;  
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
181    
182    /* Mark values in hashtable */    /* Mark values in hashtable */
183    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++)
184      tsymb= env->symbols[i];      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
185      while(tsymb!=NULL) {        if (tsymb->val != NULL)
186        gc_mark(tsymb->val);          gc_mark(tsymb->val);
187        tsymb= tsymb->next;  
188      }  
189    }    if(env->interactive)
190        printf(".");
191    
192    env->gc_count= 0;    env->gc_count= 0;
193    
194    while(env->gc_ref!=NULL) {    /* Sweep unused values */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
195    
196      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
197    
198        switch(env->gc_ref->item->type) { /* Remove content */        /* Remove content */
199          switch(env->gc_ref->item->type){
200        case string:        case string:
201          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
202          break;          break;
203        case list:        case tcons:
204          while(env->gc_ref->item->content.ptr!=NULL) {          free(env->gc_ref->item->content.c);
           titem= env->gc_ref->item->content.ptr;  
           env->gc_ref->item->content.ptr= titem->next;  
           free(titem);  
         }  
         break;  
       default:  
205          break;          break;
206          case empty:
207          case integer:
208          case tfloat:
209          case func:
210          case symb:
211            /* Symbol strings are freed when walking the hash table */
212        }        }
213    
214        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
215        titem= env->gc_ref->next;        titem= env->gc_ref->next;
216        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
217        env->gc_ref= titem;        env->gc_ref= titem;
218      } else {                    /* Keep values */        continue;
219        titem= env->gc_ref->next;      }
220        env->gc_ref->next= new_head;  #ifdef DEBUG
221        new_head= env->gc_ref;      printf("Kept value (%p)", env->gc_ref->item);
222        env->gc_ref= titem;      if(env->gc_ref->item->gc.flag.mark)
223        env->gc_count++;        printf(" (marked)");
224        if(env->gc_ref->item->gc.flag.protect)
225          printf(" (protected)");
226        switch(env->gc_ref->item->type){
227        case integer:
228          printf(" integer: %d", env->gc_ref->item->content.i);
229          break;
230        case func:
231          printf(" func: %p", env->gc_ref->item->content.ptr);
232          break;
233        case symb:
234          printf(" symb: %s", env->gc_ref->item->content.sym->id);
235          break;
236        case tcons:
237          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
238                 env->gc_ref->item->content.c->cdr);
239          break;
240        default:
241          printf(" <unknown %d>", (env->gc_ref->item->type));
242      }      }
243        printf("\n");
244    #endif /* DEBUG */
245    
246        /* Keep values */    
247        env->gc_count += sizeof(value);
248        if(env->gc_ref->item->type==string)
249          env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
250        
251        titem= env->gc_ref->next;
252        env->gc_ref->next= new_head;
253        new_head= env->gc_ref;
254        new_head->item->gc.flag.mark= 0;
255        env->gc_ref= titem;
256    }    }
257    
258    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
259        env->gc_limit= env->gc_count*2;
260    
261    env->gc_ref= new_head;    env->gc_ref= new_head;
262    
263      if(env->interactive)
264        printf("done (%d bytes still allocated)\n", env->gc_count);
265    
266  }  }
267    
268  /* Protect values from GC */  /* Protect values from GC */
269  void protect(environment *env, value *val)  void protect(value *val)
270  {  {
271    stackitem *new_item= malloc(sizeof(stackitem));    if(val==NULL || val->gc.flag.protect)
272    new_item->item= val;      return;
273    new_item->next= env->gc_protect;  
274    env->gc_protect= new_item;    val->gc.flag.protect= 1;
275    
276      if(val->type==tcons) {
277        protect(CAR(val));
278        protect(CDR(val));
279      }
280  }  }
281    
282  /* Unprotect values from GC */  /* Unprotect values from GC */
283  void unprotect(environment *env)  void unprotect(value *val)
284  {  {
285    stackitem *temp= env->gc_protect;    if(val==NULL || !(val->gc.flag.protect))
286    env->gc_protect= env->gc_protect->next;      return;
287    free(temp);  
288      val->gc.flag.protect= 0;
289    
290      if(val->type==tcons) {
291        unprotect(CAR(val));
292        unprotect(CDR(val));
293      }
294  }  }
295    
296  /* Push a value onto the stack */  /* Push a value onto the stack */
297  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
298  {  {
299    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
300    new_item->item= val;  
301    new_item->next= env->head;    new_value->content.c= malloc(sizeof(pair));
302    env->head= new_item;    assert(new_value->content.c!=NULL);
303      env->gc_count += sizeof(pair);
304      new_value->type= tcons;
305      CAR(new_value)= val;
306      CDR(new_value)= env->head;
307      env->head= new_value;
308  }  }
309    
310  /* Push an integer onto the stack */  /* Push an integer onto the stack */
# Line 286  void push_float(environment *env, float Line 333  void push_float(environment *env, float
333  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
334  {  {
335    value *new_value= new_val(env);    value *new_value= new_val(env);
336      int length= strlen(in_string)+1;
337    
338    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
339      env->gc_count += length;
340    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
341    new_value->type= string;    new_value->type= string;
342    
# Line 318  extern void mangle(environment *env) Line 367  extern void mangle(environment *env)
367  {  {
368    char *new_string;    char *new_string;
369    
370    if((env->head)==NULL) {    if(env->head->type==empty) {
371      printerr("Too Few Arguments");      printerr("Too Few Arguments");
372      env->err= 1;      env->err= 1;
373      return;      return;
374    }    }
375    
376    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
377      printerr("Bad Argument Type");      printerr("Bad Argument Type");
378      env->err= 2;      env->err= 2;
379      return;      return;
380    }    }
381    
382    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
383        mangle_str((const char *)(CAR(env->head)->content.ptr));
384    
385    toss(env);    toss(env);
386    if(env->err) return;    if(env->err) return;
# Line 354  void push_sym(environment *env, const ch Line 404  void push_sym(environment *env, const ch
404    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
405    
406    new_value= new_val(env);    new_value= new_val(env);
407    protect(env, new_value);    protect(new_value);
408    new_fvalue= new_val(env);    new_fvalue= new_val(env);
409    protect(env, new_fvalue);    protect(new_fvalue);
410    
411    /* The new value is a symbol */    /* The new value is a symbol */
412    new_value->type= symb;    new_value->type= symb;
# Line 402  void push_sym(environment *env, const ch Line 452  void push_sym(environment *env, const ch
452    }    }
453    
454    push_val(env, new_value);    push_val(env, new_value);
455    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
456  }  }
457    
458  /* Print newline. */  /* Print newline. */
# Line 414  extern void nl() Line 464  extern void nl()
464  /* Gets the type of a value */  /* Gets the type of a value */
465  extern void type(environment *env)  extern void type(environment *env)
466  {  {
467    int typenum;    if(env->head->type==empty) {
   
   if((env->head)==NULL) {  
468      printerr("Too Few Arguments");      printerr("Too Few Arguments");
469      env->err=1;      env->err= 1;
470      return;      return;
471    }    }
472    typenum=env->head->item->type;  
473    toss(env);    switch(CAR(env->head)->type){
474    switch(typenum){    case empty:
475        push_sym(env, "empty");
476        break;
477    case integer:    case integer:
478      push_sym(env, "integer");      push_sym(env, "integer");
479      break;      break;
# Line 439  extern void type(environment *env) Line 489  extern void type(environment *env)
489    case func:    case func:
490      push_sym(env, "function");      push_sym(env, "function");
491      break;      break;
492    case list:    case tcons:
493      push_sym(env, "list");      push_sym(env, "pair");
494      break;      break;
495    }    }
496      swap(env);
497      if (env->err) return;
498      toss(env);
499  }      }    
500    
501  /* Prints the top element of the stack. */  /* Print a value */
502  void print_h(stackitem *stack_head, int noquote)  void print_val(value *val, int noquote)
503  {  {
504    switch(stack_head->item->type) {    switch(val->type) {
505      case empty:
506        printf("[]");
507        break;
508    case integer:    case integer:
509      printf("%d", stack_head->item->content.i);      printf("%d", val->content.i);
510      break;      break;
511    case tfloat:    case tfloat:
512      printf("%f", stack_head->item->content.f);      printf("%f", val->content.f);
513      break;      break;
514    case string:    case string:
515      if(noquote)      if(noquote)
516        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)(val->content.ptr));
517      else      else
518        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)(val->content.ptr));
519      break;      break;
520    case symb:    case symb:
521      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", val->content.sym->id);
522      break;      break;
523    case func:    case func:
524      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(val->content.ptr));
525      break;      break;
526    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);  
527      printf("[ ");      printf("[ ");
528      while(stack_head != NULL) {      do {
529        print_h(stack_head, noquote);        print_val(CAR(val), noquote);
530        printf(" ");        val= CDR(val);
531        stack_head=stack_head->next;        switch(val->type){
532      }        case empty:
533      printf("]");          break;
534          case tcons:
535            printf(" ");
536            break;
537          default:
538            printf(" . ");          /* Improper list */
539            print_val(val, noquote);
540          }
541        } while(val->type == tcons);
542        printf(" ]");
543      break;      break;
544    }    }
545  }  }
546    
547  extern void print_(environment *env)  extern void print_(environment *env)
548  {  {
549    if(env->head==NULL) {    if(env->head->type==empty) {
550      printerr("Too Few Arguments");      printerr("Too Few Arguments");
551      env->err=1;      env->err= 1;
552      return;      return;
553    }    }
554    print_h(env->head, 0);    print_val(CAR(env->head), 0);
555    nl();    nl();
556  }  }
557    
# Line 502  extern void print(environment *env) Line 565  extern void print(environment *env)
565    
566  extern void princ_(environment *env)  extern void princ_(environment *env)
567  {  {
568    if(env->head==NULL) {    if(env->head->type==empty) {
569      printerr("Too Few Arguments");      printerr("Too Few Arguments");
570      env->err=1;      env->err= 1;
571      return;      return;
572    }    }
573    print_h(env->head, 1);    print_val(CAR(env->head), 1);
574  }  }
575    
576  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack and then discards it. */
# Line 519  extern void princ(environment *env) Line 582  extern void princ(environment *env)
582  }  }
583    
584  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
585  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
586  {  {
587    if(stack_head->next != NULL)    if(CDR(stack_head)->type != empty)
588      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
589    printf("%ld: ", counter);    printf("%ld: ", counter);
590    print_h(stack_head, 0);    print_val(CAR(stack_head), 0);
591    nl();    nl();
592  }  }
593    
594  /* Prints the stack. */  /* Prints the stack. */
595  extern void printstack(environment *env)  extern void printstack(environment *env)
596  {  {
597    if(env->head == NULL) {    if(env->head->type == empty) {
598      printf("Stack Empty\n");      printf("Stack Empty\n");
599      return;      return;
600    }    }
# Line 542  extern void printstack(environment *env) Line 605  extern void printstack(environment *env)
605  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
606  extern void swap(environment *env)  extern void swap(environment *env)
607  {  {
608    stackitem *temp= env->head;    value *temp= env->head;
609        
610    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
611      printerr("Too Few Arguments");      printerr("Too Few Arguments");
612      env->err=1;      env->err=1;
613      return;      return;
614    }    }
615    
616    env->head= env->head->next;    env->head= CDR(env->head);
617    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
618    env->head->next= temp;    CDR(env->head)= temp;
619  }  }
620    
621  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
622  extern void rot(environment *env)  extern void rot(environment *env)
623  {  {
624    stackitem *temp= env->head;    value *temp= env->head;
625        
626    if(env->head==NULL || env->head->next==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
627        || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type == empty) {
628      printerr("Too Few Arguments");      printerr("Too Few Arguments");
629      env->err=1;      env->err= 1;
630      return;      return;
631    }    }
632      
633    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
634    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
635    env->head->next= temp;    CDR(env->head)= temp;
636  }  }
637    
638  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 577  extern void rcl(environment *env) Line 640  extern void rcl(environment *env)
640  {  {
641    value *val;    value *val;
642    
643    if(env->head == NULL) {    if(env->head->type==empty) {
644      printerr("Too Few Arguments");      printerr("Too Few Arguments");
645      env->err=1;      env->err= 1;
646      return;      return;
647    }    }
648    
649    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
650      printerr("Bad Argument Type");      printerr("Bad Argument Type");
651      env->err=2;      env->err= 2;
652      return;      return;
653    }    }
654    
655    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
656    if(val == NULL){    if(val == NULL){
657      printerr("Unbound Variable");      printerr("Unbound Variable");
658      env->err=3;      env->err= 3;
659      return;      return;
660    }    }
661    protect(env, val);    push_val(env, val);           /* Return the symbol's bound value */
662    toss(env);            /* toss the symbol */    swap(env);
663      if(env->err) return;
664      toss(env);                    /* toss the symbol */
665    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(env);  
666  }  }
667    
668  /* 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 609  extern void eval(environment *env) Line 672  extern void eval(environment *env)
672  {  {
673    funcp in_func;    funcp in_func;
674    value* temp_val;    value* temp_val;
675    stackitem* iterator;    value* iterator;
676    
677   eval_start:   eval_start:
678    
679    if(env->head==NULL) {    gc_maybe(env);
680    
681      if(env->head->type==empty) {
682      printerr("Too Few Arguments");      printerr("Too Few Arguments");
683      env->err=1;      env->err= 1;
684      return;      return;
685    }    }
686    
687    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
688      /* if it's a symbol */      /* if it's a symbol */
689    case symb:    case symb:
690      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
691      if(env->err) return;      if(env->err) return;
692      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
693        goto eval_start;        goto eval_start;
694      }      }
695      return;      return;
696    
697      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
698    case func:    case func:
699      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
700      toss(env);      toss(env);
701      if(env->err) return;      if(env->err) return;
702      return in_func(env);      return in_func(env);
703    
704      /* If it's a list */      /* If it's a list */
705    case list:    case tcons:
706      temp_val= env->head->item;      temp_val= CAR(env->head);
707      protect(env, temp_val);      protect(temp_val);
708    
709      toss(env); if(env->err) return;      toss(env); if(env->err) return;
710      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
711            
712      while(iterator!=NULL) {      while(iterator->type != empty) {
713        push_val(env, iterator->item);        push_val(env, CAR(iterator));
714                
715        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
716          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
717          toss(env);          toss(env);
718          if(env->err) return;          if(env->err) return;
719                    
720          if(iterator->next == NULL){          if(CDR(iterator)->type == empty){
721            goto eval_start;            goto eval_start;
722          }          }
723          eval(env);          eval(env);
724          if(env->err) return;          if(env->err) return;
725        }        }
726        iterator= iterator->next;        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
727            iterator= CDR(iterator);
728          else {
729            printerr("Bad Argument Type"); /* Improper list */
730            env->err= 2;
731            return;
732          }
733      }      }
734      unprotect(env);      unprotect(temp_val);
735      return;      return;
736    
737    default:    case empty:
738      case integer:
739      case tfloat:
740      case string:
741      return;      return;
742    }    }
743  }  }
# Line 671  extern void eval(environment *env) Line 745  extern void eval(environment *env)
745  /* Reverse (flip) a list */  /* Reverse (flip) a list */
746  extern void rev(environment *env)  extern void rev(environment *env)
747  {  {
748    stackitem *old_head, *new_head, *item;    value *old_head, *new_head, *item;
749    
750    if((env->head)==NULL) {    if(env->head->type==empty) {
751      printerr("Too Few Arguments");      printerr("Too Few Arguments");
752      env->err= 1;      env->err= 1;
753      return;      return;
754    }    }
755    
756    if(env->head->item->type!=list) {    if(CAR(env->head)->type==empty)
757        return;                     /* Don't reverse an empty list */
758    
759      if(CAR(env->head)->type!=tcons) {
760      printerr("Bad Argument Type");      printerr("Bad Argument Type");
761      env->err= 2;      env->err= 2;
762      return;      return;
763    }    }
764    
765    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
766    new_head= NULL;    new_head= new_val(env);
767    while(old_head != NULL){    new_head->type= empty;
768      while(old_head->type != empty) {
769      item= old_head;      item= old_head;
770      old_head= old_head->next;      old_head= CDR(old_head);
771      item->next= new_head;      CDR(item)= new_head;
772      new_head= item;      new_head= item;
773    }    }
774    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
775  }  }
776    
777  /* Make a list. */  /* Make a list. */
778  extern void pack(environment *env)  extern void pack(environment *env)
779  {  {
780    stackitem *iterator, *temp;    value *iterator, *temp, *ending;
   value *pack;  
781    
782    iterator= env->head;    ending=new_val(env);
783    pack= new_val(env);    ending->type=empty;
   protect(env, pack);  
784    
785    if(iterator==NULL    iterator= env->head;
786       || (iterator->item->type==symb    if(iterator->type == empty
787       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       || (CAR(iterator)->type==symb
788      temp= NULL;       && CAR(iterator)->content.sym->id[0]=='[')) {
789        temp= ending;
790      toss(env);      toss(env);
791    } else {    } else {
792      /* Search for first delimiter */      /* Search for first delimiter */
793      while(iterator->next!=NULL      while(CDR(iterator)->type != empty
794            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
795            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
796        iterator= iterator->next;        iterator= CDR(iterator);
797            
798      /* Extract list */      /* Extract list */
799      temp= env->head;      temp= env->head;
800      env->head= iterator->next;      env->head= CDR(iterator);
801      iterator->next= NULL;      CDR(iterator)= ending;
802    
803      pack->type= list;      if(env->head->type != empty)
     pack->content.ptr= temp;  
       
     if(env->head!=NULL)  
804        toss(env);        toss(env);
805    }    }
806    
807    /* Push list */    /* Push list */
808    
809    push_val(env, pack);    push_val(env, temp);
810    rev(env);    rev(env);
   
   unprotect(env);  
811  }  }
812    
813  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
814  extern void expand(environment *env)  extern void expand(environment *env)
815  {  {
816    stackitem *temp, *new_head;    value *temp, *new_head;
817    
818    /* Is top element a list? */    /* Is top element a list? */
819    if(env->head==NULL) {    if(env->head->type==empty) {
820      printerr("Too Few Arguments");      printerr("Too Few Arguments");
821      env->err= 1;      env->err= 1;
822      return;      return;
823    }    }
824    if(env->head->item->type!=list) {  
825      if(CAR(env->head)->type!=tcons) {
826      printerr("Bad Argument Type");      printerr("Bad Argument Type");
827      env->err= 2;      env->err= 2;
828      return;      return;
# Line 761  extern void expand(environment *env) Line 834  extern void expand(environment *env)
834      return;      return;
835    
836    /* The first list element is the new stack head */    /* The first list element is the new stack head */
837    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
838    
839    toss(env);    toss(env);
840    
841    /* Find the end of the list */    /* Find the end of the list */
842    while(temp->next!=NULL)    while(CDR(temp)->type != empty) {
843      temp= temp->next;      if (CDR(temp)->type == tcons)
844          temp= CDR(temp);
845        else {
846          printerr("Bad Argument Type"); /* Improper list */
847          env->err= 2;
848          return;
849        }
850      }
851    
852    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
853    temp->next= env->head;    CDR(temp)= env->head;
854    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
855    
856  }  }
# Line 779  extern void expand(environment *env) Line 859  extern void expand(environment *env)
859  extern void eq(environment *env)  extern void eq(environment *env)
860  {  {
861    void *left, *right;    void *left, *right;
   int result;  
862    
863    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
864      printerr("Too Few Arguments");      printerr("Too Few Arguments");
865      env->err= 1;      env->err= 1;
866      return;      return;
867    }    }
868    
869    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
870    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
871    toss(env); toss(env);    toss(env); toss(env);
872    push_int(env, result);  
873      push_int(env, left==right);
874  }  }
875    
876  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 801  extern void not(environment *env) Line 878  extern void not(environment *env)
878  {  {
879    int val;    int val;
880    
881    if((env->head)==NULL) {    if(env->head->type==empty) {
882      printerr("Too Few Arguments");      printerr("Too Few Arguments");
883      env->err= 1;      env->err= 1;
884      return;      return;
885    }    }
886    
887    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
888      printerr("Bad Argument Type");      printerr("Bad Argument Type");
889      env->err= 2;      env->err= 2;
890      return;      return;
891    }    }
892    
893    val= env->head->item->content.i;    val= CAR(env->head)->content.i;
894    toss(env);    toss(env);
895    push_int(env, !val);    push_int(env, !val);
896  }  }
# Line 832  extern void def(environment *env) Line 909  extern void def(environment *env)
909    symbol *sym;    symbol *sym;
910    
911    /* 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 */
912    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
913      printerr("Too Few Arguments");      printerr("Too Few Arguments");
914      env->err= 1;      env->err= 1;
915      return;      return;
916    }    }
917    
918    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
919      printerr("Bad Argument Type");      printerr("Bad Argument Type");
920      env->err= 2;      env->err= 2;
921      return;      return;
922    }    }
923    
924    /* long names are a pain */    /* long names are a pain */
925    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
926    
927    /* Bind the symbol to the value */    /* Bind the symbol to the value */
928    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
929    
930    toss(env); toss(env);    toss(env); toss(env);
931  }  }
# Line 869  extern void quit(environment *env) Line 946  extern void quit(environment *env)
946    }    }
947    
948    env->gc_limit= 0;    env->gc_limit= 0;
949    gc_init(env);    gc_maybe(env);
950    
951      words(env);
952    
953    if(env->free_string!=NULL)    if(env->free_string!=NULL)
954      free(env->free_string);      free(env->free_string);
955        
956    #ifdef __linux__
957    muntrace();    muntrace();
958    #endif
959    
960    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
961  }  }
# Line 882  extern void quit(environment *env) Line 963  extern void quit(environment *env)
963  /* Clear stack */  /* Clear stack */
964  extern void clear(environment *env)  extern void clear(environment *env)
965  {  {
966    while(env->head!=NULL)    while(env->head->type != empty)
967      toss(env);      toss(env);
968  }  }
969    
# Line 895  extern void words(environment *env) Line 976  extern void words(environment *env)
976    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
977      temp= env->symbols[i];      temp= env->symbols[i];
978      while(temp!=NULL) {      while(temp!=NULL) {
979    #ifdef DEBUG
980          if (temp->val != NULL && temp->val->gc.flag.protect)
981            printf("(protected) ");
982    #endif /* DEBUG */
983        printf("%s\n", temp->id);        printf("%s\n", temp->id);
984        temp= temp->next;        temp= temp->next;
985      }      }
# Line 917  void forget_sym(symbol **hash_entry) Line 1002  void forget_sym(symbol **hash_entry)
1002  extern void forget(environment *env)  extern void forget(environment *env)
1003  {  {
1004    char* sym_id;    char* sym_id;
   stackitem *stack_head= env->head;  
1005    
1006    if(stack_head==NULL) {    if(env->head->type==empty) {
1007      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1008      env->err=1;      env->err= 1;
1009      return;      return;
1010    }    }
1011        
1012    if(stack_head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
1013      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1014      env->err=2;      env->err= 2;
1015      return;      return;
1016    }    }
1017    
1018    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(env->head)->content.sym->id;
1019    toss(env);    toss(env);
1020    
1021    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 949  int main(int argc, char **argv) Line 1033  int main(int argc, char **argv)
1033    
1034    int c;                        /* getopt option character */    int c;                        /* getopt option character */
1035    
1036    #ifdef __linux__
1037    mtrace();    mtrace();
1038    #endif
1039    
1040    init_env(&myenv);    init_env(&myenv);
1041    
# Line 963  int main(int argc, char **argv) Line 1049  int main(int argc, char **argv)
1049          break;          break;
1050        case '?':        case '?':
1051          fprintf (stderr,          fprintf (stderr,
1052                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1053                   optopt);                   optopt);
1054          return EX_USAGE;          return EX_USAGE;
1055        default:        default:
# Line 982  int main(int argc, char **argv) Line 1068  int main(int argc, char **argv)
1068    if(myenv.interactive) {    if(myenv.interactive) {
1069      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1070  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1071  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1072  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1073  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1074    }    }
1075    
1076    while(1) {    while(1) {
# Line 999  under certain conditions; type `copying; Line 1085  under certain conditions; type `copying;
1085        }        }
1086        myenv.err=0;        myenv.err=0;
1087      }      }
1088      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1089      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1090        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1091      } else if(myenv.head!=NULL        quit(&myenv);
1092                && myenv.head->item->type==symb      } else if(myenv.head->type!=empty
1093                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->type==symb
1094                  && CAR(myenv.head)->content.sym->id[0]
1095                  ==';') {
1096        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1097        eval(&myenv);        eval(&myenv);
1098      }      }
1099      gc_init(&myenv);      gc_maybe(&myenv);
1100    }    }
1101    quit(&myenv);    quit(&myenv);
1102    return EXIT_FAILURE;    return EXIT_FAILURE;
# Line 1023  extern void sx_2b(environment *env) Line 1111  extern void sx_2b(environment *env)
1111    char* new_string;    char* new_string;
1112    value *a_val, *b_val;    value *a_val, *b_val;
1113    
1114    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1115      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1116      env->err= 1;      env->err= 1;
1117      return;      return;
1118    }    }
1119    
1120    if(env->head->item->type==string    if(CAR(env->head)->type==string
1121       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1122      a_val= env->head->item;      a_val= CAR(env->head);
1123      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1124      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1125      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1126      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1127      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 1041  extern void sx_2b(environment *env) Line 1129  extern void sx_2b(environment *env)
1129      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1130      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1131      push_cstring(env, new_string);      push_cstring(env, new_string);
1132      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1133      free(new_string);      free(new_string);
1134            
1135      return;      return;
1136    }    }
1137        
1138    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1139       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1140      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1141      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1142      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1143      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1144      push_int(env, b+a);      push_int(env, b+a);
1145    
1146      return;      return;
1147    }    }
1148    
1149    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1150       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1151      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1152      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1153      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1154      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1155      push_float(env, fb+fa);      push_float(env, fb+fa);
1156            
1157      return;      return;
1158    }    }
1159    
1160    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1161       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1162      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1163      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1164      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1165      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1166      push_float(env, b+fa);      push_float(env, b+fa);
1167            
1168      return;      return;
1169    }    }
1170    
1171    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1172       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1173      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1174      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1175      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1176      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1177      push_float(env, fb+a);      push_float(env, fb+a);
1178    
# Line 1101  extern void sx_2d(environment *env) Line 1189  extern void sx_2d(environment *env)
1189    int a, b;    int a, b;
1190    float fa, fb;    float fa, fb;
1191    
1192    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1193      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1194      env->err=1;      env->err=1;
1195      return;      return;
1196    }    }
1197        
1198    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1199       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1200      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1201      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1202      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1203      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1204      push_int(env, b-a);      push_int(env, b-a);
1205    
1206      return;      return;
1207    }    }
1208    
1209    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1210       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1211      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1212      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1213      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1214      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1215      push_float(env, fb-fa);      push_float(env, fb-fa);
1216            
1217      return;      return;
1218    }    }
1219    
1220    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1221       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1222      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1223      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1224      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1225      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1226      push_float(env, b-fa);      push_float(env, b-fa);
1227            
1228      return;      return;
1229    }    }
1230    
1231    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1232       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1233      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1234      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1235      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1236      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1237      push_float(env, fb-a);      push_float(env, fb-a);
1238    
# Line 1161  extern void sx_3e(environment *env) Line 1249  extern void sx_3e(environment *env)
1249    int a, b;    int a, b;
1250    float fa, fb;    float fa, fb;
1251    
1252    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1253      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1254      env->err=1;      env->err= 1;
1255      return;      return;
1256    }    }
1257        
1258    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1259       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1260      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1261      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1262      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1263      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1264      push_int(env, b>a);      push_int(env, b>a);
1265    
1266      return;      return;
1267    }    }
1268    
1269    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1270       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1271      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1272      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1273      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1274      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1275      push_int(env, fb>fa);      push_int(env, fb>fa);
1276            
1277      return;      return;
1278    }    }
1279    
1280    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1281       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1282      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1283      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1284      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1285      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1286      push_int(env, b>fa);      push_int(env, b>fa);
1287            
1288      return;      return;
1289    }    }
1290    
1291    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1292       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1293      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1294      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1295      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1296      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1297      push_int(env, fb>a);      push_int(env, fb>a);
1298    
# Line 1212  extern void sx_3e(environment *env) Line 1300  extern void sx_3e(environment *env)
1300    }    }
1301    
1302    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1303    env->err=2;    env->err= 2;
1304  }  }
1305    
1306  /* "<" */  /* "<" */
# Line 1239  extern void sx_3e3d(environment *env) Line 1327  extern void sx_3e3d(environment *env)
1327  /* Return copy of a value */  /* Return copy of a value */
1328  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
1329  {  {
   stackitem *old_item, *new_item, *prev_item;  
1330    value *new_value;    value *new_value;
1331    
1332    protect(env, old_value);    if(old_value==NULL)
1333        return NULL;
1334    
1335      protect(old_value);
1336    new_value= new_val(env);    new_value= new_val(env);
   protect(env, new_value);  
1337    new_value->type= old_value->type;    new_value->type= old_value->type;
1338    
1339    switch(old_value->type){    switch(old_value->type){
# Line 1252  value *copy_val(environment *env, value Line 1341  value *copy_val(environment *env, value
1341    case integer:    case integer:
1342    case func:    case func:
1343    case symb:    case symb:
1344      case empty:
1345      new_value->content= old_value->content;      new_value->content= old_value->content;
1346      break;      break;
1347    case string:    case string:
1348      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1349        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1350      break;      break;
1351    case list:    case tcons:
     new_value->content.ptr= NULL;  
1352    
1353      prev_item= NULL;      new_value->content.c= malloc(sizeof(pair));
1354      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
1355        env->gc_count += sizeof(pair);
1356    
1357      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1358        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;  
     }      
1359      break;      break;
1360    }    }
1361    
1362    unprotect(env); unprotect(env);    unprotect(old_value);
1363    
1364    return new_value;    return new_value;
1365  }  }
# Line 1287  value *copy_val(environment *env, value Line 1367  value *copy_val(environment *env, value
1367  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1368  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1369  {  {
1370    if((env->head)==NULL) {    if(env->head->type==empty) {
1371      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1372      env->err= 1;      env->err= 1;
1373      return;      return;
1374    }    }
1375    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1376  }  }
1377    
1378  /* "if", If-Then */  /* "if", If-Then */
# Line 1300  extern void sx_6966(environment *env) Line 1380  extern void sx_6966(environment *env)
1380  {  {
1381    int truth;    int truth;
1382    
1383    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1384      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1385      env->err= 1;      env->err= 1;
1386      return;      return;
1387    }    }
1388    
1389    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1390      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1391      env->err=2;      env->err= 2;
1392      return;      return;
1393    }    }
1394        
1395    swap(env);    swap(env);
1396    if(env->err) return;    if(env->err) return;
1397        
1398    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1399    
1400    toss(env);    toss(env);
1401    if(env->err) return;    if(env->err) return;
# Line 1331  extern void ifelse(environment *env) Line 1411  extern void ifelse(environment *env)
1411  {  {
1412    int truth;    int truth;
1413    
1414    if((env->head)==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1415       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1416      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1417      env->err=1;      env->err= 1;
1418      return;      return;
1419    }    }
1420    
1421    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1422      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1423      env->err=2;      env->err= 2;
1424      return;      return;
1425    }    }
1426        
1427    rot(env);    rot(env);
1428    if(env->err) return;    if(env->err) return;
1429        
1430    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1431    
1432    toss(env);    toss(env);
1433    if(env->err) return;    if(env->err) return;
# Line 1362  extern void ifelse(environment *env) Line 1442  extern void ifelse(environment *env)
1442    eval(env);    eval(env);
1443  }  }
1444    
1445    extern void sx_656c7365(environment *env)
1446    {
1447      if(env->head->type==empty || CDR(env->head)->type==empty
1448         || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1449         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1450        printerr("Too Few Arguments");
1451        env->err= 1;
1452        return;
1453      }
1454    
1455      if(CAR(CDR(env->head))->type!=symb
1456         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1457         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1458         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1459        printerr("Bad Argument Type");
1460        env->err= 2;
1461        return;
1462      }
1463    
1464      swap(env); toss(env); rot(env); toss(env);
1465      ifelse(env);
1466    }
1467    
1468    extern void then(environment *env)
1469    {
1470      if(env->head->type==empty || CDR(env->head)->type==empty
1471         || CDR(CDR(env->head))->type==empty) {
1472        printerr("Too Few Arguments");
1473        env->err= 1;
1474        return;
1475      }
1476    
1477      if(CAR(CDR(env->head))->type!=symb
1478         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1479        printerr("Bad Argument Type");
1480        env->err= 2;
1481        return;
1482      }
1483    
1484      swap(env); toss(env);
1485      sx_6966(env);
1486    }
1487    
1488  /* "while" */  /* "while" */
1489  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1490  {  {
1491    int truth;    int truth;
1492    value *loop, *test;    value *loop, *test;
1493    
1494    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1495      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1496      env->err=1;      env->err= 1;
1497      return;      return;
1498    }    }
1499    
1500    loop= env->head->item;    loop= CAR(env->head);
1501    protect(env, loop);    protect(loop);
1502    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1503    
1504    test= env->head->item;    test= CAR(env->head);
1505    protect(env, test);    protect(test);
1506    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1507    
1508    do {    do {
1509      push_val(env, test);      push_val(env, test);
1510      eval(env);      eval(env);
1511            
1512      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1513        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1514        env->err= 2;        env->err= 2;
1515        return;        return;
1516      }      }
1517            
1518      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1519      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1520            
1521      if(truth) {      if(truth) {
# Line 1404  extern void sx_7768696c65(environment *e Line 1527  extern void sx_7768696c65(environment *e
1527        
1528    } while(truth);    } while(truth);
1529    
1530    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1531  }  }
1532    
1533    
# Line 1414  extern void sx_666f72(environment *env) Line 1537  extern void sx_666f72(environment *env)
1537    value *loop;    value *loop;
1538    int foo1, foo2;    int foo1, foo2;
1539    
1540    if(env->head==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1541       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1542      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1543      env->err= 1;      env->err= 1;
1544      return;      return;
1545    }    }
1546    
1547    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1548       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1549      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1550      env->err= 2;      env->err= 2;
1551      return;      return;
1552    }    }
1553    
1554    loop= env->head->item;    loop= CAR(env->head);
1555    protect(env, loop);    protect(loop);
1556    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1557    
1558    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1559    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1560    
1561    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1562    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1563    
1564    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1453  extern void sx_666f72(environment *env) Line 1576  extern void sx_666f72(environment *env)
1576        foo1--;        foo1--;
1577      }      }
1578    }    }
1579    unprotect(env);    unprotect(loop);
1580  }  }
1581    
1582  /* Variant of for-loop */  /* Variant of for-loop */
1583  extern void foreach(environment *env)  extern void foreach(environment *env)
1584  {    {  
1585    value *loop, *foo;    value *loop, *foo;
1586    stackitem *iterator;    value *iterator;
1587        
1588    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1589      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1590      env->err= 1;      env->err= 1;
1591      return;      return;
1592    }    }
1593    
1594    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1595      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1596      env->err= 2;      env->err= 2;
1597      return;      return;
1598    }    }
1599    
1600    loop= env->head->item;    loop= CAR(env->head);
1601    protect(env, loop);    protect(loop);
1602    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1603    
1604    foo= env->head->item;    foo= CAR(env->head);
1605    protect(env, foo);    protect(foo);
1606    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1607    
1608    iterator= foo->content.ptr;    iterator= foo;
1609    
1610    while(iterator!=NULL) {    while(iterator!=NULL) {
1611      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1612      push_val(env, loop);      push_val(env, loop);
1613      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1614      iterator= iterator->next;      if (iterator->type == tcons){
1615          iterator= CDR(iterator);
1616        } else {
1617          printerr("Bad Argument Type"); /* Improper list */
1618          env->err= 2;
1619          break;
1620        }
1621    }    }
1622    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1623  }  }
1624    
1625  /* "to" */  /* "to" */
1626  extern void to(environment *env)  extern void to(environment *env)
1627  {  {
1628    int ending, start, i;    int ending, start, i;
1629    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
1630    
1631    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1632      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1633      env->err=1;      env->err= 1;
1634      return;      return;
1635    }    }
1636    
1637    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1638       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1639      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1640      env->err=2;      env->err= 2;
1641      return;      return;
1642    }    }
1643    
1644    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1645    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1646    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1647    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1648    
1649    push_sym(env, "[");    push_sym(env, "[");
# Line 1529  extern void to(environment *env) Line 1657  extern void to(environment *env)
1657    }    }
1658    
1659    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(env, pack);  
1660    
1661    if(iterator==NULL    if(iterator->type==empty
1662       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
1663       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1664      temp= NULL;      temp= NULL;
1665      toss(env);      toss(env);
1666    } else {    } else {
1667      /* Search for first delimiter */      /* Search for first delimiter */
1668      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
1669            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
1670            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1671        iterator= iterator->next;        iterator= CDR(iterator);
1672            
1673      /* Extract list */      /* Extract list */
1674      temp= env->head;      temp= env->head;
1675      env->head= iterator->next;      env->head= CDR(iterator);
1676      iterator->next= NULL;      CDR(iterator)= NULL;
1677    
     pack->type= list;  
     pack->content.ptr= temp;  
       
1678      if(env->head!=NULL)      if(env->head!=NULL)
1679        toss(env);        toss(env);
1680    }    }
1681    
1682    /* Push list */    /* Push list */
1683      push_val(env, temp);
   push_val(env, pack);  
   
   unprotect(env);  
1684  }  }
1685    
1686  /* Read a string */  /* Read a string */
# Line 1590  extern void sx_72656164(environment *env Line 1710  extern void sx_72656164(environment *env
1710    int count= -1;    int count= -1;
1711    float ftemp;    float ftemp;
1712    static int depth= 0;    static int depth= 0;
1713    char *match, *ctemp;    char *match;
1714    size_t inlength;    size_t inlength;
1715    
1716    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1599  extern void sx_72656164(environment *env Line 1719  extern void sx_72656164(environment *env
1719      }      }
1720      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1721    
1722      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1723        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1724        return;        return;
1725      }      }
1726            
1727      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1728      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1729      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1730      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1731    }    }
1732        
# Line 1624  extern void sx_72656164(environment *env Line 1744  extern void sx_72656164(environment *env
1744      } else {      } else {
1745        push_float(env, ftemp);        push_float(env, ftemp);
1746      }      }
1747      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1748                && readlength != -1) {
1749        push_cstring(env, "");
1750    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1751              && readlength != -1) {              && readlength != -1) {
1752      push_cstring(env, match);      push_cstring(env, match);
# Line 1655  extern void sx_72656164(environment *env Line 1778  extern void sx_72656164(environment *env
1778      return sx_72656164(env);      return sx_72656164(env);
1779  }  }
1780    
1781    #ifdef __linux__
1782  extern void beep(environment *env)  extern void beep(environment *env)
1783  {  {
1784    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1785    
1786    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1787      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1788      env->err=1;      env->err= 1;
1789      return;      return;
1790    }    }
1791    
1792    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1793       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1794      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1795      env->err=2;      env->err= 2;
1796      return;      return;
1797    }    }
1798    
1799    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1800    toss(env);    toss(env);
1801    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
1802    toss(env);    toss(env);
1803    
1804    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1805                                     length */                                     length */
1806    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1807                                     timer ticks */                                     timer ticks */
1808    
1809  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1810    
1811    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1812    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1813    case 0:    case 0:
1814      usleep(dur);      usleep(dur);
1815      return;      return;
1816    case -1:    case -1:
1817      perror("beep");      perror("beep");
1818      env->err=5;      env->err= 5;
1819      return;      return;
1820    default:    default:
1821      abort();      abort();
1822    }    }
1823  }  }
1824    #endif /* __linux__ */
1825    
1826  /* "wait" */  /* "wait" */
1827  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
1828  {  {
1829    int dur;    int dur;
1830    
1831    if((env->head)==NULL) {    if(env->head->type==empty) {
1832      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1833      env->err=1;      env->err= 1;
1834      return;      return;
1835    }    }
1836    
1837    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1838      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1839      env->err=2;      env->err= 2;
1840      return;      return;
1841    }    }
1842    
1843    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1844    toss(env);    toss(env);
1845    
1846    usleep(dur);    usleep(dur);
# Line 1723  extern void sx_77616974(environment *env Line 1848  extern void sx_77616974(environment *env
1848    
1849  extern void copying(environment *env)  extern void copying(environment *env)
1850  {  {
1851    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1852                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1853  \n\  \n\
1854   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2012  extern void sx_2a(environment *env) Line 2137  extern void sx_2a(environment *env)
2137    int a, b;    int a, b;
2138    float fa, fb;    float fa, fb;
2139    
2140    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2141      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2142      env->err=1;      env->err= 1;
2143      return;      return;
2144    }    }
2145        
2146    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2147       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2148      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2149      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2150      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2151      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2152      push_int(env, b*a);      push_int(env, b*a);
2153    
2154      return;      return;
2155    }    }
2156    
2157    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2158       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2159      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2160      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2161      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2162      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2163      push_float(env, fb*fa);      push_float(env, fb*fa);
2164            
2165      return;      return;
2166    }    }
2167    
2168    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2169       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2170      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2171      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2172      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2173      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2174      push_float(env, b*fa);      push_float(env, b*fa);
2175            
2176      return;      return;
2177    }    }
2178    
2179    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2180       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2181      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2182      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2183      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2184      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2185      push_float(env, fb*a);      push_float(env, fb*a);
2186    
# Line 2063  extern void sx_2a(environment *env) Line 2188  extern void sx_2a(environment *env)
2188    }    }
2189    
2190    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2191    env->err=2;    env->err= 2;
2192  }  }
2193    
2194  /* "/" */  /* "/" */
# Line 2072  extern void sx_2f(environment *env) Line 2197  extern void sx_2f(environment *env)
2197    int a, b;    int a, b;
2198    float fa, fb;    float fa, fb;
2199    
2200    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2201      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2202      env->err=1;      env->err= 1;
2203      return;      return;
2204    }    }
2205        
2206    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2207       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2208      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2209      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2210      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2211      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2212      push_float(env, b/a);      push_float(env, b/a);
2213    
2214      return;      return;
2215    }    }
2216    
2217    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2218       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2219      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2220      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2221      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2222      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2223      push_float(env, fb/fa);      push_float(env, fb/fa);
2224            
2225      return;      return;
2226    }    }
2227    
2228    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2229       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2230      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2231      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2232      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2233      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2234      push_float(env, b/fa);      push_float(env, b/fa);
2235            
2236      return;      return;
2237    }    }
2238    
2239    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2240       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2241      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2242      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2243      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2244      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2245      push_float(env, fb/a);      push_float(env, fb/a);
2246    
# Line 2123  extern void sx_2f(environment *env) Line 2248  extern void sx_2f(environment *env)
2248    }    }
2249    
2250    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2251    env->err=2;    env->err= 2;
2252  }  }
2253    
2254  /* "mod" */  /* "mod" */
# Line 2131  extern void mod(environment *env) Line 2256  extern void mod(environment *env)
2256  {  {
2257    int a, b;    int a, b;
2258    
2259    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2260      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2261      env->err= 1;      env->err= 1;
2262      return;      return;
2263    }    }
2264        
2265    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2266       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2267      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2268      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2269      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2270      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2271      push_int(env, b%a);      push_int(env, b%a);
2272    
# Line 2149  extern void mod(environment *env) Line 2274  extern void mod(environment *env)
2274    }    }
2275    
2276    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2277    env->err=2;    env->err= 2;
2278  }  }
2279    
2280  /* "div" */  /* "div" */
# Line 2157  extern void sx_646976(environment *env) Line 2282  extern void sx_646976(environment *env)
2282  {  {
2283    int a, b;    int a, b;
2284        
2285    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2286      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2287      env->err= 1;      env->err= 1;
2288      return;      return;
2289    }    }
2290    
2291    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2292       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2293      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2294      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2295      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2296      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2297      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2298    
# Line 2177  extern void sx_646976(environment *env) Line 2302  extern void sx_646976(environment *env)
2302    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2303    env->err= 2;    env->err= 2;
2304  }  }
2305    
2306    extern void setcar(environment *env)
2307    {
2308      if(env->head->type==empty || CDR(env->head)->type==empty) {
2309        printerr("Too Few Arguments");
2310        env->err= 1;
2311        return;
2312      }
2313    
2314      if(CDR(env->head)->type!=tcons) {
2315        printerr("Bad Argument Type");
2316        env->err= 2;
2317        return;
2318      }
2319    
2320      CAR(CAR(CDR(env->head)))=CAR(env->head);
2321      toss(env);
2322    }
2323    
2324    extern void setcdr(environment *env)
2325    {
2326      if(env->head->type==empty || CDR(env->head)->type==empty) {
2327        printerr("Too Few Arguments");
2328        env->err= 1;
2329        return;
2330      }
2331    
2332      if(CDR(env->head)->type!=tcons) {
2333        printerr("Bad Argument Type");
2334        env->err= 2;
2335        return;
2336      }
2337    
2338      CDR(CAR(CDR(env->head)))=CAR(env->head);
2339      toss(env);
2340    }
2341    
2342    extern void car(environment *env)
2343    {
2344      if(env->head->type==empty) {
2345        printerr("Too Few Arguments");
2346        env->err= 1;
2347        return;
2348      }
2349    
2350      if(CAR(env->head)->type!=tcons) {
2351        printerr("Bad Argument Type");
2352        env->err= 2;
2353        return;
2354      }
2355    
2356      CAR(env->head)=CAR(CAR(env->head));
2357    }
2358    
2359    extern void cdr(environment *env)
2360    {
2361      if(env->head->type==empty) {
2362        printerr("Too Few Arguments");
2363        env->err= 1;
2364        return;
2365      }
2366    
2367      if(CAR(env->head)->type!=tcons) {
2368        printerr("Bad Argument Type");
2369        env->err= 2;
2370        return;
2371      }
2372    
2373      CAR(env->head)=CDR(CAR(env->head));
2374    }
2375    
2376    extern void cons(environment *env)
2377    {
2378      value *val;
2379    
2380      if(env->head->type==empty || CDR(env->head)->type==empty) {
2381        printerr("Too Few Arguments");
2382        env->err= 1;
2383        return;
2384      }
2385    
2386      val=new_val(env);
2387      val->content.c= malloc(sizeof(pair));
2388      assert(val->content.c!=NULL);
2389    
2390      env->gc_count += sizeof(pair);
2391      val->type=tcons;
2392    
2393      CAR(val)= CAR(CDR(env->head));
2394      CDR(val)= CAR(env->head);
2395    
2396      push_val(env, val);
2397    
2398      swap(env); if(env->err) return;
2399      toss(env); if(env->err) return;
2400      swap(env); if(env->err) return;
2401      toss(env); if(env->err) return;
2402    }
Legend:
Removed from v.1.95  
changed lines
  Added in v.1.116
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26