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

Diff of /stack/stack.c

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

revision 1.101 by teddy, Sun Mar 10 13:00:01 2002 UTC revision 1.107 by masse, Tue Mar 12 21:05:11 2002 UTC
# Line 20  Line 20 
20               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
21  */  */
22    
23    #define CAR(X) X->content.c->car
24    #define CDR(X) X->content.c->cdr
25    
26  /* printf, sscanf, fgets, fprintf, fopen, perror */  /* printf, sscanf, fgets, fprintf, fopen, perror */
27  #include <stdio.h>  #include <stdio.h>
28  /* exit, EXIT_SUCCESS, malloc, free */  /* exit, EXIT_SUCCESS, malloc, free */
# Line 34  Line 37 
37  #include <unistd.h>  #include <unistd.h>
38  /* EX_NOINPUT, EX_USAGE */  /* EX_NOINPUT, EX_USAGE */
39  #include <sysexits.h>  #include <sysexits.h>
40    
41    #ifdef __linux__
42  /* mtrace, muntrace */  /* mtrace, muntrace */
43  #include <mcheck.h>  #include <mcheck.h>
44  /* ioctl */  /* ioctl */
45  #include <sys/ioctl.h>  #include <sys/ioctl.h>
46  /* KDMKTONE */  /* KDMKTONE */
47  #include <linux/kd.h>  #include <linux/kd.h>
48    #endif /* __linux__ */
49    
50  #include "stack.h"  #include "stack.h"
51    
# Line 70  void printerr(const char* in_string) Line 76  void printerr(const char* in_string)
76  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
77  extern void toss(environment *env)  extern void toss(environment *env)
78  {  {
79    stackitem *temp= env->head;    if(env->head==NULL) {
   
   if((env->head)==NULL) {  
80      printerr("Too Few Arguments");      printerr("Too Few Arguments");
81      env->err= 1;      env->err= 1;
82      return;      return;
83    }    }
84        
85    env->head= env->head->next;   /* Remove the top stack item */    env->head= CDR(env->head); /* Remove the top stack item */
   free(temp);                   /* Free the old top stack item */  
86  }  }
87    
88  /* Returns a pointer to a pointer to an element in the hash table. */  /* Returns a pointer to a pointer to an element in the hash table. */
# Line 121  value* new_val(environment *env) Line 124  value* new_val(environment *env)
124    
125    nitem->item= nval;    nitem->item= nval;
126    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
127    
128    env->gc_ref= nitem;    env->gc_ref= nitem;
129    
130    env->gc_count += sizeof(value);    env->gc_count += sizeof(value);
# Line 134  value* new_val(environment *env) Line 138  value* new_val(environment *env)
138     Marked values are not collected by the GC. */     Marked values are not collected by the GC. */
139  inline void gc_mark(value *val)  inline void gc_mark(value *val)
140  {  {
141    stackitem *iterator;    if(val==NULL || val->gc.flag.mark)
   
   if(val->gc.flag.mark)  
142      return;      return;
143    
144    val->gc.flag.mark= 1;    val->gc.flag.mark= 1;
145    
146    if(val->type==list) {    if(val->type==tcons) {
147      iterator= val->content.ptr;      gc_mark(CAR(val));
148        gc_mark(CDR(val));
     while(iterator!=NULL) {  
       gc_mark(iterator->item);  
       iterator= iterator->next;  
     }  
149    }    }
150  }  }
151    
# Line 162  inline void gc_maybe(environment *env) Line 160  inline void gc_maybe(environment *env)
160  /* Start GC */  /* Start GC */
161  extern void gc_init(environment *env)  extern void gc_init(environment *env)
162  {  {
163    stackitem *new_head= NULL, *titem, *iterator;    stackitem *new_head= NULL, *titem;
164      cons *iterator;
165    symbol *tsymb;    symbol *tsymb;
166    int i;    int i;
167    
168    if(env->interactive){    if(env->interactive)
169      printf("Garbage collecting.");      printf("Garbage collecting.");
   }  
170    
171    /* Mark values on stack */    /* Mark values on stack */
172    iterator= env->head;    gc_mark(env->head);
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
173    
174    if(env->interactive){    if(env->interactive)
175      printf(".");      printf(".");
176    }  
177    
178    /* Mark values in hashtable */    /* Mark values in hashtable */
179    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++)
180      tsymb= env->symbols[i];      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
     while(tsymb!=NULL) {  
181        if (tsymb->val != NULL)        if (tsymb->val != NULL)
182          gc_mark(tsymb->val);          gc_mark(tsymb->val);
       tsymb= tsymb->next;  
     }  
   }  
183    
184    if(env->interactive){  
185      if(env->interactive)
186      printf(".");      printf(".");
187    }  
188    
189    env->gc_count= 0;    env->gc_count= 0;
190    
# Line 201  extern void gc_init(environment *env) Line 192  extern void gc_init(environment *env)
192    
193      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
194    
195        switch(env->gc_ref->item->type) { /* Remove content */        if(env->gc_ref->item->type==string) /* Remove content */
       case string:  
196          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
197          break;  
       case list:  
         while(env->gc_ref->item->content.ptr!=NULL) {  
           titem= env->gc_ref->item->content.ptr;  
           env->gc_ref->item->content.ptr= titem->next;  
           free(titem);  
         }  
       default:  
       }  
