/[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.109 by masse, Thu Mar 14 10:39: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    /* 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         || CDR(CDR(CDR(CDR(env->head))))==NULL) {
1381        printerr("Too Few Arguments");
1382        env->err= 1;
1383        return;
1384      }
1385    
1386      if(CAR(CDR(env->head))->type!=symb
1387         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1388         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1389         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1390        printerr("Bad Argument Type");
1391        env->err= 2;
1392        return;
1393      }
1394    
1395      swap(env); toss(env); rot(env); toss(env);
1396      ifelse(env);
1397    }
1398    
1399    extern void then(environment *env)
1400    {
1401      if(env->head==NULL || CDR(env->head)==NULL
1402         || CDR(CDR(env->head))==NULL) {
1403        printerr("Too Few Arguments");
1404        env->err= 1;
1405        return;
1406      }
1407    
1408      if(CAR(CDR(env->head))->type!=symb
1409         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1410        printerr("Bad Argument Type");
1411        env->err= 2;
1412        return;
1413      }
1414    
1415      swap(env); toss(env);
1416      sx_6966(env);
1417    }
1418    
1419  /* "while" */  /* "while" */
1420  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1421  {  {
1422    int truth;    int truth;
1423    value *loop, *test;    value *loop, *test;
1424    
1425    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1426      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1427      env->err=1;      env->err= 1;
1428      return;      return;
1429    }    }
1430    
1431    loop= env->head->item;    loop= CAR(env->head);
1432    protect(loop);    protect(loop);
1433    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1434    
1435    test= env->head->item;    test= CAR(env->head);
1436    protect(test);    protect(test);
1437    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1438    
# Line 1422  extern void sx_7768696c65(environment *e Line 1440  extern void sx_7768696c65(environment *e
1440      push_val(env, test);      push_val(env, test);
1441      eval(env);      eval(env);
1442            
1443      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1444        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1445        env->err= 2;        env->err= 2;
1446        return;        return;
1447      }      }
1448            
1449      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1450      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1451            
1452      if(truth) {      if(truth) {
# Line 1450  extern void sx_666f72(environment *env) Line 1468  extern void sx_666f72(environment *env)
1468    value *loop;    value *loop;
1469    int foo1, foo2;    int foo1, foo2;
1470    
1471    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1472       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1473      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1474      env->err= 1;      env->err= 1;
1475      return;      return;
1476    }    }
1477    
1478    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1479       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1480      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1481      env->err= 2;      env->err= 2;
1482      return;      return;
1483    }    }
1484    
1485    loop= env->head->item;    loop= CAR(env->head);
1486    protect(loop);    protect(loop);
1487    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1488    
1489    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1490    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1491    
1492    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1493    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1494    
1495    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1496  extern void sx_666f72(environment *env) Line 1514  extern void sx_666f72(environment *env)
1514  extern void foreach(environment *env)  extern void foreach(environment *env)
1515  {    {  
1516    value *loop, *foo;    value *loop, *foo;
1517    stackitem *iterator;    value *iterator;
1518        
1519    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1520      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1521      env->err= 1;      env->err= 1;
1522      return;      return;
1523    }    }
1524    
1525    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1526      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1527      env->err= 2;      env->err= 2;
1528      return;      return;
1529    }    }
1530    
1531    loop= env->head->item;    loop= CAR(env->head);
1532    protect(loop);    protect(loop);
1533    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1534    
1535    foo= env->head->item;    foo= CAR(env->head);
1536    protect(foo);    protect(foo);
1537    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1538    
1539    iterator= foo->content.ptr;    iterator= foo;
1540    
1541    while(iterator!=NULL) {    while(iterator!=NULL) {
1542      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1543      push_val(env, loop);      push_val(env, loop);
1544      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1545      iterator= iterator->next;      if (iterator->type == tcons){
1546          iterator= CDR(iterator);
1547        } else {
1548          printerr("Bad Argument Type"); /* Improper list */
1549          env->err= 2;
1550          break;
1551        }
1552    }    }
1553    unprotect(loop); unprotect(foo);    unprotect(loop); unprotect(foo);
1554  }  }
# Line 1533  extern void foreach(environment *env) Line 1557  extern void foreach(environment *env)
1557  extern void to(environment *env)  extern void to(environment *env)
1558  {  {
1559    int ending, start, i;    int ending, start, i;
1560    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
1561    
1562    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1563      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1564      env->err=1;      env->err= 1;
1565      return;      return;
1566    }    }
1567    
1568    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1569       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1570      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1571      env->err=2;      env->err= 2;
1572      return;      return;
1573    }    }
1574    
1575    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1576    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1577    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1578    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1579    
1580    push_sym(env, "[");    push_sym(env, "[");
# Line 1565  extern void to(environment *env) Line 1588  extern void to(environment *env)
1588    }    }
1589    
1590    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(pack);  
1591    
1592    if(iterator==NULL    if(iterator==NULL
1593       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
1594       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1595      temp= NULL;      temp= NULL;
1596      toss(env);      toss(env);
1597    } else {    } else {
1598      /* Search for first delimiter */      /* Search for first delimiter */
1599      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
1600            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
1601            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1602        iterator= iterator->next;        iterator= CDR(iterator);
1603            
1604      /* Extract list */      /* Extract list */
1605      temp= env->head;      temp= env->head;
1606      env->head= iterator->next;      env->head= CDR(iterator);
1607      iterator->next= NULL;      CDR(iterator)= NULL;
1608    
     pack->type= list;  
     pack->content.ptr= temp;  
       
1609      if(env->head!=NULL)      if(env->head!=NULL)
1610        toss(env);        toss(env);
1611    }    }
1612    
1613    /* Push list */    /* Push list */
1614      push_val(env, temp);
   push_val(env, pack);  
   
   unprotect(pack);  
