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

Diff of /stack/stack.c

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

revision 1.96 by teddy, Sun Mar 10 07:55:13 2002 UTC revision 1.123 by masse, Wed Mar 27 19:53:01 2002 UTC
# Line 1  Line 1 
1    /* -*- coding: utf-8; -*- */
2  /*  /*
3      stack - an interactive interpreter for a stack-based language      stack - an interactive interpreter for a stack-based language
4      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
# Line 20  Line 21 
21               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
22  */  */
23    
24    #define CAR(X) ((X)->content.c->car)
25    #define CDR(X) ((X)->content.c->cdr)
26    
27  /* printf, sscanf, fgets, fprintf, fopen, perror */  /* printf, sscanf, fgets, fprintf, fopen, perror */
28  #include <stdio.h>  #include <stdio.h>
29  /* exit, EXIT_SUCCESS, malloc, free */  /* exit, EXIT_SUCCESS, malloc, free */
# Line 34  Line 38 
38  #include <unistd.h>  #include <unistd.h>
39  /* EX_NOINPUT, EX_USAGE */  /* EX_NOINPUT, EX_USAGE */
40  #include <sysexits.h>  #include <sysexits.h>
41    /* assert */
42    #include <assert.h>
43    
44    #ifdef __linux__
45  /* mtrace, muntrace */  /* mtrace, muntrace */
46  #include <mcheck.h>  #include <mcheck.h>
47  /* ioctl */  /* ioctl */
48  #include <sys/ioctl.h>  #include <sys/ioctl.h>
49  /* KDMKTONE */  /* KDMKTONE */
50  #include <linux/kd.h>  #include <linux/kd.h>
51    #endif /* __linux__ */
52    
53  #include "stack.h"  #include "stack.h"
54    
# Line 48  void init_env(environment *env) Line 57  void init_env(environment *env)
57  {  {
58    int i;    int i;
59    
60    env->gc_limit= 200;    env->gc_limit= 400000;
61    env->gc_count= 0;    env->gc_count= 0;
62    env->gc_ref= NULL;    env->gc_ref= NULL;
   env->gc_protect= NULL;  
63    
64    env->head= NULL;    env->head= new_val(env);
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 71  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    stackitem *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->next;   /* Remove the top stack item */    env->head= CDR(env->head); /* Remove the top stack item */
   free(temp);                   /* Free the old top stack item */  
   
   env->gc_limit--;  
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 120  value* new_val(environment *env) Line 123  value* new_val(environment *env)
123    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
124    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
125    
126      assert(nval != NULL);
127      assert(nitem != NULL);
128    
129    nval->content.ptr= NULL;    nval->content.ptr= NULL;
130      nval->type= empty;
131    
132    nitem->item= nval;    nitem->item= nval;
133    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
134    
135    env->gc_ref= nitem;    env->gc_ref= nitem;
136    
137    env->gc_count++;    env->gc_count += sizeof(value);
138      nval->gc.flag.mark= 0;
139      nval->gc.flag.protect= 0;
140    
141    return nval;    return nval;
142  }  }
# Line 135  value* new_val(environment *env) Line 145  value* new_val(environment *env)
145     Marked values are not collected by the GC. */     Marked values are not collected by the GC. */
146  inline void gc_mark(value *val)  inline void gc_mark(value *val)
147  {  {
148    stackitem *iterator;    if(val==NULL || val->gc.flag.mark)
   
   if(val==NULL || val->gc_garb==0)  
149      return;      return;
150    
151    val->gc_garb= 0;    val->gc.flag.mark= 1;
   
   if(val->type==list) {  
     iterator= val->content.ptr;  
152    
153      while(iterator!=NULL) {    if(val->type==tcons) {
154        gc_mark(iterator->item);      gc_mark(CAR(val));
155        iterator= iterator->next;      gc_mark(CDR(val));
     }  
156    }    }
157  }  }
158    
# Line 163  inline void gc_maybe(environment *env) Line 167  inline void gc_maybe(environment *env)
167  /* Start GC */  /* Start GC */
168  extern void gc_init(environment *env)  extern void gc_init(environment *env)
169  {  {
170    stackitem *new_head= NULL, *titem, *iterator;    stackitem *new_head= NULL, *titem;
171    symbol *tsymb;    symbol *tsymb;
172    int i;    int i;
173    
174    /* Garb by default */    if(env->interactive)
175    iterator= env->gc_ref;      printf("Garbage collecting.");
   while(iterator!=NULL) {  
     iterator->item->gc_garb= 1;  
     iterator= iterator->next;  
   }  
   
   /* Mark protected values */  
   iterator= env->gc_protect;  
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
176    
177    /* Mark values on stack */    /* Mark values on stack */
178    iterator= env->head;    gc_mark(env->head);
179    while(iterator!=NULL) {  
180      gc_mark(iterator->item);    if(env->interactive)
181      iterator= iterator->next;      printf(".");
182    }  
183    
184    /* Mark values in hashtable */    /* Mark values in hashtable */
185    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++)
186      tsymb= env->symbols[i];      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
187      while(tsymb!=NULL) {        if (tsymb->val != NULL)
188        gc_mark(tsymb->val);          gc_mark(tsymb->val);
189        tsymb= tsymb->next;  
190      }  
191    }    if(env->interactive)
192        printf(".");
193    
194    env->gc_count= 0;    env->gc_count= 0;
195    
196    while(env->gc_ref!=NULL) {    /* Sweep unused values */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
197    
198      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
199    
200        switch(env->gc_ref->item->type) { /* Remove content */        /* Remove content */
201          switch(env->gc_ref->item->type){
202        case string:        case string:
203          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
204          break;          break;
205        case list:        case tcons:
206          while(env->gc_ref->item->content.ptr!=NULL) {          free(env->gc_ref->item->content.c);
           titem= env->gc_ref->item->content.ptr;  
           env->gc_ref->item->content.ptr= titem->next;  
           free(titem);  
         }  
         break;  
       default:  
207          break;          break;
208          case empty:
209          case integer:
210          case tfloat:
211          case func:
212          case symb:
213            /* Symbol strings are freed when walking the hash table */
214        }        }
215    
216        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
217        titem= env->gc_ref->next;        titem= env->gc_ref->next;
218        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
219        env->gc_ref= titem;        env->gc_ref= titem;
220      } else {                    /* Keep values */        continue;
       titem= env->gc_ref->next;  
       env->gc_ref->next= new_head;  
       new_head= env->gc_ref;  
       env->gc_ref= titem;  
       env->gc_count++;  
221      }      }
222    #ifdef DEBUG
223        printf("Kept value (%p)", env->gc_ref->item);
224        if(env->gc_ref->item->gc.flag.mark)
225          printf(" (marked)");
226        if(env->gc_ref->item->gc.flag.protect)
227          printf(" (protected)");
228        switch(env->gc_ref->item->type){
229        case integer:
230          printf(" integer: %d", env->gc_ref->item->content.i);
231          break;
232        case func:
233          printf(" func: %p", env->gc_ref->item->content.ptr);
234          break;
235        case symb:
236          printf(" symb: %s", env->gc_ref->item->content.sym->id);
237          break;
238        case tcons:
239          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
240                 env->gc_ref->item->content.c->cdr);
241          break;
242        default:
243          printf(" <unknown %d>", (env->gc_ref->item->type));
244        }
245        printf("\n");
246    #endif /* DEBUG */
247    
248        /* Keep values */    
249        env->gc_count += sizeof(value);
250        if(env->gc_ref->item->type==string)
251          env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
252        
253        titem= env->gc_ref->next;
254        env->gc_ref->next= new_head;
255        new_head= env->gc_ref;
256        new_head->item->gc.flag.mark= 0;
257        env->gc_ref= titem;
258    }    }
259    
260    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
261        env->gc_limit= env->gc_count*2;
262    
263    env->gc_ref= new_head;    env->gc_ref= new_head;
264    
265      if(env->interactive)
266        printf("done (%d bytes still allocated)\n", env->gc_count);
267    
268  }  }
269    
270  /* Protect values from GC */  /* Protect values from GC */
271  void protect(environment *env, value *val)  void protect(value *val)
272  {  {
273    stackitem *new_item= malloc(sizeof(stackitem));    if(val==NULL || val->gc.flag.protect)
274    new_item->item= val;      return;
275    new_item->next= env->gc_protect;  
276    env->gc_protect= new_item;    val->gc.flag.protect= 1;
277    
278      if(val->type==tcons) {
279        protect(CAR(val));
280        protect(CDR(val));
281      }
282  }  }
283    
284  /* Unprotect values from GC */  /* Unprotect values from GC */
285  void unprotect(environment *env)  void unprotect(value *val)
286  {  {
287    stackitem *temp= env->gc_protect;    if(val==NULL || !(val->gc.flag.protect))
288    env->gc_protect= env->gc_protect->next;      return;
289    free(temp);  
290      val->gc.flag.protect= 0;
291    
292      if(val->type==tcons) {
293        unprotect(CAR(val));
294        unprotect(CDR(val));
295      }
296  }  }
297    
298  /* Push a value onto the stack */  /* Push a value onto the stack */
299  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
300  {  {
301    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
302    new_item->item= val;  
303    new_item->next= env->head;    new_value->content.c= malloc(sizeof(pair));
304    env->head= new_item;    assert(new_value->content.c!=NULL);
305      env->gc_count += sizeof(pair);
306      new_value->type= tcons;
307      CAR(new_value)= val;
308      CDR(new_value)= env->head;
309      env->head= new_value;
310  }  }
311    
312  /* Push an integer onto the stack */  /* Push an integer onto the stack */
# Line 286  void push_float(environment *env, float Line 335  void push_float(environment *env, float
335  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
336  {  {
337    value *new_value= new_val(env);    value *new_value= new_val(env);
338      int length= strlen(in_string)+1;
339    
340    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
341      assert(new_value != NULL);
342      env->gc_count += length;
343    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
344    new_value->type= string;    new_value->type= string;
345    
# Line 301  char *mangle_str(const char *old_string) Line 353  char *mangle_str(const char *old_string)
353    char *new_string, *current;    char *new_string, *current;
354    
355    new_string= malloc((strlen(old_string)*2)+4);    new_string= malloc((strlen(old_string)*2)+4);
356      assert(new_string != NULL);
357    strcpy(new_string, "sx_");    /* Stack eXternal */    strcpy(new_string, "sx_");    /* Stack eXternal */
358    current= new_string+3;    current= new_string+3;
359    while(old_string[0] != '\0'){    while(old_string[0] != '\0'){
# Line 318  extern void mangle(environment *env) Line 371  extern void mangle(environment *env)
371  {  {
372    char *new_string;    char *new_string;
373    
374    if((env->head)==NULL) {    if(env->head->type==empty) {
375      printerr("Too Few Arguments");      printerr("Too Few Arguments");
376      env->err= 1;      env->err= 1;
377      return;      return;
378    }    }
379    
380    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
381      printerr("Bad Argument Type");      printerr("Bad Argument Type");
382      env->err= 2;      env->err= 2;
383      return;      return;
384    }    }
385    
386    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
387        mangle_str((const char *)(CAR(env->head)->content.ptr));
388    
389    toss(env);    toss(env);
390    if(env->err) return;    if(env->err) return;
# Line 354  void push_sym(environment *env, const ch Line 408  void push_sym(environment *env, const ch
408    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
409    
410    new_value= new_val(env);    new_value= new_val(env);
411    protect(env, new_value);    protect(new_value);
412    new_fvalue= new_val(env);    new_fvalue= new_val(env);
413    protect(env, new_fvalue);    protect(new_fvalue);
414    
415    /* The new value is a symbol */    /* The new value is a symbol */
416    new_value->type= symb;    new_value->type= symb;
# Line 369  void push_sym(environment *env, const ch Line 423  void push_sym(environment *env, const ch
423    
424      /* Create a new symbol */      /* Create a new symbol */
425      (*new_symbol)= malloc(sizeof(symbol));      (*new_symbol)= malloc(sizeof(symbol));
426        assert((*new_symbol) != NULL);
427      (*new_symbol)->val= NULL;   /* undefined value */      (*new_symbol)->val= NULL;   /* undefined value */
428      (*new_symbol)->next= NULL;      (*new_symbol)->next= NULL;
429      (*new_symbol)->id= malloc(strlen(in_string)+1);      (*new_symbol)->id= malloc(strlen(in_string)+1);
430        assert((*new_symbol)->id != NULL);
431      strcpy((*new_symbol)->id, in_string);      strcpy((*new_symbol)->id, in_string);
432    
433      /* Intern the new symbol in the hash table */      /* Intern the new symbol in the hash table */
# Line 402  void push_sym(environment *env, const ch Line 458  void push_sym(environment *env, const ch
458    }    }
459    
460    push_val(env, new_value);    push_val(env, new_value);
461    unprotect(env); unprotect(env);    unprotect(new_value); unprotect(new_fvalue);
462  }  }
463    
464  /* Print newline. */  /* Print newline. */
# Line 414  extern void nl() Line 470  extern void nl()
470  /* Gets the type of a value */  /* Gets the type of a value */
471  extern void type(environment *env)  extern void type(environment *env)
472  {  {
473    int typenum;    if(env->head->type==empty) {
   
   if((env->head)==NULL) {  
474      printerr("Too Few Arguments");      printerr("Too Few Arguments");
475      env->err=1;      env->err= 1;
476      return;      return;
477    }    }
478    typenum=env->head->item->type;  
479    toss(env);    switch(CAR(env->head)->type){
480    switch(typenum){    case empty:
481        push_sym(env, "empty");
482        break;
483    case integer:    case integer:
484      push_sym(env, "integer");      push_sym(env, "integer");
485      break;      break;
# Line 439  extern void type(environment *env) Line 495  extern void type(environment *env)
495    case func:    case func:
496      push_sym(env, "function");      push_sym(env, "function");
497      break;      break;
498    case list:    case tcons:
499      push_sym(env, "list");      push_sym(env, "pair");
500      break;      break;
501    }    }
502      swap(env);
503      if (env->err) return;
504      toss(env);
505  }      }    
506    
507  /* Prints the top element of the stack. */  /* Print a value */
508  void print_h(stackitem *stack_head, int noquote)  void print_val(value *val, int noquote, stackitem *stack)
509  {  {
510    switch(stack_head->item->type) {    stackitem *titem, *tstack;
511      int depth;
512    
513      switch(val->type) {
514      case empty:
515        printf("[]");
516        break;
517    case integer:    case integer:
518      printf("%d", stack_head->item->content.i);      printf("%d", val->content.i);
519      break;      break;
520    case tfloat:    case tfloat:
521      printf("%f", stack_head->item->content.f);      printf("%f", val->content.f);
522      break;      break;
523    case string:    case string:
524      if(noquote)      if(noquote)
525        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)(val->content.ptr));
526      else      else
527        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)(val->content.ptr));
528      break;      break;
529    case symb:    case symb:
530      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", val->content.sym->id);
531      break;      break;
532    case func:    case func:
533      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(val->content.ptr));
534      break;      break;
535    case list:    case tcons:
     /* A list is just a stack, so make stack_head point to it */  
     stack_head=(stackitem *)(stack_head->item->content.ptr);  
