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

Diff of /stack/stack.c

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

revision 1.92 by masse, Fri Mar 8 06:44:15 2002 UTC revision 1.105 by masse, Tue Mar 12 14:53:19 2002 UTC
# Line 20  Line 20 
20               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
21  */  */
22    
23    #define CAR(X) X->content.c->car
24    #define CDR(X) X->content.c->cdr
25    
26  /* printf, sscanf, fgets, fprintf, fopen, perror */  /* printf, sscanf, fgets, fprintf, fopen, perror */
27  #include <stdio.h>  #include <stdio.h>
28  /* exit, EXIT_SUCCESS, malloc, free */  /* exit, EXIT_SUCCESS, malloc, free */
# Line 48  void init_env(environment *env) Line 51  void init_env(environment *env)
51  {  {
52    int i;    int i;
53    
54    env->gc_limit= 20;    env->gc_limit= 400000;
55    env->gc_count= 0;    env->gc_count= 0;
56    env->gc_ref= NULL;    env->gc_ref= NULL;
   env->gc_protect= NULL;  
57    
58    env->head= NULL;    env->head= NULL;
59    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
# Line 63  void init_env(environment *env) Line 65  void init_env(environment *env)
65    env->interactive= 1;    env->interactive= 1;
66  }  }
67    
68  void printerr(const char* in_string) {  void printerr(const char* in_string)
69    {
70    fprintf(stderr, "Err: %s\n", in_string);    fprintf(stderr, "Err: %s\n", in_string);
71  }  }
72    
73  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
74  extern void toss(environment *env)  extern void toss(environment *env)
75  {  {
76    stackitem *temp= env->head;    if(env->head==NULL) {
   
   if((env->head)==NULL) {  
77      printerr("Too Few Arguments");      printerr("Too Few Arguments");
78      env->err= 1;      env->err= 1;
79      return;      return;
80    }    }
81        
82    env->head= env->head->next;   /* Remove the top stack item */    env->head= CDR(env->head); /* Remove the top stack item */
   free(temp);                   /* Free the old top stack item */  
   
   gc_init(env);  
83  }  }
84    
85  /* Returns a pointer to a pointer to an element in the hash table. */  /* Returns a pointer to a pointer to an element in the hash table. */
# Line 113  symbol **hash(hashtbl in_hashtbl, const Line 111  symbol **hash(hashtbl in_hashtbl, const
111    }    }
112  }  }
113    
114  value* new_val(environment *env) {  /* Create new value */
115    value* new_val(environment *env)
116    {
117    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
118    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
119    
120    nval->content.ptr= NULL;    nval->content.ptr= NULL;
   protect(env, nval);  
   
   gc_init(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++;    env->gc_count += sizeof(value);
128    unprotect(env);    nval->gc.flag.mark= 0;
129      nval->gc.flag.protect= 0;
130    
131    return nval;    return nval;
132  }  }
133    
134  void gc_mark(value *val) {  /* Mark values recursively.
135    stackitem *iterator;     Marked values are not collected by the GC. */
136    inline void gc_mark(value *val)
137    if(val==NULL || val->gc_garb==0)  {
138      if(val==NULL || val->gc.flag.mark)
139      return;      return;
140    
141    val->gc_garb= 0;    val->gc.flag.mark= 1;
   
   if(val->type==list) {  
     iterator= val->content.ptr;  
142    
143      while(iterator!=NULL) {    if(val->type==tcons) {
144        gc_mark(iterator->item);      gc_mark(CAR(val));
145        iterator= iterator->next;      gc_mark(CDR(val));
     }  
146    }    }
147  }  }
148    
149  extern void gc_init(environment *env) {  inline void gc_maybe(environment *env)
150    stackitem *new_head= NULL, *titem, *iterator= env->gc_ref;  {
151      if(env->gc_count < env->gc_limit)
152        return;
153      else
154        return gc_init(env);
155    }
156    
157    /* Start GC */
158    extern void gc_init(environment *env)
159    {
160      stackitem *new_head= NULL, *titem;
161      cons *iterator;
162    symbol *tsymb;    symbol *tsymb;
163    int i;    int i;
164    
165    if(env->gc_count < env->gc_limit)    if(env->interactive)
166      return;      printf("Garbage collecting.");
167    
168    while(iterator!=NULL) {    /* Mark values on stack */
169      iterator->item->gc_garb= 1;    gc_mark(env->head);
     iterator= iterator->next;  
   }  
170    
171    /* Mark */    if(env->interactive)
172    iterator= env->gc_protect;      printf(".");
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
173    
   iterator= env->head;  
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
174    
175    for(i= 0; i<HASHTBLSIZE; i++) {    /* Mark values in hashtable */
176      tsymb= env->symbols[i];    for(i= 0; i<HASHTBLSIZE; i++)
177      while(tsymb!=NULL) {      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
178        gc_mark(tsymb->val);        if (tsymb->val != NULL)
179        tsymb= tsymb->next;          gc_mark(tsymb->val);
180      }  
181    }  
182      if(env->interactive)
183        printf(".");
184    
185    
186    env->gc_count= 0;    env->gc_count= 0;
187    
188    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
   while(env->gc_ref!=NULL) {  
189    
190      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
191        switch(env->gc_ref->item->type) {  
192        case string:        if(env->gc_ref->item->type==string) /* Remove content */
193          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
194          break;  
195        case integer:        free(env->gc_ref->item);  /* Remove from gc_ref */
         break;  
       case list:  
         while(env->gc_ref->item->content.ptr!=NULL) {  
           titem= env->gc_ref->item->content.ptr;  
           env->gc_ref->item->content.ptr= titem->next;  
           free(titem);  
         }  
         break;  
       default:  
         break;  
       }  
       free(env->gc_ref->item);  
       titem= env->gc_ref->next;  
       free(env->gc_ref);  
       env->gc_ref= titem;  
     } else {  
196        titem= env->gc_ref->next;        titem= env->gc_ref->next;
197        env->gc_ref->next= new_head;        free(env->gc_ref);        /* Remove value */
       new_head= env->gc_ref;  
198        env->gc_ref= titem;        env->gc_ref= titem;
199        env->gc_count++;        continue;
200      }      }
201    
202        /* Keep values */    
203        env->gc_count += sizeof(value);
204        if(env->gc_ref->item->type==string)
205          env->gc_count += strlen(env->gc_ref->item->content.ptr);
206        
207        titem= env->gc_ref->next;
208        env->gc_ref->next= new_head;
209        new_head= env->gc_ref;
210        new_head->item->gc.flag.mark= 0;
211        env->gc_ref= titem;
212    }    }
213    
214    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
215        env->gc_limit= env->gc_count*2;
216    
217    env->gc_ref= new_head;    env->gc_ref= new_head;
218    
219      if(env->interactive)
220        printf("done\n");
221    
222  }  }
223    
224  void protect(environment *env, value *val)  /* Protect values from GC */
225    void protect(value *val)
226  {  {
227    stackitem *new_item= malloc(sizeof(stackitem));    if(val==NULL || val->gc.flag.protect)
228    new_item->item= val;      return;
229    new_item->next= env->gc_protect;  
230    env->gc_protect= new_item;    val->gc.flag.protect= 1;
231    
232      if(val->type==tcons) {
233        protect(CAR(val));
234        protect(CDR(val));
235      }
236  }  }
237    
238  void unprotect(environment *env)  /* Unprotect values from GC */
239    void unprotect(value *val)
240  {  {
241    stackitem *temp= env->gc_protect;    if(val==NULL || !(val->gc.flag.protect))
242    env->gc_protect= env->gc_protect->next;      return;
243    free(temp);  
244      val->gc.flag.protect= 0;
245    
246      if(val->type==tcons) {
247        unprotect(CAR(val));
248        unprotect(CDR(val));
249      }
250  }  }
251    
252  /* Push a value onto the stack */  /* Push a value onto the stack */
253  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
254  {  {
255    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
256    new_item->item= val;  
257    new_item->next= env->head;    new_value->content.c= malloc(sizeof(cons));
258    env->head= new_item;    new_value->type= tcons;
259      CAR(new_value)= val;
260      CDR(new_value)= env->head;
261      env->head= new_value;
262  }  }
263    
264  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
265  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
266  {  {
267    value *new_value= new_val(env);    value *new_value= new_val(env);
268        
269    new_value->content.val= in_val;    new_value->content.i= in_val;
270    new_value->type= integer;    new_value->type= integer;
271    
272    push_val(env, new_value);    push_val(env, new_value);
273  }  }
274    
275    /* Push a floating point number onto the stack */
276    void push_float(environment *env, float in_val)
277    {
278      value *new_value= new_val(env);
279    
280      new_value->content.f= in_val;
281      new_value->type= tfloat;
282    
283      push_val(env, new_value);
284    }
285    
286  /* Copy a string onto the stack. */  /* Copy a string onto the stack. */
287  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
288  {  {
289    value *new_value= new_val(env);    value *new_value= new_val(env);
290      int length= strlen(in_string)+1;
291    
292    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
293      env->gc_count += length;
294    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
295    new_value->type= string;    new_value->type= string;
296    
# Line 271  void push_cstring(environment *env, cons Line 298  void push_cstring(environment *env, cons
298  }  }
299    
300  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
301  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
302    {
303    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
304    char *new_string, *current;    char *new_string, *current;
305    
# Line 289  char *mangle_str(const char *old_string) Line 317  char *mangle_str(const char *old_string)
317    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
318  }  }
319    
320  extern void mangle(environment *env){  extern void mangle(environment *env)
321    {
322    char *new_string;    char *new_string;
323    
324    if((env->head)==NULL) {    if(env->head==NULL) {
325      printerr("Too Few Arguments");      printerr("Too Few Arguments");
326      env->err= 1;      env->err= 1;
327      return;      return;
328    }    }
329    
330    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
331      printerr("Bad Argument Type");      printerr("Bad Argument Type");
332      env->err= 2;      env->err= 2;
333      return;      return;
334    }    }
335    
336    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
337        mangle_str((const char *)(CAR(env->head)->content.ptr));
338    
339    toss(env);    toss(env);
340    if(env->err) return;    if(env->err) return;
# Line 328  void push_sym(environment *env, const ch Line 358  void push_sym(environment *env, const ch
358    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
359    
360    new_value= new_val(env);    new_value= new_val(env);
361      protect(new_value);
362      new_fvalue= new_val(env);
363      protect(new_fvalue);
364    
365    /* The new value is a symbol */    /* The new value is a symbol */
366    new_value->type= symb;    new_value->type= symb;
# Line 355  void push_sym(environment *env, const ch Line 388  void push_sym(environment *env, const ch
388    
389      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
390      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
391      free(mangled);  
392      dlerr= dlerror();      dlerr= dlerror();
393      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
394        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
395        dlerr= dlerror();        dlerr= dlerror();
396      }      }
397    
398      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
       new_fvalue= new_val(env); /* Create a new value */  
