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

Diff of /stack/stack.c

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

revision 1.95 by masse, Sun Mar 10 06:34:01 2002 UTC revision 1.105 by masse, Tue Mar 12 14:53:19 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 48  void init_env(environment *env) Line 51  void init_env(environment *env)
51  {  {
52    int i;    int i;
53    
54    env->gc_limit= 20;    env->gc_limit= 400000;
55    env->gc_count= 0;    env->gc_count= 0;
56    env->gc_ref= NULL;    env->gc_ref= NULL;
   env->gc_protect= NULL;  
57    
58    env->head= NULL;    env->head= NULL;
59    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
# Line 71  void printerr(const char* in_string) Line 73  void printerr(const char* in_string)
73  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
74  extern void toss(environment *env)  extern void toss(environment *env)
75  {  {
76    stackitem *temp= env->head;    if(env->head==NULL) {
   
   if((env->head)==NULL) {  
77      printerr("Too Few Arguments");      printerr("Too Few Arguments");
78      env->err= 1;      env->err= 1;
79      return;      return;
80    }    }
81        
82    env->head= env->head->next;   /* Remove the top stack item */    env->head= CDR(env->head); /* Remove the top stack item */
   free(temp);                   /* Free the old top stack item */  
   
   env->gc_limit--;  
   gc_init(env);  
83  }  }
84    
85  /* 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 125  value* new_val(environment *env) Line 121  value* new_val(environment *env)
121    
122    nitem->item= nval;    nitem->item= nval;
123    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
   env->gc_ref= nitem;  
124    
125    env->gc_count++;    env->gc_ref= nitem;
126    
127    protect(env, nval);    env->gc_count += sizeof(value);
128    gc_init(env);    nval->gc.flag.mark= 0;
129    unprotect(env);    nval->gc.flag.protect= 0;
130    
131    return nval;    return nval;
132  }  }
133    
134  /* Mark values recursively.  /* Mark values recursively.
135     Marked values are not collected by the GC. */     Marked values are not collected by the GC. */
136  void gc_mark(value *val)  inline void gc_mark(value *val)
137  {  {
138    stackitem *iterator;    if(val==NULL || val->gc.flag.mark)
   
   if(val==NULL || val->gc_garb==0)  
139      return;      return;
140    
141    val->gc_garb= 0;    val->gc.flag.mark= 1;
142    
143    if(val->type==list) {    if(val->type==tcons) {
144      iterator= val->content.ptr;      gc_mark(CAR(val));
145        gc_mark(CDR(val));
     while(iterator!=NULL) {  
       gc_mark(iterator->item);  
       iterator= iterator->next;  
     }  
146    }    }
147  }  }
148    
149    inline void gc_maybe(environment *env)
150    {
151      if(env->gc_count < env->gc_limit)
152        return;
153      else
154        return gc_init(env);
155    }
156    
157  /* Start GC */  /* Start GC */
158  extern void gc_init(environment *env)  extern void gc_init(environment *env)
159  {  {
160    stackitem *new_head= NULL, *titem, *iterator;    stackitem *new_head= NULL, *titem;
161      cons *iterator;
162    symbol *tsymb;    symbol *tsymb;
163    int i;    int i;
164    
165    if(env->gc_count < env->gc_limit)    if(env->interactive)
166      return;      printf("Garbage collecting.");
167    
168    /* Garb by default */    /* Mark values on stack */
169    iterator= env->gc_ref;    gc_mark(env->head);
   while(iterator!=NULL) {  
     iterator->item->gc_garb= 1;  
     iterator= iterator->next;  
   }  
170    
171    /* Mark protected values */    if(env->interactive)
172    iterator= env->gc_protect;      printf(".");
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
173    
   /* Mark values on stack */  
   iterator= env->head;  
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
174    
175    /* Mark values in hashtable */    /* Mark values in hashtable */
176    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++)
177      tsymb= env->symbols[i];      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
178      while(tsymb!=NULL) {        if (tsymb->val != NULL)
179        gc_mark(tsymb->val);          gc_mark(tsymb->val);
180        tsymb= tsymb->next;  
181      }  
182    }    if(env->interactive)
183        printf(".");
184    
185    
186    env->gc_count= 0;    env->gc_count= 0;
187    
188    while(env->gc_ref!=NULL) {    /* Sweep unused values */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
189    
190      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
191    
192        switch(env->gc_ref->item->type) { /* Remove content */        if(env->gc_ref->item->type==string) /* Remove content */
       case string:  
193          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
194          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);  
         }  
         break;  
       default:  
         break;  
       }  
195        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
196        titem= env->gc_ref->next;        titem= env->gc_ref->next;
197        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
198        env->gc_ref= titem;        env->gc_ref= titem;
199      } else {                    /* Keep values */        continue;
200        titem= env->gc_ref->next;      }
201        env->gc_ref->next= new_head;  
202        new_head= env->gc_ref;      /* Keep values */    
203        env->gc_ref= titem;      env->gc_count += sizeof(value);
204        env->gc_count++;      if(env->gc_ref->item->type==string)
205      }        env->gc_count += strlen(env->gc_ref->item->content.ptr);
206        
207        titem= env->gc_ref->next;
208        env->gc_ref->next= new_head;
209        new_head= env->gc_ref;
210        new_head->item->gc.flag.mark= 0;
211        env->gc_ref= titem;
212    }    }
213    
214    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
215        env->gc_limit= env->gc_count*2;
216    
217    env->gc_ref= new_head;    env->gc_ref= new_head;
218    
219      if(env->interactive)
220        printf("done\n");
221    
222  }  }
223    
224  /* Protect values from GC */  /* Protect values from GC */
225  void protect(environment *env, value *val)  void protect(value *val)
226  {  {
227    stackitem *new_item= malloc(sizeof(stackitem));    if(val==NULL || val->gc.flag.protect)
228    new_item->item= val;      return;
229    new_item->next= env->gc_protect;  
230    env->gc_protect= new_item;    val->gc.flag.protect= 1;
231    
232      if(val->type==tcons) {
233        protect(CAR(val));
234        protect(CDR(val));
235      }
236  }  }
237    
238  /* Unprotect values from GC */  /* Unprotect values from GC */
239  void unprotect(environment *env)  void unprotect(value *val)
240  {  {
241    stackitem *temp= env->gc_protect;    if(val==NULL || !(val->gc.flag.protect))
242    env->gc_protect= env->gc_protect->next;      return;
243    free(temp);  
244      val->gc.flag.protect= 0;
245    
246      if(val->type==tcons) {
247        unprotect(CAR(val));
248        unprotect(CDR(val));
249      }
250  }  }
251    
252  /* Push a value onto the stack */  /* Push a value onto the stack */
253  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
254  {  {
255    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
256    new_item->item= val;  
257    new_item->next= env->head;    new_value->content.c= malloc(sizeof(cons));
258    env->head= new_item;    new_value->type= tcons;
259      CAR(new_value)= val;
260      CDR(new_value)= env->head;
261      env->head= new_value;
262  }  }
263    
264  /* Push an integer onto the stack */  /* Push an integer onto the stack */
# Line 286  void push_float(environment *env, float Line 287  void push_float(environment *env, float
287  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
288  {  {
289    value *new_value= new_val(env);    value *new_value= new_val(env);
290      int length= strlen(in_string)+1;
291    
292    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
293      env->gc_count += length;
294    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
295    new_value->type= string;    new_value->type= string;
296    
# Line 318  extern void mangle(environment *env) Line 321  extern void mangle(environment *env)
321  {  {
322    char *new_string;    char *new_string;
323    
324    if((env->head)==NULL) {    if(env->head==NULL) {
325      printerr("Too Few Arguments");      printerr("Too Few Arguments");
326      env->err= 1;      env->err= 1;
327      return;      return;
328    }    }
329    
330    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
331      printerr("Bad Argument Type");      printerr("Bad Argument Type");
332      env->err= 2;      env->err= 2;
333      return;      return;
334    }    }
335    
336    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
337        mangle_str((const char *)(CAR(env->head)->content.ptr));
338    
339    toss(env);    toss(env);
340    if(env->err) return;    if(env->err) return;
# Line 354  void push_sym(environment *env, const ch Line 358  void push_sym(environment *env, const ch
358    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
359    
360    new_value= new_val(env);    new_value= new_val(env);
361    protect(env, new_value);    protect(new_value);
362    new_fvalue= new_val(env);    new_fvalue= new_val(env);
363    protect(env, new_fvalue);    protect(new_fvalue);
364    
365    /* The new value is a symbol */    /* The new value is a symbol */
366    new_value->type= symb;    new_value->type= symb;
# Line 402  void push_sym(environment *env, const ch Line 406  void push_sym(environment *env, const ch
406    }    }
407    
408    push_val(env, new_value);    push_val(env, new_value);
409    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
410  }  }
411    
412  /* Print newline. */  /* Print newline. */
# Line 416  extern void type(environment *env) Line 420  extern void type(environment *env)
420  {  {
421    int typenum;    int typenum;
422    
423    if((env->head)==NULL) {    if(env->head==NULL) {
424      printerr("Too Few Arguments");      printerr("Too Few Arguments");
425      env->err=1;      env->err= 1;
426      return;      return;
427    }    }
428    typenum=env->head->item->type;  
429      typenum= CAR(env->head)->type;
430    toss(env);    toss(env);
431    switch(typenum){    switch(typenum){
432    case integer:    case integer:
# Line 439  extern void type(environment *env) Line 444  extern void type(environment *env)
444    case func:    case func:
445      push_sym(env, "function");      push_sym(env, "function");
446      break;      break;
447    case list:    case tcons:
448      push_sym(env, "list");      push_sym(env, "list");
449      break;      break;
450    }    }
451  }      }    
452    
453  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
454  void print_h(stackitem *stack_head, int noquote)  void print_h(value *stack_head, int noquote)
455  {  {
456    switch(stack_head->item->type) {    switch(CAR(stack_head)->type) {
457    case integer:    case integer:
458      printf("%d", stack_head->item->content.i);      printf("%d", CAR(stack_head)->content.i);
459      break;      break;
460    case tfloat:    case tfloat:
461      printf("%f", stack_head->item->content.f);      printf("%f", CAR(stack_head)->content.f);
462      break;      break;
463    case string:    case string:
464      if(noquote)      if(noquote)
465        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)CAR(stack_head)->content.ptr);
466      else      else
467        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);
468      break;      break;
469    case symb:    case symb:
470      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
471      break;      break;
472    case func:    case func:
473      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
474      break;      break;
475    case list:    case tcons:
476      /* 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 */
477      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head= CAR(stack_head);
478      printf("[ ");      printf("[ ");
479      while(stack_head != NULL) {      while(stack_head != NULL) {
480        print_h(stack_head, noquote);        print_h(stack_head, noquote);
481        printf(" ");        printf(" ");
482        stack_head=stack_head->next;        stack_head= CDR(stack_head);
483      }      }
484      printf("]");      printf("]");
485      break;      break;
# Line 485  extern void print_(environment *env) Line 490  extern void print_(environment *env)
490  {  {
491    if(env->head==NULL) {    if(env->head==NULL) {
492      printerr("Too Few Arguments");      printerr("Too Few Arguments");
493      env->err=1;      env->err= 1;
494      return;      return;
495    }    }
496    print_h(env->head, 0);    print_h(env->head, 0);
# Line 504  extern void princ_(environment *env) Line 509  extern void princ_(environment *env)
509  {  {
510    if(env->head==NULL) {    if(env->head==NULL) {
511      printerr("Too Few Arguments");      printerr("Too Few Arguments");
512      env->err=1;      env->err= 1;
513      return;      return;
514    }    }
515    print_h(env->head, 1);    print_h(env->head, 1);
# Line 519  extern void princ(environment *env) Line 524  extern void princ(environment *env)
524  }  }
525    
526  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
527  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
528  {  {
529    if(stack_head->next != NULL)    if(CDR(stack_head) != NULL)
530      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
531    printf("%ld: ", counter);    printf("%ld: ", counter);
532    print_h(stack_head, 0);    print_h(stack_head, 0);
533    nl();    nl();
# Line 542  extern void printstack(environment *env) Line 547  extern void printstack(environment *env)
547  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
548  extern void swap(environment *env)  extern void swap(environment *env)
549  {  {
550    stackitem *temp= env->head;    value *temp= env->head;
551        
552    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
553      printerr("Too Few Arguments");      printerr("Too Few Arguments");
554      env->err=1;      env->err=1;
555      return;      return;
556    }    }
557    
558    env->head= env->head->next;    env->head= CDR(env->head);
559    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
560    env->head->next= temp;    CDR(env->head)= temp;
561  }  }
562    
563  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
564  extern void rot(environment *env)  extern void rot(environment *env)
565  {  {
566    stackitem *temp= env->head;    value *temp= env->head;
567        
568    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
569        || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
570      printerr("Too Few Arguments");      printerr("Too Few Arguments");
571      env->err=1;      env->err= 1;
572      return;      return;
573    }    }
574      
575    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
576    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
577    env->head->next= temp;    CDR(env->head)= temp;
578  }  }
579    
580  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 577  extern void rcl(environment *env) Line 582  extern void rcl(environment *env)
582  {  {
583    value *val;    value *val;
584    
585    if(env->head == NULL) {    if(env->head==NULL) {
586      printerr("Too Few Arguments");      printerr("Too Few Arguments");
587      env->err=1;      env->err= 1;
588      return;      return;
589    }    }
590    
591    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
592      printerr("Bad Argument Type");      printerr("Bad Argument Type");
593      env->err=2;      env->err= 2;
594      return;      return;
595    }    }
596    
597    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
598    if(val == NULL){    if(val == NULL){
599      printerr("Unbound Variable");      printerr("Unbound Variable");
600      env->err=3;      env->err= 3;
601      return;      return;
602    }    }
603    protect(env, val);    protect(val);
604    toss(env);            /* toss the symbol */    toss(env);            /* toss the symbol */
605    if(env->err) return;    if(env->err) return;
606    push_val(env, val); /* Return its bound value */    push_val(env, val); /* Return its bound value */
607    unprotect(env);    unprotect(val);
608  }  }
609    
610  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
# Line 609  extern void eval(environment *env) Line 614  extern void eval(environment *env)
614  {  {
615    funcp in_func;    funcp in_func;
616    value* temp_val;    value* temp_val;
617    stackitem* iterator;    value* iterator;
618    
619   eval_start:   eval_start:
620    
621      gc_maybe(env);
622    
623    if(env->head==NULL) {    if(env->head==NULL) {
624      printerr("Too Few Arguments");      printerr("Too Few Arguments");
625      env->err=1;      env->err= 1;
626      return;      return;
627    }    }
628    
629    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
630      /* if it's a symbol */      /* if it's a symbol */
631    case symb:    case symb:
632      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
633      if(env->err) return;      if(env->err) return;
634      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
635        goto eval_start;        goto eval_start;
636      }      }
637      return;      return;
638    
639      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
640    case func:    case func:
641      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
642      toss(env);      toss(env);
643      if(env->err) return;      if(env->err) return;
644      return in_func(env);      return in_func(env);
645    
646      /* If it's a list */      /* If it's a list */
647    case list:    case tcons:
648      temp_val= env->head->item;      temp_val= CAR(env->head);
649      protect(env, temp_val);      protect(temp_val);
650    
651      toss(env); if(env->err) return;      toss(env); if(env->err) return;
652      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
653            
654      while(iterator!=NULL) {      while(iterator!=NULL) {
655        push_val(env, iterator->item);        push_val(env, CAR(iterator));
656                
657        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
658          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
659          toss(env);          toss(env);
660          if(env->err) return;          if(env->err) return;
661                    
662          if(iterator->next == NULL){          if(CDR(iterator)==NULL){
663            goto eval_start;            goto eval_start;
664          }          }
665          eval(env);          eval(env);
666          if(env->err) return;          if(env->err) return;
667        }        }
668        iterator= iterator->next;        if (CDR(iterator)->type == tcons)
669            iterator= CDR(iterator);
670          else {
671            printerr("Bad Argument Type"); /* Improper list */
672            env->err= 2;
673            return;
674          }
675      }      }
676      unprotect(env);      unprotect(temp_val);
677      return;      return;
678    
679    default:    default:
# Line 671  extern void eval(environment *env) Line 684  extern void eval(environment *env)
684  /* Reverse (flip) a list */  /* Reverse (flip) a list */
685  extern void rev(environment *env)  extern void rev(environment *env)
686  {  {
687    stackitem *old_head, *new_head, *item;    value *old_head, *new_head, *item;
688    
689    if((env->head)==NULL) {    if(env->head==NULL) {
690      printerr("Too Few Arguments");      printerr("Too Few Arguments");
691      env->err= 1;      env->err= 1;
692      return;      return;
693    }    }
694    
695    if(env->head->item->type!=list) {    if(CAR(env->head)->type!=tcons) {
696      printerr("Bad Argument Type");      printerr("Bad Argument Type");
697      env->err= 2;      env->err= 2;
698      return;      return;
699    }    }
700    
701    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
702    new_head= NULL;    new_head= NULL;
703    while(old_head != NULL){    while(old_head!=NULL) {
704      item= old_head;      item= old_head;
705      old_head= old_head->next;      old_head= CDR(old_head);
706      item->next= new_head;      CDR(item)= new_head;
707      new_head= item;      new_head= item;
708    }    }
709    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
710  }  }
711    
712  /* Make a list. */  /* Make a list. */
713  extern void pack(environment *env)  extern void pack(environment *env)
714  {  {
715    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
716    
717    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(env, pack);  
   
718    if(iterator==NULL    if(iterator==NULL
719       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
720       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
721      temp= NULL;      temp= NULL;
722      toss(env);      toss(env);
723    } else {    } else {
724      /* Search for first delimiter */      /* Search for first delimiter */
725      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
726            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
727            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
728        iterator= iterator->next;        iterator= CDR(iterator);
729            
730      /* Extract list */      /* Extract list */
731      temp= env->head;      temp= env->head;
732      env->head= iterator->next;      env->head= CDR(iterator);
733      iterator->next= NULL;      CDR(iterator)= NULL;
734    
     pack->type= list;  
     pack->content.ptr= temp;  
       
735      if(env->head!=NULL)      if(env->head!=NULL)
736        toss(env);        toss(env);
737    }    }
738    
739    /* Push list */    /* Push list */
740    
741    push_val(env, pack);    push_val(env, temp);
742    rev(env);    rev(env);
   
   unprotect(env);  
743  }  }
744    
745  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
746  extern void expand(environment *env)  extern void expand(environment *env)
747  {  {
748    stackitem *temp, *new_head;    value *temp, *new_head;
749    
750    /* Is top element a list? */    /* Is top element a list? */
751    if(env->head==NULL) {    if(env->head==NULL) {
# Line 749  extern void expand(environment *env) Line 753  extern void expand(environment *env)
753      env->err= 1;      env->err= 1;
754      return;      return;
755    }    }
756    if(env->head->item->type!=list) {  
757      if(CAR(env->head)->type!=tcons) {
758      printerr("Bad Argument Type");      printerr("Bad Argument Type");
759      env->err= 2;      env->err= 2;
760      return;      return;
# Line 761  extern void expand(environment *env) Line 766  extern void expand(environment *env)
766      return;      return;
767    
768    /* The first list element is the new stack head */    /* The first list element is the new stack head */
769    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
770    
771    toss(env);    toss(env);
772    
773    /* Find the end of the list */    /* Find the end of the list */
774    while(temp->next!=NULL)    while(CDR(temp)->content.ptr != NULL) {
775      temp= temp->next;      if (CDR(temp)->type == tcons)
776          temp= CDR(temp);
777        else {
778          printerr("Bad Argument Type"); /* Improper list */
779          env->err= 2;
780          return;
781        }
782      }
783    
784    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
785    temp->next= env->head;    CDR(temp)= env->head;
786    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
787    
788  }  }
# Line 779  extern void expand(environment *env) Line 791  extern void expand(environment *env)
791  extern void eq(environment *env)  extern void eq(environment *env)
792  {  {
793    void *left, *right;    void *left, *right;
   int result;  
794    
795    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
796      printerr("Too Few Arguments");      printerr("Too Few Arguments");
797      env->err= 1;      env->err= 1;
798      return;      return;
799    }    }
800    
801    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
802    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
803    toss(env); toss(env);    toss(env); toss(env);
804    push_int(env, result);  
805      push_int(env, left==right);
806  }  }
807    
808  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 801  extern void not(environment *env) Line 810  extern void not(environment *env)
810  {  {
811    int val;    int val;
812    
813    if((env->head)==NULL) {    if(env->head==NULL) {
814      printerr("Too Few Arguments");      printerr("Too Few Arguments");
815      env->err= 1;      env->err= 1;
816      return;      return;
817    }    }
818    
819    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
820      printerr("Bad Argument Type");      printerr("Bad Argument Type");
821      env->err= 2;      env->err= 2;
822      return;      return;
823    }    }
824    
825    val= env->head->item->content.i;    val= CAR(env->head)->content.i;
826    toss(env);    toss(env);
827    push_int(env, !val);    push_int(env, !val);
828  }  }
# Line 832  extern void def(environment *env) Line 841  extern void def(environment *env)
841    symbol *sym;    symbol *sym;
842    
843    /* 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 */
844    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
845      printerr("Too Few Arguments");      printerr("Too Few Arguments");
846      env->err= 1;      env->err= 1;
847      return;      return;
848    }    }
849    
850    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
851      printerr("Bad Argument Type");      printerr("Bad Argument Type");
852      env->err= 2;      env->err= 2;
853      return;      return;
854    }    }
855    
856    /* long names are a pain */    /* long names are a pain */
857    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
858    
859    /* Bind the symbol to the value */    /* Bind the symbol to the value */
860    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
861    
862    toss(env); toss(env);    toss(env); toss(env);
863  }  }
# Line 869  extern void quit(environment *env) Line 878  extern void quit(environment *env)
878    }    }
879    
880    env->gc_limit= 0;    env->gc_limit= 0;
881    gc_init(env);    gc_maybe(env);
882    
883    if(env->free_string!=NULL)    if(env->free_string!=NULL)
884      free(env->free_string);      free(env->free_string);
# Line 917  void forget_sym(symbol **hash_entry) Line 926  void forget_sym(symbol **hash_entry)
926  extern void forget(environment *env)  extern void forget(environment *env)
927  {  {
928    char* sym_id;    char* sym_id;
929    stackitem *stack_head= env->head;    value *stack_head= env->head;
930    
931    if(stack_head==NULL) {    if(stack_head==NULL) {
932      printerr("Too Few Arguments");      printerr("Too Few Arguments");
933      env->err=1;      env->err= 1;
934      return;      return;
935    }    }
936        
937    if(stack_head->item->type!=symb) {    if(CAR(stack_head)->type!=symb) {
938      printerr("Bad Argument Type");      printerr("Bad Argument Type");
939      env->err=2;      env->err= 2;
940      return;      return;
941    }    }
942    
943    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(stack_head)->content.sym->id;
944    toss(env);    toss(env);
945    
946    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 1003  under certain conditions; type `copying; Line 1012  under certain conditions; type `copying;
1012      if (myenv.err==4) {      if (myenv.err==4) {
1013        return EXIT_SUCCESS;      /* EOF */        return EXIT_SUCCESS;      /* EOF */
1014      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1015                && myenv.head->item->type==symb                && CAR(myenv.head)->type==symb
1016                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->content.sym->id[0]
1017                  ==';') {
1018        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1019        eval(&myenv);        eval(&myenv);
1020      }      }
1021      gc_init(&myenv);      gc_maybe(&myenv);
1022    }    }
1023    quit(&myenv);    quit(&myenv);
1024    return EXIT_FAILURE;    return EXIT_FAILURE;
# Line 1023  extern void sx_2b(environment *env) Line 1033  extern void sx_2b(environment *env)
1033    char* new_string;    char* new_string;
1034    value *a_val, *b_val;    value *a_val, *b_val;
1035    
1036    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1037      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1038      env->err= 1;      env->err= 1;
1039      return;      return;
1040    }    }
1041    
1042    if(env->head->item->type==string    if(CAR(env->head)->type==string
1043       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1044      a_val= env->head->item;      a_val= CAR(env->head);
1045      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1046      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1047      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1048      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1049      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
# Line 1041  extern void sx_2b(environment *env) Line 1051  extern void sx_2b(environment *env)
1051      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1052      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1053      push_cstring(env, new_string);      push_cstring(env, new_string);
1054      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1055      free(new_string);      free(new_string);
1056            
1057      return;      return;
1058    }    }
1059        
1060    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1061       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1062      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1063      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1064      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1065      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1066      push_int(env, b+a);      push_int(env, b+a);
1067    
1068      return;      return;
1069    }    }
1070    
1071    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1072       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1073      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1074      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1075      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1076      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1077      push_float(env, fb+fa);      push_float(env, fb+fa);
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==integer) {       && CAR(CDR(env->head))->type==integer) {
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      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1087      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1088      push_float(env, b+fa);      push_float(env, b+fa);
1089            
1090      return;      return;
1091    }    }
1092    
1093    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1094       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1095      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1096      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1097      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1098      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1099      push_float(env, fb+a);      push_float(env, fb+a);
1100    
# Line 1101  extern void sx_2d(environment *env) Line 1111  extern void sx_2d(environment *env)
1111    int a, b;    int a, b;
1112    float fa, fb;    float fa, fb;
1113    
1114    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1115      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1116      env->err=1;      env->err=1;
1117      return;      return;
1118    }    }
1119        
1120    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1121       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1122      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1123      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1124      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1125      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1126      push_int(env, b-a);      push_int(env, b-a);
1127    
1128      return;      return;
1129    }    }
1130    
1131    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1132       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1133      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1134      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1135      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1136      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1137      push_float(env, fb-fa);      push_float(env, fb-fa);
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==integer) {       && CAR(CDR(env->head))->type==integer) {
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      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1147      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1148      push_float(env, b-fa);      push_float(env, b-fa);
1149            
1150      return;      return;
1151    }    }
1152    
1153    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1154       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1155      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1156      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1157      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1158      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1159      push_float(env, fb-a);      push_float(env, fb-a);
1160    
# Line 1161  extern void sx_3e(environment *env) Line 1171  extern void sx_3e(environment *env)
1171    int a, b;    int a, b;
1172    float fa, fb;    float fa, fb;
1173    
1174    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1175      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1176      env->err=1;      env->err= 1;
1177      return;      return;
1178    }    }
1179        
1180    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1181       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1182      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1183      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1184      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1185      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1186      push_int(env, b>a);      push_int(env, b>a);
1187    
1188      return;      return;
1189    }    }
1190    
1191    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1192       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1193      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1194      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1195      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1196      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1197      push_int(env, fb>fa);      push_int(env, fb>fa);
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==integer) {       && CAR(CDR(env->head))->type==integer) {
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      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1207      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1208      push_int(env, b>fa);      push_int(env, b>fa);
1209            
1210      return;      return;
1211    }    }
1212    
1213    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1214       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1215      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1216      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1217      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1218      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1219      push_int(env, fb>a);      push_int(env, fb>a);
1220    
# Line 1212  extern void sx_3e(environment *env) Line 1222  extern void sx_3e(environment *env)
1222    }    }
1223    
1224    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1225    env->err=2;    env->err= 2;
1226  }  }
1227    
1228  /* "<" */  /* "<" */
# Line 1239  extern void sx_3e3d(environment *env) Line 1249  extern void sx_3e3d(environment *env)
1249  /* Return copy of a value */  /* Return copy of a value */
1250  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
1251  {  {
   stackitem *old_item, *new_item, *prev_item;  
1252    value *new_value;    value *new_value;
1253    
1254    protect(env, old_value);    if(old_value==NULL)
1255        return NULL;
1256    
1257      protect(old_value);
1258    new_value= new_val(env);    new_value= new_val(env);
1259    protect(env, new_value);    protect(new_value);
1260    new_value->type= old_value->type;    new_value->type= old_value->type;
1261    
1262    switch(old_value->type){    switch(old_value->type){
# Line 1258  value *copy_val(environment *env, value Line 1270  value *copy_val(environment *env, value
1270      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1271        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1272      break;      break;
1273    case list:    case tcons:
1274      new_value->content.ptr= NULL;      new_value= NULL;
   
     prev_item= NULL;  
     old_item= (stackitem*)(old_value->content.ptr);  
1275    
1276      while(old_item != NULL) {   /* While list is not empty */      new_value->content.c= malloc(sizeof(cons));
1277        new_item= malloc(sizeof(stackitem));      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1278        new_item->item= copy_val(env, old_item->item); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* 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;  
     }      
1279      break;      break;
1280    }    }
1281    
1282    unprotect(env); unprotect(env);    unprotect(old_value); unprotect(new_value);
1283    
1284    return new_value;    return new_value;
1285  }  }
# Line 1287  value *copy_val(environment *env, value Line 1287  value *copy_val(environment *env, value
1287  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1288  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1289  {  {
1290    if((env->head)==NULL) {    if(env->head==NULL) {
1291      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1292      env->err= 1;      env->err= 1;
1293      return;      return;
1294    }    }
1295    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1296  }  }
1297    
1298  /* "if", If-Then */  /* "if", If-Then */
# Line 1300  extern void sx_6966(environment *env) Line 1300  extern void sx_6966(environment *env)
1300  {  {
1301    int truth;    int truth;
1302    
1303    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1304      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1305      env->err= 1;      env->err= 1;
1306      return;      return;
1307    }    }
1308    
1309    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1310      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1311      env->err=2;      env->err= 2;
1312      return;      return;
1313    }    }
1314        
1315    swap(env);    swap(env);
1316    if(env->err) return;    if(env->err) return;
1317        
1318    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1319    
1320    toss(env);    toss(env);
1321    if(env->err) return;    if(env->err) return;
# Line 1331  extern void ifelse(environment *env) Line 1331  extern void ifelse(environment *env)
1331  {  {
1332    int truth;    int truth;
1333    
1334    if((env->head)==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1335       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1336      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1337      env->err=1;      env->err= 1;
1338      return;      return;
1339    }    }
1340    
1341    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1342      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1343      env->err=2;      env->err= 2;
1344      return;      return;
1345    }    }
1346        
1347    rot(env);    rot(env);
1348    if(env->err) return;    if(env->err) return;
1349        
1350    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1351    
1352    toss(env);    toss(env);
1353    if(env->err) return;    if(env->err) return;
# Line 1368  extern void sx_7768696c65(environment *e Line 1368  extern void sx_7768696c65(environment *e
1368    int truth;    int truth;
1369    value *loop, *test;    value *loop, *test;
1370    
1371    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1372      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1373      env->err=1;      env->err= 1;
1374      return;      return;
1375    }    }
1376    
1377    loop= env->head->item;    loop= CAR(env->head);
1378    protect(env, loop);    protect(loop);
1379    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1380    
1381    test= env->head->item;    test= CAR(env->head);
1382    protect(env, test);    protect(test);
1383    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1384    
1385    do {    do {
1386      push_val(env, test);      push_val(env, test);
1387      eval(env);      eval(env);
1388            
1389      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1390        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1391        env->err= 2;        env->err= 2;
1392        return;        return;
1393      }      }
1394            
1395      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1396      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1397            
1398      if(truth) {      if(truth) {
# Line 1404  extern void sx_7768696c65(environment *e Line 1404  extern void sx_7768696c65(environment *e
1404        
1405    } while(truth);    } while(truth);
1406    
1407    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1408  }  }
1409    
1410    
# Line 1414  extern void sx_666f72(environment *env) Line 1414  extern void sx_666f72(environment *env)
1414    value *loop;    value *loop;
1415    int foo1, foo2;    int foo1, foo2;
1416    
1417    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1418       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1419      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1420      env->err= 1;      env->err= 1;
1421      return;      return;
1422    }    }
1423    
1424    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1425       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1426      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1427      env->err= 2;      env->err= 2;
1428      return;      return;
1429    }    }
1430    
1431    loop= env->head->item;    loop= CAR(env->head);
1432    protect(env, loop);    protect(loop);
1433    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1434    
1435    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1436    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1437    
1438    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1439    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1440    
1441    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1453  extern void sx_666f72(environment *env) Line 1453  extern void sx_666f72(environment *env)
1453        foo1--;        foo1--;
1454      }      }
1455    }    }
1456    unprotect(env);    unprotect(loop);
1457  }  }
1458    
1459  /* Variant of for-loop */  /* Variant of for-loop */
1460  extern void foreach(environment *env)  extern void foreach(environment *env)
1461  {    {  
1462    value *loop, *foo;    value *loop, *foo;
1463    stackitem *iterator;    value *iterator;
1464        
1465    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1466      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1467      env->err= 1;      env->err= 1;
1468      return;      return;
1469    }    }
1470    
1471    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1472      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1473      env->err= 2;      env->err= 2;
1474      return;      return;
1475    }    }
1476    
1477    loop= env->head->item;    loop= CAR(env->head);
1478    protect(env, loop);    protect(loop);
1479    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1480    
1481    foo= env->head->item;    foo= CAR(env->head);
1482    protect(env, foo);    protect(foo);
1483    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1484    
1485    iterator= foo->content.ptr;    iterator= foo;
1486    
1487    while(iterator!=NULL) {    while(iterator!=NULL) {
1488      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1489      push_val(env, loop);      push_val(env, loop);
1490      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1491      iterator= iterator->next;      if (iterator->type == tcons){
1492          iterator= CDR(iterator);
1493        } else {
1494          printerr("Bad Argument Type"); /* Improper list */
1495          env->err= 2;
1496          break;
1497        }
1498    }    }
1499    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1500  }  }
1501    
1502  /* "to" */  /* "to" */
1503  extern void to(environment *env)  extern void to(environment *env)
1504  {  {
1505    int ending, start, i;    int ending, start, i;
1506    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
1507    
1508    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1509      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1510      env->err=1;      env->err= 1;
1511      return;      return;
1512    }    }
1513    
1514    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1515       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1516      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1517      env->err=2;      env->err= 2;
1518      return;      return;
1519    }    }
1520    
1521    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1522    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1523    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1524    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1525    
1526    push_sym(env, "[");    push_sym(env, "[");
# Line 1529  extern void to(environment *env) Line 1534  extern void to(environment *env)
1534    }    }
1535    
1536    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(env, pack);  
1537    
1538    if(iterator==NULL    if(iterator==NULL
1539       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
1540       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1541      temp= NULL;      temp= NULL;
1542      toss(env);      toss(env);
1543    } else {    } else {
1544      /* Search for first delimiter */      /* Search for first delimiter */
1545      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
1546            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
1547            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1548        iterator= iterator->next;        iterator= CDR(iterator);
1549            
1550      /* Extract list */      /* Extract list */
1551      temp= env->head;      temp= env->head;
1552      env->head= iterator->next;      env->head= CDR(iterator);
1553      iterator->next= NULL;      CDR(iterator)= NULL;
1554    
     pack->type= list;  
     pack->content.ptr= temp;  
       
1555      if(env->head!=NULL)      if(env->head!=NULL)
1556        toss(env);        toss(env);
1557    }    }
1558    
1559    /* Push list */    /* Push list */
1560      push_val(env, temp);
   push_val(env, pack);  
   
   unprotect(env);  