198        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
199        titem= env->gc_ref->next;        titem= env->gc_ref->next;
200        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
201        env->gc_ref= titem;        env->gc_ref= titem;
202        continue;        continue;
203      } else {      }
204        env->gc_count += sizeof(value);  
205        if(env->gc_ref->item->type == string)      /* Keep values */    
206          env->gc_count += strlen(env->gc_ref->item->content.ptr);      env->gc_count += sizeof(value);
207      }      if(env->gc_ref->item->type==string)
208          env->gc_count += strlen(env->gc_ref->item->content.ptr);
209            
     /* Keep values */  
210      titem= env->gc_ref->next;      titem= env->gc_ref->next;
211      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
212      new_head= env->gc_ref;      new_head= env->gc_ref;
# Line 237  extern void gc_init(environment *env) Line 219  extern void gc_init(environment *env)
219    
220    env->gc_ref= new_head;    env->gc_ref= new_head;
221    
222    if(env->interactive){    if(env->interactive)
223      printf("done\n");      printf("done\n");
   }  
224    
225  }  }
226    
227  /* Protect values from GC */  /* Protect values from GC */
228  void protect(value *val)  void protect(value *val)
229  {  {
230    stackitem *iterator;    if(val==NULL || val->gc.flag.protect)
   
   if(val->gc.flag.protect)  
231      return;      return;
232    
233    val->gc.flag.protect= 1;    val->gc.flag.protect= 1;
234    
235    if(val->type==list) {    if(val->type==tcons) {
236      iterator= val->content.ptr;      protect(CAR(val));
237        protect(CDR(val));
     while(iterator!=NULL) {  
       protect(iterator->item);  
       iterator= iterator->next;  
     }  
238    }    }
239  }  }
240    
241  /* Unprotect values from GC */  /* Unprotect values from GC */
242  void unprotect(value *val)  void unprotect(value *val)
243  {  {
244    stackitem *iterator;    if(val==NULL || !(val->gc.flag.protect))
   
   if(!(val->gc.flag.protect))  
245      return;      return;
246    
247    val->gc.flag.protect= 0;    val->gc.flag.protect= 0;
248    
249    if(val->type==list) {    if(val->type==tcons) {
250      iterator= val->content.ptr;      unprotect(CAR(val));
251        unprotect(CDR(val));
     while(iterator!=NULL) {  
       unprotect(iterator->item);  
       iterator= iterator->next;  
     }  
252    }    }
253  }  }
254    
255  /* Push a value onto the stack */  /* Push a value onto the stack */
256  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
257  {  {
258    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
259    new_item->item= val;  
260    new_item->next= env->head;    new_value->content.c= malloc(sizeof(cons));
261    env->head= new_item;    new_value->type= tcons;
262      CAR(new_value)= val;
263      CDR(new_value)= env->head;
264      env->head= new_value;
265  }  }
266    
267  /* Push an integer onto the stack */  /* Push an integer onto the stack */
# Line 352  extern void mangle(environment *env) Line 324  extern void mangle(environment *env)
324  {  {
325    char *new_string;    char *new_string;
326    
327    if((env->head)==NULL) {    if(env->head==NULL) {
328      printerr("Too Few Arguments");      printerr("Too Few Arguments");
329      env->err= 1;      env->err= 1;
330      return;      return;
331    }    }
332    
333    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
334      printerr("Bad Argument Type");      printerr("Bad Argument Type");
335      env->err= 2;      env->err= 2;
336      return;      return;
337    }    }
338    
339    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
340        mangle_str((const char *)(CAR(env->head)->content.ptr));
341    
342    toss(env);    toss(env);
343    if(env->err) return;    if(env->err) return;
# Line 450  extern void type(environment *env) Line 423  extern void type(environment *env)
423  {  {
424    int typenum;    int typenum;
425    
426    if((env->head)==NULL) {    if(env->head==NULL) {
427      printerr("Too Few Arguments");      printerr("Too Few Arguments");
428      env->err=1;      env->err= 1;
429      return;      return;
430    }    }
431    typenum=env->head->item->type;  
432      typenum= CAR(env->head)->type;
433    toss(env);    toss(env);
434    switch(typenum){    switch(typenum){
435    case integer:    case integer:
# Line 473  extern void type(environment *env) Line 447  extern void type(environment *env)
447    case func:    case func:
448      push_sym(env, "function");      push_sym(env, "function");
449      break;      break;
450    case list:    case tcons:
451      push_sym(env, "list");      push_sym(env, "list");
452      break;      break;
453    }    }
454  }      }    
455    
456  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
457  void print_h(stackitem *stack_head, int noquote)  void print_h(value *stack_head, int noquote)
458  {  {
459    switch(stack_head->item->type) {    switch(CAR(stack_head)->type) {
460    case integer:    case integer:
461      printf("%d", stack_head->item->content.i);      printf("%d", CAR(stack_head)->content.i);
462      break;      break;
463    case tfloat:    case tfloat:
464      printf("%f", stack_head->item->content.f);      printf("%f", CAR(stack_head)->content.f);
465      break;      break;
466    case string:    case string:
467      if(noquote)      if(noquote)
468        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)CAR(stack_head)->content.ptr);
469      else      else
470        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);
471      break;      break;
472    case symb:    case symb:
473      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
474      break;      break;
475    case func:    case func:
476      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
477      break;      break;
478    case list:    case tcons:
479      /* A list is just a stack, so make stack_head point to it */      /* A list is just a stack, so make stack_head point to it */
480      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head= CAR(stack_head);
481      printf("[ ");      printf("[ ");
482      while(stack_head != NULL) {      while(stack_head != NULL) {
483        print_h(stack_head, noquote);        print_h(stack_head, noquote);
484        printf(" ");        printf(" ");
485        stack_head=stack_head->next;        stack_head= CDR(stack_head);
486      }      }
487      printf("]");      printf("]");
488      break;      break;
# Line 519  extern void print_(environment *env) Line 493  extern void print_(environment *env)
493  {  {
494    if(env->head==NULL) {    if(env->head==NULL) {
495      printerr("Too Few Arguments");      printerr("Too Few Arguments");
496      env->err=1;      env->err= 1;
497      return;      return;
498    }    }
499    print_h(env->head, 0);    print_h(env->head, 0);
# Line 538  extern void princ_(environment *env) Line 512  extern void princ_(environment *env)
512  {  {
513    if(env->head==NULL) {    if(env->head==NULL) {
514      printerr("Too Few Arguments");      printerr("Too Few Arguments");
515      env->err=1;      env->err= 1;
516      return;      return;
517    }    }
518    print_h(env->head, 1);    print_h(env->head, 1);
# Line 553  extern void princ(environment *env) Line 527  extern void princ(environment *env)
527  }  }
528    
529  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
530  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
531  {  {
532    if(stack_head->next != NULL)    if(CDR(stack_head) != NULL)
533      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
534    printf("%ld: ", counter);    printf("%ld: ", counter);
535    print_h(stack_head, 0);    print_h(stack_head, 0);
536    nl();    nl();
# Line 576  extern void printstack(environment *env) Line 550  extern void printstack(environment *env)
550  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
551  extern void swap(environment *env)  extern void swap(environment *env)
552  {  {
553    stackitem *temp= env->head;    value *temp= env->head;
554        
555    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
556      printerr("Too Few Arguments");      printerr("Too Few Arguments");
557      env->err=1;      env->err=1;
558      return;      return;
559    }    }
560    
561    env->head= env->head->next;    env->head= CDR(env->head);
562    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
563    env->head->next= temp;    CDR(env->head)= temp;
564  }  }
565    
566  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
567  extern void rot(environment *env)  extern void rot(environment *env)
568  {  {
569    stackitem *temp= env->head;    value *temp= env->head;
570        
571    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
572        || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
573      printerr("Too Few Arguments");      printerr("Too Few Arguments");
574      env->err=1;      env->err= 1;
575      return;      return;
576    }    }
577      
578    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
579    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
580    env->head->next= temp;    CDR(env->head)= temp;
581  }  }
582    
583  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 611  extern void rcl(environment *env) Line 585  extern void rcl(environment *env)
585  {  {
586    value *val;    value *val;
587    
588    if(env->head == NULL) {    if(env->head==NULL) {
589      printerr("Too Few Arguments");      printerr("Too Few Arguments");
590      env->err=1;      env->err= 1;
591      return;      return;
592    }    }
593    
594    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
595      printerr("Bad Argument Type");      printerr("Bad Argument Type");
596      env->err=2;      env->err= 2;
597      return;      return;
598    }    }
599    
600    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
601    if(val == NULL){    if(val == NULL){
602      printerr("Unbound Variable");      printerr("Unbound Variable");
603      env->err=3;      env->err= 3;
604      return;      return;
605    }    }
606    protect(val);    protect(val);
# Line 643  extern void eval(environment *env) Line 617  extern void eval(environment *env)
617  {  {
618    funcp in_func;    funcp in_func;
619    value* temp_val;    value* temp_val;
620    stackitem* iterator;    value* iterator;
621    
622   eval_start:   eval_start:
623    
# Line 651  extern void eval(environment *env) Line 625  extern void eval(environment *env)
625    
626    if(env->head==NULL) {    if(env->head==NULL) {
627      printerr("Too Few Arguments");      printerr("Too Few Arguments");
628      env->err=1;      env->err= 1;
629      return;      return;
630    }    }
631    
632    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
633      /* if it's a symbol */      /* if it's a symbol */
634    case symb:    case symb:
635      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
636      if(env->err) return;      if(env->err) return;
637      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
638        goto eval_start;        goto eval_start;
639      }      }
640      return;      return;
641    
642      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
643    case func:    case func:
644      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
645      toss(env);      toss(env);
646      if(env->err) return;      if(env->err) return;
647      return in_func(env);      return in_func(env);
648    
649      /* If it's a list */      /* If it's a list */
650    case list:    case tcons:
651      temp_val= env->head->item;      temp_val= CAR(env->head);
652      protect(temp_val);      protect(temp_val);
653    
654      toss(env); if(env->err) return;      toss(env); if(env->err) return;
655      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
656            
657      while(iterator!=NULL) {      while(iterator!=NULL) {
658        push_val(env, iterator->item);        push_val(env, CAR(iterator));
659                
660        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
661           && (((symbol*)(env->head->item->content.ptr))->id[0] == ';')) {           && CAR(env->head)->content.sym->id[0]==';') {
662          toss(env);          toss(env);
663          if(env->err) return;          if(env->err) return;
664                    
665          if(iterator->next == NULL){          if(CDR(iterator)==NULL){
666            goto eval_start;            goto eval_start;
667          }          }
668          eval(env);          eval(env);
669          if(env->err) return;          if(env->err) return;
670        }        }
671        iterator= iterator->next;        if (CDR(iterator)->type == tcons)
672            iterator= CDR(iterator);
673          else {
674            printerr("Bad Argument Type"); /* Improper list */
675            env->err= 2;
676            return;
677          }
678      }      }
679      unprotect(temp_val);      unprotect(temp_val);
680      return;      return;
# Line 707  extern void eval(environment *env) Line 687  extern void eval(environment *env)
687  /* Reverse (flip) a list */  /* Reverse (flip) a list */
688  extern void rev(environment *env)  extern void rev(environment *env)
689  {  {
690    stackitem *old_head, *new_head, *item;    value *old_head, *new_head, *item;
691    
692    if((env->head)==NULL) {    if(env->head==NULL) {
693      printerr("Too Few Arguments");      printerr("Too Few Arguments");
694      env->err= 1;      env->err= 1;
695      return;      return;
696    }    }
697    
698    if(env->head->item->type!=list) {    if(CAR(env->head)->type!=tcons) {
699      printerr("Bad Argument Type");      printerr("Bad Argument Type");
700      env->err= 2;      env->err= 2;
701      return;      return;
702    }    }
703    
704    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
705    new_head= NULL;    new_head= NULL;
706    while(old_head != NULL){    while(old_head!=NULL) {
707      item= old_head;      item= old_head;
708      old_head= old_head->next;      old_head= CDR(old_head);
709      item->next= new_head;      CDR(item)= new_head;
710      new_head= item;      new_head= item;
711    }    }
712    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
713  }  }
714    
715  /* Make a list. */  /* Make a list. */
716  extern void pack(environment *env)  extern void pack(environment *env)
717  {  {
718    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
719    
720    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(pack);  
   
721    if(iterator==NULL    if(iterator==NULL
722       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
723       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
724      temp= NULL;      temp= NULL;
725      toss(env);      toss(env);
726    } else {    } else {
727      /* Search for first delimiter */      /* Search for first delimiter */
728      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
729            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
730            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
731        iterator= iterator->next;        iterator= CDR(iterator);
732            
733      /* Extract list */      /* Extract list */
734      temp= env->head;      temp= env->head;
735      env->head= iterator->next;      env->head= CDR(iterator);
736      iterator->next= NULL;      CDR(iterator)= NULL;
737    
     pack->type= list;  
     pack->content.ptr= temp;  
       
738      if(env->head!=NULL)      if(env->head!=NULL)
739        toss(env);        toss(env);
740    }    }
741    
742    /* Push list */    /* Push list */
743    
744    push_val(env, pack);    push_val(env, temp);
745    rev(env);    rev(env);
   
   unprotect(pack);  
746  }  }
747    
748  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
749  extern void expand(environment *env)  extern void expand(environment *env)
750  {  {
751    stackitem *temp, *new_head;    value *temp, *new_head;
752    
753    /* Is top element a list? */    /* Is top element a list? */
754    if(env->head==NULL) {    if(env->head==NULL) {
# Line 785  extern void expand(environment *env) Line 756  extern void expand(environment *env)
756      env->err= 1;      env->err= 1;
757      return;      return;
758    }    }
759    if(env->head->item->type!=list) {  
760      if(CAR(env->head)->type!=tcons) {
761      printerr("Bad Argument Type");      printerr("Bad Argument Type");
762      env->err= 2;      env->err= 2;
763      return;      return;
# Line 797  extern void expand(environment *env) Line 769  extern void expand(environment *env)
769      return;      return;
770    
771    /* The first list element is the new stack head */    /* The first list element is the new stack head */
772    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
773    
774    toss(env);    toss(env);
775    
776    /* Find the end of the list */    /* Find the end of the list */
777    while(temp->next!=NULL)    while(CDR(temp)->content.ptr != NULL) {
778      temp= temp->next;      if (CDR(temp)->type == tcons)
779          temp= CDR(temp);
780        else {
781          printerr("Bad Argument Type"); /* Improper list */
782          env->err= 2;
783          return;
784        }
785      }
786    
787    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
788    temp->next= env->head;    CDR(temp)= env->head;
789    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
790    
791  }  }
# Line 815  extern void expand(environment *env) Line 794  extern void expand(environment *env)
794  extern void eq(environment *env)  extern void eq(environment *env)
795  {  {
796    void *left, *right;    void *left, *right;
   int result;  
797    
798    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
799      printerr("Too Few Arguments");      printerr("Too Few Arguments");
800      env->err= 1;      env->err= 1;
801      return;      return;
802    }    }
803    
804    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
805    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
806    toss(env); toss(env);    toss(env); toss(env);
807    push_int(env, result);  
808      push_int(env, left==right);
809  }  }
810    
811  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 837  extern void not(environment *env) Line 813  extern void not(environment *env)
813  {  {
814    int val;    int val;
815    
816    if((env->head)==NULL) {    if(env->head==NULL) {
817      printerr("Too Few Arguments");      printerr("Too Few Arguments");
818      env->err= 1;      env->err= 1;
819      return;      return;
820    }    }
821    
822    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
823      printerr("Bad Argument Type");      printerr("Bad Argument Type");
824      env->err= 2;      env->err= 2;
825      return;      return;
826    }    }
827    
828    val= env->head->item->content.i;    val= CAR(env->head)->content.i;
829    toss(env);    toss(env);
830    push_int(env, !val);    push_int(env, !val);
831  }  }
# Line 868  extern void def(environment *env) Line 844  extern void def(environment *env)
844    symbol *sym;    symbol *sym;
845    
846    /* Needs two values on the stack, the top one must be a symbol */    /* Needs two values on the stack, the top one must be a symbol */
847    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
848      printerr("Too Few Arguments");      printerr("Too Few Arguments");
849      env->err= 1;      env->err= 1;
850      return;      return;
851    }    }
852    
853    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
854      printerr("Bad Argument Type");      printerr("Bad Argument Type");
855      env->err= 2;      env->err= 2;
856      return;      return;
857    }    }
858    
859    /* long names are a pain */    /* long names are a pain */
860    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
861    
862    /* Bind the symbol to the value */    /* Bind the symbol to the value */
863    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
864    
865    toss(env); toss(env);    toss(env); toss(env);
866  }  }
# Line 910  extern void quit(environment *env) Line 886  extern void quit(environment *env)
886    if(env->free_string!=NULL)    if(env->free_string!=NULL)
887      free(env->free_string);      free(env->free_string);
888        
889    #ifdef __linux__
890    muntrace();    muntrace();
891    #endif
892    
893    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
894  }  }
# Line 953  void forget_sym(symbol **hash_entry) Line 931  void forget_sym(symbol **hash_entry)
931  extern void forget(environment *env)  extern void forget(environment *env)
932  {  {
933    char* sym_id;    char* sym_id;
934    stackitem *stack_head= env->head;    value *stack_head= env->head;
935    
936    if(stack_head==NULL) {    if(stack_head==NULL) {
937      printerr("Too Few Arguments");      printerr("Too Few Arguments");
938      env->err=1;      env->err= 1;
939      return;      return;
940    }    }
941        
942    if(stack_head->item->type!=symb) {    if(CAR(stack_head)->type!=symb) {
943      printerr("Bad Argument Type");      printerr("Bad Argument Type");
944      env->err=2;      env->err= 2;
945      return;      return;
946    }    }
947    
948    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(stack_head)->content.sym->id;
949    toss(env);    toss(env);
950    
951    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 985  int main(int argc, char **argv) Line 963  int main(int argc, char **argv)
963    
964    int c;                        /* getopt option character */    int c;                        /* getopt option character */
965    
966    #ifdef __linux__
967    mtrace();    mtrace();
968    #endif
969    
970    init_env(&myenv);    init_env(&myenv);
971    
# Line 1039  under certain conditions; type `copying; Line 1019  under certain conditions; type `copying;
1019      if (myenv.err==4) {      if (myenv.err==4) {
1020        return EXIT_SUCCESS;      /* EOF */        return EXIT_SUCCESS;      /* EOF */
1021      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1022                && myenv.head->item->type==symb                && CAR(myenv.head)->type==symb
1023                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->content.sym->id[0]
1024                  ==';') {
1025        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1026        eval(&myenv);        eval(&myenv);
1027      }      }
# Line 1059  extern void sx_2b(environment *env) Line 1040  extern void sx_2b(environment *env)
1040    char* new_string;    char* new_string;
1041    value *a_val, *b_val;    value *a_val, *b_val;
1042    
1043    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1044      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1045      env->err= 1;      env->err= 1;
1046      return;      return;
1047    }    }
1048    
1049    if(env->head->item->type==string    if(CAR(env->head)->type==string
1050       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1051      a_val= env->head->item;      a_val= CAR(env->head);
1052      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1053      protect(a_val); protect(b_val);      protect(a_val); protect(b_val);
1054      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1055      toss(env); if(env->err) return;      toss(env); if(env->err) return;
# Line 1083  extern void sx_2b(environment *env) Line 1064  extern void sx_2b(environment *env)
1064      return;      return;
1065    }    }
1066        
1067    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1068       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1069      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1070      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1071      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1072      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1073      push_int(env, b+a);      push_int(env, b+a);
1074    
1075      return;      return;
1076    }    }
1077    
1078    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1079       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1080      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1081      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1082      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1083      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1084      push_float(env, fb+fa);      push_float(env, fb+fa);
1085            
1086      return;      return;
1087    }    }
1088    
1089    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1090       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1091      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1092      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1093      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1094      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1095      push_float(env, b+fa);      push_float(env, b+fa);
1096            
1097      return;      return;
1098    }    }
1099    
1100    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1101       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1102      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1103      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1104      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1105      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1106      push_float(env, fb+a);      push_float(env, fb+a);
1107    
# Line 1137  extern void sx_2d(environment *env) Line 1118  extern void sx_2d(environment *env)
1118    int a, b;    int a, b;
1119    float fa, fb;    float fa, fb;
1120    
1121    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1122      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1123      env->err=1;      env->err=1;
1124      return;      return;
1125    }    }
1126        
1127    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1128       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1129      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1130      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1131      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1132      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1133      push_int(env, b-a);      push_int(env, b-a);
1134    
1135      return;      return;
1136    }    }
1137    
1138    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1139       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1140      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1141      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1142      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1143      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1144      push_float(env, fb-fa);      push_float(env, fb-fa);
1145            
1146      return;      return;
1147    }    }
1148    
1149    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1150       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1151      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1152      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1153      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1154      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1155      push_float(env, b-fa);      push_float(env, b-fa);
1156            
1157      return;      return;
1158    }    }
1159    
1160    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1161       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1162      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1163      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1164      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1165      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1166      push_float(env, fb-a);      push_float(env, fb-a);
1167    
# Line 1197  extern void sx_3e(environment *env) Line 1178  extern void sx_3e(environment *env)
1178    int a, b;    int a, b;
1179    float fa, fb;    float fa, fb;
1180    
1181    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1182      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1183      env->err=1;      env->err= 1;
1184      return;      return;
1185    }    }
1186        
1187    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1188       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1189      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1190      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1191      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1192      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1193      push_int(env, b>a);      push_int(env, b>a);
1194    
1195      return;      return;
1196    }    }
1197    
1198    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1199       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1200      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1201      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1202      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1203      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1204      push_int(env, fb>fa);      push_int(env, fb>fa);
1205            
1206      return;      return;
1207    }    }
1208    
1209    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1210       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1211      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1212      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1213      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1214      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1215      push_int(env, b>fa);      push_int(env, b>fa);
1216            
1217      return;      return;
1218    }    }
1219    
1220    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1221       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1222      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1223      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1224      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1225      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1226      push_int(env, fb>a);      push_int(env, fb>a);
1227    
# Line 1248  extern void sx_3e(environment *env) Line 1229  extern void sx_3e(environment *env)
1229    }    }
1230    
1231    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1232    env->err=2;    env->err= 2;
1233  }  }
1234    
1235  /* "<" */  /* "<" */
# Line 1275  extern void sx_3e3d(environment *env) Line 1256  extern void sx_3e3d(environment *env)
1256  /* Return copy of a value */  /* Return copy of a value */
1257  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
1258  {  {
   stackitem *old_item, *new_item, *prev_item;  
1259    value *new_value;    value *new_value;
1260    
1261      if(old_value==NULL)
1262        return NULL;
1263    
1264    protect(old_value);    protect(old_value);
1265    new_value= new_val(env);    new_value= new_val(env);
1266    protect(new_value);    protect(new_value);
# Line 1294  value *copy_val(environment *env, value Line 1277  value *copy_val(environment *env, value
1277      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1278        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1279      break;      break;
1280    case list:    case tcons:
1281      new_value->content.ptr= NULL;      new_value= NULL;
1282    
1283      prev_item= NULL;      new_value->content.c= malloc(sizeof(cons));
1284      old_item= (stackitem*)(old_value->content.ptr);      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1285        CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
     while(old_item != NULL) {   /* While list is not empty */  
       new_item= malloc(sizeof(stackitem));  
       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;  
     }      
1286      break;      break;
1287    }    }
1288    
# Line 1323  value *copy_val(environment *env, value Line 1294  value *copy_val(environment *env, value
1294  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1295  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1296  {  {
1297    if((env->head)==NULL) {    if(env->head==NULL) {
1298      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1299      env->err= 1;      env->err= 1;
1300      return;      return;
1301    }    }
1302    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1303  }  }
1304    
1305  /* "if", If-Then */  /* "if", If-Then */
# Line 1336  extern void sx_6966(environment *env) Line 1307  extern void sx_6966(environment *env)
1307  {  {
1308    int truth;    int truth;
1309    
1310    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1311      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1312      env->err= 1;      env->err= 1;
1313      return;      return;
1314    }    }
1315    
1316    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1317      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1318      env->err=2;      env->err= 2;
1319      return;      return;
1320    }    }
1321        
1322    swap(env);    swap(env);
1323    if(env->err) return;    if(env->err) return;
1324        
1325    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1326    
1327    toss(env);    toss(env);
1328    if(env->err) return;    if(env->err) return;
# Line 1367  extern void ifelse(environment *env) Line 1338  extern void ifelse(environment *env)
1338  {  {
1339    int truth;    int truth;
1340    
1341    if((env->head)==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1342       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1343      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1344      env->err=1;      env->err= 1;
1345      return;      return;
1346    }    }
1347    
1348    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1349      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1350      env->err=2;      env->err= 2;
1351      return;      return;
1352    }    }
1353        
1354    rot(env);    rot(env);
1355    if(env->err) return;    if(env->err) return;
1356        
1357    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1358    
1359    toss(env);    toss(env);
1360    if(env->err) return;    if(env->err) return;
# Line 1398  extern void ifelse(environment *env) Line 1369  extern void ifelse(environment *env)
1369    eval(env);    eval(env);
1370  }  }
1371    
1372    extern void sx_656c7365(environment *env)
1373    {
1374      if(env->head==NULL || CDR(env->head)==NULL
1375         || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL) {
1376        printerr("Too Few Arguments");
1377        env->err= 1;
1378        return;
1379      }
1380    
1381      if(CAR(CDR(env->head))->type!=symb
1382         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1383        printerr("Bad Argument Type");
1384        env->err= 2;
1385        return;
1386      }
1387    
1388      swap(env); toss(env);
1389      ifelse(env);
1390    }
1391    
1392  /* "while" */  /* "while" */
1393  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1394  {  {
1395    int truth;    int truth;
1396    value *loop, *test;    value *loop, *test;
1397    
1398    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1399      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1400      env->err=1;      env->err= 1;
1401      return;      return;
1402    }    }
1403    
1404    loop= env->head->item;    loop= CAR(env->head);
1405    protect(loop);    protect(loop);
1406    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1407    
1408    test= env->head->item;    test= CAR(env->head);
1409    protect(test);    protect(test);
1410    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1411    
# Line 1422  extern void sx_7768696c65(environment *e Line 1413  extern void sx_7768696c65(environment *e
1413      push_val(env, test);      push_val(env, test);
1414      eval(env);      eval(env);
1415            
1416      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1417        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1418        env->err= 2;        env->err= 2;
1419        return;        return;
1420      }      }
1421            
1422      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1423      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1424            
1425      if(truth) {      if(truth) {
# Line 1450  extern void sx_666f72(environment *env) Line 1441  extern void sx_666f72(environment *env)
1441    value *loop;    value *loop;
1442    int foo1, foo2;    int foo1, foo2;
1443    
1444    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1445       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1446      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1447      env->err= 1;      env->err= 1;
1448      return;      return;
1449    }    }
1450    
1451    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1452       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1453      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1454      env->err= 2;      env->err= 2;
1455      return;      return;
1456    }    }
1457    
1458    loop= env->head->item;    loop= CAR(env->head);
1459    protect(loop);    protect(loop);
1460    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1461    
1462    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1463    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1464    
1465    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1466    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1467    
1468    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1496  extern void sx_666f72(environment *env) Line 1487  extern void sx_666f72(environment *env)
1487  extern void foreach(environment *env)  extern void foreach(environment *env)
1488  {    {  
1489    value *loop, *foo;    value *loop, *foo;
1490    stackitem *iterator;    value *iterator;
1491        
1492    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1493      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1494      env->err= 1;      env->err= 1;
1495      return;      return;
1496    }    }
1497    
1498    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1499      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1500      env->err= 2;      env->err= 2;
1501      return;      return;
1502    }    }
1503    
1504    loop= env->head->item;    loop= CAR(env->head);
1505    protect(loop);    protect(loop);
1506    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1507    
1508    foo= env->head->item;    foo= CAR(env->head);
1509    protect(foo);    protect(foo);
1510    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1511    
1512    iterator= foo->content.ptr;    iterator= foo;
1513    
1514    while(iterator!=NULL) {    while(iterator!=NULL) {
1515      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1516      push_val(env, loop);      push_val(env, loop);
1517      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1518      iterator= iterator->next;      if (iterator->type == tcons){
1519          iterator= CDR(iterator);
1520        } else {
1521          printerr("Bad Argument Type"); /* Improper list */
1522          env->err= 2;
1523          break;
1524        }
1525    }    }
1526    unprotect(loop); unprotect(foo);    unprotect(loop); unprotect(foo);
1527  }  }
# Line 1533  extern void foreach(environment *env) Line 1530  extern void foreach(environment *env)
1530  extern void to(environment *env)  extern void to(environment *env)
1531  {  {
1532    int ending, start, i;    int ending, start, i;
1533    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
1534    
1535    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1536      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1537      env->err=1;      env->err= 1;
1538      return;      return;
1539    }    }
1540    
1541    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1542       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1543      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1544      env->err=2;      env->err= 2;
1545      return;      return;
1546    }    }
1547    
1548    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1549    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1550    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1551    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1552    
1553    push_sym(env, "[");    push_sym(env, "[");
# Line 1565  extern void to(environment *env) Line 1561  extern void to(environment *env)
1561    }    }
1562    
1563    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(pack);  
1564    
1565    if(iterator==NULL    if(iterator==NULL
1566       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
1567       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1568      temp= NULL;      temp= NULL;
1569      toss(env);      toss(env);
1570    } else {    } else {
1571      /* Search for first delimiter */      /* Search for first delimiter */
1572      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
1573            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
1574            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1575        iterator= iterator->next;        iterator= CDR(iterator);
1576            
1577      /* Extract list */      /* Extract list */
1578      temp= env->head;      temp= env->head;
1579      env->head= iterator->next;      env->head= CDR(iterator);
1580      iterator->next= NULL;      CDR(iterator)= NULL;
1581    
     pack->type= list;  
     pack->content.ptr= temp;  
       
1582      if(env->head!=NULL)      if(env->head!=NULL)
1583        toss(env);        toss(env);
1584    }    }
1585    
1586    /* Push list */    /* Push list */
1587      push_val(env, temp);
   push_val(env, pack);  
   
   unprotect(pack);  