399        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
400        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
401        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
402                                           function value */                                           function value */
403      }      }
404    
405        free(mangled);
406    }    }
407    
408    push_val(env, new_value);    push_val(env, new_value);
409      unprotect(new_value); unprotect(new_fvalue);
410  }  }
411    
412  /* Print newline. */  /* Print newline. */
# Line 379  extern void nl() Line 416  extern void nl()
416  }  }
417    
418  /* Gets the type of a value */  /* Gets the type of a value */
419  extern void type(environment *env){  extern void type(environment *env)
420    {
421    int typenum;    int typenum;
422    
423    if((env->head)==NULL) {    if(env->head==NULL) {
424      printerr("Too Few Arguments");      printerr("Too Few Arguments");
425      env->err=1;      env->err= 1;
426      return;      return;
427    }    }
428    typenum=env->head->item->type;  
429      typenum= CAR(env->head)->type;
430    toss(env);    toss(env);
431    switch(typenum){    switch(typenum){
432    case integer:    case integer:
433      push_sym(env, "integer");      push_sym(env, "integer");
434      break;      break;
435      case tfloat:
436        push_sym(env, "float");
437        break;
438    case string:    case string:
439      push_sym(env, "string");      push_sym(env, "string");
440      break;      break;
# Line 402  extern void type(environment *env){ Line 444  extern void type(environment *env){
444    case func:    case func:
445      push_sym(env, "function");      push_sym(env, "function");
446      break;      break;
447    case list:    case tcons:
448      push_sym(env, "list");      push_sym(env, "list");
449      break;      break;
450    }    }
451  }      }    
452    
453  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
454  void print_h(stackitem *stack_head, int noquote)  void print_h(value *stack_head, int noquote)
455  {  {
456    switch(stack_head->item->type) {    switch(CAR(stack_head)->type) {
457    case integer:    case integer:
458      printf("%d", stack_head->item->content.val);      printf("%d", CAR(stack_head)->content.i);
459        break;
460      case tfloat:
461        printf("%f", CAR(stack_head)->content.f);
462      break;      break;
463    case string:    case string:
464      if(noquote)      if(noquote)
465        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)CAR(stack_head)->content.ptr);
466      else      else
467        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);
468      break;      break;
469    case symb:    case symb:
470      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
471      break;      break;
472    case func:    case func:
473      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
474      break;      break;
475    case list:    case tcons:
476      /* A list is just a stack, so make stack_head point to it */      /* A list is just a stack, so make stack_head point to it */
477      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head= CAR(stack_head);
478      printf("[ ");      printf("[ ");
479      while(stack_head != NULL) {      while(stack_head != NULL) {
480        print_h(stack_head, noquote);        print_h(stack_head, noquote);
481        printf(" ");        printf(" ");
482        stack_head=stack_head->next;        stack_head= CDR(stack_head);
483      }      }
484      printf("]");      printf("]");
485      break;      break;
486    }    }
487  }  }
488    
489  extern void print_(environment *env) {  extern void print_(environment *env)
490    {
491    if(env->head==NULL) {    if(env->head==NULL) {
492      printerr("Too Few Arguments");      printerr("Too Few Arguments");
493      env->err=1;      env->err= 1;
494      return;      return;
495    }    }
496    print_h(env->head, 0);    print_h(env->head, 0);
# Line 459  extern void print(environment *env) Line 505  extern void print(environment *env)
505    toss(env);    toss(env);
506  }  }
507    
508  extern void princ_(environment *env) {  extern void princ_(environment *env)
509    {
510    if(env->head==NULL) {    if(env->head==NULL) {
511      printerr("Too Few Arguments");      printerr("Too Few Arguments");
512      env->err=1;      env->err= 1;
513      return;      return;
514    }    }
515    print_h(env->head, 1);    print_h(env->head, 1);
# Line 477  extern void princ(environment *env) Line 524  extern void princ(environment *env)
524  }  }
525    
526  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
527  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
528  {  {
529    if(stack_head->next != NULL)    if(CDR(stack_head) != NULL)
530      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
531    printf("%ld: ", counter);    printf("%ld: ", counter);
532    print_h(stack_head, 0);    print_h(stack_head, 0);
533    nl();    nl();
# Line 493  extern void printstack(environment *env) Line 540  extern void printstack(environment *env)
540      printf("Stack Empty\n");      printf("Stack Empty\n");
541      return;      return;
542    }    }
543    
544    print_st(env->head, 1);    print_st(env->head, 1);
545  }  }
546    
547  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
548  extern void swap(environment *env)  extern void swap(environment *env)
549  {  {
550    stackitem *temp= env->head;    value *temp= env->head;
551        
552    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
553      printerr("Too Few Arguments");      printerr("Too Few Arguments");
554      env->err=1;      env->err=1;
555      return;      return;
556    }    }
557    
558    env->head= env->head->next;    env->head= CDR(env->head);
559    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
560    env->head->next= temp;    CDR(env->head)= temp;
561  }  }
562    
563  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
564  extern void rot(environment *env)  extern void rot(environment *env)
565  {  {
566    stackitem *temp= env->head;    value *temp= env->head;
567        
568    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
569        || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
570      printerr("Too Few Arguments");      printerr("Too Few Arguments");
571      env->err=1;      env->err= 1;
572      return;      return;
573    }    }
574      
575    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
576    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
577    env->head->next= temp;    CDR(env->head)= temp;
578  }  }
579    
580  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 534  extern void rcl(environment *env) Line 582  extern void rcl(environment *env)
582  {  {
583    value *val;    value *val;
584    
585    if(env->head == NULL) {    if(env->head==NULL) {
586      printerr("Too Few Arguments");      printerr("Too Few Arguments");
587      env->err=1;      env->err= 1;
588      return;      return;
589    }    }
590    
591    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
592      printerr("Bad Argument Type");      printerr("Bad Argument Type");
593      env->err=2;      env->err= 2;
594      return;      return;
595    }    }
596    
597    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
598    if(val == NULL){    if(val == NULL){
599      printerr("Unbound Variable");      printerr("Unbound Variable");
600      env->err=3;      env->err= 3;
601      return;      return;
602    }    }
603    protect(env, val);    protect(val);
604    toss(env);            /* toss the symbol */    toss(env);            /* toss the symbol */
605    if(env->err) return;    if(env->err) return;
606    push_val(env, val); /* Return its bound value */    push_val(env, val); /* Return its bound value */
607    unprotect(env);    unprotect(val);
608  }  }
609    
610  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
# Line 566  extern void eval(environment *env) Line 614  extern void eval(environment *env)
614  {  {
615    funcp in_func;    funcp in_func;
616    value* temp_val;    value* temp_val;
617    stackitem* iterator;    value* iterator;
618    
619   eval_start:   eval_start:
620    
621      gc_maybe(env);
622    
623    if(env->head==NULL) {    if(env->head==NULL) {
624      printerr("Too Few Arguments");      printerr("Too Few Arguments");
625      env->err=1;      env->err= 1;
626      return;      return;
627    }    }
628    
629    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
630      /* if it's a symbol */      /* if it's a symbol */
631    case symb:    case symb:
632      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
633      if(env->err) return;      if(env->err) return;
634      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
635        goto eval_start;        goto eval_start;
636      }      }
637      return;      return;
638    
639      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
640    case func:    case func:
641      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
642      toss(env);      toss(env);
643      if(env->err) return;      if(env->err) return;
644      return in_func(env);      return in_func(env);
645    
646      /* If it's a list */      /* If it's a list */
647    case list:    case tcons:
648      temp_val= env->head->item;      temp_val= CAR(env->head);
649      protect(env, temp_val);      protect(temp_val);
650      toss(env);  
651      if(env->err) return;      toss(env); if(env->err) return;
652      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
     unprotect(env);  