1561  }  }
1562    
1563  /* Read a string */  /* Read a string */
# Line 1599  extern void sx_72656164(environment *env Line 1596  extern void sx_72656164(environment *env
1596      }      }
1597      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1598    
1599      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1600        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1601        return;        return;
1602      }      }
1603            
1604      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1605      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1606      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1607      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1608    }    }
1609        
# Line 1659  extern void beep(environment *env) Line 1656  extern void beep(environment *env)
1656  {  {
1657    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1658    
1659    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1660      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1661      env->err=1;      env->err= 1;
1662      return;      return;
1663    }    }
1664    
1665    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1666       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1667      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1668      env->err=2;      env->err= 2;
1669      return;      return;
1670    }    }
1671    
1672    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1673    toss(env);    toss(env);
1674    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
1675    toss(env);    toss(env);
1676    
1677    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1678                                     length */                                     length */
1679    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1680                                     timer ticks */                                     timer ticks */
1681    
1682  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1683    
1684    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1685    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1686    case 0:    case 0:
1687      usleep(dur);      usleep(dur);
1688      return;      return;
1689    case -1:    case -1:
1690      perror("beep");      perror("beep");
1691      env->err=5;      env->err= 5;
1692      return;      return;
1693    default:    default:
1694      abort();      abort();
# Line 1703  extern void sx_77616974(environment *env Line 1700  extern void sx_77616974(environment *env
1700  {  {
1701    int dur;    int dur;
1702    
1703    if((env->head)==NULL) {    if(env->head==NULL) {
1704      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1705      env->err=1;      env->err= 1;
1706      return;      return;
1707    }    }
1708    
1709    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1710      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1711      env->err=2;      env->err= 2;
1712      return;      return;
1713    }    }
1714    
1715    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1716    toss(env);    toss(env);
1717    
1718    usleep(dur);    usleep(dur);
# Line 2012  extern void sx_2a(environment *env) Line 2009  extern void sx_2a(environment *env)
2009    int a, b;    int a, b;
2010    float fa, fb;    float fa, fb;
2011    
2012    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2013      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2014      env->err=1;      env->err= 1;
2015      return;      return;
2016    }    }
2017        
2018    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2019       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2020      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2021      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2022      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2023      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2024      push_int(env, b*a);      push_int(env, b*a);
2025    
2026      return;      return;
2027    }    }
2028    
2029    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2030       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2031      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2032      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2033      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2034      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2035      push_float(env, fb*fa);      push_float(env, fb*fa);
2036            
2037      return;      return;
2038    }    }
2039    
2040    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2041       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2042      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2043      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2044      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2045      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2046      push_float(env, b*fa);      push_float(env, b*fa);
2047            
2048      return;      return;
2049    }    }
2050    
2051    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2052       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
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      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2056      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2057      push_float(env, fb*a);      push_float(env, fb*a);
2058    
# Line 2063  extern void sx_2a(environment *env) Line 2060  extern void sx_2a(environment *env)
2060    }    }
2061    
2062    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2063    env->err=2;    env->err= 2;
2064  }  }
2065    
2066  /* "/" */  /* "/" */
# Line 2072  extern void sx_2f(environment *env) Line 2069  extern void sx_2f(environment *env)
2069    int a, b;    int a, b;
2070    float fa, fb;    float fa, fb;
2071    
2072    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2073      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2074      env->err=1;      env->err= 1;
2075      return;      return;
2076    }    }
2077        
2078    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2079       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2080      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2081      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2082      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2083      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2084      push_float(env, b/a);      push_float(env, b/a);
2085    
2086      return;      return;
2087    }    }
2088    
2089    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2090       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2091      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2092      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2093      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2094      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2095      push_float(env, fb/fa);      push_float(env, fb/fa);
2096            
2097      return;      return;
2098    }    }
2099    
2100    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2101       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2102      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2103      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2104      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2105      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2106      push_float(env, b/fa);      push_float(env, b/fa);
2107            
2108      return;      return;
2109    }    }
2110    
2111    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2112       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
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      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2116      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2117      push_float(env, fb/a);      push_float(env, fb/a);
2118    
# Line 2123  extern void sx_2f(environment *env) Line 2120  extern void sx_2f(environment *env)
2120    }    }
2121    
2122    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2123    env->err=2;    env->err= 2;
2124  }  }
2125    
2126  /* "mod" */  /* "mod" */
# Line 2131  extern void mod(environment *env) Line 2128  extern void mod(environment *env)
2128  {  {
2129    int a, b;    int a, b;
2130    
2131    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2132      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2133      env->err= 1;      env->err= 1;
2134      return;      return;
2135    }    }
2136        
2137    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2138       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2139      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2140      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2141      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2142      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2143      push_int(env, b%a);      push_int(env, b%a);
2144    
# Line 2149  extern void mod(environment *env) Line 2146  extern void mod(environment *env)
2146    }    }
2147    
2148    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2149    env->err=2;    env->err= 2;
2150  }  }
2151    
2152  /* "div" */  /* "div" */
# Line 2157  extern void sx_646976(environment *env) Line 2154  extern void sx_646976(environment *env)
2154  {  {
2155    int a, b;    int a, b;
2156        
2157    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2158      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2159      env->err= 1;      env->err= 1;
2160      return;      return;
2161    }    }
2162    
2163    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2164       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2165      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2166      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2167      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2168      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2169      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2170    
Legend:
Removed from v.1.95  
changed lines
  Added in v.1.105
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26