/[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.102 by masse, Sun Mar 10 20:08:47 2002 UTC
# Line 70  void printerr(const char* in_string) Line 70  void printerr(const char* in_string)
70  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
71  extern void toss(environment *env)  extern void toss(environment *env)
72  {  {
73    stackitem *temp= env->head;    cons *temp= env->head;
74    
75    if((env->head)==NULL) {    if(env->head==NULL) {
76      printerr("Too Few Arguments");      printerr("Too Few Arguments");
77      env->err= 1;      env->err= 1;
78      return;      return;
79    }    }
80        
81    env->head= env->head->next;   /* Remove the top stack item */    env->head= env->head->cdr->content.c; /* Remove the top stack item */
82    free(temp);                   /* Free the old top stack item */    free(temp);                   /* Free the old top stack item */
83  }  }
84    
# Line 121  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;
124    
125    env->gc_ref= nitem;    env->gc_ref= nitem;
126    
127    env->gc_count += sizeof(value);    env->gc_count += sizeof(value);
# Line 134  value* new_val(environment *env) Line 135  value* new_val(environment *env)
135     Marked values are not collected by the GC. */     Marked values are not collected by the GC. */
136  inline void gc_mark(value *val)  inline void gc_mark(value *val)
137  {  {
138    stackitem *iterator;    if(val==NULL || val->gc.flag.mark)
   
   if(val->gc.flag.mark)  
139      return;      return;
140    
141    val->gc.flag.mark= 1;    val->gc.flag.mark= 1;
142    
143    if(val->type==list) {    if(val->type==tcons && val->content.c!=NULL) {
144      iterator= val->content.ptr;      gc_mark(val->content.c->car);
145        gc_mark(val->content.c->cdr);
     while(iterator!=NULL) {  
       gc_mark(iterator->item);  
       iterator= iterator->next;  
     }  
146    }    }
147  }  }
148    
# Line 162  inline void gc_maybe(environment *env) Line 157  inline void gc_maybe(environment *env)
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->interactive){    if(env->interactive)
166      printf("Garbage collecting.");      printf("Garbage collecting.");
   }  
167    
168    /* Mark values on stack */    /* Mark values on stack */
169    iterator= env->head;    if(env->head!=NULL) {
170    while(iterator!=NULL) {      gc_mark(env->head->car);
171      gc_mark(iterator->item);      gc_mark(env->head->cdr);
     iterator= iterator->next;  
172    }    }
173    
174    if(env->interactive){    if(env->interactive)
175      printf(".");      printf(".");
176    }  
177    
178    /* Mark values in hashtable */    /* Mark values in hashtable */
179    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++)
180      tsymb= env->symbols[i];      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
     while(tsymb!=NULL) {  
181        if (tsymb->val != NULL)        if (tsymb->val != NULL)
182          gc_mark(tsymb->val);          gc_mark(tsymb->val);
       tsymb= tsymb->next;  
     }  
   }  
183    
184    if(env->interactive){  
185      if(env->interactive)
186      printf(".");      printf(".");
187    }  
188    
189    env->gc_count= 0;    env->gc_count= 0;
190    
# Line 201  extern void gc_init(environment *env) Line 192  extern void gc_init(environment *env)
192    
193      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
194    
195        switch(env->gc_ref->item->type) { /* Remove content */        if(env->gc_ref->item->type==string) /* Remove content */
       case string:  
196          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
197          break;  
       case list:  
         while(env->gc_ref->item->content.ptr!=NULL) {  
           titem= env->gc_ref->item->content.ptr;  
           env->gc_ref->item->content.ptr= titem->next;  
           free(titem);  
         }  
       default:  
       }  
198        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
199        titem= env->gc_ref->next;        titem= env->gc_ref->next;
200        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
201        env->gc_ref= titem;        env->gc_ref= titem;
202        continue;        continue;
203      } else {      }
204        env->gc_count += sizeof(value);  
205        if(env->gc_ref->item->type == string)      /* Keep values */    
206          env->gc_count += strlen(env->gc_ref->item->content.ptr);      env->gc_count += sizeof(value);
207      }      if(env->gc_ref->item->type==string)
208          env->gc_count += strlen(env->gc_ref->item->content.ptr);
209            
     /* Keep values */  
210      titem= env->gc_ref->next;      titem= env->gc_ref->next;
211      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
212      new_head= env->gc_ref;      new_head= env->gc_ref;
# Line 237  extern void gc_init(environment *env) Line 219  extern void gc_init(environment *env)
219    
220    env->gc_ref= new_head;    env->gc_ref= new_head;
221    
222    if(env->interactive){    if(env->interactive)
223      printf("done\n");      printf("done\n");
   }  
