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