1615  }  }
1616    
1617  /* Read a string */  /* Read a string */
# Line 1635  extern void sx_72656164(environment *env Line 1650  extern void sx_72656164(environment *env
1650      }      }
1651      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1652    
1653      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1654        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1655        return;        return;
1656      }      }
1657            
1658      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1659      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1660      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1661      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1662    }    }
1663        
# Line 1691  extern void sx_72656164(environment *env Line 1706  extern void sx_72656164(environment *env
1706      return sx_72656164(env);      return sx_72656164(env);
1707  }  }
1708    
1709    #ifdef __linux__
1710  extern void beep(environment *env)  extern void beep(environment *env)
1711  {  {
1712    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1713    
1714    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1715      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1716      env->err=1;      env->err= 1;
1717      return;      return;
1718    }    }
1719    
1720    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1721       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1722      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1723      env->err=2;      env->err= 2;
1724      return;      return;
1725    }    }
1726    
1727    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1728    toss(env);    toss(env);
1729    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
1730    toss(env);    toss(env);
1731    
1732    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1733                                     length */                                     length */
1734    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1735                                     timer ticks */                                     timer ticks */
1736    
1737  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1738    
1739    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1740    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1741    case 0:    case 0:
1742      usleep(dur);      usleep(dur);
1743      return;      return;
1744    case -1:    case -1:
1745      perror("beep");      perror("beep");
1746      env->err=5;      env->err= 5;
1747      return;      return;
1748    default:    default:
1749      abort();      abort();
1750    }    }
1751  }  }
1752    #endif /* __linux__ */
1753    
1754  /* "wait" */  /* "wait" */
1755  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
1756  {  {
1757    int dur;    int dur;
1758    
1759    if((env->head)==NULL) {    if(env->head==NULL) {
1760      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1761      env->err=1;      env->err= 1;
1762      return;      return;
1763    }    }
1764    
1765    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1766      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1767      env->err=2;      env->err= 2;
1768      return;      return;
1769    }    }
1770    
1771    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1772    toss(env);    toss(env);
1773    
1774    usleep(dur);    usleep(dur);
# Line 2048  extern void sx_2a(environment *env) Line 2065  extern void sx_2a(environment *env)
2065    int a, b;    int a, b;
2066    float fa, fb;    float fa, fb;
2067    
2068    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2069      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2070      env->err=1;      env->err= 1;
2071      return;      return;
2072    }    }
2073        
2074    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2075       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2076      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2077      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2078      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2079      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2080      push_int(env, b*a);      push_int(env, b*a);
2081    
2082      return;      return;
2083    }    }
2084    
2085    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2086       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2087      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2088      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2089      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2090      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2091      push_float(env, fb*fa);      push_float(env, fb*fa);
2092            
2093      return;      return;
2094    }    }
2095    
2096    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2097       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2098      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2099      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2100      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2101      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2102      push_float(env, b*fa);      push_float(env, b*fa);
2103            
2104      return;      return;
2105    }    }
2106    
2107    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2108       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
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      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2112      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2113      push_float(env, fb*a);      push_float(env, fb*a);
2114    
# Line 2099  extern void sx_2a(environment *env) Line 2116  extern void sx_2a(environment *env)
2116    }    }
2117    
2118    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2119    env->err=2;    env->err= 2;
2120  }  }
2121    
2122  /* "/" */  /* "/" */
# Line 2108  extern void sx_2f(environment *env) Line 2125  extern void sx_2f(environment *env)
2125    int a, b;    int a, b;
2126    float fa, fb;    float fa, fb;
2127    
2128    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2129      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2130      env->err=1;      env->err= 1;
2131      return;      return;
2132    }    }
2133        
2134    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2135       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2136      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2137      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2138      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2139      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2140      push_float(env, b/a);      push_float(env, b/a);
2141    
2142      return;      return;
2143    }    }
2144    
2145    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2146       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2147      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2148      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2149      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2150      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2151      push_float(env, fb/fa);      push_float(env, fb/fa);
2152            
2153      return;      return;
2154    }    }
2155    
2156    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2157       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2158      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2159      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2160      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2161      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2162      push_float(env, b/fa);      push_float(env, b/fa);
2163            
2164      return;      return;
2165    }    }
2166    
2167    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2168       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2169      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2170      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2171      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2172      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2173      push_float(env, fb/a);      push_float(env, fb/a);
2174    
# Line 2159  extern void sx_2f(environment *env) Line 2176  extern void sx_2f(environment *env)
2176    }    }
2177    
2178    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2179    env->err=2;    env->err= 2;
2180  }  }
2181    
2182  /* "mod" */  /* "mod" */
# Line 2167  extern void mod(environment *env) Line 2184  extern void mod(environment *env)
2184  {  {
2185    int a, b;    int a, b;
2186    
2187    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2188      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2189      env->err= 1;      env->err= 1;
2190      return;      return;
2191    }    }
2192        
2193    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2194       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2195      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2196      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2197      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2198      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2199      push_int(env, b%a);      push_int(env, b%a);
2200    
# Line 2185  extern void mod(environment *env) Line 2202  extern void mod(environment *env)
2202    }    }
2203    
2204    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2205    env->err=2;    env->err= 2;
2206  }  }
2207    
2208  /* "div" */  /* "div" */
# Line 2193  extern void sx_646976(environment *env) Line 2210  extern void sx_646976(environment *env)
2210  {  {
2211    int a, b;    int a, b;
2212        
2213    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2214      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2215      env->err= 1;      env->err= 1;
2216      return;      return;
2217    }    }
2218    
2219    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2220       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2221      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2222      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2223      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2224      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2225      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2226    
Legend:
Removed from v.1.101  
changed lines
  Added in v.1.109
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26