1588  }  }
1589    
1590  /* Read a string */  /* Read a string */
# Line 1635  extern void sx_72656164(environment *env Line 1623  extern void sx_72656164(environment *env
1623      }      }
1624      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1625    
1626      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1627        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1628        return;        return;
1629      }      }
1630            
1631      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1632      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1633      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1634      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1635    }    }
1636        
# Line 1691  extern void sx_72656164(environment *env Line 1679  extern void sx_72656164(environment *env
1679      return sx_72656164(env);      return sx_72656164(env);
1680  }  }
1681    
1682    #ifdef __linux__
1683  extern void beep(environment *env)  extern void beep(environment *env)
1684  {  {
1685    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1686    
1687    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1688      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1689      env->err=1;      env->err= 1;
1690      return;      return;
1691    }    }
1692    
1693    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1694       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1695      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1696      env->err=2;      env->err= 2;
1697      return;      return;
1698    }    }
1699    
1700    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1701    toss(env);    toss(env);
1702    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
1703    toss(env);    toss(env);
1704    
1705    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1706                                     length */                                     length */
1707    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1708                                     timer ticks */                                     timer ticks */
1709    
1710  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1711    
1712    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1713    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1714    case 0:    case 0:
1715      usleep(dur);      usleep(dur);
1716      return;      return;
1717    case -1:    case -1:
1718      perror("beep");      perror("beep");
1719      env->err=5;      env->err= 5;
1720      return;      return;
1721    default:    default:
1722      abort();      abort();
1723    }    }
1724  }  }
1725    #endif /* __linux__ */
1726    
1727  /* "wait" */  /* "wait" */
1728  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
1729  {  {
1730    int dur;    int dur;
1731    
1732    if((env->head)==NULL) {    if(env->head==NULL) {
1733      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1734      env->err=1;      env->err= 1;
1735      return;      return;
1736    }    }
1737    
1738    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1739      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1740      env->err=2;      env->err= 2;
1741      return;      return;
1742    }    }
1743    
1744    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1745    toss(env);    toss(env);
1746    
1747    usleep(dur);    usleep(dur);
# Line 2048  extern void sx_2a(environment *env) Line 2038  extern void sx_2a(environment *env)
2038    int a, b;    int a, b;
2039    float fa, fb;    float fa, fb;
2040    
2041    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2042      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2043      env->err=1;      env->err= 1;
2044      return;      return;
2045    }    }
2046        
2047    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2048       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2049      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2050      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2051      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2052      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2053      push_int(env, b*a);      push_int(env, b*a);
2054    
2055      return;      return;
2056    }    }
2057    
2058    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2059       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2060      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2061      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2062      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2063      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2064      push_float(env, fb*fa);      push_float(env, fb*fa);
2065            
2066      return;      return;
2067    }    }
2068    
2069    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2070       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2071      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2072      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2073      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2074      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2075      push_float(env, b*fa);      push_float(env, b*fa);
2076            
2077      return;      return;
2078    }    }
2079    
2080    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2081       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2082      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2083      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2084      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2085      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2086      push_float(env, fb*a);      push_float(env, fb*a);
2087    
# Line 2099  extern void sx_2a(environment *env) Line 2089  extern void sx_2a(environment *env)
2089    }    }
2090    
2091    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2092    env->err=2;    env->err= 2;
2093  }  }
2094    
2095  /* "/" */  /* "/" */
# Line 2108  extern void sx_2f(environment *env) Line 2098  extern void sx_2f(environment *env)
2098    int a, b;    int a, b;
2099    float fa, fb;    float fa, fb;
2100    
2101    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2102      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2103      env->err=1;      env->err= 1;
2104      return;      return;
2105    }    }
2106        
2107    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2108       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2109      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2110      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2111      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2112      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2113      push_float(env, b/a);      push_float(env, b/a);
2114    
2115      return;      return;
2116    }    }
2117    
2118    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2119       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2120      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2121      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2122      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2123      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2124      push_float(env, fb/fa);      push_float(env, fb/fa);
2125            
2126      return;      return;
2127    }    }
2128    
2129    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2130       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2131      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2132      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2133      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2134      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2135      push_float(env, b/fa);      push_float(env, b/fa);
2136            
2137      return;      return;
2138    }    }
2139    
2140    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2141       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2142      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2143      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2144      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2145      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2146      push_float(env, fb/a);      push_float(env, fb/a);
2147    
# Line 2159  extern void sx_2f(environment *env) Line 2149  extern void sx_2f(environment *env)
2149    }    }
2150    
2151    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2152    env->err=2;    env->err= 2;
2153  }  }
2154    
2155  /* "mod" */  /* "mod" */
# Line 2167  extern void mod(environment *env) Line 2157  extern void mod(environment *env)
2157  {  {
2158    int a, b;    int a, b;
2159    
2160    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2161      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2162      env->err= 1;      env->err= 1;
2163      return;      return;
2164    }    }
2165        
2166    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2167       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2168      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2169      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2170      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2171      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2172      push_int(env, b%a);      push_int(env, b%a);
2173    
# Line 2185  extern void mod(environment *env) Line 2175  extern void mod(environment *env)
2175    }    }
2176    
2177    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2178    env->err=2;    env->err= 2;
2179  }  }
2180    
2181  /* "div" */  /* "div" */
# Line 2193  extern void sx_646976(environment *env) Line 2183  extern void sx_646976(environment *env)
2183  {  {
2184    int a, b;    int a, b;
2185        
2186    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2187      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2188      env->err= 1;      env->err= 1;
2189      return;      return;
2190    }    }
2191    
2192    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2193       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2194      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2195      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2196      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2197      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2198      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2199    
Legend:
Removed from v.1.101  
changed lines
  Added in v.1.107
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26