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

Diff of /stack/stack.c

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

revision 1.103 by teddy, Mon Mar 11 08:52:59 2002 UTC revision 1.112 by teddy, Sat Mar 16 20:09:51 2002 UTC
# Line 20  Line 20 
20               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
21  */  */
22    
23    #define CAR(X) X->content.c->car
24    #define CDR(X) X->content.c->cdr
25    
26  /* printf, sscanf, fgets, fprintf, fopen, perror */  /* printf, sscanf, fgets, fprintf, fopen, perror */
27  #include <stdio.h>  #include <stdio.h>
28  /* exit, EXIT_SUCCESS, malloc, free */  /* exit, EXIT_SUCCESS, malloc, free */
# Line 34  Line 37 
37  #include <unistd.h>  #include <unistd.h>
38  /* EX_NOINPUT, EX_USAGE */  /* EX_NOINPUT, EX_USAGE */
39  #include <sysexits.h>  #include <sysexits.h>
40    /* assert */
41    #include <assert.h>
42    
43    #ifdef __linux__
44  /* mtrace, muntrace */  /* mtrace, muntrace */
45  #include <mcheck.h>  #include <mcheck.h>
46  /* ioctl */  /* ioctl */
47  #include <sys/ioctl.h>  #include <sys/ioctl.h>
48  /* KDMKTONE */  /* KDMKTONE */
49  #include <linux/kd.h>  #include <linux/kd.h>
50    #endif /* __linux__ */
51    
52  #include "stack.h"  #include "stack.h"
53    
# Line 52  void init_env(environment *env) Line 60  void init_env(environment *env)
60    env->gc_count= 0;    env->gc_count= 0;
61    env->gc_ref= NULL;    env->gc_ref= NULL;
62    
63    env->head= NULL;    env->head= new_val(env);
64      env->head->type= empty;
65    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
66      env->symbols[i]= NULL;      env->symbols[i]= NULL;
67    env->err= 0;    env->err= 0;
# Line 70  void printerr(const char* in_string) Line 79  void printerr(const char* in_string)
79  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
80  extern void toss(environment *env)  extern void toss(environment *env)
81  {  {
82    cons *temp= env->head;    if(env->head->type==empty) {
   
   if(env->head==NULL) {  
83      printerr("Too Few Arguments");      printerr("Too Few Arguments");
84      env->err= 1;      env->err= 1;
85      return;      return;
86    }    }
87        
88    env->head= env->head->cdr->content.c; /* Remove the top stack item */    env->head= CDR(env->head); /* Remove the top stack item */
   free(temp);                   /* Free the old top stack item */  
89  }  }
90    
91  /* Returns a pointer to a pointer to an element in the hash table. */  /* Returns a pointer to a pointer to an element in the hash table. */
# Line 118  value* new_val(environment *env) Line 124  value* new_val(environment *env)
124    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
125    
126    nval->content.ptr= NULL;    nval->content.ptr= NULL;
127      nval->type= integer;
128    
129    nitem->item= nval;    nitem->item= nval;
130    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
# Line 140  inline void gc_mark(value *val) Line 147  inline void gc_mark(value *val)
147    
148    val->gc.flag.mark= 1;    val->gc.flag.mark= 1;
149    
150    if(val->type==tcons && val->content.c!=NULL) {    if(val->type==tcons) {
151      gc_mark(val->content.c->car);      gc_mark(CAR(val));
152      gc_mark(val->content.c->cdr);      gc_mark(CDR(val));
153    }    }
154  }  }
155    
# Line 166  extern void gc_init(environment *env) Line 173  extern void gc_init(environment *env)
173      printf("Garbage collecting.");      printf("Garbage collecting.");
174    
175    /* Mark values on stack */    /* Mark values on stack */
176    if(env->head!=NULL) {    gc_mark(env->head);
     gc_mark(env->head->car);  
     gc_mark(env->head->cdr);  
   }  
177    
178    if(env->interactive)    if(env->interactive)
179      printf(".");      printf(".");
# Line 185  extern void gc_init(environment *env) Line 189  extern void gc_init(environment *env)
189    if(env->interactive)    if(env->interactive)
190      printf(".");      printf(".");
191    
   