653            
654      while(iterator!=NULL) {      while(iterator!=NULL) {
655        push_val(env, iterator->item);        push_val(env, CAR(iterator));
656                
657        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
658          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
659          toss(env);          toss(env);
660          if(env->err) return;          if(env->err) return;
661                    
662          if(iterator->next == NULL){          if(CDR(iterator)==NULL){
663            goto eval_start;            goto eval_start;
664          }          }
665          eval(env);          eval(env);
666          if(env->err) return;          if(env->err) return;
667        }        }
668        iterator= iterator->next;        if (CDR(iterator)->type == tcons)
669            iterator= CDR(iterator);
670          else {
671            printerr("Bad Argument Type"); /* Improper list */
672            env->err= 2;
673            return;
674          }
675      }      }
676        unprotect(temp_val);
677      return;      return;
678    
679    default:    default:
# Line 626  extern void eval(environment *env) Line 682  extern void eval(environment *env)
682  }  }
683    
684  /* Reverse (flip) a list */  /* Reverse (flip) a list */
685  extern void rev(environment *env){  extern void rev(environment *env)
686    stackitem *old_head, *new_head, *item;  {
687      value *old_head, *new_head, *item;
688    
689    if((env->head)==NULL) {    if(env->head==NULL) {
690      printerr("Too Few Arguments");      printerr("Too Few Arguments");
691      env->err= 1;      env->err= 1;
692      return;      return;
693    }    }
694    
695    if(env->head->item->type!=list) {    if(CAR(env->head)->type!=tcons) {
696      printerr("Bad Argument Type");      printerr("Bad Argument Type");
697      env->err= 2;      env->err= 2;
698      return;      return;
699    }    }
700    
701    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
702    new_head= NULL;    new_head= NULL;
703    while(old_head != NULL){    while(old_head!=NULL) {
704      item= old_head;      item= old_head;
705      old_head= old_head->next;      old_head= CDR(old_head);
706      item->next= new_head;      CDR(item)= new_head;
707      new_head= item;      new_head= item;
708    }    }
709    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
710  }  }
711    
712  /* Make a list. */  /* Make a list. */
713  extern void pack(environment *env)  extern void pack(environment *env)
714  {  {
715    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
716    
717    iterator= env->head;    iterator= env->head;
   
718    if(iterator==NULL    if(iterator==NULL
719       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
720       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
721      temp= NULL;      temp= NULL;
722      toss(env);      toss(env);
723    } else {    } else {
724      /* Search for first delimiter */      /* Search for first delimiter */
725      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
726            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
727            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
728        iterator= iterator->next;        iterator= CDR(iterator);
729            
730      /* Extract list */      /* Extract list */
731      temp= env->head;      temp= env->head;
732      env->head= iterator->next;      env->head= CDR(iterator);
733      iterator->next= NULL;      CDR(iterator)= NULL;
734        
735      if(env->head!=NULL)      if(env->head!=NULL)
736        toss(env);        toss(env);
737    }    }
738    
739    /* Push list */    /* Push list */
   pack= new_val(env);  
   pack->type= list;  
   pack->content.ptr= temp;  
740    
741    push_val(env, pack);    push_val(env, temp);
742    rev(env);    rev(env);
743  }  }
744    
745  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
746  extern void expand(environment *env)  extern void expand(environment *env)
747  {  {
748    stackitem *temp, *new_head;    value *temp, *new_head;
749    
750    /* Is top element a list? */    /* Is top element a list? */
751    if(env->head==NULL) {    if(env->head==NULL) {
# Line 701  extern void expand(environment *env) Line 753  extern void expand(environment *env)
753      env->err= 1;      env->err= 1;
754      return;      return;
755    }    }
756    if(env->head->item->type!=list) {  
757      if(CAR(env->head)->type!=tcons) {
758      printerr("Bad Argument Type");      printerr("Bad Argument Type");
759      env->err= 2;      env->err= 2;
760      return;      return;
# Line 713  extern void expand(environment *env) Line 766  extern void expand(environment *env)
766      return;      return;
767    
768    /* The first list element is the new stack head */    /* The first list element is the new stack head */
769    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
770    
771    toss(env);    toss(env);
772    
773    /* Find the end of the list */    /* Find the end of the list */
774    while(temp->next!=NULL)    while(CDR(temp)->content.ptr != NULL) {
775      temp= temp->next;      if (CDR(temp)->type == tcons)
776          temp= CDR(temp);
777        else {
778          printerr("Bad Argument Type"); /* Improper list */
779          env->err= 2;
780          return;
781        }
782      }
783    
784    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
785    temp->next= env->head;    CDR(temp)= env->head;
786    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
787    
788  }  }
# Line 731  extern void expand(environment *env) Line 791  extern void expand(environment *env)
791  extern void eq(environment *env)  extern void eq(environment *env)
792  {  {
793    void *left, *right;    void *left, *right;
   int result;  
794    
795    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
796      printerr("Too Few Arguments");      printerr("Too Few Arguments");
797      env->err= 1;      env->err= 1;
798      return;      return;
799    }    }
800    
801    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
802    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
803    toss(env); toss(env);    toss(env); toss(env);
804    push_int(env, result);  
805      push_int(env, left==right);
806  }  }
807    
808  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 753  extern void not(environment *env) Line 810  extern void not(environment *env)
810  {  {
811    int val;    int val;
812    
813    if((env->head)==NULL) {    if(env->head==NULL) {
814      printerr("Too Few Arguments");      printerr("Too Few Arguments");
815      env->err= 1;      env->err= 1;
816      return;      return;
817    }    }
818    
819    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
820      printerr("Bad Argument Type");      printerr("Bad Argument Type");
821      env->err= 2;      env->err= 2;
822      return;      return;
823    }    }
824    
825    val= env->head->item->content.val;    val= CAR(env->head)->content.i;
826    toss(env);    toss(env);
827    push_int(env, !val);    push_int(env, !val);
828  }  }
# Line 784  extern void def(environment *env) Line 841  extern void def(environment *env)
841    symbol *sym;    symbol *sym;
842    
843    /* Needs two values on the stack, the top one must be a symbol */    /* Needs two values on the stack, the top one must be a symbol */
844    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
845      printerr("Too Few Arguments");      printerr("Too Few Arguments");
846      env->err= 1;      env->err= 1;
847      return;      return;
848    }    }
849    
850    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
851      printerr("Bad Argument Type");      printerr("Bad Argument Type");
852      env->err= 2;      env->err= 2;
853      return;      return;
854    }    }
855    
856    /* long names are a pain */    /* long names are a pain */
857    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
858    
859    /* Bind the symbol to the value */    /* Bind the symbol to the value */
860    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
861    
862    toss(env); toss(env);    toss(env); toss(env);
863  }  }
# Line 808  extern void def(environment *env) Line 865  extern void def(environment *env)
865  /* Quit stack. */  /* Quit stack. */
866  extern void quit(environment *env)  extern void quit(environment *env)
867  {  {
868    long i;    int i;
869    
870    clear(env);    clear(env);
871    
# Line 821  extern void quit(environment *env) Line 878  extern void quit(environment *env)
878    }    }
879    
880    env->gc_limit= 0;    env->gc_limit= 0;
881    gc_init(env);    gc_maybe(env);
882    
883    if(env->free_string!=NULL)    if(env->free_string!=NULL)
884      free(env->free_string);      free(env->free_string);
# Line 854  extern void words(environment *env) Line 911  extern void words(environment *env)
911  }  }
912    
913  /* Internal forget function */  /* Internal forget function */
914  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
915    {
916    symbol *temp;    symbol *temp;
917    
918    temp= *hash_entry;    temp= *hash_entry;
# Line 868  void forget_sym(symbol **hash_entry) { Line 926  void forget_sym(symbol **hash_entry) {
926  extern void forget(environment *env)  extern void forget(environment *env)
927  {  {
928    char* sym_id;    char* sym_id;
929    stackitem *stack_head= env->head;    value *stack_head= env->head;
930    
931    if(stack_head==NULL) {    if(stack_head==NULL) {
932      printerr("Too Few Arguments");      printerr("Too Few Arguments");
933      env->err=1;      env->err= 1;
934      return;      return;
935    }    }
936        
937    if(stack_head->item->type!=symb) {    if(CAR(stack_head)->type!=symb) {
938      printerr("Bad Argument Type");      printerr("Bad Argument Type");
939      env->err=2;      env->err= 2;
940      return;      return;
941    }    }
942    
943    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(stack_head)->content.sym->id;
944    toss(env);    toss(env);
945    
946    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
947  }  }
948    
949  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
950  extern void errn(environment *env){  extern void errn(environment *env)
951    {
952    push_int(env, env->err);    push_int(env, env->err);
953  }  }
954    
# Line 953  under certain conditions; type `copying; Line 1012  under certain conditions; type `copying;
1012      if (myenv.err==4) {      if (myenv.err==4) {
1013        return EXIT_SUCCESS;      /* EOF */        return EXIT_SUCCESS;      /* EOF */
1014      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1015                && myenv.head->item->type==symb                && CAR(myenv.head)->type==symb
1016                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->content.sym->id[0]
1017                  ==';') {
1018        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1019        eval(&myenv);        eval(&myenv);
1020      }      }
1021      gc_init(&myenv);      gc_maybe(&myenv);
1022    }    }
1023    quit(&myenv);    quit(&myenv);
1024    return EXIT_FAILURE;    return EXIT_FAILURE;
1025  }  }
1026    
1027  /* "+" */  /* "+" */
1028  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1029    {
1030    int a, b;    int a, b;
1031      float fa, fb;
1032    size_t len;    size_t len;
1033    char* new_string;    char* new_string;
1034    value *a_val, *b_val;    value *a_val, *b_val;
1035    
1036    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1037      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1038      env->err= 1;      env->err= 1;
1039      return;      return;
1040    }    }
1041    
1042    if(env->head->item->type==string    if(CAR(env->head)->type==string
1043       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1044      a_val= env->head->item;      a_val= CAR(env->head);
1045      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1046      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1047      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1048      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1049      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
# Line 989  extern void sx_2b(environment *env) { Line 1051  extern void sx_2b(environment *env) {
1051      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1052      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1053      push_cstring(env, new_string);      push_cstring(env, new_string);
1054      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1055      free(new_string);      free(new_string);
1056        
1057      return;      return;
1058    }    }
1059        
1060    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1061       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1062      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1063      env->err=2;      toss(env); if(env->err) return;
1064        b= CAR(env->head)->content.i;
1065        toss(env); if(env->err) return;
1066        push_int(env, b+a);
1067    
1068      return;      return;
1069    }    }
1070    a= env->head->item->content.val;  
1071    toss(env); if(env->err) return;    if(CAR(env->head)->type==tfloat
1072           && CAR(CDR(env->head))->type==tfloat) {
1073    b= env->head->item->content.val;      fa= CAR(env->head)->content.f;
1074    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1075    push_int(env, a+b);      fb= CAR(env->head)->content.f;
1076        toss(env); if(env->err) return;
1077        push_float(env, fb+fa);
1078        
1079        return;
1080      }
1081    
1082      if(CAR(env->head)->type==tfloat
1083         && CAR(CDR(env->head))->type==integer) {
1084        fa= CAR(env->head)->content.f;
1085        toss(env); if(env->err) return;
1086        b= CAR(env->head)->content.i;
1087        toss(env); if(env->err) return;
1088        push_float(env, b+fa);
1089        
1090        return;
1091      }
1092    
1093      if(CAR(env->head)->type==integer
1094         && CAR(CDR(env->head))->type==tfloat) {
1095        a= CAR(env->head)->content.i;
1096        toss(env); if(env->err) return;
1097        fb= CAR(env->head)->content.f;
1098        toss(env); if(env->err) return;
1099        push_float(env, fb+a);
1100    
1101        return;
1102      }
1103    
1104      printerr("Bad Argument Type");
1105      env->err=2;
1106  }  }
1107    
1108  /* "-" */  /* "-" */
1109  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1110    {
1111    int a, b;    int a, b;
1112      float fa, fb;
1113    
1114    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1115      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1116      env->err=1;      env->err=1;
1117      return;      return;
1118    }    }
1119        
1120    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1121       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1122      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1123      env->err=2;      toss(env); if(env->err) return;
1124        b= CAR(env->head)->content.i;
1125        toss(env); if(env->err) return;
1126        push_int(env, b-a);
1127    
1128      return;      return;
1129    }    }
1130    
1131    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
1132    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
1133    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
1134    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1135    push_int(env, b-a);      fb= CAR(env->head)->content.f;
1136        toss(env); if(env->err) return;
1137        push_float(env, fb-fa);
1138        
1139        return;
1140      }
1141    
1142      if(CAR(env->head)->type==tfloat
1143         && CAR(CDR(env->head))->type==integer) {
1144        fa= CAR(env->head)->content.f;
1145        toss(env); if(env->err) return;
1146        b= CAR(env->head)->content.i;
1147        toss(env); if(env->err) return;
1148        push_float(env, b-fa);
1149        
1150        return;
1151      }
1152    
1153      if(CAR(env->head)->type==integer
1154         && CAR(CDR(env->head))->type==tfloat) {
1155        a= CAR(env->head)->content.i;
1156        toss(env); if(env->err) return;
1157        fb= CAR(env->head)->content.f;
1158        toss(env); if(env->err) return;
1159        push_float(env, fb-a);
1160    
1161        return;
1162      }
1163    
1164      printerr("Bad Argument Type");
1165      env->err=2;
1166  }  }
1167    
1168  /* ">" */  /* ">" */
1169  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1170    {
1171    int a, b;    int a, b;
1172      float fa, fb;
1173    
1174    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1175      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1176      env->err=1;      env->err= 1;
1177      return;      return;
1178    }    }
1179        
1180    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1181       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1182      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1183      env->err=2;      toss(env); if(env->err) return;
1184        b= CAR(env->head)->content.i;
1185        toss(env); if(env->err) return;
1186        push_int(env, b>a);
1187    
1188      return;      return;
1189    }    }
1190    
1191    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
1192    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
1193    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
1194    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1195    push_int(env, b>a);      fb= CAR(env->head)->content.f;
1196        toss(env); if(env->err) return;
1197        push_int(env, fb>fa);
1198        
1199        return;
1200      }
1201    
1202      if(CAR(env->head)->type==tfloat
1203         && CAR(CDR(env->head))->type==integer) {
1204        fa= CAR(env->head)->content.f;
1205        toss(env); if(env->err) return;
1206        b= CAR(env->head)->content.i;
1207        toss(env); if(env->err) return;
1208        push_int(env, b>fa);
1209        
1210        return;
1211      }
1212    
1213      if(CAR(env->head)->type==integer
1214         && CAR(CDR(env->head))->type==tfloat) {
1215        a= CAR(env->head)->content.i;
1216        toss(env); if(env->err) return;
1217        fb= CAR(env->head)->content.f;
1218        toss(env); if(env->err) return;
1219        push_int(env, fb>a);
1220    
1221        return;
1222      }
1223    
1224      printerr("Bad Argument Type");
1225      env->err= 2;
1226    }
1227    
1228    /* "<" */
1229    extern void sx_3c(environment *env)
1230    {
1231      swap(env); if(env->err) return;
1232      sx_3e(env);
1233    }
1234    
1235    /* "<=" */
1236    extern void sx_3c3d(environment *env)
1237    {
1238      sx_3e(env); if(env->err) return;
1239      not(env);
1240    }
1241    
1242    /* ">=" */
1243    extern void sx_3e3d(environment *env)
1244    {
1245      sx_3c(env); if(env->err) return;
1246      not(env);
1247  }  }
1248    
1249  /* Return copy of a value */  /* Return copy of a value */
1250  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1251    stackitem *old_item, *new_item, *prev_item;  {
1252      value *new_value;
1253    
1254    value *new_value= new_val(env);    if(old_value==NULL)
1255        return NULL;
1256    
1257    protect(env, old_value);    protect(old_value);
1258      new_value= new_val(env);
1259      protect(new_value);
1260    new_value->type= old_value->type;    new_value->type= old_value->type;
1261    
1262    switch(old_value->type){    switch(old_value->type){
1263      case tfloat:
1264    case integer:    case integer:
1265      new_value->content.val= old_value->content.val;    case func:
1266      case symb:
1267        new_value->content= old_value->content;
1268      break;      break;
1269    case string:    case string:
1270      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1271        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1272      break;      break;
1273    case func:    case tcons:
1274    case symb:      new_value= NULL;
     new_value->content.ptr= old_value->content.ptr;  
     break;  
   case list:  
     new_value->content.ptr= NULL;  
   
     prev_item= NULL;  
     old_item= (stackitem*)(old_value->content.ptr);  
1275    
1276      while(old_item != NULL) {   /* While list is not empty */      new_value->content.c= malloc(sizeof(cons));
1277        new_item= malloc(sizeof(stackitem));      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1278        new_item->item= copy_val(env, old_item->item); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
       new_item->next= NULL;  
       if(prev_item != NULL)     /* If this wasn't the first item */  
         prev_item->next= new_item; /* point the previous item to the  
                                      new item */  
       else  
         new_value->content.ptr= new_item;  
       old_item= old_item->next;  
       prev_item= new_item;  
     }      
1279      break;      break;
1280    }    }
1281    
1282    unprotect(env);    unprotect(old_value); unprotect(new_value);
1283    
1284    return new_value;    return new_value;
1285  }  }
1286    
1287  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1288  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1289    if((env->head)==NULL) {  {
1290      if(env->head==NULL) {
1291      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1292      env->err= 1;      env->err= 1;
1293      return;      return;
1294    }    }
1295    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1296  }  }
1297    
1298  /* "if", If-Then */  /* "if", If-Then */
1299  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1300    {
1301    int truth;    int truth;
1302    
1303    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1304      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1305      env->err= 1;      env->err= 1;
1306      return;      return;
1307    }    }
1308    
1309    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1310      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1311      env->err=2;      env->err= 2;
1312      return;      return;
1313    }    }
1314        
1315    swap(env);    swap(env);
1316    if(env->err) return;    if(env->err) return;
1317        
1318    truth=env->head->item->content.val;    truth= CAR(env->head)->content.i;
1319    
1320    toss(env);    toss(env);
1321    if(env->err) return;    if(env->err) return;
# Line 1145  extern void sx_6966(environment *env) { Line 1327  extern void sx_6966(environment *env) {
1327  }  }
1328    
1329  /* If-Then-Else */  /* If-Then-Else */
1330  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1331    {
1332    int truth;    int truth;
1333    
1334    if((env->head)==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1335       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1336      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1337      env->err=1;      env->err= 1;
1338      return;      return;
1339    }    }
1340    
1341    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1342      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1343      env->err=2;      env->err= 2;
1344      return;      return;
1345    }    }
1346        
1347    rot(env);    rot(env);
1348    if(env->err) return;    if(env->err) return;
1349        
1350    truth=env->head->item->content.val;    truth= CAR(env->head)->content.i;
1351    
1352    toss(env);    toss(env);
1353    if(env->err) return;    if(env->err) return;
# Line 1181  extern void ifelse(environment *env) { Line 1363  extern void ifelse(environment *env) {
1363  }  }
1364    
1365  /* "while" */  /* "while" */
1366  extern void sx_7768696c65(environment *env) {  extern void sx_7768696c65(environment *env)
1367    {
1368    int truth;    int truth;
1369    value *loop, *test;    value *loop, *test;
1370    
1371    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1372      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1373      env->err=1;      env->err= 1;
1374      return;      return;
1375    }    }
1376    
1377    loop= env->head->item;    loop= CAR(env->head);
1378    protect(env, loop);    protect(loop);
1379    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1380    
1381    test= env->head->item;    test= CAR(env->head);
1382    protect(env, test);    protect(test);
1383    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1384    
1385    do {    do {
1386      push_val(env, test);      push_val(env, test);
1387      eval(env);      eval(env);
1388            
1389      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1390        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1391        env->err= 2;        env->err= 2;
1392        return;        return;
1393      }      }
1394            
1395      truth= env->head->item->content.val;      truth= CAR(env->head)->content.i;
1396      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1397            
1398      if(truth) {      if(truth) {
# Line 1222  extern void sx_7768696c65(environment *e Line 1404  extern void sx_7768696c65(environment *e
1404        
1405    } while(truth);    } while(truth);
1406    
1407    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1408  }  }
1409    
1410    
1411  /* "for"; for-loop */  /* "for"; for-loop */
1412  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1413    {
1414    value *loop;    value *loop;
1415    int foo1, foo2;    int foo1, foo2;
1416    
1417    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1418       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1419      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1420      env->err= 1;      env->err= 1;
1421      return;      return;
1422    }    }
1423    
1424    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1425       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1426      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1427      env->err= 2;      env->err= 2;
1428      return;      return;
1429    }    }
1430    
1431    loop= env->head->item;    loop= CAR(env->head);
1432    protect(env, loop);    protect(loop);
1433    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1434    
1435    foo2= env->head->item->content.val;    foo2= CAR(env->head)->content.i;
1436    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1437    
1438    foo1= env->head->item->content.val;    foo1= CAR(env->head)->content.i;
1439    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1440    
1441    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1270  extern void sx_666f72(environment *env) Line 1453  extern void sx_666f72(environment *env)
1453        foo1--;        foo1--;
1454      }      }
1455    }    }
1456    unprotect(env);    unprotect(loop);
1457  }  }
1458    
1459  /* Variant of for-loop */  /* Variant of for-loop */
1460  extern void foreach(environment *env) {  extern void foreach(environment *env)
1461      {  
1462    value *loop, *foo;    value *loop, *foo;
1463    stackitem *iterator;    value *iterator;
1464        
1465    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1466      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1467      env->err= 1;      env->err= 1;
1468      return;      return;
1469    }    }
1470    
1471    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1472      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1473      env->err= 2;      env->err= 2;
1474      return;      return;
1475    }    }
1476    
1477    loop= env->head->item;    loop= CAR(env->head);
1478    protect(env, loop);    protect(loop);
1479    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1480    
1481    foo= env->head->item;    foo= CAR(env->head);
1482    protect(env, foo);    protect(foo);
1483    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1484    
1485    iterator= foo->content.ptr;    iterator= foo;
1486    
1487    while(iterator!=NULL) {    while(iterator!=NULL) {
1488      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1489      push_val(env, loop);      push_val(env, loop);
1490      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1491      iterator= iterator->next;      if (iterator->type == tcons){
1492          iterator= CDR(iterator);
1493        } else {
1494          printerr("Bad Argument Type"); /* Improper list */
1495          env->err= 2;
1496          break;
1497        }
1498    }    }
1499    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1500  }  }
1501    
1502  /* "to" */  /* "to" */
1503  extern void to(environment *env) {  extern void to(environment *env)
1504    int i, start, ending;  {
1505    stackitem *temp_head;    int ending, start, i;
1506    value *temp_val;    value *iterator, *temp;
1507      
1508    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1509      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1510      env->err=1;      env->err= 1;
1511      return;      return;
1512    }    }
1513    
1514    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1515       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1516      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1517      env->err=2;      env->err= 2;
1518      return;      return;
1519    }    }
1520    
1521    ending= env->head->item->content.val;    ending= CAR(env->head)->content.i;
1522    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1523    start= env->head->item->content.val;    start= CAR(env->head)->content.i;
1524    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1525    
1526    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1527    
1528    if(ending>=start) {    if(ending>=start) {
1529      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1345  extern void to(environment *env) { Line 1533  extern void to(environment *env) {
1533        push_int(env, i);        push_int(env, i);
1534    }    }
1535    
1536    temp_val= new_val(env);    iterator= env->head;
1537    temp_val->content.ptr= env->head;  
1538    temp_val->type= list;    if(iterator==NULL
1539    env->head= temp_head;       || (CAR(iterator)->type==symb
1540    push_val(env, temp_val);           && CAR(iterator)->content.sym->id[0]=='[')) {
1541        temp= NULL;
1542        toss(env);
1543      } else {
1544        /* Search for first delimiter */
1545        while(CDR(iterator)!=NULL
1546              && (CAR(CDR(iterator))->type!=symb
1547                  || CAR(CDR(iterator))->content.sym->id[0]!='['))
1548          iterator= CDR(iterator);
1549        
1550        /* Extract list */
1551        temp= env->head;
1552        env->head= CDR(iterator);
1553        CDR(iterator)= NULL;
1554    
1555        if(env->head!=NULL)
1556          toss(env);
1557      }
1558    
1559      /* Push list */
1560      push_val(env, temp);
1561  }  }
1562    
1563  /* Read a string */  /* Read a string */
1564  extern void readline(environment *env) {  extern void readline(environment *env)
1565    {
1566    char in_string[101];    char in_string[101];
1567    
1568    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1363  extern void readline(environment *env) { Line 1572  extern void readline(environment *env) {
1572  }  }
1573    
1574  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1575  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1576    {
1577    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1578    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1579    const char intform[]= "%i%n";    const char intform[]= "%i%n";
1580      const char fltform[]= "%f%n";
1581    const char blankform[]= "%*[ \t]%n";    const char blankform[]= "%*[ \t]%n";
1582    const char ebrackform[]= "]%n";    const char ebrackform[]= "]%n";
1583    const char semicform[]= ";%n";    const char semicform[]= ";%n";
1584    const char bbrackform[]= "[%n";    const char bbrackform[]= "[%n";
1585    
1586    int itemp, readlength= -1;    int itemp, readlength= -1;
1587      int count= -1;
1588      float ftemp;
1589    static int depth= 0;    static int depth= 0;
1590    char *match;    char *match, *ctemp;
1591    size_t inlength;    size_t inlength;
1592    
1593    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1383  extern void sx_72656164(environment *env Line 1596  extern void sx_72656164(environment *env
1596      }      }
1597      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1598    
1599      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1600        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1601        return;        return;
1602      }      }
1603            
1604      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1605      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1606      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1607      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1608    }    }
1609        
1610    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1611    match= malloc(inlength);    match= malloc(inlength);
1612    
1613    if(sscanf(env->in_string, blankform, &readlength)!=EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1614       && readlength != -1) {       && readlength != -1) {
1615      ;      ;
1616    } else if(sscanf(env->in_string, intform, &itemp, &readlength) != EOF    } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
1617              && readlength != -1) {              && readlength != -1) {
1618      push_int(env, itemp);      if(sscanf(env->in_string, intform, &itemp, &count) != EOF
1619           && count==readlength) {
1620          push_int(env, itemp);
1621        } else {
1622          push_float(env, ftemp);
1623        }
1624    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1625              && readlength != -1) {              && readlength != -1) {
1626      push_cstring(env, match);      push_cstring(env, match);
# Line 1424  extern void sx_72656164(environment *env Line 1642  extern void sx_72656164(environment *env
1642      free(env->free_string);      free(env->free_string);
1643      env->in_string = env->free_string = NULL;      env->in_string = env->free_string = NULL;
1644    }    }
1645    if ( env->in_string != NULL) {    if (env->in_string != NULL) {
1646      env->in_string += readlength;      env->in_string += readlength;
1647    }    }
1648    
# Line 1434  extern void sx_72656164(environment *env Line 1652  extern void sx_72656164(environment *env
1652      return sx_72656164(env);      return sx_72656164(env);
1653  }  }
1654    
1655  extern void beep(environment *env) {  extern void beep(environment *env)
1656    {
1657    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1658    
1659    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1660      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1661      env->err=1;      env->err= 1;
1662      return;      return;
1663    }    }
1664    
1665    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1666       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1667      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1668      env->err=2;      env->err= 2;
1669      return;      return;
1670    }    }
1671    
1672    dur=env->head->item->content.val;    dur= CAR(env->head)->content.i;
1673    toss(env);    toss(env);
1674    freq=env->head->item->content.val;    freq= CAR(env->head)->content.i;
1675    toss(env);    toss(env);
1676    
1677    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1678                                     length */                                     length */
1679    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1680                                     timer ticks */                                     timer ticks */
1681    
1682  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1683    
1684    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1685    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1686    case 0:    case 0:
1687      usleep(dur);      usleep(dur);
1688      return;      return;
1689    case -1:    case -1:
1690      perror("beep");      perror("beep");
1691      env->err=5;      env->err= 5;
1692      return;      return;
1693    default:    default:
1694      abort();      abort();
1695    }    }
1696  };  }
1697    
1698  /* "wait" */  /* "wait" */
1699  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1700    {
1701    int dur;    int dur;
1702    
1703    if((env->head)==NULL) {    if(env->head==NULL) {
1704      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1705      env->err=1;      env->err= 1;
1706      return;      return;
1707    }    }
1708    
1709    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1710      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1711      env->err=2;      env->err= 2;
1712      return;      return;
1713    }    }
1714    
1715    dur=env->head->item->content.val;    dur= CAR(env->head)->content.i;
1716    toss(env);    toss(env);
1717    
1718    usleep(dur);    usleep(dur);
1719  };  }
1720    
1721  extern void copying(environment *env){  extern void copying(environment *env)
1722    {
1723    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1724                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1725  \n\  \n\
# Line 1759  of preserving the free status of all der Line 1978  of preserving the free status of all der
1978  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
1979  }  }
1980    
1981  extern void warranty(environment *env){  extern void warranty(environment *env)
1982    {
1983    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
1984  \n\  \n\
1985    11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\    11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\
# Line 1787  POSSIBILITY OF SUCH DAMAGES.\n"); Line 2007  POSSIBILITY OF SUCH DAMAGES.\n");
2007  extern void sx_2a(environment *env)  extern void sx_2a(environment *env)
2008  {  {
2009    int a, b;    int a, b;
2010      float fa, fb;
2011    
2012    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2013      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2014      env->err=1;      env->err= 1;
2015      return;      return;
2016    }    }
2017        
2018    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
2019       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
2020      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
2021      env->err=2;      toss(env); if(env->err) return;
2022        b= CAR(env->head)->content.i;
2023        toss(env); if(env->err) return;
2024        push_int(env, b*a);
2025    
2026      return;      return;
2027    }    }
2028    
2029    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
2030    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
2031    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
2032    toss(env); if(env->err) return;      toss(env); if(env->err) return;
2033    push_int(env, b*a);      fb= CAR(env->head)->content.f;
2034        toss(env); if(env->err) return;
2035        push_float(env, fb*fa);
2036        
2037        return;
2038      }
2039    
2040      if(CAR(env->head)->type==tfloat
2041         && CAR(CDR(env->head))->type==integer) {
2042        fa= CAR(env->head)->content.f;
2043        toss(env); if(env->err) return;
2044        b= CAR(env->head)->content.i;
2045        toss(env); if(env->err) return;
2046        push_float(env, b*fa);
2047        
2048        return;
2049      }
2050    
2051      if(CAR(env->head)->type==integer
2052         && CAR(CDR(env->head))->type==tfloat) {
2053        a= CAR(env->head)->content.i;
2054        toss(env); if(env->err) return;
2055        fb= CAR(env->head)->content.f;
2056        toss(env); if(env->err) return;
2057        push_float(env, fb*a);
2058    
2059        return;
2060      }
2061    
2062      printerr("Bad Argument Type");
2063      env->err= 2;
2064  }  }
2065    
2066  /* "/" */  /* "/" */
2067  extern void sx_2f(environment *env)  extern void sx_2f(environment *env)
2068  {  {
2069    int a, b;    int a, b;
2070      float fa, fb;
2071    
2072    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2073      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2074      env->err=1;      env->err= 1;
2075      return;      return;
2076    }    }
2077        
2078    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
2079       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
2080      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
2081      env->err=2;      toss(env); if(env->err) return;
2082        b= CAR(env->head)->content.i;
2083        toss(env); if(env->err) return;
2084        push_float(env, b/a);
2085    
2086      return;      return;
2087    }    }
2088    
2089    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
2090    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
2091    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
2092    toss(env); if(env->err) return;      toss(env); if(env->err) return;
2093    push_int(env, b/a);      fb= CAR(env->head)->content.f;
2094        toss(env); if(env->err) return;
2095        push_float(env, fb/fa);
2096        
2097        return;
2098      }
2099    
2100      if(CAR(env->head)->type==tfloat
2101         && CAR(CDR(env->head))->type==integer) {
2102        fa= CAR(env->head)->content.f;
2103        toss(env); if(env->err) return;
2104        b= CAR(env->head)->content.i;
2105        toss(env); if(env->err) return;
2106        push_float(env, b/fa);
2107        
2108        return;
2109      }
2110    
2111      if(CAR(env->head)->type==integer
2112         && CAR(CDR(env->head))->type==tfloat) {
2113        a= CAR(env->head)->content.i;
2114        toss(env); if(env->err) return;
2115        fb= CAR(env->head)->content.f;
2116        toss(env); if(env->err) return;
2117        push_float(env, fb/a);
2118    
2119        return;
2120      }
2121    
2122      printerr("Bad Argument Type");
2123      env->err= 2;
2124  }  }
2125    
2126  /* "mod" */  /* "mod" */
# Line 1838  extern void mod(environment *env) Line 2128  extern void mod(environment *env)
2128  {  {
2129    int a, b;    int a, b;
2130    
2131    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2132      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2133      env->err=1;      env->err= 1;
2134      return;      return;
2135    }    }
2136        
2137    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
2138       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
2139      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
2140      env->err=2;      toss(env); if(env->err) return;
2141        b= CAR(env->head)->content.i;
2142        toss(env); if(env->err) return;
2143        push_int(env, b%a);
2144    
2145      return;      return;
2146    }    }
2147    
2148    a=env->head->item->content.val;    printerr("Bad Argument Type");
2149    toss(env); if(env->err) return;    env->err= 2;
2150    b=env->head->item->content.val;  }
2151    toss(env); if(env->err) return;  
2152    push_int(env, b%a);  /* "div" */
2153    extern void sx_646976(environment *env)
2154    {
2155      int a, b;
2156      
2157      if(env->head==NULL || CDR(env->head)==NULL) {
2158        printerr("Too Few Arguments");
2159        env->err= 1;
2160        return;
2161      }
2162    
2163      if(CAR(env->head)->type==integer
2164         && CAR(CDR(env->head))->type==integer) {
2165        a= CAR(env->head)->content.i;
2166        toss(env); if(env->err) return;
2167        b= CAR(env->head)->content.i;
2168        toss(env); if(env->err) return;
2169        push_int(env, (int)b/a);
2170    
2171        return;
2172      }
2173    
2174      printerr("Bad Argument Type");
2175      env->err= 2;
2176  }  }
Legend:
Removed from v.1.92  
changed lines
  Added in v.1.105
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26