536      printf("[ ");      printf("[ ");
537      while(stack_head != NULL) {      tstack= stack;
538        print_h(stack_head, noquote);      do {
539        printf(" ");        titem=malloc(sizeof(stackitem));
540        stack_head=stack_head->next;        assert(titem != NULL);
541          titem->item=val;
542          titem->next=tstack;
543          tstack=titem;             /* Put it on the stack */
544          /* Search a stack of values being printed to see if we are already
545             printing this value */
546          titem=tstack;
547          depth=0;
548          while(titem != NULL && titem->item != CAR(val)){
549            titem=titem->next;
550            depth++;
551          }
552          if(titem != NULL){        /* If we found it on the stack, */
553            printf("#%d#", depth);  /* print a depth reference */
554          } else {
555            print_val(CAR(val), noquote, tstack);
556          }
557          val= CDR(val);
558          switch(val->type){
559          case empty:
560            break;
561          case tcons:
562            /* Search a stack of values being printed to see if we are already
563               printing this value */
564            titem=tstack;
565            depth=0;
566            while(titem != NULL && titem->item != val){
567              titem=titem->next;
568              depth++;
569            }
570            if(titem != NULL){      /* If we found it on the stack, */
571              printf(" . #%d#", depth); /* print a depth reference */
572            } else {
573              printf(" ");
574            }
575            break;
576          default:
577            printf(" . ");          /* Improper list */
578            print_val(val, noquote, tstack);
579          }
580        } while(val->type == tcons && titem == NULL);
581        titem=tstack;
582        while(titem != stack){
583          tstack=titem->next;
584          free(titem);
585          titem=tstack;
586      }      }
587      printf("]");      printf(" ]");
588      break;      break;
589    }    }
590  }  }
591    
592  extern void print_(environment *env)  extern void print_(environment *env)
593  {  {
594    if(env->head==NULL) {    if(env->head->type==empty) {
595      printerr("Too Few Arguments");      printerr("Too Few Arguments");
596      env->err=1;      env->err= 1;
597      return;      return;
598    }    }
599    print_h(env->head, 0);    print_val(CAR(env->head), 0, NULL);
600    nl();    nl();
601  }  }
602    
# Line 502  extern void print(environment *env) Line 610  extern void print(environment *env)
610    
611  extern void princ_(environment *env)  extern void princ_(environment *env)
612  {  {
613    if(env->head==NULL) {    if(env->head->type==empty) {
614      printerr("Too Few Arguments");      printerr("Too Few Arguments");
615      env->err=1;      env->err= 1;
616      return;      return;
617    }    }
618    print_h(env->head, 1);    print_val(CAR(env->head), 1, NULL);
619  }  }
620    
621  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack and then discards it. */
# Line 519  extern void princ(environment *env) Line 627  extern void princ(environment *env)
627  }  }
628    
629  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
630  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
631  {  {
632    if(stack_head->next != NULL)    if(CDR(stack_head)->type != empty)
633      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
634    printf("%ld: ", counter);    printf("%ld: ", counter);
635    print_h(stack_head, 0);    print_val(CAR(stack_head), 0, NULL);
636    nl();    nl();
637  }  }
638    
639  /* Prints the stack. */  /* Prints the stack. */
640  extern void printstack(environment *env)  extern void printstack(environment *env)
641  {  {
642    if(env->head == NULL) {    if(env->head->type == empty) {
643      printf("Stack Empty\n");      printf("Stack Empty\n");
644      return;      return;
645    }    }
# Line 542  extern void printstack(environment *env) Line 650  extern void printstack(environment *env)
650  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
651  extern void swap(environment *env)  extern void swap(environment *env)
652  {  {
653    stackitem *temp= env->head;    value *temp= env->head;
654        
655    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
656      printerr("Too Few Arguments");      printerr("Too Few Arguments");
657      env->err=1;      env->err=1;
658      return;      return;
659    }    }
660    
661    env->head= env->head->next;    env->head= CDR(env->head);
662    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
663    env->head->next= temp;    CDR(env->head)= temp;
664  }  }
665    
666  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
667  extern void rot(environment *env)  extern void rot(environment *env)
668  {  {
669    stackitem *temp= env->head;    value *temp= env->head;
670        
671    if(env->head==NULL || env->head->next==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
672        || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type == empty) {
673      printerr("Too Few Arguments");      printerr("Too Few Arguments");
674      env->err=1;      env->err= 1;
675      return;      return;
676    }    }
677      
678    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
679    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
680    env->head->next= temp;    CDR(env->head)= temp;
681  }  }
682    
683  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 577  extern void rcl(environment *env) Line 685  extern void rcl(environment *env)
685  {  {
686    value *val;    value *val;
687    
688    if(env->head == NULL) {    if(env->head->type==empty) {
689      printerr("Too Few Arguments");      printerr("Too Few Arguments");
690      env->err=1;      env->err= 1;
691      return;      return;
692    }    }
693    
694    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
695      printerr("Bad Argument Type");      printerr("Bad Argument Type");
696      env->err=2;      env->err= 2;
697      return;      return;
698    }    }
699    
700    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
701    if(val == NULL){    if(val == NULL){
702      printerr("Unbound Variable");      printerr("Unbound Variable");
703      env->err=3;      env->err= 3;
704      return;      return;
705    }    }
706    protect(env, val);    push_val(env, val);           /* Return the symbol's bound value */
707    toss(env);            /* toss the symbol */    swap(env);
708      if(env->err) return;
709      toss(env);                    /* toss the symbol */
710    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(env);  
711  }  }
712    
713  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
# Line 609  extern void eval(environment *env) Line 717  extern void eval(environment *env)
717  {  {
718    funcp in_func;    funcp in_func;
719    value* temp_val;    value* temp_val;
720    stackitem* iterator;    value* iterator;
721    
722   eval_start:   eval_start:
723    
724    gc_maybe(env);    gc_maybe(env);
725    
726    if(env->head==NULL) {    if(env->head->type==empty) {
727      printerr("Too Few Arguments");      printerr("Too Few Arguments");
728      env->err=1;      env->err= 1;
729      return;      return;
730    }    }
731    
732    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
733      /* if it's a symbol */      /* if it's a symbol */
734    case symb:    case symb:
735      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
736      if(env->err) return;      if(env->err) return;
737      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
738        goto eval_start;        goto eval_start;
739      }      }
740      return;      return;
741    
742      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
743    case func:    case func:
744      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
745      toss(env);      toss(env);
746      if(env->err) return;      if(env->err) return;
747      return in_func(env);      return in_func(env);
748    
749      /* If it's a list */      /* If it's a list */
750    case list:    case tcons:
751      temp_val= env->head->item;      temp_val= CAR(env->head);
752      protect(env, temp_val);      protect(temp_val);
753    
754      toss(env); if(env->err) return;      toss(env); if(env->err) return;
755      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
756            
757      while(iterator!=NULL) {      while(iterator->type != empty) {
758        push_val(env, iterator->item);        push_val(env, CAR(iterator));
759                
760        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
761          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
762          toss(env);          toss(env);
763          if(env->err) return;          if(env->err) return;
764                    
765          if(iterator->next == NULL){          if(CDR(iterator)->type == empty){
766            goto eval_start;            goto eval_start;
767          }          }
768          eval(env);          eval(env);
769          if(env->err) return;          if(env->err) return;
770        }        }
771        iterator= iterator->next;        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
772            iterator= CDR(iterator);
773          else {
774            printerr("Bad Argument Type"); /* Improper list */
775            env->err= 2;
776            return;
777          }
778      }      }
779      unprotect(env);      unprotect(temp_val);
780      return;      return;
781    
782    default:    case empty:
783      case integer:
784      case tfloat:
785      case string:
786      return;      return;
787    }    }
788  }  }
# Line 673  extern void eval(environment *env) Line 790  extern void eval(environment *env)
790  /* Reverse (flip) a list */  /* Reverse (flip) a list */
791  extern void rev(environment *env)  extern void rev(environment *env)
792  {  {
793    stackitem *old_head, *new_head, *item;    value *old_head, *new_head, *item;
794    
795    if((env->head)==NULL) {    if(env->head->type==empty) {
796      printerr("Too Few Arguments");      printerr("Too Few Arguments");
797      env->err= 1;      env->err= 1;
798      return;      return;
799    }    }
800    
801    if(env->head->item->type!=list) {    if(CAR(env->head)->type==empty)
802        return;                     /* Don't reverse an empty list */
803    
804      if(CAR(env->head)->type!=tcons) {
805      printerr("Bad Argument Type");      printerr("Bad Argument Type");
806      env->err= 2;      env->err= 2;
807      return;      return;
808    }    }
809    
810    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
811    new_head= NULL;    new_head= new_val(env);
812    while(old_head != NULL){    while(old_head->type != empty) {
813      item= old_head;      item= old_head;
814      old_head= old_head->next;      old_head= CDR(old_head);
815      item->next= new_head;      CDR(item)= new_head;
816      new_head= item;      new_head= item;
817    }    }
818    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
819  }  }
820    
821  /* Make a list. */  /* Make a list. */
822  extern void pack(environment *env)  extern void pack(environment *env)
823  {  {
824    stackitem *iterator, *temp;    value *iterator, *temp, *ending;
   value *pack;  
825    
826    iterator= env->head;    ending=new_val(env);
   pack= new_val(env);  
   protect(env, pack);  
827    
828    if(iterator==NULL    iterator= env->head;
829       || (iterator->item->type==symb    if(iterator->type == empty
830       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       || (CAR(iterator)->type==symb
831      temp= NULL;       && CAR(iterator)->content.sym->id[0]=='[')) {
832        temp= ending;
833      toss(env);      toss(env);
834    } else {    } else {
835      /* Search for first delimiter */      /* Search for first delimiter */
836      while(iterator->next!=NULL      while(CDR(iterator)->type != empty
837            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
838            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
839        iterator= iterator->next;        iterator= CDR(iterator);
840            
841      /* Extract list */      /* Extract list */
842      temp= env->head;      temp= env->head;
843      env->head= iterator->next;      env->head= CDR(iterator);
844      iterator->next= NULL;      CDR(iterator)= ending;
845    
846      pack->type= list;      if(env->head->type != empty)
     pack->content.ptr= temp;  
       
     if(env->head!=NULL)  
847        toss(env);        toss(env);
848    }    }
849    
850    /* Push list */    /* Push list */
851    
852    push_val(env, pack);    push_val(env, temp);
853    rev(env);    rev(env);
   
   unprotect(env);  
854  }  }
855    
856  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
857  extern void expand(environment *env)  extern void expand(environment *env)
858  {  {
859    stackitem *temp, *new_head;    value *temp, *new_head;
860    
861    /* Is top element a list? */    /* Is top element a list? */
862    if(env->head==NULL) {    if(env->head->type==empty) {
863      printerr("Too Few Arguments");      printerr("Too Few Arguments");
864      env->err= 1;      env->err= 1;
865      return;      return;
866    }    }
867    if(env->head->item->type!=list) {  
868      if(CAR(env->head)->type!=tcons) {
869      printerr("Bad Argument Type");      printerr("Bad Argument Type");
870      env->err= 2;      env->err= 2;
871      return;      return;
# Line 763  extern void expand(environment *env) Line 877  extern void expand(environment *env)
877      return;      return;
878    
879    /* The first list element is the new stack head */    /* The first list element is the new stack head */
880    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
881    
882    toss(env);    toss(env);
883    
884    /* Find the end of the list */    /* Find the end of the list */
885    while(temp->next!=NULL)    while(CDR(temp)->type != empty) {
886      temp= temp->next;      if (CDR(temp)->type == tcons)
887          temp= CDR(temp);
888        else {
889          printerr("Bad Argument Type"); /* Improper list */
890          env->err= 2;
891          return;
892        }
893      }
894    
895    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
896    temp->next= env->head;    CDR(temp)= env->head;
897    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
898    
899  }  }
# Line 781  extern void expand(environment *env) Line 902  extern void expand(environment *env)
902  extern void eq(environment *env)  extern void eq(environment *env)
903  {  {
904    void *left, *right;    void *left, *right;
   int result;  
905    
906    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
907      printerr("Too Few Arguments");      printerr("Too Few Arguments");
908      env->err= 1;      env->err= 1;
909      return;      return;
910    }    }
911    
912    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
913    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
914    toss(env); toss(env);    toss(env); toss(env);
915    push_int(env, result);  
916      push_int(env, left==right);
917  }  }
918    
919  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 803  extern void not(environment *env) Line 921  extern void not(environment *env)
921  {  {
922    int val;    int val;
923    
924    if((env->head)==NULL) {    if(env->head->type==empty) {
925      printerr("Too Few Arguments");      printerr("Too Few Arguments");
926      env->err= 1;      env->err= 1;
927      return;      return;
928    }    }
929    
930    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
931      printerr("Bad Argument Type");      printerr("Bad Argument Type");
932      env->err= 2;      env->err= 2;
933      return;      return;
934    }    }
935    
936    val= env->head->item->content.i;    val= CAR(env->head)->content.i;
937    toss(env);    toss(env);
938    push_int(env, !val);    push_int(env, !val);
939  }  }
# Line 834  extern void def(environment *env) Line 952  extern void def(environment *env)
952    symbol *sym;    symbol *sym;
953    
954    /* 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 */
955    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
956      printerr("Too Few Arguments");      printerr("Too Few Arguments");
957      env->err= 1;      env->err= 1;
958      return;      return;
959    }    }
960    
961    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
962      printerr("Bad Argument Type");      printerr("Bad Argument Type");
963      env->err= 2;      env->err= 2;
964      return;      return;
965    }    }
966    
967    /* long names are a pain */    /* long names are a pain */
968    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
969    
970    /* Bind the symbol to the value */    /* Bind the symbol to the value */
971    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
972    
973    toss(env); toss(env);    toss(env); toss(env);
974  }  }
# Line 873  extern void quit(environment *env) Line 991  extern void quit(environment *env)
991    env->gc_limit= 0;    env->gc_limit= 0;
992    gc_maybe(env);    gc_maybe(env);
993    
994      words(env);
995    
996    if(env->free_string!=NULL)    if(env->free_string!=NULL)
997      free(env->free_string);      free(env->free_string);
998        
999    #ifdef __linux__
1000    muntrace();    muntrace();
1001    #endif
1002    
1003    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
1004  }  }
# Line 884  extern void quit(environment *env) Line 1006  extern void quit(environment *env)
1006  /* Clear stack */  /* Clear stack */
1007  extern void clear(environment *env)  extern void clear(environment *env)
1008  {  {
1009    while(env->head!=NULL)    while(env->head->type != empty)
1010      toss(env);      toss(env);
1011  }  }
1012    
# Line 897  extern void words(environment *env) Line 1019  extern void words(environment *env)
1019    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
1020      temp= env->symbols[i];      temp= env->symbols[i];
1021      while(temp!=NULL) {      while(temp!=NULL) {
1022    #ifdef DEBUG
1023          if (temp->val != NULL && temp->val->gc.flag.protect)
1024            printf("(protected) ");
1025    #endif /* DEBUG */
1026        printf("%s\n", temp->id);        printf("%s\n", temp->id);
1027        temp= temp->next;        temp= temp->next;
1028      }      }
# Line 919  void forget_sym(symbol **hash_entry) Line 1045  void forget_sym(symbol **hash_entry)
1045  extern void forget(environment *env)  extern void forget(environment *env)
1046  {  {
1047    char* sym_id;    char* sym_id;
   stackitem *stack_head= env->head;  
1048    
1049    if(stack_head==NULL) {    if(env->head->type==empty) {
1050      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1051      env->err=1;      env->err= 1;
1052      return;      return;
1053    }    }
1054        
1055    if(stack_head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
1056      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1057      env->err=2;      env->err= 2;
1058      return;      return;
1059    }    }
1060    
1061    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(env->head)->content.sym->id;
1062    toss(env);    toss(env);
1063    
1064    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 951  int main(int argc, char **argv) Line 1076  int main(int argc, char **argv)
1076    
1077    int c;                        /* getopt option character */    int c;                        /* getopt option character */
1078    
1079    #ifdef __linux__
1080    mtrace();    mtrace();
1081    #endif
1082    
1083    init_env(&myenv);    init_env(&myenv);
1084    
# Line 965  int main(int argc, char **argv) Line 1092  int main(int argc, char **argv)
1092          break;          break;
1093        case '?':        case '?':
1094          fprintf (stderr,          fprintf (stderr,
1095                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1096                   optopt);                   optopt);
1097          return EX_USAGE;          return EX_USAGE;
1098        default:        default:
# Line 984  int main(int argc, char **argv) Line 1111  int main(int argc, char **argv)
1111    if(myenv.interactive) {    if(myenv.interactive) {
1112      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1113  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1114  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1115  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1116  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1117    }    }
1118    
1119    while(1) {    while(1) {
# Line 1001  under certain conditions; type `copying; Line 1128  under certain conditions; type `copying;
1128        }        }
1129        myenv.err=0;        myenv.err=0;
1130      }      }
1131      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1132      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1133        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1134      } else if(myenv.head!=NULL        quit(&myenv);
1135                && myenv.head->item->type==symb      } else if(myenv.head->type!=empty
1136                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->type==symb
1137                  && CAR(myenv.head)->content.sym->id[0]
1138                  ==';') {
1139        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1140        eval(&myenv);        eval(&myenv);
1141      }      }
# Line 1025  extern void sx_2b(environment *env) Line 1154  extern void sx_2b(environment *env)
1154    char* new_string;    char* new_string;
1155    value *a_val, *b_val;    value *a_val, *b_val;
1156    
1157    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1158      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1159      env->err= 1;      env->err= 1;
1160      return;      return;
1161    }    }
1162    
1163    if(env->head->item->type==string    if(CAR(env->head)->type==string
1164       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1165      a_val= env->head->item;      a_val= CAR(env->head);
1166      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1167      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1168      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1169      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1170      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
1171      new_string= malloc(len);      new_string= malloc(len);
1172        assert(new_string != NULL);
1173      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1174      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1175      push_cstring(env, new_string);      push_cstring(env, new_string);
1176      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1177      free(new_string);      free(new_string);
1178            
1179      return;      return;
1180    }    }
1181        
1182    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1183       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1184      a=env->head->item->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->item->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->item->type==tfloat    if(CAR(env->head)->type==tfloat
1194       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1195      fa= env->head->item->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->item->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->item->type==tfloat    if(CAR(env->head)->type==tfloat
1205       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1206      fa= env->head->item->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->item->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->item->type==integer    if(CAR(env->head)->type==integer
1216       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1217      a= env->head->item->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->item->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 1103  extern void sx_2d(environment *env) Line 1233  extern void sx_2d(environment *env)
1233    int a, b;    int a, b;
1234    float fa, fb;    float fa, fb;
1235    
1236    if((env->head)==NULL || env->head->next==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->item->type==integer    if(CAR(env->head)->type==integer
1243       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1244      a=env->head->item->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->item->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->item->type==tfloat    if(CAR(env->head)->type==tfloat
1254       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1255      fa= env->head->item->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->item->content.f;      fb= CAR(env->head)->content.f;
1258      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1259      push_float(env, fb-fa);      push_float(env, fb-fa);
1260            
1261      return;      return;
1262    }    }
1263    
1264    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1265       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1266      fa= env->head->item->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->item->content.i;      b= CAR(env->head)->content.i;
1269      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1270      push_float(env, b-fa);      push_float(env, b-fa);
1271            
1272      return;      return;
1273    }    }
1274    
1275    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1276       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1277      a= env->head->item->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->item->content.f;      fb= CAR(env->head)->content.f;
1280      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1281      push_float(env, fb-a);      push_float(env, fb-a);
1282    
# Line 1163  extern void sx_3e(environment *env) Line 1293  extern void sx_3e(environment *env)
1293    int a, b;    int a, b;
1294    float fa, fb;    float fa, fb;
1295    
1296    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1297      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1298      env->err=1;      env->err= 1;
1299      return;      return;
1300    }    }
1301        
1302    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1303       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1304      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1305      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1306      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1307      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1308      push_int(env, b>a);      push_int(env, b>a);
1309    
1310      return;      return;
1311    }    }
1312    
1313    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1314       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1315      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1316      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1317      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1318      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1319      push_int(env, fb>fa);      push_int(env, fb>fa);
1320            
1321      return;      return;
1322    }    }
1323    
1324    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1325       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1326      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1327      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1328      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1329      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1330      push_int(env, b>fa);      push_int(env, b>fa);
1331            
1332      return;      return;
1333    }    }
1334    
1335    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1336       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1337      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1338      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1339      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1340      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1341      push_int(env, fb>a);      push_int(env, fb>a);
1342    
# Line 1214  extern void sx_3e(environment *env) Line 1344  extern void sx_3e(environment *env)
1344    }    }
1345    
1346    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1347    env->err=2;    env->err= 2;
1348  }  }
1349    
1350  /* "<" */  /* "<" */
# Line 1241  extern void sx_3e3d(environment *env) Line 1371  extern void sx_3e3d(environment *env)
1371  /* Return copy of a value */  /* Return copy of a value */
1372  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
1373  {  {
   stackitem *old_item, *new_item, *prev_item;  
1374    value *new_value;    value *new_value;
1375    
1376    protect(env, old_value);    if(old_value==NULL)
1377        return NULL;
1378    
1379      protect(old_value);
1380    new_value= new_val(env);    new_value= new_val(env);
   protect(env, new_value);  
1381    new_value->type= old_value->type;    new_value->type= old_value->type;
1382    
1383    switch(old_value->type){    switch(old_value->type){
# Line 1254  value *copy_val(environment *env, value Line 1385  value *copy_val(environment *env, value
1385    case integer:    case integer:
1386    case func:    case func:
1387    case symb:    case symb:
1388      case empty:
1389      new_value->content= old_value->content;      new_value->content= old_value->content;
1390      break;      break;
1391    case string:    case string:
1392      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1393        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1394      break;      break;
1395    case list:    case tcons:
     new_value->content.ptr= NULL;  
1396    
1397      prev_item= NULL;      new_value->content.c= malloc(sizeof(pair));
1398      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
1399        env->gc_count += sizeof(pair);
1400    
1401      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1402        new_item= malloc(sizeof(stackitem));      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
       new_item->item= copy_val(env, old_item->item); /* recurse */  
       new_item->next= NULL;  
       if(prev_item != NULL)     /* If this wasn't the first item */  
         prev_item->next= new_item; /* point the previous item to the  
                                      new item */  
       else  
         new_value->content.ptr= new_item;  
       old_item= old_item->next;  
       prev_item= new_item;  
     }      
1403      break;      break;
1404    }    }
1405    
1406    unprotect(env); unprotect(env);    unprotect(old_value);
1407    
1408    return new_value;    return new_value;
1409  }  }
# Line 1289  value *copy_val(environment *env, value Line 1411  value *copy_val(environment *env, value
1411  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1412  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1413  {  {
1414    if((env->head)==NULL) {    if(env->head->type==empty) {
1415      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1416      env->err= 1;      env->err= 1;
1417      return;      return;
1418    }    }
1419    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1420  }  }
1421    
1422  /* "if", If-Then */  /* "if", If-Then */
# Line 1302  extern void sx_6966(environment *env) Line 1424  extern void sx_6966(environment *env)
1424  {  {
1425    int truth;    int truth;
1426    
1427    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1428      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1429      env->err= 1;      env->err= 1;
1430      return;      return;
1431    }    }
1432    
1433    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1434      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1435      env->err=2;      env->err= 2;
1436      return;      return;
1437    }    }
1438        
1439    swap(env);    swap(env);
1440    if(env->err) return;    if(env->err) return;
1441        
1442    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1443    
1444    toss(env);    toss(env);
1445    if(env->err) return;    if(env->err) return;
# Line 1333  extern void ifelse(environment *env) Line 1455  extern void ifelse(environment *env)
1455  {  {
1456    int truth;    int truth;
1457    
1458    if((env->head)==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1459       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1460      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1461      env->err=1;      env->err= 1;
1462      return;      return;
1463    }    }
1464    
1465    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1466      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1467      env->err=2;      env->err= 2;
1468      return;      return;
1469    }    }
1470        
1471    rot(env);    rot(env);
1472    if(env->err) return;    if(env->err) return;
1473        
1474    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1475    
1476    toss(env);    toss(env);
1477    if(env->err) return;    if(env->err) return;
# Line 1364  extern void ifelse(environment *env) Line 1486  extern void ifelse(environment *env)
1486    eval(env);    eval(env);
1487  }  }
1488    
1489    extern void sx_656c7365(environment *env)
1490    {
1491      if(env->head->type==empty || CDR(env->head)->type==empty
1492         || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1493         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1494        printerr("Too Few Arguments");
1495        env->err= 1;
1496        return;
1497      }
1498    
1499      if(CAR(CDR(env->head))->type!=symb
1500         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1501         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1502         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1503        printerr("Bad Argument Type");
1504        env->err= 2;
1505        return;
1506      }
1507    
1508      swap(env); toss(env); rot(env); toss(env);
1509      ifelse(env);
1510    }
1511    
1512    extern void then(environment *env)
1513    {
1514      if(env->head->type==empty || CDR(env->head)->type==empty
1515         || CDR(CDR(env->head))->type==empty) {
1516        printerr("Too Few Arguments");
1517        env->err= 1;
1518        return;
1519      }
1520    
1521      if(CAR(CDR(env->head))->type!=symb
1522         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1523        printerr("Bad Argument Type");
1524        env->err= 2;
1525        return;
1526      }
1527    
1528      swap(env); toss(env);
1529      sx_6966(env);
1530    }
1531    
1532  /* "while" */  /* "while" */
1533  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1534  {  {
1535    int truth;    int truth;
1536    value *loop, *test;    value *loop, *test;
1537    
1538    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1539      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1540      env->err=1;      env->err= 1;
1541      return;      return;
1542    }    }
1543    
1544    loop= env->head->item;    loop= CAR(env->head);
1545    protect(env, loop);    protect(loop);
1546    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1547    
1548    test= env->head->item;    test= CAR(env->head);
1549    protect(env, test);    protect(test);
1550    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1551    
1552    do {    do {
1553      push_val(env, test);      push_val(env, test);
1554      eval(env);      eval(env);
1555            
1556      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1557        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1558        env->err= 2;        env->err= 2;
1559        return;        return;
1560      }      }
1561            
1562      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1563      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1564            
1565      if(truth) {      if(truth) {
# Line 1406  extern void sx_7768696c65(environment *e Line 1571  extern void sx_7768696c65(environment *e
1571        
1572    } while(truth);    } while(truth);
1573    
1574    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1575  }  }
1576    
1577    
# Line 1416  extern void sx_666f72(environment *env) Line 1581  extern void sx_666f72(environment *env)
1581    value *loop;    value *loop;
1582    int foo1, foo2;    int foo1, foo2;
1583    
1584    if(env->head==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1585       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1586      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1587      env->err= 1;      env->err= 1;
1588      return;      return;
1589    }    }
1590    
1591    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1592       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1593      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1594      env->err= 2;      env->err= 2;
1595      return;      return;
1596    }    }
1597    
1598    loop= env->head->item;    loop= CAR(env->head);
1599    protect(env, loop);    protect(loop);
1600    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1601    
1602    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1603    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1604    
1605    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1606    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1607    
1608    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1455  extern void sx_666f72(environment *env) Line 1620  extern void sx_666f72(environment *env)
1620        foo1--;        foo1--;
1621      }      }
1622    }    }
1623    unprotect(env);    unprotect(loop);
1624  }  }
1625    
1626  /* Variant of for-loop */  /* Variant of for-loop */
1627  extern void foreach(environment *env)  extern void foreach(environment *env)
1628  {    {  
1629    value *loop, *foo;    value *loop, *foo;
1630    stackitem *iterator;    value *iterator;
1631        
1632    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1633      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1634      env->err= 1;      env->err= 1;
1635      return;      return;
1636    }    }
1637    
1638    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1639      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1640      env->err= 2;      env->err= 2;
1641      return;      return;
1642    }    }
1643    
1644    loop= env->head->item;    loop= CAR(env->head);
1645    protect(env, loop);    protect(loop);
1646    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1647    
1648    foo= env->head->item;    foo= CAR(env->head);
1649    protect(env, foo);    protect(foo);
1650    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1651    
1652    iterator= foo->content.ptr;    iterator= foo;
1653    
1654    while(iterator!=NULL) {    while(iterator->type!=empty) {
1655      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1656      push_val(env, loop);      push_val(env, loop);
1657      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1658      iterator= iterator->next;      if (iterator->type == tcons){
1659          iterator= CDR(iterator);
1660        } else {
1661          printerr("Bad Argument Type"); /* Improper list */
1662          env->err= 2;
1663          break;
1664        }
1665    }    }
1666    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1667  }  }
1668    
1669  /* "to" */  /* "to" */
1670  extern void to(environment *env)  extern void to(environment *env)
1671  {  {
1672    int ending, start, i;    int ending, start, i;
1673    stackitem *iterator, *temp;    value *iterator, *temp, *end;
   value *pack;  
1674    
1675    if((env->head)==NULL || env->head->next==NULL) {    end= new_val(env);
1676    
1677      if(env->head->type==empty || CDR(env->head)->type==empty) {
1678      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1679      env->err=1;      env->err= 1;
1680      return;      return;
1681    }    }
1682    
1683    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1684       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1685      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1686      env->err=2;      env->err= 2;
1687      return;      return;
1688    }    }
1689    
1690    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1691    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1692    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1693    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1694    
1695    push_sym(env, "[");    push_sym(env, "[");
# Line 1531  extern void to(environment *env) Line 1703  extern void to(environment *env)
1703    }    }
1704    
1705    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(env, pack);  
1706    
1707    if(iterator==NULL    if(iterator->type==empty
1708       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
1709       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1710      temp= NULL;      temp= end;
1711      toss(env);      toss(env);
1712    } else {    } else {
1713      /* Search for first delimiter */      /* Search for first delimiter */
1714      while(iterator->next!=NULL      while(CDR(iterator)->type!=empty
1715            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
1716            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1717        iterator= iterator->next;        iterator= CDR(iterator);
1718            
1719      /* Extract list */      /* Extract list */
1720      temp= env->head;      temp= env->head;
1721      env->head= iterator->next;      env->head= CDR(iterator);
1722      iterator->next= NULL;      CDR(iterator)= end;
1723    
1724      pack->type= list;      if(env->head->type!=empty)
     pack->content.ptr= temp;  
       
     if(env->head!=NULL)  
1725        toss(env);        toss(env);
1726    }    }
1727    
1728    /* Push list */    /* Push list */
1729      push_val(env, temp);
   push_val(env, pack);  
   
   unprotect(env);  
1730  }  }
1731    
1732  /* Read a string */  /* Read a string */
# Line 1592  extern void sx_72656164(environment *env Line 1756  extern void sx_72656164(environment *env
1756    int count= -1;    int count= -1;
1757    float ftemp;    float ftemp;
1758    static int depth= 0;    static int depth= 0;
1759    char *match, *ctemp;    char *match;
1760    size_t inlength;    size_t inlength;
1761    
1762    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1601  extern void sx_72656164(environment *env Line 1765  extern void sx_72656164(environment *env
1765      }      }
1766      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1767    
1768      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1769        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1770        return;        return;
1771      }      }
1772            
1773      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1774        assert(env->in_string != NULL);
1775      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1776      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1777      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1778    }    }
1779        
1780    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1781    match= malloc(inlength);    match= malloc(inlength);
1782      assert(match != NULL);
1783    
1784    if(sscanf(env->in_string, blankform, &readlength) != EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1785       && readlength != -1) {       && readlength != -1) {
# Line 1626  extern void sx_72656164(environment *env Line 1792  extern void sx_72656164(environment *env
1792      } else {      } else {
1793        push_float(env, ftemp);        push_float(env, ftemp);
1794      }      }
1795      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1796                && readlength != -1) {
1797        push_cstring(env, "");
1798    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1799              && readlength != -1) {              && readlength != -1) {
1800      push_cstring(env, match);      push_cstring(env, match);
# Line 1657  extern void sx_72656164(environment *env Line 1826  extern void sx_72656164(environment *env
1826      return sx_72656164(env);      return sx_72656164(env);
1827  }  }
1828    
1829    #ifdef __linux__
1830  extern void beep(environment *env)  extern void beep(environment *env)
1831  {  {
1832    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1833    
1834    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1835      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1836      env->err=1;      env->err= 1;
1837      return;      return;
1838    }    }
1839    
1840    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1841       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1842      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1843      env->err=2;      env->err= 2;
1844      return;      return;
1845    }    }
1846    
1847    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1848    toss(env);    toss(env);
1849    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
1850    toss(env);    toss(env);
1851    
1852    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1853                                     length */                                     length */
1854    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1855                                     timer ticks */                                     timer ticks */
1856    
1857  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1858    
1859    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1860    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1861    case 0:    case 0:
1862      usleep(dur);      usleep(dur);
1863      return;      return;
1864    case -1:    case -1:
1865      perror("beep");      perror("beep");
1866      env->err=5;      env->err= 5;
1867      return;      return;
1868    default:    default:
1869      abort();      abort();
1870    }    }
1871  }  }
1872    #endif /* __linux__ */
1873    
1874  /* "wait" */  /* "wait" */
1875  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
1876  {  {
1877    int dur;    int dur;
1878    
1879    if((env->head)==NULL) {    if(env->head->type==empty) {
1880      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1881      env->err=1;      env->err= 1;
1882      return;      return;
1883    }    }
1884    
1885    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1886      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1887      env->err=2;      env->err= 2;
1888      return;      return;
1889    }    }
1890    
1891    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1892    toss(env);    toss(env);
1893    
1894    usleep(dur);    usleep(dur);
# Line 1725  extern void sx_77616974(environment *env Line 1896  extern void sx_77616974(environment *env
1896    
1897  extern void copying(environment *env)  extern void copying(environment *env)
1898  {  {
1899    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1900                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1901  \n\  \n\
1902   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2014  extern void sx_2a(environment *env) Line 2185  extern void sx_2a(environment *env)
2185    int a, b;    int a, b;
2186    float fa, fb;    float fa, fb;
2187    
2188    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2189      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2190      env->err=1;      env->err= 1;
2191      return;      return;
2192    }    }
2193        
2194    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2195       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2196      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2197      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2198      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2199      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2200      push_int(env, b*a);      push_int(env, b*a);
2201    
2202      return;      return;
2203    }    }
2204    
2205    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2206       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2207      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2208      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2209      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2210      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2211      push_float(env, fb*fa);      push_float(env, fb*fa);
2212            
2213      return;      return;
2214    }    }
2215    
2216    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2217       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2218      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2219      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2220      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2221      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2222      push_float(env, b*fa);      push_float(env, b*fa);
2223            
2224      return;      return;
2225    }    }
2226    
2227    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2228       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2229      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2230      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2231      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2232      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2233      push_float(env, fb*a);      push_float(env, fb*a);
2234    
# Line 2065  extern void sx_2a(environment *env) Line 2236  extern void sx_2a(environment *env)
2236    }    }
2237    
2238    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2239    env->err=2;    env->err= 2;
2240  }  }
2241    
2242  /* "/" */  /* "/" */
# Line 2074  extern void sx_2f(environment *env) Line 2245  extern void sx_2f(environment *env)
2245    int a, b;    int a, b;
2246    float fa, fb;    float fa, fb;
2247    
2248    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2249      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2250      env->err=1;      env->err= 1;
2251      return;      return;
2252    }    }
2253        
2254    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2255       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2256      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2257      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2258      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2259      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2260      push_float(env, b/a);      push_float(env, b/a);
2261    
2262      return;      return;
2263    }    }
2264    
2265    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2266       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2267      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2268      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2269      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2270      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2271      push_float(env, fb/fa);      push_float(env, fb/fa);
2272            
2273      return;      return;
2274    }    }
2275    
2276    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2277       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2278      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2279      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2280      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2281      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2282      push_float(env, b/fa);      push_float(env, b/fa);
2283            
2284      return;      return;
2285    }    }
2286    
2287    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2288       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2289      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2290      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2291      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2292      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2293      push_float(env, fb/a);      push_float(env, fb/a);
2294    
# Line 2125  extern void sx_2f(environment *env) Line 2296  extern void sx_2f(environment *env)
2296    }    }
2297    
2298    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2299    env->err=2;    env->err= 2;
2300  }  }
2301    
2302  /* "mod" */  /* "mod" */
# Line 2133  extern void mod(environment *env) Line 2304  extern void mod(environment *env)
2304  {  {
2305    int a, b;    int a, b;
2306    
2307    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2308      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2309      env->err= 1;      env->err= 1;
2310      return;      return;
2311    }    }
2312        
2313    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2314       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2315      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2316      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2317      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2318      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2319      push_int(env, b%a);      push_int(env, b%a);
2320    
# Line 2151  extern void mod(environment *env) Line 2322  extern void mod(environment *env)
2322    }    }
2323    
2324    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2325    env->err=2;    env->err= 2;
2326  }  }
2327    
2328  /* "div" */  /* "div" */
# Line 2159  extern void sx_646976(environment *env) Line 2330  extern void sx_646976(environment *env)
2330  {  {
2331    int a, b;    int a, b;
2332        
2333    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2334      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2335      env->err= 1;      env->err= 1;
2336      return;      return;
2337    }    }
2338    
2339    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2340       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2341      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2342      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2343      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2344      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2345      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2346    
# Line 2179  extern void sx_646976(environment *env) Line 2350  extern void sx_646976(environment *env)
2350    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2351    env->err= 2;    env->err= 2;
2352  }  }
2353    
2354    extern void setcar(environment *env)
2355    {
2356      if(env->head->type==empty || CDR(env->head)->type==empty) {
2357        printerr("Too Few Arguments");
2358        env->err= 1;
2359        return;
2360      }
2361    
2362      if(CDR(env->head)->type!=tcons) {
2363        printerr("Bad Argument Type");
2364        env->err= 2;
2365        return;
2366      }
2367    
2368      CAR(CAR(CDR(env->head)))=CAR(env->head);
2369      toss(env);
2370    }
2371    
2372    extern void setcdr(environment *env)
2373    {
2374      if(env->head->type==empty || CDR(env->head)->type==empty) {
2375        printerr("Too Few Arguments");
2376        env->err= 1;
2377        return;
2378      }
2379    
2380      if(CDR(env->head)->type!=tcons) {
2381        printerr("Bad Argument Type");
2382        env->err= 2;
2383        return;
2384      }
2385    
2386      CDR(CAR(CDR(env->head)))=CAR(env->head);
2387      toss(env);
2388    }
2389    
2390    extern void car(environment *env)
2391    {
2392      if(env->head->type==empty) {
2393        printerr("Too Few Arguments");
2394        env->err= 1;
2395        return;
2396      }
2397    
2398      if(CAR(env->head)->type!=tcons) {
2399        printerr("Bad Argument Type");
2400        env->err= 2;
2401        return;
2402      }
2403    
2404      CAR(env->head)=CAR(CAR(env->head));
2405    }
2406    
2407    extern void cdr(environment *env)
2408    {
2409      if(env->head->type==empty) {
2410        printerr("Too Few Arguments");
2411        env->err= 1;
2412        return;
2413      }
2414    
2415      if(CAR(env->head)->type!=tcons) {
2416        printerr("Bad Argument Type");
2417        env->err= 2;
2418        return;
2419      }
2420    
2421      CAR(env->head)=CDR(CAR(env->head));
2422    }
2423    
2424    extern void cons(environment *env)
2425    {
2426      value *val;
2427    
2428      if(env->head->type==empty || CDR(env->head)->type==empty) {
2429        printerr("Too Few Arguments");
2430        env->err= 1;
2431        return;
2432      }
2433    
2434      val=new_val(env);
2435      val->content.c= malloc(sizeof(pair));
2436      assert(val->content.c!=NULL);
2437    
2438      env->gc_count += sizeof(pair);
2439      val->type=tcons;
2440    
2441      CAR(val)= CAR(CDR(env->head));
2442      CDR(val)= CAR(env->head);
2443    
2444      push_val(env, val);
2445    
2446      swap(env); if(env->err) return;
2447      toss(env); if(env->err) return;
2448      swap(env); if(env->err) return;
2449      toss(env); if(env->err) return;
2450    }
2451    
2452    /*  2: 3                        =>                */
2453    /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
2454    extern void assq(environment *env)
2455    {
2456      assocgen(env, eq);
2457    }
2458    
2459    
2460    /* General assoc function */
2461    void assocgen(environment *env, funcp eqfunc)
2462    {
2463      value *key, *item;
2464    
2465      /* Needs two values on the stack, the top one must be an association
2466         list */
2467      if(env->head->type==empty || CDR(env->head)->type==empty) {
2468        printerr("Too Few Arguments");
2469        env->err= 1;
2470        return;
2471      }
2472    
2473      if(CAR(env->head)->type!=tcons) {
2474        printerr("Bad Argument Type");
2475        env->err= 2;
2476        return;
2477      }
2478    
2479      key=CAR(CDR(env->head));
2480      item=CAR(env->head);
2481    
2482      while(item->type == tcons){
2483        if(CAR(item)->type != tcons){
2484          printerr("Bad Argument Type");
2485          env->err= 2;
2486          return;
2487        }
2488        push_val(env, key);
2489        push_val(env, CAR(CAR(item)));
2490        eqfunc(env); if(env->err) return;
2491    
2492        /* Check the result of 'eqfunc' */
2493        if(env->head->type==empty) {
2494          printerr("Too Few Arguments");
2495          env->err= 1;
2496        return;
2497        }
2498        if(CAR(env->head)->type!=integer) {
2499          printerr("Bad Argument Type");
2500          env->err= 2;
2501          return;
2502        }
2503    
2504        if(CAR(env->head)->content.i){
2505          toss(env); if(env->err) return;
2506          break;
2507        }
2508        toss(env); if(env->err) return;
2509    
2510        if(item->type!=tcons) {
2511          printerr("Bad Argument Type");
2512          env->err= 2;
2513          return;
2514        }
2515    
2516        item=CDR(item);
2517      }
2518    
2519      if(item->type == tcons){      /* A match was found */
2520        push_val(env, CAR(item));
2521      } else {
2522        push_int(env, 0);
2523      }
2524      swap(env); if(env->err) return;
2525      toss(env); if(env->err) return;
2526      swap(env); if(env->err) return;
2527      toss(env);
2528    }
2529    
2530    extern void sx_646f(environment *env)
2531    {
2532      swap(env); if(env->err) return;
2533      eval(env);
2534    }
Legend:
Removed from v.1.96  
changed lines
  Added in v.1.123
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26