192    env->gc_count= 0;    env->gc_count= 0;
193    
194    while(env->gc_ref!=NULL) {    /* Sweep unused values */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
# Line 200  extern void gc_init(environment *env) Line 203  extern void gc_init(environment *env)
203        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
204        env->gc_ref= titem;        env->gc_ref= titem;
205        continue;        continue;
206      }      }
207    #ifdef DEBUG
208        printf("Kept value (%p)", env->gc_ref->item);
209        if(env->gc_ref->item->gc.flag.mark)
210          printf(" (marked)");
211        if(env->gc_ref->item->gc.flag.protect)
212          printf(" (protected)");
213        switch(env->gc_ref->item->type){
214        case integer:
215          printf(" integer: %d", env->gc_ref->item->content.i);
216          break;
217        case func:
218          printf(" func: %p", env->gc_ref->item->content.ptr);
219          break;
220        case symb:
221          printf(" symb: %s", env->gc_ref->item->content.sym->id);
222          break;
223        case tcons:
224          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
225                 env->gc_ref->item->content.c->cdr);
226          break;
227        default:
228          printf(" <unknown %d>", (env->gc_ref->item->type));
229        }
230        printf("\n");
231    #endif /* DEBUG */
232    
233      /* Keep values */          /* Keep values */    
234      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
# Line 220  extern void gc_init(environment *env) Line 248  extern void gc_init(environment *env)
248    env->gc_ref= new_head;    env->gc_ref= new_head;
249    
250    if(env->interactive)    if(env->interactive)
251      printf("done\n");      printf("done (%d bytes still allocated)\n", env->gc_count);
252    
253  }  }
254    
# Line 232  void protect(value *val) Line 260  void protect(value *val)
260    
261    val->gc.flag.protect= 1;    val->gc.flag.protect= 1;
262    
263    if(val->type==tcons && val->content.c!=NULL) {    if(val->type==tcons) {
264      protect(val->content.c->car);      protect(CAR(val));
265      protect(val->content.c->cdr);      protect(CDR(val));
266    }    }
267  }  }
268    
# Line 246  void unprotect(value *val) Line 274  void unprotect(value *val)
274    
275    val->gc.flag.protect= 0;    val->gc.flag.protect= 0;
276    
277    if(val->type==tcons && val->content.c!=NULL) {    if(val->type==tcons) {
278      unprotect(val->content.c->car);      unprotect(CAR(val));
279      unprotect(val->content.c->cdr);      unprotect(CDR(val));
280    }    }
281  }  }
282    
283  /* Push a value onto the stack */  /* Push a value onto the stack */
284  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
285  {  {
286    cons *new_item= malloc(sizeof(cons));    value *new_value= new_val(env);
   new_item->car= val;  
287    
288    new_item->cdr= new_val(env);    new_value->content.c= malloc(sizeof(cons));
289    new_item->cdr->type= tcons;    assert(new_value->content.c!=NULL);
290    new_item->cdr->content.c= env->head;    new_value->type= tcons;
291    env->head= new_item;    CAR(new_value)= val;
292      CDR(new_value)= env->head;
293      env->head= new_value;
294  }  }
295    
296  /* Push an integer onto the stack */  /* Push an integer onto the stack */
# Line 324  extern void mangle(environment *env) Line 353  extern void mangle(environment *env)
353  {  {
354    char *new_string;    char *new_string;
355    
356    if((env->head)==NULL) {    if(env->head->type==empty) {
357      printerr("Too Few Arguments");      printerr("Too Few Arguments");
358      env->err= 1;      env->err= 1;
359      return;      return;
360    }    }
361    
362    if(env->head->car->type!=string) {    if(CAR(env->head)->type!=string) {
363      printerr("Bad Argument Type");      printerr("Bad Argument Type");
364      env->err= 2;      env->err= 2;
365      return;      return;
366    }    }
367    
368    new_string= mangle_str((const char *)(env->head->car->content.ptr));    new_string=
369        mangle_str((const char *)(CAR(env->head)->content.ptr));
370    
371    toss(env);    toss(env);
372    if(env->err) return;    if(env->err) return;
# Line 420  extern void nl() Line 450  extern void nl()
450  /* Gets the type of a value */  /* Gets the type of a value */
451  extern void type(environment *env)  extern void type(environment *env)
452  {  {
453    int typenum;    if(env->head->type==empty) {
   
   if((env->head)==NULL) {  
454      printerr("Too Few Arguments");      printerr("Too Few Arguments");
455      env->err=1;      env->err= 1;
456      return;      return;
457    }    }
458    typenum=env->head->car->type;  
459    toss(env);    switch(CAR(env->head)->type){
460    switch(typenum){    case empty:
461        push_sym(env, "empty");
462        break;
463    case integer:    case integer:
464      push_sym(env, "integer");      push_sym(env, "integer");
465      break;      break;
# Line 449  extern void type(environment *env) Line 479  extern void type(environment *env)
479      push_sym(env, "list");      push_sym(env, "list");
480      break;      break;
481    }    }
482      swap(env);
483      if (env->err) return;
484      toss(env);
485  }      }    
486    
487  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
488  void print_h(cons *stack_head, int noquote)  void print_h(value *stack_head, int noquote)
489  {  {
490    switch(stack_head->car->type) {    switch(CAR(stack_head)->type) {
491      case empty:
492        printf("[]");
493        break;
494    case integer:    case integer:
495      printf("%d", stack_head->car->content.i);      printf("%d", CAR(stack_head)->content.i);
496      break;      break;
497    case tfloat:    case tfloat:
498      printf("%f", stack_head->car->content.f);      printf("%f", CAR(stack_head)->content.f);
499      break;      break;
500    case string:    case string:
501      if(noquote)      if(noquote)
502        printf("%s", (char*)stack_head->car->content.ptr);        printf("%s", (char*)(CAR(stack_head)->content.ptr));
503      else      else
504        printf("\"%s\"", (char*)stack_head->car->content.ptr);        printf("\"%s\"", (char*)(CAR(stack_head)->content.ptr));
505      break;      break;
506    case symb:    case symb:
507      printf("%s", ((symbol *)(stack_head->car->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
508      break;      break;
509    case func:    case func:
510      printf("#<function %p>", (funcp)(stack_head->car->content.ptr));      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
511      break;      break;
512    case tcons:    case tcons:
513      /* 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 */
514      stack_head=stack_head->car->content.c;      stack_head= CAR(stack_head);
515      printf("[ ");      printf("[ ");
516      while(stack_head != NULL) {      while(stack_head->type != empty) {
517        print_h(stack_head, noquote);        print_h(stack_head, noquote);
518        printf(" ");        switch(CDR(stack_head)->type){
519        stack_head= stack_head->cdr->content.c;        case empty:
520            break;
521          case tcons:
522            printf(" ");
523            break;
524          default:
525            printf(" . ");          /* Improper list */
526          }
527          stack_head= CDR(stack_head);
528      }      }
529      printf("]");      printf(" ]");
530      break;      break;
531    }    }
532  }  }
533    
534  extern void print_(environment *env)  extern void print_(environment *env)
535  {  {
536    if(env->head==NULL) {    if(env->head->type==empty) {
537      printerr("Too Few Arguments");      printerr("Too Few Arguments");
538      env->err=1;      env->err= 1;
539      return;      return;
540    }    }
541    print_h(env->head, 0);    print_h(env->head, 0);
# Line 508  extern void print(environment *env) Line 552  extern void print(environment *env)
552    
553  extern void princ_(environment *env)  extern void princ_(environment *env)
554  {  {
555    if(env->head==NULL) {    if(env->head->type==empty) {
556      printerr("Too Few Arguments");      printerr("Too Few Arguments");
557      env->err=1;      env->err= 1;
558      return;      return;
559    }    }
560    print_h(env->head, 1);    print_h(env->head, 1);
# Line 525  extern void princ(environment *env) Line 569  extern void princ(environment *env)
569  }  }
570    
571  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
572  void print_st(cons *stack_head, long counter)  void print_st(value *stack_head, long counter)
573  {  {
574    if(stack_head->cdr->content.c != NULL)    if(CDR(stack_head)->type != empty)
575      print_st(stack_head->cdr->content.c, counter+1);      print_st(CDR(stack_head), counter+1);
576    printf("%ld: ", counter);    printf("%ld: ", counter);
577    print_h(stack_head, 0);    print_h(stack_head, 0);
578    nl();    nl();
# Line 537  void print_st(cons *stack_head, long cou Line 581  void print_st(cons *stack_head, long cou
581  /* Prints the stack. */  /* Prints the stack. */
582  extern void printstack(environment *env)  extern void printstack(environment *env)
583  {  {
584    if(env->head == NULL) {    if(env->head->type == empty) {
585      printf("Stack Empty\n");      printf("Stack Empty\n");
586      return;      return;
587    }    }
# Line 548  extern void printstack(environment *env) Line 592  extern void printstack(environment *env)
592  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
593  extern void swap(environment *env)  extern void swap(environment *env)
594  {  {
595    cons *temp= env->head;    value *temp= env->head;
596        
597    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
598      printerr("Too Few Arguments");      printerr("Too Few Arguments");
599      env->err=1;      env->err=1;
600      return;      return;
601    }    }
602    
603    env->head= env->head->cdr->content.c;    env->head= CDR(env->head);
604    temp->cdr->content.c= env->head->cdr->content.c;    CDR(temp)= CDR(env->head);
605    env->head->cdr->content.c= temp;    CDR(env->head)= temp;
606  }  }
607    
608  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
609  extern void rot(environment *env)  extern void rot(environment *env)
610  {  {
611    cons *temp= env->head;    value *temp= env->head;
612        
613    if(env->head==NULL || env->head->cdr->content.c==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
614       || env->head->cdr->content.c->cdr->content.c==NULL) {       || CDR(CDR(env->head))->type == empty) {
615      printerr("Too Few Arguments");      printerr("Too Few Arguments");
616      env->err=1;      env->err= 1;
617      return;      return;
618    }    }
619      
620    env->head= env->head->cdr->content.c->cdr->content.c;    env->head= CDR(CDR(env->head));
621    temp->cdr->content.c->cdr->content.c= env->head->cdr->content.c;    CDR(CDR(temp))= CDR(env->head);
622    env->head->cdr->content.c= temp;    CDR(env->head)= temp;
623  }  }
624    
625  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 583  extern void rcl(environment *env) Line 627  extern void rcl(environment *env)
627  {  {
628    value *val;    value *val;
629    
630    if(env->head==NULL) {    if(env->head->type==empty) {
631      printerr("Too Few Arguments");      printerr("Too Few Arguments");
632      env->err= 1;      env->err= 1;
633      return;      return;
634    }    }
635    
636    if(env->head->car->type!=symb) {    if(CAR(env->head)->type!=symb) {
637      printerr("Bad Argument Type");      printerr("Bad Argument Type");
638      env->err= 2;      env->err= 2;
639      return;      return;
640    }    }
641    
642    val= ((symbol *)(env->head->car->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
643    if(val == NULL){    if(val == NULL){
644      printerr("Unbound Variable");      printerr("Unbound Variable");
645      env->err= 3;      env->err= 3;
646      return;      return;
647    }    }
648    protect(val);    push_val(env, val);           /* Return the symbol's bound value */
649    toss(env);            /* toss the symbol */    swap(env);
650      if(env->err) return;
651      toss(env);                    /* toss the symbol */
652    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(val);  
653  }  }
654    
655  /* 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 615  extern void eval(environment *env) Line 659  extern void eval(environment *env)
659  {  {
660    funcp in_func;    funcp in_func;
661    value* temp_val;    value* temp_val;
662    cons* iterator;    value* iterator;
663    
664   eval_start:   eval_start:
665    
666    gc_maybe(env);    gc_maybe(env);
667    
668    if(env->head==NULL) {    if(env->head->type==empty) {
669      printerr("Too Few Arguments");      printerr("Too Few Arguments");
670      env->err= 1;      env->err= 1;
671      return;      return;
672    }    }
673    
674    switch(env->head->car->type) {    switch(CAR(env->head)->type) {
675      /* if it's a symbol */      /* if it's a symbol */
676    case symb:    case symb:
677      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
678      if(env->err) return;      if(env->err) return;
679      if(env->head->car->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
680        goto eval_start;        goto eval_start;
681      }      }
682      return;      return;
683    
684      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
685    case func:    case func:
686      in_func= (funcp)(env->head->car->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
687      toss(env);      toss(env);
688      if(env->err) return;      if(env->err) return;
689      return in_func(env);      return in_func(env);
690    
691      /* If it's a list */      /* If it's a list */
692    case tcons:    case tcons:
693      temp_val= env->head->car;      temp_val= CAR(env->head);
694      protect(temp_val);      protect(temp_val);
695    
696      toss(env); if(env->err) return;      toss(env); if(env->err) return;
697      iterator= (cons*)temp_val->content.ptr;      iterator= temp_val;
698            
699      while(iterator!=NULL) {      while(iterator->type != empty) {
700        push_val(env, iterator->car);        push_val(env, CAR(iterator));
701                
702        if(env->head->car->type==symb        if(CAR(env->head)->type==symb
703           && (((symbol*)(env->head->car->content.ptr))->id[0] == ';')) {           && CAR(env->head)->content.sym->id[0]==';') {
704          toss(env);          toss(env);
705          if(env->err) return;          if(env->err) return;
706                    
707          if(iterator->cdr->content.ptr==NULL){          if(CDR(iterator)->type == empty){
708            goto eval_start;            goto eval_start;
709          }          }
710          eval(env);          eval(env);
711          if(env->err) return;          if(env->err) return;
712        }        }
713        if (iterator->cdr->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
714          iterator= iterator->cdr->content.c;          iterator= CDR(iterator);
715        else {        else {
716          printerr("Bad Argument Type"); /* Improper list */          printerr("Bad Argument Type"); /* Improper list */
717          env->err= 2;          env->err= 2;
# Line 685  extern void eval(environment *env) Line 729  extern void eval(environment *env)
729  /* Reverse (flip) a list */  /* Reverse (flip) a list */
730  extern void rev(environment *env)  extern void rev(environment *env)
731  {  {
732    cons *old_head, *new_head, *item;    value *old_head, *new_head, *item;
733    
734    if((env->head)==NULL) {    if(env->head->type==empty) {
735      printerr("Too Few Arguments");      printerr("Too Few Arguments");
736      env->err= 1;      env->err= 1;
737      return;      return;
738    }    }
739    
740    if(env->head->car->type!=tcons) {    if(CAR(env->head)->type==empty)
741        return;                     /* Don't reverse an empty list */
742    
743      if(CAR(env->head)->type!=tcons) {
744      printerr("Bad Argument Type");      printerr("Bad Argument Type");
745      env->err= 2;      env->err= 2;
746      return;      return;
747    }    }
748    
749    old_head= env->head->car->content.c;    old_head= CAR(env->head);
750    new_head= NULL;    new_head= new_val(env);
751    while(old_head!=NULL) {    new_head->type= empty;
752      while(old_head->type != empty) {
753      item= old_head;      item= old_head;
754      old_head= old_head->cdr->content.c;      old_head= CDR(old_head);
755      item->cdr->content.c= new_head;      CDR(item)= new_head;
756      new_head= item;      new_head= item;
757    }    }
758    env->head->car->content.ptr= new_head;    CAR(env->head)= new_head;
759  }  }
760    
761  /* Make a list. */  /* Make a list. */
762  extern void pack(environment *env)  extern void pack(environment *env)
763  {  {
764    cons *iterator, *temp;    value *iterator, *temp, *ending;
   value *pack;  
765    
766    iterator= env->head;    ending=new_val(env);
767    pack= new_val(env);    ending->type=empty;
   protect(pack);  
768    
769    if(iterator==NULL    iterator= env->head;
770       || (iterator->car->type==symb    if(iterator->type == empty
771       && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) {       || (CAR(iterator)->type==symb
772      temp= NULL;       && CAR(iterator)->content.sym->id[0]=='[')) {
773        temp= ending;
774      toss(env);      toss(env);
775    } else {    } else {
776      /* Search for first delimiter */      /* Search for first delimiter */
777      while(iterator->cdr->content.c!=NULL      while(CDR(iterator)->type != empty
778            && (iterator->cdr->content.c->car->type!=symb            && (CAR(CDR(iterator))->type!=symb
779                || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0]             || CAR(CDR(iterator))->content.sym->id[0]!='['))
780                !='['))        iterator= CDR(iterator);
       iterator= iterator->cdr->content.c;  
781            
782      /* Extract list */      /* Extract list */
783      temp= env->head;      temp= env->head;
784      env->head= iterator->cdr->content.c;      env->head= CDR(iterator);
785      iterator->cdr->content.c= NULL;      CDR(iterator)= ending;
786    
787      pack->type= tcons;      if(env->head->type != empty)
     pack->content.ptr= temp;  
       
     if(env->head!=NULL)  
788        toss(env);        toss(env);
789    }    }
790    
791    /* Push list */    /* Push list */
792    
793    push_val(env, pack);    push_val(env, temp);
794    rev(env);    rev(env);
   
   unprotect(pack);  
795  }  }
796    
797  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
798  extern void expand(environment *env)  extern void expand(environment *env)
799  {  {
800    cons *temp, *new_head;    value *temp, *new_head;
801    
802    /* Is top element a list? */    /* Is top element a list? */
803    if(env->head==NULL) {    if(env->head->type==empty) {
804      printerr("Too Few Arguments");      printerr("Too Few Arguments");
805      env->err= 1;      env->err= 1;
806      return;      return;
807    }    }
808    if(env->head->car->type!=tcons) {  
809      if(CAR(env->head)->type!=tcons) {
810      printerr("Bad Argument Type");      printerr("Bad Argument Type");
811      env->err= 2;      env->err= 2;
812      return;      return;
# Line 776  extern void expand(environment *env) Line 818  extern void expand(environment *env)
818      return;      return;
819    
820    /* The first list element is the new stack head */    /* The first list element is the new stack head */
821    new_head= temp= env->head->car->content.c;    new_head= temp= CAR(env->head);
822    
823    toss(env);    toss(env);
824    
825    /* Find the end of the list */    /* Find the end of the list */
826    while(temp->cdr->content.ptr != NULL) {    while(CDR(temp)->type != empty) {
827      if (temp->cdr->type == tcons)      if (CDR(temp)->type == tcons)
828        temp= temp->cdr->content.c;        temp= CDR(temp);
829      else {      else {
830        printerr("Bad Argument Type"); /* Improper list */        printerr("Bad Argument Type"); /* Improper list */
831        env->err= 2;        env->err= 2;
# Line 792  extern void expand(environment *env) Line 834  extern void expand(environment *env)
834    }    }
835    
836    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
837    temp->cdr->content.c= env->head;    CDR(temp)= env->head;
838    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
839    
840  }  }
# Line 802  extern void eq(environment *env) Line 844  extern void eq(environment *env)
844  {  {
845    void *left, *right;    void *left, *right;
846    
847    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
848      printerr("Too Few Arguments");      printerr("Too Few Arguments");
849      env->err= 1;      env->err= 1;
850      return;      return;
851    }    }
852    
853    left= env->head->car->content.ptr;    left= CAR(env->head)->content.ptr;
854    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->car->content.ptr;  
855    toss(env); toss(env);    toss(env); toss(env);
856    
857    push_int(env, left==right);    push_int(env, left==right);
# Line 821  extern void not(environment *env) Line 862  extern void not(environment *env)
862  {  {
863    int val;    int val;
864    
865    if(env->head==NULL) {    if(env->head->type==empty) {
866      printerr("Too Few Arguments");      printerr("Too Few Arguments");
867      env->err= 1;      env->err= 1;
868      return;      return;
869    }    }
870    
871    if(env->head->car->type!=integer) {    if(CAR(env->head)->type!=integer) {
872      printerr("Bad Argument Type");      printerr("Bad Argument Type");
873      env->err= 2;      env->err= 2;
874      return;      return;
875    }    }
876    
877    val= env->head->car->content.i;    val= CAR(env->head)->content.i;
878    toss(env);    toss(env);
879    push_int(env, !val);    push_int(env, !val);
880  }  }
# Line 852  extern void def(environment *env) Line 893  extern void def(environment *env)
893    symbol *sym;    symbol *sym;
894    
895    /* 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 */
896    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
897      printerr("Too Few Arguments");      printerr("Too Few Arguments");
898      env->err= 1;      env->err= 1;
899      return;      return;
900    }    }
901    
902    if(env->head->car->type!=symb) {    if(CAR(env->head)->type!=symb) {
903      printerr("Bad Argument Type");      printerr("Bad Argument Type");
904      env->err= 2;      env->err= 2;
905      return;      return;
906    }    }
907    
908    /* long names are a pain */    /* long names are a pain */
909    sym= env->head->car->content.ptr;    sym= CAR(env->head)->content.ptr;
910    
911    /* Bind the symbol to the value */    /* Bind the symbol to the value */
912    sym->val= env->head->cdr->content.c->car;    sym->val= CAR(CDR(env->head));
913    
914    toss(env); toss(env);    toss(env); toss(env);
915  }  }
# Line 891  extern void quit(environment *env) Line 932  extern void quit(environment *env)
932    env->gc_limit= 0;    env->gc_limit= 0;
933    gc_maybe(env);    gc_maybe(env);
934    
935      words(env);
936    
937    if(env->free_string!=NULL)    if(env->free_string!=NULL)
938      free(env->free_string);      free(env->free_string);
939        
940    #ifdef __linux__
941    muntrace();    muntrace();
942    #endif
943    
944    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
945  }  }
# Line 902  extern void quit(environment *env) Line 947  extern void quit(environment *env)
947  /* Clear stack */  /* Clear stack */
948  extern void clear(environment *env)  extern void clear(environment *env)
949  {  {
950    while(env->head!=NULL)    while(env->head->type != empty)
951      toss(env);      toss(env);
952  }  }
953    
# Line 915  extern void words(environment *env) Line 960  extern void words(environment *env)
960    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
961      temp= env->symbols[i];      temp= env->symbols[i];
962      while(temp!=NULL) {      while(temp!=NULL) {
963    #ifdef DEBUG
964          if (temp->val != NULL && temp->val->gc.flag.protect)
965            printf("(protected) ");
966    #endif /* DEBUG */
967        printf("%s\n", temp->id);        printf("%s\n", temp->id);
968        temp= temp->next;        temp= temp->next;
969      }      }
# Line 937  void forget_sym(symbol **hash_entry) Line 986  void forget_sym(symbol **hash_entry)
986  extern void forget(environment *env)  extern void forget(environment *env)
987  {  {
988    char* sym_id;    char* sym_id;
   cons *stack_head= env->head;  
989    
990    if(stack_head==NULL) {    if(env->head->type==empty) {
991      printerr("Too Few Arguments");      printerr("Too Few Arguments");
992      env->err= 1;      env->err= 1;
993      return;      return;
994    }    }
995        
996    if(stack_head->car->type!=symb) {    if(CAR(env->head)->type!=symb) {
997      printerr("Bad Argument Type");      printerr("Bad Argument Type");
998      env->err= 2;      env->err= 2;
999      return;      return;
1000    }    }
1001    
1002    sym_id= ((symbol*)(stack_head->car->content.ptr))->id;    sym_id= CAR(env->head)->content.sym->id;
1003    toss(env);    toss(env);
1004    
1005    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 969  int main(int argc, char **argv) Line 1017  int main(int argc, char **argv)
1017    
1018    int c;                        /* getopt option character */    int c;                        /* getopt option character */
1019    
1020    #ifdef __linux__
1021    mtrace();    mtrace();
1022    #endif
1023    
1024    init_env(&myenv);    init_env(&myenv);
1025    
# Line 983  int main(int argc, char **argv) Line 1033  int main(int argc, char **argv)
1033          break;          break;
1034        case '?':        case '?':
1035          fprintf (stderr,          fprintf (stderr,
1036                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1037                   optopt);                   optopt);
1038          return EX_USAGE;          return EX_USAGE;
1039        default:        default:
# Line 1002  int main(int argc, char **argv) Line 1052  int main(int argc, char **argv)
1052    if(myenv.interactive) {    if(myenv.interactive) {
1053      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1054  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1055  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1056  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1057  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1058    }    }
1059    
1060    while(1) {    while(1) {
# Line 1019  under certain conditions; type `copying; Line 1069  under certain conditions; type `copying;
1069        }        }
1070        myenv.err=0;        myenv.err=0;
1071      }      }
1072      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1073      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1074        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1075      } else if(myenv.head!=NULL        quit(&myenv);
1076                && myenv.head->car->type==symb      } else if(myenv.head->type!=empty
1077                && ((symbol*)(myenv.head->car->content.ptr))->id[0]==';') {                && CAR(myenv.head)->type==symb
1078                  && CAR(myenv.head)->content.sym->id[0]
1079                  ==';') {
1080        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1081        eval(&myenv);        eval(&myenv);
1082      }      }
# Line 1043  extern void sx_2b(environment *env) Line 1095  extern void sx_2b(environment *env)
1095    char* new_string;    char* new_string;
1096    value *a_val, *b_val;    value *a_val, *b_val;
1097    
1098    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1099      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1100      env->err= 1;      env->err= 1;
1101      return;      return;
1102    }    }
1103    
1104    if(env->head->car->type==string    if(CAR(env->head)->type==string
1105       && env->head->cdr->content.c->car->type==string) {       && CAR(CDR(env->head))->type==string) {
1106      a_val= env->head->car;      a_val= CAR(env->head);
1107      b_val= env->head->cdr->content.c->car;      b_val= CAR(CDR(env->head));
1108      protect(a_val); protect(b_val);      protect(a_val); protect(b_val);
1109      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1110      toss(env); if(env->err) return;      toss(env); if(env->err) return;
# Line 1067  extern void sx_2b(environment *env) Line 1119  extern void sx_2b(environment *env)
1119      return;      return;
1120    }    }
1121        
1122    if(env->head->car->type==integer    if(CAR(env->head)->type==integer
1123       && env->head->cdr->content.c->car->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1124      a= env->head->car->content.i;      a= CAR(env->head)->content.i;
1125      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1126      b= env->head->car->content.i;      b= CAR(env->head)->content.i;
1127      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1128      push_int(env, b+a);      push_int(env, b+a);
1129    
1130      return;      return;
1131    }    }
1132    
1133    if(env->head->car->type==tfloat    if(CAR(env->head)->type==tfloat
1134       && env->head->cdr->content.c->car->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1135      fa= env->head->car->content.f;      fa= CAR(env->head)->content.f;
1136      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1137      fb= env->head->car->content.f;      fb= CAR(env->head)->content.f;
1138      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1139      push_float(env, fb+fa);      push_float(env, fb+fa);
1140            
1141      return;      return;
1142    }    }
1143    
1144    if(env->head->car->type==tfloat    if(CAR(env->head)->type==tfloat
1145       && env->head->cdr->content.c->car->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1146      fa= env->head->car->content.f;      fa= CAR(env->head)->content.f;
1147      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1148      b= env->head->car->content.i;      b= CAR(env->head)->content.i;
1149      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1150      push_float(env, b+fa);      push_float(env, b+fa);
1151            
1152      return;      return;
1153    }    }
1154    
1155    if(env->head->car->type==integer    if(CAR(env->head)->type==integer
1156       && env->head->cdr->content.c->car->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1157      a= env->head->car->content.i;      a= CAR(env->head)->content.i;
1158      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1159      fb= env->head->car->content.f;      fb= CAR(env->head)->content.f;
1160      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1161      push_float(env, fb+a);      push_float(env, fb+a);
1162    
# Line 1121  extern void sx_2d(environment *env) Line 1173  extern void sx_2d(environment *env)
1173    int a, b;    int a, b;
1174    float fa, fb;    float fa, fb;
1175    
1176    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1177      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1178      env->err=1;      env->err=1;
1179      return;      return;
1180    }    }
1181        
1182    if(env->head->car->type==integer    if(CAR(env->head)->type==integer
1183       && env->head->cdr->content.c->car->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1184      a= env->head->car->content.i;      a= CAR(env->head)->content.i;
1185      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1186      b= env->head->car->content.i;      b= CAR(env->head)->content.i;
1187      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1188      push_int(env, b-a);      push_int(env, b-a);
1189    
1190      return;      return;
1191    }    }
1192    
1193    if(env->head->car->type==tfloat    if(CAR(env->head)->type==tfloat
1194       && env->head->cdr->content.c->car->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1195      fa= env->head->car->content.f;      fa= CAR(env->head)->content.f;
1196      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1197      fb= env->head->car->content.f;      fb= CAR(env->head)->content.f;
1198      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1199      push_float(env, fb-fa);      push_float(env, fb-fa);
1200            
1201      return;      return;
1202    }    }
1203    
1204    if(env->head->car->type==tfloat    if(CAR(env->head)->type==tfloat
1205       && env->head->cdr->content.c->car->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1206      fa= env->head->car->content.f;      fa= CAR(env->head)->content.f;
1207      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1208      b= env->head->car->content.i;      b= CAR(env->head)->content.i;
1209      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1210      push_float(env, b-fa);      push_float(env, b-fa);
1211            
1212      return;      return;
1213    }    }
1214    
1215    if(env->head->car->type==integer    if(CAR(env->head)->type==integer
1216       && env->head->cdr->content.c->car->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1217      a= env->head->car->content.i;      a= CAR(env->head)->content.i;
1218      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1219      fb= env->head->car->content.f;      fb= CAR(env->head)->content.f;
1220      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1221      push_float(env, fb-a);      push_float(env, fb-a);
1222    
# Line 1181  extern void sx_3e(environment *env) Line 1233  extern void sx_3e(environment *env)
1233    int a, b;    int a, b;
1234    float fa, fb;    float fa, fb;
1235    
1236    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1237      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1238      env->err= 1;      env->err= 1;
1239      return;      return;
1240    }    }
1241        
1242    if(env->head->car->type==integer    if(CAR(env->head)->type==integer
1243       && env->head->cdr->content.c->car->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1244      a=env->head->car->content.i;      a= CAR(env->head)->content.i;
1245      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1246      b=env->head->car->content.i;      b= CAR(env->head)->content.i;
1247      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1248      push_int(env, b>a);      push_int(env, b>a);
1249    
1250      return;      return;
1251    }    }
1252    
1253    if(env->head->car->type==tfloat    if(CAR(env->head)->type==tfloat
1254       && env->head->cdr->content.c->car->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1255      fa= env->head->car->content.f;      fa= CAR(env->head)->content.f;
1256      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1257      fb= env->head->car->content.f;      fb= CAR(env->head)->content.f;
1258      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1259      push_int(env, fb>fa);      push_int(env, fb>fa);
1260            
1261      return;      return;
1262    }    }
1263    
1264    if(env->head->car->type==tfloat    if(CAR(env->head)->type==tfloat
1265       && env->head->cdr->content.c->car->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1266      fa= env->head->car->content.f;      fa= CAR(env->head)->content.f;
1267      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1268      b= env->head->car->content.i;      b= CAR(env->head)->content.i;
1269      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1270      push_int(env, b>fa);      push_int(env, b>fa);
1271            
1272      return;      return;
1273    }    }
1274    
1275    if(env->head->car->type==integer    if(CAR(env->head)->type==integer
1276       && env->head->cdr->content.c->car->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1277      a= env->head->car->content.i;      a= CAR(env->head)->content.i;
1278      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1279      fb= env->head->car->content.f;      fb= CAR(env->head)->content.f;
1280      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1281      push_int(env, fb>a);      push_int(env, fb>a);
1282    
# Line 1232  extern void sx_3e(environment *env) Line 1284  extern void sx_3e(environment *env)
1284    }    }
1285    
1286    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1287    env->err=2;    env->err= 2;
1288  }  }
1289    
1290  /* "<" */  /* "<" */
# Line 1259  extern void sx_3e3d(environment *env) Line 1311  extern void sx_3e3d(environment *env)
1311  /* Return copy of a value */  /* Return copy of a value */
1312  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
1313  {  {
   cons *old_item, *new_item, *prev_item;  
1314    value *new_value;    value *new_value;
1315    
1316      if(old_value==NULL)
1317        return NULL;
1318    
1319    protect(old_value);    protect(old_value);
1320    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
1321    new_value->type= old_value->type;    new_value->type= old_value->type;
1322    
1323    switch(old_value->type){    switch(old_value->type){
# Line 1279  value *copy_val(environment *env, value Line 1332  value *copy_val(environment *env, value
1332        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1333      break;      break;
1334    case tcons:    case tcons:
     new_value->content.ptr= NULL;  
1335    
1336      prev_item= NULL;      new_value->content.c= malloc(sizeof(cons));
1337      old_item= old_value->content.c;      assert(new_value->content.c!=NULL);
1338    
1339      if(old_value->content.ptr != NULL) { /* if list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1340        new_item= malloc(sizeof(cons));      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
       new_item->car= copy_val(env, old_item->car); /* recurse */  
       new_item->cdr= copy_val(env, old_item->cdr); /* recurse */  
     }  
1341      break;      break;
1342    }    }
1343    
1344    unprotect(old_value); unprotect(new_value);    unprotect(old_value);
1345    
1346    return new_value;    return new_value;
1347  }  }
# Line 1300  value *copy_val(environment *env, value Line 1349  value *copy_val(environment *env, value
1349  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1350  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1351  {  {
1352    if(env->head==NULL) {    if(env->head->type==empty) {
1353      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1354      env->err= 1;      env->err= 1;
1355      return;      return;
1356    }    }
1357    push_val(env, copy_val(env, env->head->car));    push_val(env, copy_val(env, CAR(env->head)));
1358  }  }
1359    
1360  /* "if", If-Then */  /* "if", If-Then */
# Line 1313  extern void sx_6966(environment *env) Line 1362  extern void sx_6966(environment *env)
1362  {  {
1363    int truth;    int truth;
1364    
1365    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1366      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1367      env->err= 1;      env->err= 1;
1368      return;      return;
1369    }    }
1370    
1371    if(env->head->cdr->content.c->car->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1372      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1373      env->err= 2;      env->err= 2;
1374      return;      return;
# Line 1328  extern void sx_6966(environment *env) Line 1377  extern void sx_6966(environment *env)
1377    swap(env);    swap(env);
1378    if(env->err) return;    if(env->err) return;
1379        
1380    truth=env->head->car->content.i;    truth= CAR(env->head)->content.i;
1381    
1382    toss(env);    toss(env);
1383    if(env->err) return;    if(env->err) return;
# Line 1344  extern void ifelse(environment *env) Line 1393  extern void ifelse(environment *env)
1393  {  {
1394    int truth;    int truth;
1395    
1396    if(env->head==NULL || env->head->cdr->content.c==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1397       || env->head->cdr->content.c->cdr->content.c==NULL) {       || CDR(CDR(env->head))->type==empty) {
1398      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1399      env->err= 1;      env->err= 1;
1400      return;      return;
1401    }    }
1402    
1403    if(env->head->cdr->content.c->cdr->content.c->car->type!=integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1404      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1405      env->err= 2;      env->err= 2;
1406      return;      return;
# Line 1360  extern void ifelse(environment *env) Line 1409  extern void ifelse(environment *env)
1409    rot(env);    rot(env);
1410    if(env->err) return;    if(env->err) return;
1411        
1412    truth= env->head->car->content.i;    truth= CAR(env->head)->content.i;
1413    
1414    toss(env);    toss(env);
1415    if(env->err) return;    if(env->err) return;
# Line 1375  extern void ifelse(environment *env) Line 1424  extern void ifelse(environment *env)
1424    eval(env);    eval(env);
1425  }  }
1426    
1427    extern void sx_656c7365(environment *env)
1428    {
1429      if(env->head->type==empty || CDR(env->head)->type==empty
1430         || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1431         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1432        printerr("Too Few Arguments");
1433        env->err= 1;
1434        return;
1435      }
1436    
1437      if(CAR(CDR(env->head))->type!=symb
1438         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1439         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1440         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1441        printerr("Bad Argument Type");
1442        env->err= 2;
1443        return;
1444      }
1445    
1446      swap(env); toss(env); rot(env); toss(env);
1447      ifelse(env);
1448    }
1449    
1450    extern void then(environment *env)
1451    {
1452      if(env->head->type==empty || CDR(env->head)->type==empty
1453         || CDR(CDR(env->head))->type==empty) {
1454        printerr("Too Few Arguments");
1455        env->err= 1;
1456        return;
1457      }
1458    
1459      if(CAR(CDR(env->head))->type!=symb
1460         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1461        printerr("Bad Argument Type");
1462        env->err= 2;
1463        return;
1464      }
1465    
1466      swap(env); toss(env);
1467      sx_6966(env);
1468    }
1469    
1470  /* "while" */  /* "while" */
1471  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1472  {  {
1473    int truth;    int truth;
1474    value *loop, *test;    value *loop, *test;
1475    
1476    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1477      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1478      env->err= 1;      env->err= 1;
1479      return;      return;
1480    }    }
1481    
1482    loop= env->head->car;    loop= CAR(env->head);
1483    protect(loop);    protect(loop);
1484    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1485    
1486    test= env->head->car;    test= CAR(env->head);
1487    protect(test);    protect(test);
1488    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1489    
# Line 1399  extern void sx_7768696c65(environment *e Line 1491  extern void sx_7768696c65(environment *e
1491      push_val(env, test);      push_val(env, test);
1492      eval(env);      eval(env);
1493            
1494      if(env->head->car->type != integer) {      if(CAR(env->head)->type != integer) {
1495        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1496        env->err= 2;        env->err= 2;
1497        return;        return;
1498      }      }
1499            
1500      truth= env->head->car->content.i;      truth= CAR(env->head)->content.i;
1501      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1502            
1503      if(truth) {      if(truth) {
# Line 1427  extern void sx_666f72(environment *env) Line 1519  extern void sx_666f72(environment *env)
1519    value *loop;    value *loop;
1520    int foo1, foo2;    int foo1, foo2;
1521    
1522    if(env->head==NULL || env->head->cdr->content.c==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1523       || env->head->cdr->content.c->cdr->content.c==NULL) {       || CDR(CDR(env->head))->type==empty) {
1524      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1525      env->err= 1;      env->err= 1;
1526      return;      return;
1527    }    }
1528    
1529    if(env->head->cdr->content.c->car->type!=integer    if(CAR(CDR(env->head))->type!=integer
1530       || env->head->cdr->content.c->cdr->content.c->car->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1531      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1532      env->err= 2;      env->err= 2;
1533      return;      return;
1534    }    }
1535    
1536    loop= env->head->car;    loop= CAR(env->head);
1537    protect(loop);    protect(loop);
1538    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1539    
1540    foo2= env->head->car->content.i;    foo2= CAR(env->head)->content.i;
1541    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1542    
1543    foo1= env->head->car->content.i;    foo1= CAR(env->head)->content.i;
1544    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1545    
1546    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1473  extern void sx_666f72(environment *env) Line 1565  extern void sx_666f72(environment *env)
1565  extern void foreach(environment *env)  extern void foreach(environment *env)
1566  {    {  
1567    value *loop, *foo;    value *loop, *foo;
1568    cons *iterator;    value *iterator;
1569        
1570    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1571      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1572      env->err= 1;      env->err= 1;
1573      return;      return;
1574    }    }
1575    
1576    if(env->head->cdr->content.c->car->type!=tcons) {    if(CAR(CDR(env->head))->type!=tcons) {
1577      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1578      env->err= 2;      env->err= 2;
1579      return;      return;
1580    }    }
1581    
1582    loop= env->head->car;    loop= CAR(env->head);
1583    protect(loop);    protect(loop);
1584    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1585    
1586    foo= env->head->car;    foo= CAR(env->head);
1587    protect(foo);    protect(foo);
1588    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1589    
1590    iterator= foo->content.c;    iterator= foo;
1591    
1592    while(iterator!=NULL) {    while(iterator!=NULL) {
1593      push_val(env, iterator->car);      push_val(env, CAR(iterator));
1594      push_val(env, loop);      push_val(env, loop);
1595      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1596      if (iterator->cdr->type == tcons){      if (iterator->type == tcons){
1597        iterator= iterator->cdr->content.c;        iterator= CDR(iterator);
1598      } else {      } else {
1599        printerr("Bad Argument Type"); /* Improper list */        printerr("Bad Argument Type"); /* Improper list */
1600        env->err= 2;        env->err= 2;
# Line 1516  extern void foreach(environment *env) Line 1608  extern void foreach(environment *env)
1608  extern void to(environment *env)  extern void to(environment *env)
1609  {  {
1610    int ending, start, i;    int ending, start, i;
1611    cons *iterator, *temp;    value *iterator, *temp;
   value *pack;  
1612    
1613    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1614      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1615      env->err= 1;      env->err= 1;
1616      return;      return;
1617    }    }
1618    
1619    if(env->head->car->type!=integer    if(CAR(env->head)->type!=integer
1620       || env->head->cdr->content.c->car->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1621      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1622      env->err= 2;      env->err= 2;
1623      return;      return;
1624    }    }
1625    
1626    ending= env->head->car->content.i;    ending= CAR(env->head)->content.i;
1627    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1628    start= env->head->car->content.i;    start= CAR(env->head)->content.i;
1629    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1630    
1631    push_sym(env, "[");    push_sym(env, "[");
# Line 1548  extern void to(environment *env) Line 1639  extern void to(environment *env)
1639    }    }
1640    
1641    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(pack);  
1642    
1643    if(iterator==NULL    if(iterator->type==empty
1644       || (iterator->car->type==symb       || (CAR(iterator)->type==symb
1645           && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1646      temp= NULL;      temp= NULL;
1647      toss(env);      toss(env);
1648    } else {    } else {
1649      /* Search for first delimiter */      /* Search for first delimiter */
1650      while(iterator->cdr->content.c!=NULL      while(CDR(iterator)!=NULL
1651            && (iterator->cdr->content.c->car->type!=symb            && (CAR(CDR(iterator))->type!=symb
1652                || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0]                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1653                !='['))        iterator= CDR(iterator);
       iterator= iterator->cdr->content.ptr;  
1654            
1655      /* Extract list */      /* Extract list */
1656      temp= env->head;      temp= env->head;
1657      env->head= iterator->cdr->content.c;      env->head= CDR(iterator);
1658      iterator->cdr->content.c= NULL;      CDR(iterator)= NULL;
1659    
     pack->type= tcons;  
     pack->content.ptr= temp;  
       
1660      if(env->head!=NULL)      if(env->head!=NULL)
1661        toss(env);        toss(env);
1662    }    }
1663    
1664    /* Push list */    /* Push list */
1665      push_val(env, temp);
   push_val(env, pack);  
   
   unprotect(pack);  
1666  }  }
1667    
1668  /* Read a string */  /* Read a string */
# Line 1619  extern void sx_72656164(environment *env Line 1701  extern void sx_72656164(environment *env
1701      }      }
1702      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1703    
1704      if(((char *)(env->head->car->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1705        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1706        return;        return;
1707      }      }
1708            
1709      env->in_string= malloc(strlen(env->head->car->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1710      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1711      strcpy(env->in_string, env->head->car->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1712      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1713    }    }
1714        
# Line 1675  extern void sx_72656164(environment *env Line 1757  extern void sx_72656164(environment *env
1757      return sx_72656164(env);      return sx_72656164(env);
1758  }  }
1759    
1760    #ifdef __linux__
1761  extern void beep(environment *env)  extern void beep(environment *env)
1762  {  {
1763    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1764    
1765    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1766      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1767      env->err= 1;      env->err= 1;
1768      return;      return;
1769    }    }
1770    
1771    if(env->head->car->type!=integer    if(CAR(env->head)->type!=integer
1772       || env->head->cdr->content.c->car->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1773      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1774      env->err= 2;      env->err= 2;
1775      return;      return;
1776    }    }
1777    
1778    dur= env->head->car->content.i;    dur= CAR(env->head)->content.i;
1779    toss(env);    toss(env);
1780    freq= env->head->car->content.i;    freq= CAR(env->head)->content.i;
1781    toss(env);    toss(env);
1782    
1783    period= 1193180/freq;         /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
# Line 1717  extern void beep(environment *env) Line 1800  extern void beep(environment *env)
1800      abort();      abort();
1801    }    }
1802  }  }
1803    #endif /* __linux__ */
1804    
1805  /* "wait" */  /* "wait" */
1806  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
1807  {  {
1808    int dur;    int dur;
1809    
1810    if(env->head==NULL) {    if(env->head->type==empty) {
1811      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1812      env->err= 1;      env->err= 1;
1813      return;      return;
1814    }    }
1815    
1816    if(env->head->car->type!=integer) {    if(CAR(env->head)->type!=integer) {
1817      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1818      env->err= 2;      env->err= 2;
1819      return;      return;
1820    }    }
1821    
1822    dur=env->head->car->content.i;    dur= CAR(env->head)->content.i;
1823    toss(env);    toss(env);
1824    
1825    usleep(dur);    usleep(dur);
# Line 1743  extern void sx_77616974(environment *env Line 1827  extern void sx_77616974(environment *env
1827    
1828  extern void copying(environment *env)  extern void copying(environment *env)
1829  {  {
1830    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1831                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1832  \n\  \n\
1833   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2032  extern void sx_2a(environment *env) Line 2116  extern void sx_2a(environment *env)
2116    int a, b;    int a, b;
2117    float fa, fb;    float fa, fb;
2118    
2119    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2120      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2121      env->err= 1;      env->err= 1;
2122      return;      return;
2123    }    }
2124        
2125    if(env->head->car->type==integer    if(CAR(env->head)->type==integer
2126       && env->head->cdr->content.c->car->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2127      a= env->head->car->content.i;      a= CAR(env->head)->content.i;
2128      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2129      b= env->head->car->content.i;      b= CAR(env->head)->content.i;
2130      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2131      push_int(env, b*a);      push_int(env, b*a);
2132    
2133      return;      return;
2134    }    }
2135    
2136    if(env->head->car->type==tfloat    if(CAR(env->head)->type==tfloat
2137       && env->head->cdr->content.c->car->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2138      fa= env->head->car->content.f;      fa= CAR(env->head)->content.f;
2139      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2140      fb= env->head->car->content.f;      fb= CAR(env->head)->content.f;
2141      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2142      push_float(env, fb*fa);      push_float(env, fb*fa);
2143            
2144      return;      return;
2145    }    }
2146    
2147    if(env->head->car->type==tfloat    if(CAR(env->head)->type==tfloat
2148       && env->head->cdr->content.c->car->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2149      fa= env->head->car->content.f;      fa= CAR(env->head)->content.f;
2150      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2151      b= env->head->car->content.i;      b= CAR(env->head)->content.i;
2152      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2153      push_float(env, b*fa);      push_float(env, b*fa);
2154            
2155      return;      return;
2156    }    }
2157    
2158    if(env->head->car->type==integer    if(CAR(env->head)->type==integer
2159       && env->head->cdr->content.c->car->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2160      a= env->head->car->content.i;      a= CAR(env->head)->content.i;
2161      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2162      fb= env->head->car->content.f;      fb= CAR(env->head)->content.f;
2163      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2164      push_float(env, fb*a);      push_float(env, fb*a);
2165    
# Line 2092  extern void sx_2f(environment *env) Line 2176  extern void sx_2f(environment *env)
2176    int a, b;    int a, b;
2177    float fa, fb;    float fa, fb;
2178    
2179    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2180      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2181      env->err= 1;      env->err= 1;
2182      return;      return;
2183    }    }
2184        
2185    if(env->head->car->type==integer    if(CAR(env->head)->type==integer
2186       && env->head->cdr->content.c->car->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2187      a= env->head->car->content.i;      a= CAR(env->head)->content.i;
2188      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2189      b= env->head->car->content.i;      b= CAR(env->head)->content.i;
2190      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2191      push_float(env, b/a);      push_float(env, b/a);
2192    
2193      return;      return;
2194    }    }
2195    
2196    if(env->head->car->type==tfloat    if(CAR(env->head)->type==tfloat
2197       && env->head->cdr->content.c->car->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2198      fa= env->head->car->content.f;      fa= CAR(env->head)->content.f;
2199      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2200      fb= env->head->car->content.f;      fb= CAR(env->head)->content.f;
2201      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2202      push_float(env, fb/fa);      push_float(env, fb/fa);
2203            
2204      return;      return;
2205    }    }
2206    
2207    if(env->head->car->type==tfloat    if(CAR(env->head)->type==tfloat
2208       && env->head->cdr->content.c->car->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2209      fa= env->head->car->content.f;      fa= CAR(env->head)->content.f;
2210      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2211      b= env->head->car->content.i;      b= CAR(env->head)->content.i;
2212      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2213      push_float(env, b/fa);      push_float(env, b/fa);
2214            
2215      return;      return;
2216    }    }
2217    
2218    if(env->head->car->type==integer    if(CAR(env->head)->type==integer
2219       && env->head->cdr->content.c->car->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2220      a= env->head->car->content.i;      a= CAR(env->head)->content.i;
2221      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2222      fb= env->head->car->content.f;      fb= CAR(env->head)->content.f;
2223      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2224      push_float(env, fb/a);      push_float(env, fb/a);
2225    
# Line 2151  extern void mod(environment *env) Line 2235  extern void mod(environment *env)
2235  {  {
2236    int a, b;    int a, b;
2237    
2238    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2239      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2240      env->err= 1;      env->err= 1;
2241      return;      return;
2242    }    }
2243        
2244    if(env->head->car->type==integer    if(CAR(env->head)->type==integer
2245       && env->head->cdr->content.c->car->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2246      a= env->head->car->content.i;      a= CAR(env->head)->content.i;
2247      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2248      b= env->head->car->content.i;      b= CAR(env->head)->content.i;
2249      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2250      push_int(env, b%a);      push_int(env, b%a);
2251    
# Line 2177  extern void sx_646976(environment *env) Line 2261  extern void sx_646976(environment *env)
2261  {  {
2262    int a, b;    int a, b;
2263        
2264    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2265      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2266      env->err= 1;      env->err= 1;
2267      return;      return;
2268    }    }
2269    
2270    if(env->head->car->type==integer    if(CAR(env->head)->type==integer
2271       && env->head->cdr->content.c->car->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2272      a= env->head->car->content.i;      a= CAR(env->head)->content.i;
2273      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2274      b= env->head->car->content.i;      b= CAR(env->head)->content.i;
2275      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2276      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2277    
Legend:
Removed from v.1.103  
changed lines
  Added in v.1.112
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26