224    
225  }  }
226    
227  /* Protect values from GC */  /* Protect values from GC */
228  void protect(value *val)  void protect(value *val)
229  {  {
230    stackitem *iterator;    if(val==NULL || val->gc.flag.protect)
   
   if(val->gc.flag.protect)  
231      return;      return;
232    
233    val->gc.flag.protect= 1;    val->gc.flag.protect= 1;
234    
235    if(val->type==list) {    if(val->type==tcons && val->content.c!=NULL) {
236      iterator= val->content.ptr;      protect(val->content.c->car);
237        protect(val->content.c->cdr);
     while(iterator!=NULL) {  
       protect(iterator->item);  
       iterator= iterator->next;  
     }  
238    }    }
239  }  }
240    
241  /* Unprotect values from GC */  /* Unprotect values from GC */
242  void unprotect(value *val)  void unprotect(value *val)
243  {  {
244    stackitem *iterator;    if(val==NULL || !(val->gc.flag.protect))
   
   if(!(val->gc.flag.protect))  
245      return;      return;
246    
247    val->gc.flag.protect= 0;    val->gc.flag.protect= 0;
248    
249    if(val->type==list) {    if(val->type==tcons && val->content.c!=NULL) {
250      iterator= val->content.ptr;      unprotect(val->content.c->car);
251        unprotect(val->content.c->cdr);
     while(iterator!=NULL) {  
       unprotect(iterator->item);  
       iterator= iterator->next;  
     }  
252    }    }
253  }  }
254    
255  /* Push a value onto the stack */  /* Push a value onto the stack */
256  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
257  {  {
258    stackitem *new_item= malloc(sizeof(stackitem));    cons *new_item= malloc(sizeof(cons));
259    new_item->item= val;    new_item->car= val;
260    new_item->next= env->head;  
261      new_item->cdr= new_val(env);
262      new_item->cdr->type= tcons;
263      new_item->cdr->content.c= env->head;
264    env->head= new_item;    env->head= new_item;
265  }  }
266    
# Line 358  extern void mangle(environment *env) Line 330  extern void mangle(environment *env)
330      return;      return;
331    }    }
332    
333    if(env->head->item->type!=string) {    if(env->head->car->type!=string) {
334      printerr("Bad Argument Type");      printerr("Bad Argument Type");
335      env->err= 2;      env->err= 2;
336      return;      return;
337    }    }
338    
339    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string= mangle_str((const char *)(env->head->car->content.ptr));
340    
341    toss(env);    toss(env);
342    if(env->err) return;    if(env->err) return;
# Line 455  extern void type(environment *env) Line 427  extern void type(environment *env)
427      env->err=1;      env->err=1;
428      return;      return;
429    }    }
430    typenum=env->head->item->type;    typenum=env->head->car->type;
431    toss(env);    toss(env);
432    switch(typenum){    switch(typenum){
433    case integer:    case integer:
# Line 473  extern void type(environment *env) Line 445  extern void type(environment *env)
445    case func:    case func:
446      push_sym(env, "function");      push_sym(env, "function");
447      break;      break;
448    case list:    case tcons:
449      push_sym(env, "list");      push_sym(env, "list");
450      break;      break;
451    }    }
452  }      }    
453    
454  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
455  void print_h(stackitem *stack_head, int noquote)  void print_h(cons *stack_head, int noquote)
456  {  {
457    switch(stack_head->item->type) {    switch(stack_head->car->type) {
458    case integer:    case integer:
459      printf("%d", stack_head->item->content.i);      printf("%d", stack_head->car->content.i);
460      break;      break;
461    case tfloat:    case tfloat:
462      printf("%f", stack_head->item->content.f);      printf("%f", stack_head->car->content.f);
463      break;      break;
464    case string:    case string:
465      if(noquote)      if(noquote)
466        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)stack_head->car->content.ptr);
467      else      else
468        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)stack_head->car->content.ptr);
469      break;      break;
470    case symb:    case symb:
471      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", ((symbol *)(stack_head->car->content.ptr))->id);
472      break;      break;
473    case func:    case func:
474      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(stack_head->car->content.ptr));
475      break;      break;
476    case list:    case tcons:
477      /* 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 */
478      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head=(cons*)(stack_head->car->content.ptr);
479      printf("[ ");      printf("[ ");
480      while(stack_head != NULL) {      while(stack_head != NULL) {
481        print_h(stack_head, noquote);        print_h(stack_head, noquote);
482        printf(" ");        printf(" ");
483        stack_head=stack_head->next;        stack_head= stack_head->cdr->content.c;
484      }      }
485      printf("]");      printf("]");
486      break;      break;
# Line 553  extern void princ(environment *env) Line 525  extern void princ(environment *env)
525  }  }
526    
527  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
528  void print_st(stackitem *stack_head, long counter)  void print_st(cons *stack_head, long counter)
529  {  {
530    if(stack_head->next != NULL)    if(stack_head->cdr->content.c != NULL)
531      print_st(stack_head->next, counter+1);      print_st(stack_head->cdr->content.c, counter+1);
532    printf("%ld: ", counter);    printf("%ld: ", counter);
533    print_h(stack_head, 0);    print_h(stack_head, 0);
534    nl();    nl();
# Line 576  extern void printstack(environment *env) Line 548  extern void printstack(environment *env)
548  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
549  extern void swap(environment *env)  extern void swap(environment *env)
550  {  {
551    stackitem *temp= env->head;    cons *temp= env->head;
552        
553    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
554      printerr("Too Few Arguments");      printerr("Too Few Arguments");
555      env->err=1;      env->err=1;
556      return;      return;
557    }    }
558    
559    env->head= env->head->next;    env->head= env->head->cdr->content.c;
560    temp->next= env->head->next;    temp->cdr->content.c= env->head->cdr->content.c;
561    env->head->next= temp;    env->head->cdr->content.c= temp;
562  }  }
563    
564  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
565  extern void rot(environment *env)  extern void rot(environment *env)
566  {  {
567    stackitem *temp= env->head;    cons *temp= env->head;
568        
569    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || env->head->cdr->content.c==NULL
570        || env->head->next->next==NULL) {        || env->head->cdr->content.c->cdr->content.c==NULL) {
571      printerr("Too Few Arguments");      printerr("Too Few Arguments");
572      env->err=1;      env->err=1;
573      return;      return;
574    }    }
575    
576    env->head= env->head->next->next;    env->head= env->head->cdr->content.c->cdr->content.c;
577    temp->next->next= env->head->next;    temp->cdr->content.c->cdr->content.c= env->head->cdr->content.c;
578    env->head->next= temp;    env->head->cdr->content.c= temp;
579  }  }
580    
581  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 611  extern void rcl(environment *env) Line 583  extern void rcl(environment *env)
583  {  {
584    value *val;    value *val;
585    
586    if(env->head == NULL) {    if(env->head==NULL) {
587      printerr("Too Few Arguments");      printerr("Too Few Arguments");
588      env->err=1;      env->err= 1;
589      return;      return;
590    }    }
591    
592    if(env->head->item->type!=symb) {    if(env->head->car->type!=symb) {
593      printerr("Bad Argument Type");      printerr("Bad Argument Type");
594      env->err=2;      env->err= 2;
595      return;      return;
596    }    }
597    
598    val=((symbol *)(env->head->item->content.ptr))->val;    val= ((symbol *)(env->head->car->content.ptr))->val;
599    if(val == NULL){    if(val == NULL){
600      printerr("Unbound Variable");      printerr("Unbound Variable");
601      env->err=3;      env->err= 3;
602      return;      return;
603    }    }
604    protect(val);    protect(val);
# Line 643  extern void eval(environment *env) Line 615  extern void eval(environment *env)
615  {  {
616    funcp in_func;    funcp in_func;
617    value* temp_val;    value* temp_val;
618    stackitem* iterator;    cons* iterator;
619    
620   eval_start:   eval_start:
621    
# Line 651  extern void eval(environment *env) Line 623  extern void eval(environment *env)
623    
624    if(env->head==NULL) {    if(env->head==NULL) {
625      printerr("Too Few Arguments");      printerr("Too Few Arguments");
626      env->err=1;      env->err= 1;
627      return;      return;
628    }    }
629    
630    switch(env->head->item->type) {    switch(env->head->car->type) {
631      /* if it's a symbol */      /* if it's a symbol */
632    case symb:    case symb:
633      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
634      if(env->err) return;      if(env->err) return;
635      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(env->head->car->type!=symb){ /* don't recurse symbols */
636        goto eval_start;        goto eval_start;
637      }      }
638      return;      return;
639    
640      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
641    case func:    case func:
642      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(env->head->car->content.ptr);
643      toss(env);      toss(env);
644      if(env->err) return;      if(env->err) return;
645      return in_func(env);      return in_func(env);
646    
647      /* If it's a list */      /* If it's a list */
648    case list:    case tcons:
649      temp_val= env->head->item;      temp_val= env->head->car;
650      protect(temp_val);      protect(temp_val);
651    
652      toss(env); if(env->err) return;      toss(env); if(env->err) return;
653      iterator= (stackitem*)temp_val->content.ptr;      iterator= (cons*)temp_val->content.ptr;
654            
655      while(iterator!=NULL) {      while(iterator!=NULL) {
656        push_val(env, iterator->item);        push_val(env, iterator->car);
657                
658        if(env->head->item->type==symb        if(env->head->car->type==symb
659           && (((symbol*)(env->head->item->content.ptr))->id[0] == ';')) {           && (((symbol*)(env->head->car->content.ptr))->id[0] == ';')) {
660          toss(env);          toss(env);
661          if(env->err) return;          if(env->err) return;
662                    
663          if(iterator->next == NULL){          if(iterator->cdr->content.c==NULL){
664            goto eval_start;            goto eval_start;
665          }          }
666          eval(env);          eval(env);
667          if(env->err) return;          if(env->err) return;
668        }        }
669        iterator= iterator->next;        iterator= iterator->cdr->content.c;
670      }      }
671      unprotect(temp_val);      unprotect(temp_val);
672      return;      return;
# Line 707  extern void eval(environment *env) Line 679  extern void eval(environment *env)
679  /* Reverse (flip) a list */  /* Reverse (flip) a list */
680  extern void rev(environment *env)  extern void rev(environment *env)
681  {  {
682    stackitem *old_head, *new_head, *item;    cons *old_head, *new_head, *item;
683    
684    if((env->head)==NULL) {    if((env->head)==NULL) {
685      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 715  extern void rev(environment *env) Line 687  extern void rev(environment *env)
687      return;      return;
688    }    }
689    
690    if(env->head->item->type!=list) {    if(env->head->car->type!=tcons) {
691      printerr("Bad Argument Type");      printerr("Bad Argument Type");
692      env->err= 2;      env->err= 2;
693      return;      return;
694    }    }
695    
696    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= (cons*)(env->head->car->content.ptr);
697    new_head= NULL;    new_head= NULL;
698    while(old_head != NULL){    while(old_head!=NULL) {
699      item= old_head;      item= old_head;
700      old_head= old_head->next;      old_head= old_head->cdr->content.c;
701      item->next= new_head;      item->cdr->content.c= new_head;
702      new_head= item;      new_head= item;
703    }    }
704    env->head->item->content.ptr= new_head;    env->head->car->content.ptr= new_head;
705  }  }
706    
707  /* Make a list. */  /* Make a list. */
708  extern void pack(environment *env)  extern void pack(environment *env)
709  {  {
710    stackitem *iterator, *temp;    cons *iterator, *temp;
711    value *pack;    value *pack;
712    
713    iterator= env->head;    iterator= env->head;
# Line 743  extern void pack(environment *env) Line 715  extern void pack(environment *env)
715    protect(pack);    protect(pack);
716    
717    if(iterator==NULL    if(iterator==NULL
718       || (iterator->item->type==symb       || (iterator->car->type==symb
719       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) {
720      temp= NULL;      temp= NULL;
721      toss(env);      toss(env);
722    } else {    } else {
723      /* Search for first delimiter */      /* Search for first delimiter */
724      while(iterator->next!=NULL      while(iterator->cdr->content.c!=NULL
725            && (iterator->next->item->type!=symb            && (iterator->cdr->content.c->car->type!=symb
726            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))            || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0]
727        iterator= iterator->next;                !='['))
728          iterator= iterator->cdr->content.c;
729            
730      /* Extract list */      /* Extract list */
731      temp= env->head;      temp= env->head;
732      env->head= iterator->next;      env->head= iterator->cdr->content.c;
733      iterator->next= NULL;      iterator->cdr->content.c= NULL;
734    
735      pack->type= list;      pack->type= tcons;
736      pack->content.ptr= temp;      pack->content.ptr= temp;
737            
738      if(env->head!=NULL)      if(env->head!=NULL)
# Line 777  extern void pack(environment *env) Line 750  extern void pack(environment *env)
750  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
751  extern void expand(environment *env)  extern void expand(environment *env)
752  {  {
753    stackitem *temp, *new_head;    cons *temp, *new_head;
754    
755    /* Is top element a list? */    /* Is top element a list? */
756    if(env->head==NULL) {    if(env->head==NULL) {
# Line 785  extern void expand(environment *env) Line 758  extern void expand(environment *env)
758      env->err= 1;      env->err= 1;
759      return;      return;
760    }    }
761    if(env->head->item->type!=list) {    if(env->head->car->type!=tcons) {
762      printerr("Bad Argument Type");      printerr("Bad Argument Type");
763      env->err= 2;      env->err= 2;
764      return;      return;
# Line 797  extern void expand(environment *env) Line 770  extern void expand(environment *env)
770      return;      return;
771    
772    /* The first list element is the new stack head */    /* The first list element is the new stack head */
773    new_head= temp= env->head->item->content.ptr;    new_head= temp= env->head->car->content.ptr;
774    
775    toss(env);    toss(env);
776    
777    /* Find the end of the list */    /* Find the end of the list */
778    while(temp->next!=NULL)    while(temp->cdr->content.c!=NULL)
779      temp= temp->next;      temp= temp->cdr->content.c;
780    
781    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
782    temp->next= env->head;    temp->cdr->content.c= env->head;
783    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
784    
785  }  }
# Line 815  extern void expand(environment *env) Line 788  extern void expand(environment *env)
788  extern void eq(environment *env)  extern void eq(environment *env)
789  {  {
790    void *left, *right;    void *left, *right;
   int result;  
791    
792    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
793      printerr("Too Few Arguments");      printerr("Too Few Arguments");
794      env->err= 1;      env->err= 1;
795      return;      return;
796    }    }
797    
798    left= env->head->item->content.ptr;    left= env->head->car->content.ptr;
799    swap(env);    swap(env);
800    right= env->head->item->content.ptr;    right= env->head->car->content.ptr;
   result= (left==right);  
     
801    toss(env); toss(env);    toss(env); toss(env);
802    push_int(env, result);  
803      push_int(env, left==right);
804  }  }
805    
806  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 837  extern void not(environment *env) Line 808  extern void not(environment *env)
808  {  {
809    int val;    int val;
810    
811    if((env->head)==NULL) {    if(env->head==NULL) {
812      printerr("Too Few Arguments");      printerr("Too Few Arguments");
813      env->err= 1;      env->err= 1;
814      return;      return;
815    }    }
816    
817    if(env->head->item->type!=integer) {    if(env->head->car->type!=integer) {
818      printerr("Bad Argument Type");      printerr("Bad Argument Type");
819      env->err= 2;      env->err= 2;
820      return;      return;
821    }    }
822    
823    val= env->head->item->content.i;    val= env->head->car->content.i;
824    toss(env);    toss(env);
825    push_int(env, !val);    push_int(env, !val);
826  }  }
# Line 868  extern void def(environment *env) Line 839  extern void def(environment *env)
839    symbol *sym;    symbol *sym;
840    
841    /* 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 */
842    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
843      printerr("Too Few Arguments");      printerr("Too Few Arguments");
844      env->err= 1;      env->err= 1;
845      return;      return;
846    }    }
847    
848    if(env->head->item->type!=symb) {    if(env->head->car->type!=symb) {
849      printerr("Bad Argument Type");      printerr("Bad Argument Type");
850      env->err= 2;      env->err= 2;
851      return;      return;
852    }    }
853    
854    /* long names are a pain */    /* long names are a pain */
855    sym= env->head->item->content.ptr;    sym= env->head->car->content.ptr;
856    
857    /* Bind the symbol to the value */    /* Bind the symbol to the value */
858    sym->val= env->head->next->item;    sym->val= env->head->cdr->content.c->car;
859    
860    toss(env); toss(env);    toss(env); toss(env);
861  }  }
# Line 953  void forget_sym(symbol **hash_entry) Line 924  void forget_sym(symbol **hash_entry)
924  extern void forget(environment *env)  extern void forget(environment *env)
925  {  {
926    char* sym_id;    char* sym_id;
927    stackitem *stack_head= env->head;    cons *stack_head= env->head;
928    
929    if(stack_head==NULL) {    if(stack_head==NULL) {
930      printerr("Too Few Arguments");      printerr("Too Few Arguments");
931      env->err=1;      env->err= 1;
932      return;      return;
933    }    }
934        
935    if(stack_head->item->type!=symb) {    if(stack_head->car->type!=symb) {
936      printerr("Bad Argument Type");      printerr("Bad Argument Type");
937      env->err=2;      env->err= 2;
938      return;      return;
939    }    }
940    
941    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= ((symbol*)(stack_head->car->content.ptr))->id;
942    toss(env);    toss(env);
943    
944    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 1039  under certain conditions; type `copying; Line 1010  under certain conditions; type `copying;
1010      if (myenv.err==4) {      if (myenv.err==4) {
1011        return EXIT_SUCCESS;      /* EOF */        return EXIT_SUCCESS;      /* EOF */
1012      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1013                && myenv.head->item->type==symb                && myenv.head->car->type==symb
1014                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && ((symbol*)(myenv.head->car->content.ptr))->id[0]==';') {
1015        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1016        eval(&myenv);        eval(&myenv);
1017      }      }
# Line 1059  extern void sx_2b(environment *env) Line 1030  extern void sx_2b(environment *env)
1030    char* new_string;    char* new_string;
1031    value *a_val, *b_val;    value *a_val, *b_val;
1032    
1033    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1034      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1035      env->err= 1;      env->err= 1;
1036      return;      return;
1037    }    }
1038    
1039    if(env->head->item->type==string    if(env->head->car->type==string
1040       && env->head->next->item->type==string) {       && env->head->cdr->content.c->car->type==string) {
1041      a_val= env->head->item;      a_val= env->head->car;
1042      b_val= env->head->next->item;      b_val= env->head->cdr->content.c->car;
1043      protect(a_val); protect(b_val);      protect(a_val); protect(b_val);
1044      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1045      toss(env); if(env->err) return;      toss(env); if(env->err) return;
# Line 1083  extern void sx_2b(environment *env) Line 1054  extern void sx_2b(environment *env)
1054      return;      return;
1055    }    }
1056        
1057    if(env->head->item->type==integer    if(env->head->car->type==integer
1058       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1059      a=env->head->item->content.i;      a= env->head->car->content.i;
1060      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1061      b=env->head->item->content.i;      b= env->head->car->content.i;
1062      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1063      push_int(env, b+a);      push_int(env, b+a);
1064    
1065      return;      return;
1066    }    }
1067    
1068    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1069       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1070      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1071      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1072      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1073      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1074      push_float(env, fb+fa);      push_float(env, fb+fa);
1075            
1076      return;      return;
1077    }    }
1078    
1079    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1080       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1081      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1082      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1083      b= env->head->item->content.i;      b= env->head->car->content.i;
1084      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1085      push_float(env, b+fa);      push_float(env, b+fa);
1086            
1087      return;      return;
1088    }    }
1089    
1090    if(env->head->item->type==integer    if(env->head->car->type==integer
1091       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1092      a= env->head->item->content.i;      a= env->head->car->content.i;
1093      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1094      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1095      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1096      push_float(env, fb+a);      push_float(env, fb+a);
1097    
# Line 1137  extern void sx_2d(environment *env) Line 1108  extern void sx_2d(environment *env)
1108    int a, b;    int a, b;
1109    float fa, fb;    float fa, fb;
1110    
1111    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1112      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1113      env->err=1;      env->err=1;
1114      return;      return;
1115    }    }
1116        
1117    if(env->head->item->type==integer    if(env->head->car->type==integer
1118       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1119      a=env->head->item->content.i;      a= env->head->car->content.i;
1120      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1121      b=env->head->item->content.i;      b= env->head->car->content.i;
1122      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1123      push_int(env, b-a);      push_int(env, b-a);
1124    
1125      return;      return;
1126    }    }
1127    
1128    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1129       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1130      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1131      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1132      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1133      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1134      push_float(env, fb-fa);      push_float(env, fb-fa);
1135            
1136      return;      return;
1137    }    }
1138    
1139    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1140       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1141      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1142      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1143      b= env->head->item->content.i;      b= env->head->car->content.i;
1144      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1145      push_float(env, b-fa);      push_float(env, b-fa);
1146            
1147      return;      return;
1148    }    }
1149    
1150    if(env->head->item->type==integer    if(env->head->car->type==integer
1151       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1152      a= env->head->item->content.i;      a= env->head->car->content.i;
1153      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1154      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1155      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1156      push_float(env, fb-a);      push_float(env, fb-a);
1157    
# Line 1197  extern void sx_3e(environment *env) Line 1168  extern void sx_3e(environment *env)
1168    int a, b;    int a, b;
1169    float fa, fb;    float fa, fb;
1170    
1171    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1172      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1173      env->err=1;      env->err= 1;
1174      return;      return;
1175    }    }
1176        
1177    if(env->head->item->type==integer    if(env->head->car->type==integer
1178       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1179      a=env->head->item->content.i;      a=env->head->car->content.i;
1180      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1181      b=env->head->item->content.i;      b=env->head->car->content.i;
1182      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1183      push_int(env, b>a);      push_int(env, b>a);
1184    
1185      return;      return;
1186    }    }
1187    
1188    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1189       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1190      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1191      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1192      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1193      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1194      push_int(env, fb>fa);      push_int(env, fb>fa);
1195            
1196      return;      return;
1197    }    }
1198    
1199    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
1200       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
1201      fa= env->head->item->content.f;      fa= env->head->car->content.f;
1202      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1203      b= env->head->item->content.i;      b= env->head->car->content.i;
1204      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1205      push_int(env, b>fa);      push_int(env, b>fa);
1206            
1207      return;      return;
1208    }    }
1209    
1210    if(env->head->item->type==integer    if(env->head->car->type==integer
1211       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
1212      a= env->head->item->content.i;      a= env->head->car->content.i;
1213      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1214      fb= env->head->item->content.f;      fb= env->head->car->content.f;
1215      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1216      push_int(env, fb>a);      push_int(env, fb>a);
1217    
# Line 1275  extern void sx_3e3d(environment *env) Line 1246  extern void sx_3e3d(environment *env)
1246  /* Return copy of a value */  /* Return copy of a value */
1247  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
1248  {  {
1249    stackitem *old_item, *new_item, *prev_item;    cons *old_item, *new_item, *prev_item;
1250    value *new_value;    value *new_value;
1251    
1252    protect(old_value);    protect(old_value);
# Line 1294  value *copy_val(environment *env, value Line 1265  value *copy_val(environment *env, value
1265      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1266        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1267      break;      break;
1268    case list:    case tcons:
1269      new_value->content.ptr= NULL;      new_value->content.ptr= NULL;
1270    
1271      prev_item= NULL;      prev_item= NULL;
1272      old_item= (stackitem*)(old_value->content.ptr);      old_item= (cons*)(old_value->content.ptr);
1273    
1274      while(old_item != NULL) {   /* While list is not empty */      while(old_item != NULL) {   /* While list is not empty */
1275        new_item= malloc(sizeof(stackitem));        new_item= malloc(sizeof(cons));
1276        new_item->item= copy_val(env, old_item->item); /* recurse */        new_item->car= copy_val(env, old_item->car); /* recurse */
1277        new_item->next= NULL;        new_item->cdr= new_val(env);
1278          new_item->cdr->type= tcons;
1279          new_item->cdr->content.c= NULL;
1280        if(prev_item != NULL)     /* If this wasn't the first item */        if(prev_item != NULL)     /* If this wasn't the first item */
1281          prev_item->next= new_item; /* point the previous item to the          prev_item->cdr->content.c= new_item; /* point the previous item to the
1282                                       new item */                                       new item */
1283        else        else
1284          new_value->content.ptr= new_item;          new_value->content.ptr= new_item;
1285        old_item= old_item->next;        old_item= old_item->cdr->content.c;
1286        prev_item= new_item;        prev_item= new_item;
1287      }          }    
1288      break;      break;
# Line 1323  value *copy_val(environment *env, value Line 1296  value *copy_val(environment *env, value
1296  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1297  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1298  {  {
1299    if((env->head)==NULL) {    if(env->head==NULL) {
1300      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1301      env->err= 1;      env->err= 1;
1302      return;      return;
1303    }    }
1304    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, env->head->car));
1305  }  }
1306    
1307  /* "if", If-Then */  /* "if", If-Then */
# Line 1336  extern void sx_6966(environment *env) Line 1309  extern void sx_6966(environment *env)
1309  {  {
1310    int truth;    int truth;
1311    
1312    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1313      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1314      env->err= 1;      env->err= 1;
1315      return;      return;
1316    }    }
1317    
1318    if(env->head->next->item->type != integer) {    if(env->head->cdr->content.c->car->type != integer) {
1319      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1320      env->err=2;      env->err= 2;
1321      return;      return;
1322    }    }
1323        
1324    swap(env);    swap(env);
1325    if(env->err) return;    if(env->err) return;
1326        
1327    truth=env->head->item->content.i;    truth=env->head->car->content.i;
1328    
1329    toss(env);    toss(env);
1330    if(env->err) return;    if(env->err) return;
# Line 1367  extern void ifelse(environment *env) Line 1340  extern void ifelse(environment *env)
1340  {  {
1341    int truth;    int truth;
1342    
1343    if((env->head)==NULL || env->head->next==NULL    if(env->head==NULL || env->head->cdr->content.c==NULL
1344       || env->head->next->next==NULL) {       || env->head->cdr->content.c->cdr->content.c==NULL) {
1345      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1346      env->err=1;      env->err= 1;
1347      return;      return;
1348    }    }
1349    
1350    if(env->head->next->next->item->type != integer) {    if(env->head->cdr->content.c->cdr->content.c->car->type!=integer) {
1351      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1352      env->err=2;      env->err= 2;
1353      return;      return;
1354    }    }
1355        
1356    rot(env);    rot(env);
1357    if(env->err) return;    if(env->err) return;
1358        
1359    truth=env->head->item->content.i;    truth= env->head->car->content.i;
1360    
1361    toss(env);    toss(env);
1362    if(env->err) return;    if(env->err) return;
# Line 1404  extern void sx_7768696c65(environment *e Line 1377  extern void sx_7768696c65(environment *e
1377    int truth;    int truth;
1378    value *loop, *test;    value *loop, *test;
1379    
1380    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1381      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1382      env->err=1;      env->err= 1;
1383      return;      return;
1384    }    }
1385    
1386    loop= env->head->item;    loop= env->head->car;
1387    protect(loop);    protect(loop);
1388    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1389    
1390    test= env->head->item;    test= env->head->car;
1391    protect(test);    protect(test);
1392    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1393    
# Line 1422  extern void sx_7768696c65(environment *e Line 1395  extern void sx_7768696c65(environment *e
1395      push_val(env, test);      push_val(env, test);
1396      eval(env);      eval(env);
1397            
1398      if(env->head->item->type != integer) {      if(env->head->car->type != integer) {
1399        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1400        env->err= 2;        env->err= 2;
1401        return;        return;
1402      }      }
1403            
1404      truth= env->head->item->content.i;      truth= env->head->car->content.i;
1405      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1406            
1407      if(truth) {      if(truth) {
# Line 1450  extern void sx_666f72(environment *env) Line 1423  extern void sx_666f72(environment *env)
1423    value *loop;    value *loop;
1424    int foo1, foo2;    int foo1, foo2;
1425    
1426    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || env->head->cdr->content.c==NULL
1427       || env->head->next->next==NULL) {       || env->head->cdr->content.c->cdr->content.c==NULL) {
1428      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1429      env->err= 1;      env->err= 1;
1430      return;      return;
1431    }    }
1432    
1433    if(env->head->next->item->type!=integer    if(env->head->cdr->content.c->car->type!=integer
1434       || env->head->next->next->item->type!=integer) {       || env->head->cdr->content.c->cdr->content.c->car->type!=integer) {
1435      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1436      env->err= 2;      env->err= 2;
1437      return;      return;
1438    }    }
1439    
1440    loop= env->head->item;    loop= env->head->car;
1441    protect(loop);    protect(loop);
1442    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1443    
1444    foo2= env->head->item->content.i;    foo2= env->head->car->content.i;
1445    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1446    
1447    foo1= env->head->item->content.i;    foo1= env->head->car->content.i;
1448    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1449    
1450    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1496  extern void sx_666f72(environment *env) Line 1469  extern void sx_666f72(environment *env)
1469  extern void foreach(environment *env)  extern void foreach(environment *env)
1470  {    {  
1471    value *loop, *foo;    value *loop, *foo;
1472    stackitem *iterator;    cons *iterator;
1473        
1474    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1475      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1476      env->err= 1;      env->err= 1;
1477      return;      return;
1478    }    }
1479    
1480    if(env->head->next->item->type != list) {    if(env->head->cdr->content.c->car->type!=tcons) {
1481      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1482      env->err= 2;      env->err= 2;
1483      return;      return;
1484    }    }
1485    
1486    loop= env->head->item;    loop= env->head->car;
1487    protect(loop);    protect(loop);
1488    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1489    
1490    foo= env->head->item;    foo= env->head->car;
1491    protect(foo);    protect(foo);
1492    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1493    
1494    iterator= foo->content.ptr;    iterator= foo->content.ptr;
1495    
1496    while(iterator!=NULL) {    while(iterator!=NULL) {
1497      push_val(env, iterator->item);      push_val(env, iterator->car);
1498      push_val(env, loop);      push_val(env, loop);
1499      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1500      iterator= iterator->next;      iterator= iterator->cdr->content.c;
1501    }    }
1502    unprotect(loop); unprotect(foo);    unprotect(loop); unprotect(foo);
1503  }  }
# Line 1533  extern void foreach(environment *env) Line 1506  extern void foreach(environment *env)
1506  extern void to(environment *env)  extern void to(environment *env)
1507  {  {
1508    int ending, start, i;    int ending, start, i;
1509    stackitem *iterator, *temp;    cons *iterator, *temp;
1510    value *pack;    value *pack;
1511    
1512    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1513      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1514      env->err=1;      env->err= 1;
1515      return;      return;
1516    }    }
1517    
1518    if(env->head->item->type!=integer    if(env->head->car->type!=integer
1519       || env->head->next->item->type!=integer) {       || env->head->cdr->content.c->car->type!=integer) {
1520      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1521      env->err=2;      env->err= 2;
1522      return;      return;
1523    }    }
1524    
1525    ending= env->head->item->content.i;    ending= env->head->car->content.i;
1526    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1527    start= env->head->item->content.i;    start= env->head->car->content.i;
1528    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1529    
1530    push_sym(env, "[");    push_sym(env, "[");
# Line 1569  extern void to(environment *env) Line 1542  extern void to(environment *env)
1542    protect(pack);    protect(pack);
1543    
1544    if(iterator==NULL    if(iterator==NULL
1545       || (iterator->item->type==symb       || (iterator->car->type==symb
1546       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) {
1547      temp= NULL;      temp= NULL;
1548      toss(env);      toss(env);
1549    } else {    } else {
1550      /* Search for first delimiter */      /* Search for first delimiter */
1551      while(iterator->next!=NULL      while(iterator->cdr->content.c!=NULL
1552            && (iterator->next->item->type!=symb            && (iterator->cdr->content.c->car->type!=symb
1553            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))            || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0]
1554        iterator= iterator->next;                !='['))
1555          iterator= iterator->cdr->content.c;
1556            
1557      /* Extract list */      /* Extract list */
1558      temp= env->head;      temp= env->head;
1559      env->head= iterator->next;      env->head= iterator->cdr->content.c;
1560      iterator->next= NULL;      iterator->cdr->content.c= NULL;
1561    
1562      pack->type= list;      pack->type= tcons;
1563      pack->content.ptr= temp;      pack->content.ptr= temp;
1564            
1565      if(env->head!=NULL)      if(env->head!=NULL)
# Line 1635  extern void sx_72656164(environment *env Line 1609  extern void sx_72656164(environment *env
1609      }      }
1610      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1611    
1612      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(env->head->car->content.ptr))[0]=='\0'){
1613        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1614        return;        return;
1615      }      }
1616            
1617      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(env->head->car->content.ptr)+1);
1618      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1619      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, env->head->car->content.ptr);
1620      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1621    }    }
1622        
# Line 1695  extern void beep(environment *env) Line 1669  extern void beep(environment *env)
1669  {  {
1670    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1671    
1672    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
1673      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1674      env->err=1;      env->err= 1;
1675      return;      return;
1676    }    }
1677    
1678    if(env->head->item->type!=integer    if(env->head->car->type!=integer
1679       || env->head->next->item->type!=integer) {       || env->head->cdr->content.c->car->type!=integer) {
1680      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1681      env->err=2;      env->err= 2;
1682      return;      return;
1683    }    }
1684    
1685    dur=env->head->item->content.i;    dur= env->head->car->content.i;
1686    toss(env);    toss(env);
1687    freq=env->head->item->content.i;    freq= env->head->car->content.i;
1688    toss(env);    toss(env);
1689    
1690    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1691                                     length */                                     length */
1692    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1693                                     timer ticks */                                     timer ticks */
1694    
1695  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1696    
1697    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1698    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1699    case 0:    case 0:
1700      usleep(dur);      usleep(dur);
1701      return;      return;
1702    case -1:    case -1:
1703      perror("beep");      perror("beep");
1704      env->err=5;      env->err= 5;
1705      return;      return;
1706    default:    default:
1707      abort();      abort();
# Line 1739  extern void sx_77616974(environment *env Line 1713  extern void sx_77616974(environment *env
1713  {  {
1714    int dur;    int dur;
1715    
1716    if((env->head)==NULL) {    if(env->head==NULL) {
1717      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1718      env->err=1;      env->err= 1;
1719      return;      return;
1720    }    }
1721    
1722    if(env->head->item->type!=integer) {    if(env->head->car->type!=integer) {
1723      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1724      env->err=2;      env->err= 2;
1725      return;      return;
1726    }    }
1727    
1728    dur=env->head->item->content.i;    dur=env->head->car->content.i;
1729    toss(env);    toss(env);
1730    
1731    usleep(dur);    usleep(dur);
# Line 2048  extern void sx_2a(environment *env) Line 2022  extern void sx_2a(environment *env)
2022    int a, b;    int a, b;
2023    float fa, fb;    float fa, fb;
2024    
2025    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
2026      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2027      env->err=1;      env->err= 1;
2028      return;      return;
2029    }    }
2030        
2031    if(env->head->item->type==integer    if(env->head->car->type==integer
2032       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2033      a=env->head->item->content.i;      a= env->head->car->content.i;
2034      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2035      b=env->head->item->content.i;      b= env->head->car->content.i;
2036      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2037      push_int(env, b*a);      push_int(env, b*a);
2038    
2039      return;      return;
2040    }    }
2041    
2042    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
2043       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
2044      fa= env->head->item->content.f;      fa= env->head->car->content.f;
2045      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2046      fb= env->head->item->content.f;      fb= env->head->car->content.f;
2047      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2048      push_float(env, fb*fa);      push_float(env, fb*fa);
2049            
2050      return;      return;
2051    }    }
2052    
2053    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
2054       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2055      fa= env->head->item->content.f;      fa= env->head->car->content.f;
2056      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2057      b= env->head->item->content.i;      b= env->head->car->content.i;
2058      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2059      push_float(env, b*fa);      push_float(env, b*fa);
2060            
2061      return;      return;
2062    }    }
2063    
2064    if(env->head->item->type==integer    if(env->head->car->type==integer
2065       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
2066      a= env->head->item->content.i;      a= env->head->car->content.i;
2067      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2068      fb= env->head->item->content.f;      fb= env->head->car->content.f;
2069      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2070      push_float(env, fb*a);      push_float(env, fb*a);
2071    
# Line 2099  extern void sx_2a(environment *env) Line 2073  extern void sx_2a(environment *env)
2073    }    }
2074    
2075    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2076    env->err=2;    env->err= 2;
2077  }  }
2078    
2079  /* "/" */  /* "/" */
# Line 2108  extern void sx_2f(environment *env) Line 2082  extern void sx_2f(environment *env)
2082    int a, b;    int a, b;
2083    float fa, fb;    float fa, fb;
2084    
2085    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
2086      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2087      env->err=1;      env->err= 1;
2088      return;      return;
2089    }    }
2090        
2091    if(env->head->item->type==integer    if(env->head->car->type==integer
2092       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2093      a=env->head->item->content.i;      a= env->head->car->content.i;
2094      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2095      b=env->head->item->content.i;      b= env->head->car->content.i;
2096      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2097      push_float(env, b/a);      push_float(env, b/a);
2098    
2099      return;      return;
2100    }    }
2101    
2102    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
2103       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
2104      fa= env->head->item->content.f;      fa= env->head->car->content.f;
2105      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2106      fb= env->head->item->content.f;      fb= env->head->car->content.f;
2107      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2108      push_float(env, fb/fa);      push_float(env, fb/fa);
2109            
2110      return;      return;
2111    }    }
2112    
2113    if(env->head->item->type==tfloat    if(env->head->car->type==tfloat
2114       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2115      fa= env->head->item->content.f;      fa= env->head->car->content.f;
2116      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2117      b= env->head->item->content.i;      b= env->head->car->content.i;
2118      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2119      push_float(env, b/fa);      push_float(env, b/fa);
2120            
2121      return;      return;
2122    }    }
2123    
2124    if(env->head->item->type==integer    if(env->head->car->type==integer
2125       && env->head->next->item->type==tfloat) {       && env->head->cdr->content.c->car->type==tfloat) {
2126      a= env->head->item->content.i;      a= env->head->car->content.i;
2127      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2128      fb= env->head->item->content.f;      fb= env->head->car->content.f;
2129      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2130      push_float(env, fb/a);      push_float(env, fb/a);
2131    
# Line 2159  extern void sx_2f(environment *env) Line 2133  extern void sx_2f(environment *env)
2133    }    }
2134    
2135    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2136    env->err=2;    env->err= 2;
2137  }  }
2138    
2139  /* "mod" */  /* "mod" */
# Line 2167  extern void mod(environment *env) Line 2141  extern void mod(environment *env)
2141  {  {
2142    int a, b;    int a, b;
2143    
2144    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
2145      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2146      env->err= 1;      env->err= 1;
2147      return;      return;
2148    }    }
2149        
2150    if(env->head->item->type==integer    if(env->head->car->type==integer
2151       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2152      a= env->head->item->content.i;      a= env->head->car->content.i;
2153      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2154      b= env->head->item->content.i;      b= env->head->car->content.i;
2155      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2156      push_int(env, b%a);      push_int(env, b%a);
2157    
# Line 2185  extern void mod(environment *env) Line 2159  extern void mod(environment *env)
2159    }    }
2160    
2161    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2162    env->err=2;    env->err= 2;
2163  }  }
2164    
2165  /* "div" */  /* "div" */
# Line 2193  extern void sx_646976(environment *env) Line 2167  extern void sx_646976(environment *env)
2167  {  {
2168    int a, b;    int a, b;
2169        
2170    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
2171      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2172      env->err= 1;      env->err= 1;
2173      return;      return;
2174    }    }
2175    
2176    if(env->head->item->type==integer    if(env->head->car->type==integer
2177       && env->head->next->item->type==integer) {       && env->head->cdr->content.c->car->type==integer) {
2178      a= env->head->item->content.i;      a= env->head->car->content.i;
2179      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2180      b= env->head->item->content.i;      b= env->head->car->content.i;
2181      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2182      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2183    
Legend:
Removed from v.1.101  
changed lines
  Added in v.1.102
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26