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

Diff of /stack/stack.c

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

revision 1.91 by teddy, Thu Mar 7 03:28:29 2002 UTC revision 1.116 by teddy, Sun Mar 17 12:49:27 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= 20;    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      env->head->type= empty;
66    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
67      env->symbols[i]= NULL;      env->symbols[i]= NULL;
68    env->err= 0;    env->err= 0;
# Line 63  void init_env(environment *env) Line 72  void init_env(environment *env)
72    env->interactive= 1;    env->interactive= 1;
73  }  }
74    
75  void printerr(const char* in_string) {  void printerr(const char* in_string)
76    {
77    fprintf(stderr, "Err: %s\n", in_string);    fprintf(stderr, "Err: %s\n", in_string);
78  }  }
79    
80  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
81  extern void toss(environment *env)  extern void toss(environment *env)
82  {  {
83    stackitem *temp= env->head;    if(env->head->type==empty) {
   
   if((env->head)==NULL) {  
84      printerr("Too Few Arguments");      printerr("Too Few Arguments");
85      env->err= 1;      env->err= 1;
86      return;      return;
87    }    }
88        
89    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);  
90  }  }
91    
92  /* 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 118  symbol **hash(hashtbl in_hashtbl, const
118    }    }
119  }  }
120    
121  value* new_val(environment *env) {  /* Create new value */
122    value* new_val(environment *env)
123    {
124    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
125    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
126    
127    nval->content.ptr= NULL;    nval->content.ptr= NULL;
128    protect(env, nval);    nval->type= integer;
   
   gc_init(env);  
129    
130    nitem->item= nval;    nitem->item= nval;
131    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
132    
133    env->gc_ref= nitem;    env->gc_ref= nitem;
134    
135    env->gc_count++;    env->gc_count += sizeof(value);
136    unprotect(env);    nval->gc.flag.mark= 0;
137      nval->gc.flag.protect= 0;
138    
139    return nval;    return nval;
140  }  }
141    
142  void gc_mark(value *val) {  /* Mark values recursively.
143    stackitem *iterator;     Marked values are not collected by the GC. */
144    inline void gc_mark(value *val)
145    if(val==NULL || val->gc_garb==0)  {
146      if(val==NULL || val->gc.flag.mark)
147      return;      return;
148    
149    val->gc_garb= 0;    val->gc.flag.mark= 1;
150    
151    if(val->type==list) {    if(val->type==tcons) {
152      iterator= val->content.ptr;      gc_mark(CAR(val));
153        gc_mark(CDR(val));
     while(iterator!=NULL) {  
       gc_mark(iterator->item);  
       iterator= iterator->next;  
     }  
154    }    }
155  }  }
156    
157  extern void gc_init(environment *env) {  inline void gc_maybe(environment *env)
158    stackitem *new_head= NULL, *titem, *iterator= env->gc_ref;  {
159      if(env->gc_count < env->gc_limit)
160        return;
161      else
162        return gc_init(env);
163    }
164    
165    /* Start GC */
166    extern void gc_init(environment *env)
167    {
168      stackitem *new_head= NULL, *titem;
169    symbol *tsymb;    symbol *tsymb;
170    int i;    int i;
171    
172    if(env->gc_count < env->gc_limit)    if(env->interactive)
173      return;      printf("Garbage collecting.");
174    
175    while(iterator!=NULL) {    /* Mark values on stack */
176      iterator->item->gc_garb= 1;    gc_mark(env->head);
     iterator= iterator->next;  
   }  
177    
178    /* Mark */    if(env->interactive)
179    iterator= env->gc_protect;      printf(".");
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
180    
   iterator= env->head;  
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
181    
182    for(i= 0; i<HASHTBLSIZE; i++) {    /* Mark values in hashtable */
183      tsymb= env->symbols[i];    for(i= 0; i<HASHTBLSIZE; i++)
184      while(tsymb!=NULL) {      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
185        gc_mark(tsymb->val);        if (tsymb->val != NULL)
186        tsymb= tsymb->next;          gc_mark(tsymb->val);
187      }  
188    }  
189      if(env->interactive)
190        printf(".");
191    
192    env->gc_count= 0;    env->gc_count= 0;
193    
194    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
   while(env->gc_ref!=NULL) {  
195    
196      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
197        switch(env->gc_ref->item->type) {  
198          /* Remove content */
199          switch(env->gc_ref->item->type){
200        case string:        case string:
201          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
202          break;          break;
203        case integer:        case tcons:
204          break;          free(env->gc_ref->item->content.c);
       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:  
205          break;          break;
206          case empty:
207          case integer:
208          case tfloat:
209          case func:
210          case symb:
211            /* Symbol strings are freed when walking the hash table */
212        }        }
213        free(env->gc_ref->item);  
214        titem= env->gc_ref->next;        free(env->gc_ref->item);  /* Remove from gc_ref */
       free(env->gc_ref);  
       env->gc_ref= titem;  
     } else {  
215        titem= env->gc_ref->next;        titem= env->gc_ref->next;
216        env->gc_ref->next= new_head;        free(env->gc_ref);        /* Remove value */
       new_head= env->gc_ref;  
217        env->gc_ref= titem;        env->gc_ref= titem;
218        env->gc_count++;        continue;
219        }
220    #ifdef DEBUG
221        printf("Kept value (%p)", env->gc_ref->item);
222        if(env->gc_ref->item->gc.flag.mark)
223          printf(" (marked)");
224        if(env->gc_ref->item->gc.flag.protect)
225          printf(" (protected)");
226        switch(env->gc_ref->item->type){
227        case integer:
228          printf(" integer: %d", env->gc_ref->item->content.i);
229          break;
230        case func:
231          printf(" func: %p", env->gc_ref->item->content.ptr);
232          break;
233        case symb:
234          printf(" symb: %s", env->gc_ref->item->content.sym->id);
235          break;
236        case tcons:
237          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
238                 env->gc_ref->item->content.c->cdr);
239          break;
240        default:
241          printf(" <unknown %d>", (env->gc_ref->item->type));
242      }      }
243        printf("\n");
244    #endif /* DEBUG */
245    
246        /* Keep values */    
247        env->gc_count += sizeof(value);
248        if(env->gc_ref->item->type==string)
249          env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
250        
251        titem= env->gc_ref->next;
252        env->gc_ref->next= new_head;
253        new_head= env->gc_ref;
254        new_head->item->gc.flag.mark= 0;
255        env->gc_ref= titem;
256    }    }
257    
258    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
259        env->gc_limit= env->gc_count*2;
260    
261    env->gc_ref= new_head;    env->gc_ref= new_head;
262    
263      if(env->interactive)
264        printf("done (%d bytes still allocated)\n", env->gc_count);
265    
266  }  }
267    
268  void protect(environment *env, value *val)  /* Protect values from GC */
269    void protect(value *val)
270  {  {
271    stackitem *new_item= malloc(sizeof(stackitem));    if(val==NULL || val->gc.flag.protect)
272    new_item->item= val;      return;
273    new_item->next= env->gc_protect;  
274    env->gc_protect= new_item;    val->gc.flag.protect= 1;
275    
276      if(val->type==tcons) {
277        protect(CAR(val));
278        protect(CDR(val));
279      }
280  }  }
281    
282  void unprotect(environment *env)  /* Unprotect values from GC */
283    void unprotect(value *val)
284  {  {
285    stackitem *temp= env->gc_protect;    if(val==NULL || !(val->gc.flag.protect))
286    env->gc_protect= env->gc_protect->next;      return;
287    free(temp);  
288      val->gc.flag.protect= 0;
289    
290      if(val->type==tcons) {
291        unprotect(CAR(val));
292        unprotect(CDR(val));
293      }
294  }  }
295    
296  /* Push a value onto the stack */  /* Push a value onto the stack */
297  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
298  {  {
299    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
300    new_item->item= val;  
301    new_item->next= env->head;    new_value->content.c= malloc(sizeof(pair));
302    env->head= new_item;    assert(new_value->content.c!=NULL);
303      env->gc_count += sizeof(pair);
304      new_value->type= tcons;
305      CAR(new_value)= val;
306      CDR(new_value)= env->head;
307      env->head= new_value;
308  }  }
309    
310  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
311  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
312  {  {
313    value *new_value= new_val(env);    value *new_value= new_val(env);
314        
315    new_value->content.val= in_val;    new_value->content.i= in_val;
316    new_value->type= integer;    new_value->type= integer;
317    
318    push_val(env, new_value);    push_val(env, new_value);
319  }  }
320    
321    /* Push a floating point number onto the stack */
322    void push_float(environment *env, float in_val)
323    {
324      value *new_value= new_val(env);
325    
326      new_value->content.f= in_val;
327      new_value->type= tfloat;
328    
329      push_val(env, new_value);
330    }
331    
332  /* Copy a string onto the stack. */  /* Copy a string onto the stack. */
333  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
334  {  {
335    value *new_value= new_val(env);    value *new_value= new_val(env);
336      int length= strlen(in_string)+1;
337    
338    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
339      env->gc_count += length;
340    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
341    new_value->type= string;    new_value->type= string;
342    
# Line 271  void push_cstring(environment *env, cons Line 344  void push_cstring(environment *env, cons
344  }  }
345    
346  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
347  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
348    {
349    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
350    char *new_string, *current;    char *new_string, *current;
351    
# Line 289  char *mangle_str(const char *old_string) Line 363  char *mangle_str(const char *old_string)
363    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
364  }  }
365    
366  extern void mangle(environment *env){  extern void mangle(environment *env)
367    {
368    char *new_string;    char *new_string;
369    
370    if((env->head)==NULL) {    if(env->head->type==empty) {
371      printerr("Too Few Arguments");      printerr("Too Few Arguments");
372      env->err= 1;      env->err= 1;
373      return;      return;
374    }    }
375    
376    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
377      printerr("Bad Argument Type");      printerr("Bad Argument Type");
378      env->err= 2;      env->err= 2;
379      return;      return;
380    }    }
381    
382    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
383        mangle_str((const char *)(CAR(env->head)->content.ptr));
384    
385    toss(env);    toss(env);
386    if(env->err) return;    if(env->err) return;
# Line 328  void push_sym(environment *env, const ch Line 404  void push_sym(environment *env, const ch
404    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
405    
406    new_value= new_val(env);    new_value= new_val(env);
407      protect(new_value);
408      new_fvalue= new_val(env);
409      protect(new_fvalue);
410    
411    /* The new value is a symbol */    /* The new value is a symbol */
412    new_value->type= symb;    new_value->type= symb;
# Line 355  void push_sym(environment *env, const ch Line 434  void push_sym(environment *env, const ch
434    
435      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
436      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
437      free(mangled);  
438      dlerr= dlerror();      dlerr= dlerror();
439      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
440        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
441        dlerr= dlerror();        dlerr= dlerror();
442      }      }
443    
444      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 */  
445        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
446        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
447        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
448                                           function value */                                           function value */
449      }      }
450    
451        free(mangled);
452    }    }
453    
454    push_val(env, new_value);    push_val(env, new_value);
455      unprotect(new_value); unprotect(new_fvalue);
456  }  }
457    
458  /* Print newline. */  /* Print newline. */
# Line 379  extern void nl() Line 462  extern void nl()
462  }  }
463    
464  /* Gets the type of a value */  /* Gets the type of a value */
465  extern void type(environment *env){  extern void type(environment *env)
466    int typenum;  {
467      if(env->head->type==empty) {
   if((env->head)==NULL) {  
468      printerr("Too Few Arguments");      printerr("Too Few Arguments");
469      env->err=1;      env->err= 1;
470      return;      return;
471    }    }
472    typenum=env->head->item->type;  
473    toss(env);    switch(CAR(env->head)->type){
474    switch(typenum){    case empty:
475        push_sym(env, "empty");
476        break;
477    case integer:    case integer:
478      push_sym(env, "integer");      push_sym(env, "integer");
479      break;      break;
480      case tfloat:
481        push_sym(env, "float");
482        break;
483    case string:    case string:
484      push_sym(env, "string");      push_sym(env, "string");
485      break;      break;
# Line 402  extern void type(environment *env){ Line 489  extern void type(environment *env){
489    case func:    case func:
490      push_sym(env, "function");      push_sym(env, "function");
491      break;      break;
492    case list:    case tcons:
493      push_sym(env, "list");      push_sym(env, "pair");
494      break;      break;
495    }    }
496      swap(env);
497      if (env->err) return;
498      toss(env);
499  }      }    
500    
501  /* Prints the top element of the stack. */  /* Print a value */
502  void print_h(stackitem *stack_head, int noquote)  void print_val(value *val, int noquote)
503  {  {
504    switch(stack_head->item->type) {    switch(val->type) {
505      case empty:
506        printf("[]");
507        break;
508    case integer:    case integer:
509      printf("%d", stack_head->item->content.val);      printf("%d", val->content.i);
510        break;
511      case tfloat:
512        printf("%f", val->content.f);
513      break;      break;
514    case string:    case string:
515      if(noquote)      if(noquote)
516        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)(val->content.ptr));
517      else      else
518        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)(val->content.ptr));
519      break;      break;
520    case symb:    case symb:
521      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", val->content.sym->id);
522      break;      break;
523    case func:    case func:
524      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(val->content.ptr));
525      break;      break;
526    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);  
527      printf("[ ");      printf("[ ");
528      while(stack_head != NULL) {      do {
529        print_h(stack_head, noquote);        print_val(CAR(val), noquote);
530        printf(" ");        val= CDR(val);
531        stack_head=stack_head->next;        switch(val->type){
532      }        case empty:
533      printf("]");          break;
534          case tcons:
535            printf(" ");
536            break;
537          default:
538            printf(" . ");          /* Improper list */
539            print_val(val, noquote);
540          }
541        } while(val->type == tcons);
542        printf(" ]");
543      break;      break;
544    }    }
545  }  }
546    
547  extern void print_(environment *env) {  extern void print_(environment *env)
548    if(env->head==NULL) {  {
549      if(env->head->type==empty) {
550      printerr("Too Few Arguments");      printerr("Too Few Arguments");
551      env->err=1;      env->err= 1;
552      return;      return;
553    }    }
554    print_h(env->head, 0);    print_val(CAR(env->head), 0);
555    nl();    nl();
556  }  }
557    
# Line 459  extern void print(environment *env) Line 563  extern void print(environment *env)
563    toss(env);    toss(env);
564  }  }
565    
566  extern void princ_(environment *env) {  extern void princ_(environment *env)
567    if(env->head==NULL) {  {
568      if(env->head->type==empty) {
569      printerr("Too Few Arguments");      printerr("Too Few Arguments");
570      env->err=1;      env->err= 1;
571      return;      return;
572    }    }
573    print_h(env->head, 1);    print_val(CAR(env->head), 1);
574  }  }
575    
576  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack and then discards it. */
# Line 477  extern void princ(environment *env) Line 582  extern void princ(environment *env)
582  }  }
583    
584  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
585  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
586  {  {
587    if(stack_head->next != NULL)    if(CDR(stack_head)->type != empty)
588      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
589    printf("%ld: ", counter);    printf("%ld: ", counter);
590    print_h(stack_head, 0);    print_val(CAR(stack_head), 0);
591    nl();    nl();
592  }  }
593    
594  /* Prints the stack. */  /* Prints the stack. */
595  extern void printstack(environment *env)  extern void printstack(environment *env)
596  {  {
597    if(env->head == NULL) {    if(env->head->type == empty) {
598      printf("Stack Empty\n");      printf("Stack Empty\n");
599      return;      return;
600    }    }
601    
602    print_st(env->head, 1);    print_st(env->head, 1);
603  }  }
604    
605  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
606  extern void swap(environment *env)  extern void swap(environment *env)
607  {  {
608    stackitem *temp= env->head;    value *temp= env->head;
609        
610    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
611      printerr("Too Few Arguments");      printerr("Too Few Arguments");
612      env->err=1;      env->err=1;
613      return;      return;
614    }    }
615    
616    env->head= env->head->next;    env->head= CDR(env->head);
617    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
618    env->head->next= temp;    CDR(env->head)= temp;
619  }  }
620    
621  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
622  extern void rot(environment *env)  extern void rot(environment *env)
623  {  {
624    stackitem *temp= env->head;    value *temp= env->head;
625        
626    if(env->head==NULL || env->head->next==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
627        || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type == empty) {
628      printerr("Too Few Arguments");      printerr("Too Few Arguments");
629      env->err=1;      env->err= 1;
630      return;      return;
631    }    }
632      
633    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
634    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
635    env->head->next= temp;    CDR(env->head)= temp;
636  }  }
637    
638  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 534  extern void rcl(environment *env) Line 640  extern void rcl(environment *env)
640  {  {
641    value *val;    value *val;
642    
643    if(env->head == NULL) {    if(env->head->type==empty) {
644      printerr("Too Few Arguments");      printerr("Too Few Arguments");
645      env->err=1;      env->err= 1;
646      return;      return;
647    }    }
648    
649    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
650      printerr("Bad Argument Type");      printerr("Bad Argument Type");
651      env->err=2;      env->err= 2;
652      return;      return;
653    }    }
654    
655    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
656    if(val == NULL){    if(val == NULL){
657      printerr("Unbound Variable");      printerr("Unbound Variable");
658      env->err=3;      env->err= 3;
659      return;      return;
660    }    }
661    protect(env, val);    push_val(env, val);           /* Return the symbol's bound value */
662    toss(env);            /* toss the symbol */    swap(env);
663      if(env->err) return;
664      toss(env);                    /* toss the symbol */
665    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(env);  
666  }  }
667    
668  /* 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 672  extern void eval(environment *env)
672  {  {
673    funcp in_func;    funcp in_func;
674    value* temp_val;    value* temp_val;
675    stackitem* iterator;    value* iterator;
676    
677   eval_start:   eval_start:
678    
679    if(env->head==NULL) {    gc_maybe(env);
680    
681      if(env->head->type==empty) {
682      printerr("Too Few Arguments");      printerr("Too Few Arguments");
683      env->err=1;      env->err= 1;
684      return;      return;
685    }    }
686    
687    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
688      /* if it's a symbol */      /* if it's a symbol */
689    case symb:    case symb:
690      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
691      if(env->err) return;      if(env->err) return;
692      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
693        goto eval_start;        goto eval_start;
694      }      }
695      return;      return;
696    
697      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
698    case func:    case func:
699      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
700      toss(env);      toss(env);
701      if(env->err) return;      if(env->err) return;
702      return in_func(env);      return in_func(env);
703    
704      /* If it's a list */      /* If it's a list */
705    case list:    case tcons:
706      temp_val= env->head->item;      temp_val= CAR(env->head);
707      protect(env, temp_val);      protect(temp_val);
708      toss(env);  
709      if(env->err) return;      toss(env); if(env->err) return;
710      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
     unprotect(env);  
711            
712      while(iterator!=NULL) {      while(iterator->type != empty) {
713        push_val(env, iterator->item);        push_val(env, CAR(iterator));
714                
715        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
716          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
717          toss(env);          toss(env);
718          if(env->err) return;          if(env->err) return;
719                    
720          if(iterator->next == NULL){          if(CDR(iterator)->type == empty){
721            goto eval_start;            goto eval_start;
722          }          }
723          eval(env);          eval(env);
724          if(env->err) return;          if(env->err) return;
725        }        }
726        iterator= iterator->next;        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
727            iterator= CDR(iterator);
728          else {
729            printerr("Bad Argument Type"); /* Improper list */
730            env->err= 2;
731            return;
732          }
733      }      }
734        unprotect(temp_val);
735      return;      return;
736    
737    default:    case empty:
738      case integer:
739      case tfloat:
740      case string:
741      return;      return;
742    }    }
743  }  }
744    
745  /* Reverse (flip) a list */  /* Reverse (flip) a list */
746  extern void rev(environment *env){  extern void rev(environment *env)
747    stackitem *old_head, *new_head, *item;  {
748      value *old_head, *new_head, *item;
749    
750    if((env->head)==NULL) {    if(env->head->type==empty) {
751      printerr("Too Few Arguments");      printerr("Too Few Arguments");
752      env->err= 1;      env->err= 1;
753      return;      return;
754    }    }
755    
756    if(env->head->item->type!=list) {    if(CAR(env->head)->type==empty)
757        return;                     /* Don't reverse an empty list */
758    
759      if(CAR(env->head)->type!=tcons) {
760      printerr("Bad Argument Type");      printerr("Bad Argument Type");
761      env->err= 2;      env->err= 2;
762      return;      return;
763    }    }
764    
765    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
766    new_head= NULL;    new_head= new_val(env);
767    while(old_head != NULL){    new_head->type= empty;
768      while(old_head->type != empty) {
769      item= old_head;      item= old_head;
770      old_head= old_head->next;      old_head= CDR(old_head);
771      item->next= new_head;      CDR(item)= new_head;
772      new_head= item;      new_head= item;
773    }    }
774    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
775  }  }
776    
777  /* Make a list. */  /* Make a list. */
778  extern void pack(environment *env)  extern void pack(environment *env)
779  {  {
780    stackitem *iterator, *temp;    value *iterator, *temp, *ending;
   value *pack;  
781    
782    iterator= env->head;    ending=new_val(env);
783      ending->type=empty;
784    
785    if(iterator==NULL    iterator= env->head;
786       || (iterator->item->type==symb    if(iterator->type == empty
787       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       || (CAR(iterator)->type==symb
788      temp= NULL;       && CAR(iterator)->content.sym->id[0]=='[')) {
789        temp= ending;
790      toss(env);      toss(env);
791    } else {    } else {
792      /* Search for first delimiter */      /* Search for first delimiter */
793      while(iterator->next!=NULL      while(CDR(iterator)->type != empty
794            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
795            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
796        iterator= iterator->next;        iterator= CDR(iterator);
797            
798      /* Extract list */      /* Extract list */
799      temp= env->head;      temp= env->head;
800      env->head= iterator->next;      env->head= CDR(iterator);
801      iterator->next= NULL;      CDR(iterator)= ending;
802        
803      if(env->head!=NULL)      if(env->head->type != empty)
804        toss(env);        toss(env);
805    }    }
806    
807    /* Push list */    /* Push list */
   pack= new_val(env);  
   pack->type= list;  
   pack->content.ptr= temp;  
808    
809    push_val(env, pack);    push_val(env, temp);
810    rev(env);    rev(env);
811  }  }
812    
813  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
814  extern void expand(environment *env)  extern void expand(environment *env)
815  {  {
816    stackitem *temp, *new_head;    value *temp, *new_head;
817    
818    /* Is top element a list? */    /* Is top element a list? */
819    if(env->head==NULL) {    if(env->head->type==empty) {
820      printerr("Too Few Arguments");      printerr("Too Few Arguments");
821      env->err= 1;      env->err= 1;
822      return;      return;
823    }    }
824    if(env->head->item->type!=list) {  
825      if(CAR(env->head)->type!=tcons) {
826      printerr("Bad Argument Type");      printerr("Bad Argument Type");
827      env->err= 2;      env->err= 2;
828      return;      return;
# Line 713  extern void expand(environment *env) Line 834  extern void expand(environment *env)
834      return;      return;
835    
836    /* The first list element is the new stack head */    /* The first list element is the new stack head */
837    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
838    
839    toss(env);    toss(env);
840    
841    /* Find the end of the list */    /* Find the end of the list */
842    while(temp->next!=NULL)    while(CDR(temp)->type != empty) {
843      temp= temp->next;      if (CDR(temp)->type == tcons)
844          temp= CDR(temp);
845        else {
846          printerr("Bad Argument Type"); /* Improper list */
847          env->err= 2;
848          return;
849        }
850      }
851    
852    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
853    temp->next= env->head;    CDR(temp)= env->head;
854    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
855    
856  }  }
# Line 731  extern void expand(environment *env) Line 859  extern void expand(environment *env)
859  extern void eq(environment *env)  extern void eq(environment *env)
860  {  {
861    void *left, *right;    void *left, *right;
   int result;  
862    
863    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
864      printerr("Too Few Arguments");      printerr("Too Few Arguments");
865      env->err= 1;      env->err= 1;
866      return;      return;
867    }    }
868    
869    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
870    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
871    toss(env); toss(env);    toss(env); toss(env);
872    push_int(env, result);  
873      push_int(env, left==right);
874  }  }
875    
876  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 753  extern void not(environment *env) Line 878  extern void not(environment *env)
878  {  {
879    int val;    int val;
880    
881    if((env->head)==NULL) {    if(env->head->type==empty) {
882      printerr("Too Few Arguments");      printerr("Too Few Arguments");
883      env->err= 1;      env->err= 1;
884      return;      return;
885    }    }
886    
887    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
888      printerr("Bad Argument Type");      printerr("Bad Argument Type");
889      env->err= 2;      env->err= 2;
890      return;      return;
891    }    }
892    
893    val= env->head->item->content.val;    val= CAR(env->head)->content.i;
894    toss(env);    toss(env);
895    push_int(env, !val);    push_int(env, !val);
896  }  }
# Line 784  extern void def(environment *env) Line 909  extern void def(environment *env)
909    symbol *sym;    symbol *sym;
910    
911    /* 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 */
912    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
913      printerr("Too Few Arguments");      printerr("Too Few Arguments");
914      env->err= 1;      env->err= 1;
915      return;      return;
916    }    }
917    
918    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
919      printerr("Bad Argument Type");      printerr("Bad Argument Type");
920      env->err= 2;      env->err= 2;
921      return;      return;
922    }    }
923    
924    /* long names are a pain */    /* long names are a pain */
925    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
926    
927    /* Bind the symbol to the value */    /* Bind the symbol to the value */
928    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
929    
930    toss(env); toss(env);    toss(env); toss(env);
931  }  }
# Line 808  extern void def(environment *env) Line 933  extern void def(environment *env)
933  /* Quit stack. */  /* Quit stack. */
934  extern void quit(environment *env)  extern void quit(environment *env)
935  {  {
936    long i;    int i;
937    
938    clear(env);    clear(env);
939    
# Line 821  extern void quit(environment *env) Line 946  extern void quit(environment *env)
946    }    }
947    
948    env->gc_limit= 0;    env->gc_limit= 0;
949    gc_init(env);    gc_maybe(env);
950    
951      words(env);
952    
953    if(env->free_string!=NULL)    if(env->free_string!=NULL)
954      free(env->free_string);      free(env->free_string);
955        
956    #ifdef __linux__
957    muntrace();    muntrace();
958    #endif
959    
960    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
961  }  }
# Line 834  extern void quit(environment *env) Line 963  extern void quit(environment *env)
963  /* Clear stack */  /* Clear stack */
964  extern void clear(environment *env)  extern void clear(environment *env)
965  {  {
966    while(env->head!=NULL)    while(env->head->type != empty)
967      toss(env);      toss(env);
968  }  }
969    
# Line 847  extern void words(environment *env) Line 976  extern void words(environment *env)
976    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
977      temp= env->symbols[i];      temp= env->symbols[i];
978      while(temp!=NULL) {      while(temp!=NULL) {
979    #ifdef DEBUG
980          if (temp->val != NULL && temp->val->gc.flag.protect)
981            printf("(protected) ");
982    #endif /* DEBUG */
983        printf("%s\n", temp->id);        printf("%s\n", temp->id);
984        temp= temp->next;        temp= temp->next;
985      }      }
# Line 854  extern void words(environment *env) Line 987  extern void words(environment *env)
987  }  }
988    
989  /* Internal forget function */  /* Internal forget function */
990  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
991    {
992    symbol *temp;    symbol *temp;
993    
994    temp= *hash_entry;    temp= *hash_entry;
# Line 868  void forget_sym(symbol **hash_entry) { Line 1002  void forget_sym(symbol **hash_entry) {
1002  extern void forget(environment *env)  extern void forget(environment *env)
1003  {  {
1004    char* sym_id;    char* sym_id;
   stackitem *stack_head= env->head;  
1005    
1006    if(stack_head==NULL) {    if(env->head->type==empty) {
1007      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1008      env->err=1;      env->err= 1;
1009      return;      return;
1010    }    }
1011        
1012    if(stack_head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
1013      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1014      env->err=2;      env->err= 2;
1015      return;      return;
1016    }    }
1017    
1018    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(env->head)->content.sym->id;
1019    toss(env);    toss(env);
1020    
1021    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
1022  }  }
1023    
1024  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
1025  extern void errn(environment *env){  extern void errn(environment *env)
1026    {
1027    push_int(env, env->err);    push_int(env, env->err);
1028  }  }
1029    
# Line 899  int main(int argc, char **argv) Line 1033  int main(int argc, char **argv)
1033    
1034    int c;                        /* getopt option character */    int c;                        /* getopt option character */
1035    
1036    #ifdef __linux__
1037    mtrace();    mtrace();
1038    #endif
1039    
1040    init_env(&myenv);    init_env(&myenv);
1041    
# Line 913  int main(int argc, char **argv) Line 1049  int main(int argc, char **argv)
1049          break;          break;
1050        case '?':        case '?':
1051          fprintf (stderr,          fprintf (stderr,
1052                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1053                   optopt);                   optopt);
1054          return EX_USAGE;          return EX_USAGE;
1055        default:        default:
# Line 932  int main(int argc, char **argv) Line 1068  int main(int argc, char **argv)
1068    if(myenv.interactive) {    if(myenv.interactive) {
1069      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1070  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1071  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1072  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1073  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1074    }    }
1075    
1076    while(1) {    while(1) {
# Line 949  under certain conditions; type `copying; Line 1085  under certain conditions; type `copying;
1085        }        }
1086        myenv.err=0;        myenv.err=0;
1087      }      }
1088      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1089      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1090        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1091      } else if(myenv.head!=NULL        quit(&myenv);
1092                && myenv.head->item->type==symb      } else if(myenv.head->type!=empty
1093                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->type==symb
1094                  && CAR(myenv.head)->content.sym->id[0]
1095                  ==';') {
1096        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1097        eval(&myenv);        eval(&myenv);
1098      }      }
1099      gc_init(&myenv);      gc_maybe(&myenv);
1100    }    }
1101    quit(&myenv);    quit(&myenv);
1102    return EXIT_FAILURE;    return EXIT_FAILURE;
1103  }  }
1104    
1105  /* "+" */  /* "+" */
1106  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1107    {
1108    int a, b;    int a, b;
1109      float fa, fb;
1110    size_t len;    size_t len;
1111    char* new_string;    char* new_string;
1112    value *a_val, *b_val;    value *a_val, *b_val;
1113    
1114    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
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==string    if(CAR(env->head)->type==string
1121       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1122      a_val= env->head->item;      a_val= CAR(env->head);
1123      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1124      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1125      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1126      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1127      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 1129  extern void sx_2b(environment *env) {
1129      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1130      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1131      push_cstring(env, new_string);      push_cstring(env, new_string);
1132      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1133      free(new_string);      free(new_string);
1134        
1135      return;      return;
1136    }    }
1137        
1138    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1139       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1140      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1141      env->err=2;      toss(env); if(env->err) return;
1142        b= CAR(env->head)->content.i;
1143        toss(env); if(env->err) return;
1144        push_int(env, b+a);
1145    
1146      return;      return;
1147    }    }
1148    a= env->head->item->content.val;  
1149    toss(env); if(env->err) return;    if(CAR(env->head)->type==tfloat
1150           && CAR(CDR(env->head))->type==tfloat) {
1151    b= env->head->item->content.val;      fa= CAR(env->head)->content.f;
1152    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1153    push_int(env, a+b);      fb= CAR(env->head)->content.f;
1154        toss(env); if(env->err) return;
1155        push_float(env, fb+fa);
1156        
1157        return;
1158      }
1159    
1160      if(CAR(env->head)->type==tfloat
1161         && CAR(CDR(env->head))->type==integer) {
1162        fa= CAR(env->head)->content.f;
1163        toss(env); if(env->err) return;
1164        b= CAR(env->head)->content.i;
1165        toss(env); if(env->err) return;
1166        push_float(env, b+fa);
1167        
1168        return;
1169      }
1170    
1171      if(CAR(env->head)->type==integer
1172         && CAR(CDR(env->head))->type==tfloat) {
1173        a= CAR(env->head)->content.i;
1174        toss(env); if(env->err) return;
1175        fb= CAR(env->head)->content.f;
1176        toss(env); if(env->err) return;
1177        push_float(env, fb+a);
1178    
1179        return;
1180      }
1181    
1182      printerr("Bad Argument Type");
1183      env->err=2;
1184  }  }
1185    
1186  /* "-" */  /* "-" */
1187  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1188    {
1189    int a, b;    int a, b;
1190      float fa, fb;
1191    
1192    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1193      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1194      env->err=1;      env->err=1;
1195      return;      return;
1196    }    }
1197        
1198    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1199       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1200      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1201      env->err=2;      toss(env); if(env->err) return;
1202        b= CAR(env->head)->content.i;
1203        toss(env); if(env->err) return;
1204        push_int(env, b-a);
1205    
1206      return;      return;
1207    }    }
1208    
1209    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
1210    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
1211    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
1212    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1213    push_int(env, b-a);      fb= CAR(env->head)->content.f;
1214        toss(env); if(env->err) return;
1215        push_float(env, fb-fa);
1216        
1217        return;
1218      }
1219    
1220      if(CAR(env->head)->type==tfloat
1221         && CAR(CDR(env->head))->type==integer) {
1222        fa= CAR(env->head)->content.f;
1223        toss(env); if(env->err) return;
1224        b= CAR(env->head)->content.i;
1225        toss(env); if(env->err) return;
1226        push_float(env, b-fa);
1227        
1228        return;
1229      }
1230    
1231      if(CAR(env->head)->type==integer
1232         && CAR(CDR(env->head))->type==tfloat) {
1233        a= CAR(env->head)->content.i;
1234        toss(env); if(env->err) return;
1235        fb= CAR(env->head)->content.f;
1236        toss(env); if(env->err) return;
1237        push_float(env, fb-a);
1238    
1239        return;
1240      }
1241    
1242      printerr("Bad Argument Type");
1243      env->err=2;
1244  }  }
1245    
1246  /* ">" */  /* ">" */
1247  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1248    {
1249    int a, b;    int a, b;
1250      float fa, fb;
1251    
1252    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1253      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1254      env->err=1;      env->err= 1;
1255      return;      return;
1256    }    }
1257        
1258    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1259       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1260      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1261      env->err=2;      toss(env); if(env->err) return;
1262        b= CAR(env->head)->content.i;
1263        toss(env); if(env->err) return;
1264        push_int(env, b>a);
1265    
1266      return;      return;
1267    }    }
1268    
1269    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
1270    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
1271    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
1272    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1273    push_int(env, b>a);      fb= CAR(env->head)->content.f;
1274        toss(env); if(env->err) return;
1275        push_int(env, fb>fa);
1276        
1277        return;
1278      }
1279    
1280      if(CAR(env->head)->type==tfloat
1281         && CAR(CDR(env->head))->type==integer) {
1282        fa= CAR(env->head)->content.f;
1283        toss(env); if(env->err) return;
1284        b= CAR(env->head)->content.i;
1285        toss(env); if(env->err) return;
1286        push_int(env, b>fa);
1287        
1288        return;
1289      }
1290    
1291      if(CAR(env->head)->type==integer
1292         && CAR(CDR(env->head))->type==tfloat) {
1293        a= CAR(env->head)->content.i;
1294        toss(env); if(env->err) return;
1295        fb= CAR(env->head)->content.f;
1296        toss(env); if(env->err) return;
1297        push_int(env, fb>a);
1298    
1299        return;
1300      }
1301    
1302      printerr("Bad Argument Type");
1303      env->err= 2;
1304    }
1305    
1306    /* "<" */
1307    extern void sx_3c(environment *env)
1308    {
1309      swap(env); if(env->err) return;
1310      sx_3e(env);
1311    }
1312    
1313    /* "<=" */
1314    extern void sx_3c3d(environment *env)
1315    {
1316      sx_3e(env); if(env->err) return;
1317      not(env);
1318    }
1319    
1320    /* ">=" */
1321    extern void sx_3e3d(environment *env)
1322    {
1323      sx_3c(env); if(env->err) return;
1324      not(env);
1325  }  }
1326    
1327  /* Return copy of a value */  /* Return copy of a value */
1328  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1329    stackitem *old_item, *new_item, *prev_item;  {
1330      value *new_value;
1331    
1332    value *new_value= new_val(env);    if(old_value==NULL)
1333        return NULL;
1334    
1335    protect(env, old_value);    protect(old_value);
1336      new_value= new_val(env);
1337    new_value->type= old_value->type;    new_value->type= old_value->type;
1338    
1339    switch(old_value->type){    switch(old_value->type){
1340      case tfloat:
1341    case integer:    case integer:
1342      new_value->content.val= old_value->content.val;    case func:
1343      case symb:
1344      case empty:
1345        new_value->content= old_value->content;
1346      break;      break;
1347    case string:    case string:
1348      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1349        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1350      break;      break;
1351    case func:    case tcons:
   case symb:  
     new_value->content.ptr= old_value->content.ptr;  
     break;  
   case list:  
     new_value->content.ptr= NULL;  
1352    
1353      prev_item= NULL;      new_value->content.c= malloc(sizeof(pair));
1354      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
1355        env->gc_count += sizeof(pair);
1356    
1357      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1358        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;  
     }      
1359      break;      break;
1360    }    }
1361    
1362    unprotect(env);    unprotect(old_value);
1363    
1364    return new_value;    return new_value;
1365  }  }
1366    
1367  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1368  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1369    if((env->head)==NULL) {  {
1370      if(env->head->type==empty) {
1371      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1372      env->err= 1;      env->err= 1;
1373      return;      return;
1374    }    }
1375    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1376  }  }
1377    
1378  /* "if", If-Then */  /* "if", If-Then */
1379  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1380    {
1381    int truth;    int truth;
1382    
1383    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1384      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1385      env->err= 1;      env->err= 1;
1386      return;      return;
1387    }    }
1388    
1389    if(env->head->next->item->type != integer) {    if(CAR(CDR(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    swap(env);    swap(env);
1396    if(env->err) return;    if(env->err) return;
1397        
1398    truth=env->head->item->content.val;    truth= CAR(env->head)->content.i;
1399    
1400    toss(env);    toss(env);
1401    if(env->err) return;    if(env->err) return;
# Line 1145  extern void sx_6966(environment *env) { Line 1407  extern void sx_6966(environment *env) {
1407  }  }
1408    
1409  /* If-Then-Else */  /* If-Then-Else */
1410  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1411    {
1412    int truth;    int truth;
1413    
1414    if((env->head)==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1415       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1416      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1417      env->err=1;      env->err= 1;
1418      return;      return;
1419    }    }
1420    
1421    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1422      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1423      env->err=2;      env->err= 2;
1424      return;      return;
1425    }    }
1426        
1427    rot(env);    rot(env);
1428    if(env->err) return;    if(env->err) return;
1429        
1430    truth=env->head->item->content.val;    truth= CAR(env->head)->content.i;
1431    
1432    toss(env);    toss(env);
1433    if(env->err) return;    if(env->err) return;
# Line 1180  extern void ifelse(environment *env) { Line 1442  extern void ifelse(environment *env) {
1442    eval(env);    eval(env);
1443  }  }
1444    
1445  /* "while" */  extern void sx_656c7365(environment *env)
1446  extern void sx_7768696c65(environment *env) {  {
1447      if(env->head->type==empty || CDR(env->head)->type==empty
1448         || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1449         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1450        printerr("Too Few Arguments");
1451        env->err= 1;
1452        return;
1453      }
1454    
1455      if(CAR(CDR(env->head))->type!=symb
1456         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1457         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1458         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1459        printerr("Bad Argument Type");
1460        env->err= 2;
1461        return;
1462      }
1463    
1464      swap(env); toss(env); rot(env); toss(env);
1465      ifelse(env);
1466    }
1467    
1468    extern void then(environment *env)
1469    {
1470      if(env->head->type==empty || CDR(env->head)->type==empty
1471         || CDR(CDR(env->head))->type==empty) {
1472        printerr("Too Few Arguments");
1473        env->err= 1;
1474        return;
1475      }
1476    
1477      if(CAR(CDR(env->head))->type!=symb
1478         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1479        printerr("Bad Argument Type");
1480        env->err= 2;
1481        return;
1482      }
1483    
1484      swap(env); toss(env);
1485      sx_6966(env);
1486    }
1487    
1488    /* "while" */
1489    extern void sx_7768696c65(environment *env)
1490    {
1491    int truth;    int truth;
1492    value *loop, *test;    value *loop, *test;
1493    
1494    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1495      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1496      env->err=1;      env->err= 1;
1497      return;      return;
1498    }    }
1499    
1500    loop= env->head->item;    loop= CAR(env->head);
1501    protect(env, loop);    protect(loop);
1502    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1503    
1504    test= env->head->item;    test= CAR(env->head);
1505    protect(env, test);    protect(test);
1506    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1507    
1508    do {    do {
1509      push_val(env, test);      push_val(env, test);
1510      eval(env);      eval(env);
1511            
1512      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1513        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1514        env->err= 2;        env->err= 2;
1515        return;        return;
1516      }      }
1517            
1518      truth= env->head->item->content.val;      truth= CAR(env->head)->content.i;
1519      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1520            
1521      if(truth) {      if(truth) {
# Line 1222  extern void sx_7768696c65(environment *e Line 1527  extern void sx_7768696c65(environment *e
1527        
1528    } while(truth);    } while(truth);
1529    
1530    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1531  }  }
1532    
1533    
1534  /* "for"; for-loop */  /* "for"; for-loop */
1535  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1536    {
1537    value *loop;    value *loop;
1538    int foo1, foo2;    int foo1, foo2;
1539    
1540    if(env->head==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1541       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1542      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1543      env->err= 1;      env->err= 1;
1544      return;      return;
1545    }    }
1546    
1547    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1548       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1549      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1550      env->err= 2;      env->err= 2;
1551      return;      return;
1552    }    }
1553    
1554    loop= env->head->item;    loop= CAR(env->head);
1555    protect(env, loop);    protect(loop);
1556    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1557    
1558    foo2= env->head->item->content.val;    foo2= CAR(env->head)->content.i;
1559    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1560    
1561    foo1= env->head->item->content.val;    foo1= CAR(env->head)->content.i;
1562    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1563    
1564    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1270  extern void sx_666f72(environment *env) Line 1576  extern void sx_666f72(environment *env)
1576        foo1--;        foo1--;
1577      }      }
1578    }    }
1579    unprotect(env);    unprotect(loop);
1580  }  }
1581    
1582  /* Variant of for-loop */  /* Variant of for-loop */
1583  extern void foreach(environment *env) {  extern void foreach(environment *env)
1584      {  
1585    value *loop, *foo;    value *loop, *foo;
1586    stackitem *iterator;    value *iterator;
1587        
1588    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1589      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1590      env->err= 1;      env->err= 1;
1591      return;      return;
1592    }    }
1593    
1594    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1595      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1596      env->err= 2;      env->err= 2;
1597      return;      return;
1598    }    }
1599    
1600    loop= env->head->item;    loop= CAR(env->head);
1601    protect(env, loop);    protect(loop);
1602    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1603    
1604    foo= env->head->item;    foo= CAR(env->head);
1605    protect(env, foo);    protect(foo);
1606    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1607    
1608    iterator= foo->content.ptr;    iterator= foo;
1609    
1610    while(iterator!=NULL) {    while(iterator!=NULL) {
1611      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1612      push_val(env, loop);      push_val(env, loop);
1613      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1614      iterator= iterator->next;      if (iterator->type == tcons){
1615          iterator= CDR(iterator);
1616        } else {
1617          printerr("Bad Argument Type"); /* Improper list */
1618          env->err= 2;
1619          break;
1620        }
1621    }    }
1622    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1623  }  }
1624    
1625  /* "to" */  /* "to" */
1626  extern void to(environment *env) {  extern void to(environment *env)
1627    int i, start, ending;  {
1628    stackitem *temp_head;    int ending, start, i;
1629    value *temp_val;    value *iterator, *temp;
1630      
1631    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1632      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1633      env->err=1;      env->err= 1;
1634      return;      return;
1635    }    }
1636    
1637    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1638       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1639      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1640      env->err=2;      env->err= 2;
1641      return;      return;
1642    }    }
1643    
1644    ending= env->head->item->content.val;    ending= CAR(env->head)->content.i;
1645    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1646    start= env->head->item->content.val;    start= CAR(env->head)->content.i;
1647    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1648    
1649    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1650    
1651    if(ending>=start) {    if(ending>=start) {
1652      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1345  extern void to(environment *env) { Line 1656  extern void to(environment *env) {
1656        push_int(env, i);        push_int(env, i);
1657    }    }
1658    
1659    temp_val= new_val(env);    iterator= env->head;
1660    temp_val->content.ptr= env->head;  
1661    temp_val->type= list;    if(iterator->type==empty
1662    env->head= temp_head;       || (CAR(iterator)->type==symb
1663    push_val(env, temp_val);           && CAR(iterator)->content.sym->id[0]=='[')) {
1664        temp= NULL;
1665        toss(env);
1666      } else {
1667        /* Search for first delimiter */
1668        while(CDR(iterator)!=NULL
1669              && (CAR(CDR(iterator))->type!=symb
1670                  || CAR(CDR(iterator))->content.sym->id[0]!='['))
1671          iterator= CDR(iterator);
1672        
1673        /* Extract list */
1674        temp= env->head;
1675        env->head= CDR(iterator);
1676        CDR(iterator)= NULL;
1677    
1678        if(env->head!=NULL)
1679          toss(env);
1680      }
1681    
1682      /* Push list */
1683      push_val(env, temp);
1684  }  }
1685    
1686  /* Read a string */  /* Read a string */
1687  extern void readline(environment *env) {  extern void readline(environment *env)
1688    {
1689    char in_string[101];    char in_string[101];
1690    
1691    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1363  extern void readline(environment *env) { Line 1695  extern void readline(environment *env) {
1695  }  }
1696    
1697  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1698  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1699    {
1700    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1701    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1702    const char intform[]= "%i%n";    const char intform[]= "%i%n";
1703      const char fltform[]= "%f%n";
1704    const char blankform[]= "%*[ \t]%n";    const char blankform[]= "%*[ \t]%n";
1705    const char ebrackform[]= "]%n";    const char ebrackform[]= "]%n";
1706    const char semicform[]= ";%n";    const char semicform[]= ";%n";
1707    const char bbrackform[]= "[%n";    const char bbrackform[]= "[%n";
1708    
1709    int itemp, readlength= -1;    int itemp, readlength= -1;
1710      int count= -1;
1711      float ftemp;
1712    static int depth= 0;    static int depth= 0;
1713    char *match;    char *match;
1714    size_t inlength;    size_t inlength;
# Line 1383  extern void sx_72656164(environment *env Line 1719  extern void sx_72656164(environment *env
1719      }      }
1720      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1721    
1722      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1723        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1724        return;        return;
1725      }      }
1726            
1727      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1728      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1729      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1730      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1731    }    }
1732        
1733    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1734    match= malloc(inlength);    match= malloc(inlength);
1735    
1736    if(sscanf(env->in_string, blankform, &readlength)!=EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1737       && readlength != -1) {       && readlength != -1) {
1738      ;      ;
1739    } else if(sscanf(env->in_string, intform, &itemp, &readlength) != EOF    } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
1740                && readlength != -1) {
1741        if(sscanf(env->in_string, intform, &itemp, &count) != EOF
1742           && count==readlength) {
1743          push_int(env, itemp);
1744        } else {
1745          push_float(env, ftemp);
1746        }
1747      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1748              && readlength != -1) {              && readlength != -1) {
1749      push_int(env, itemp);      push_cstring(env, "");
1750    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1751              && readlength != -1) {              && readlength != -1) {
1752      push_cstring(env, match);      push_cstring(env, match);
# Line 1424  extern void sx_72656164(environment *env Line 1768  extern void sx_72656164(environment *env
1768      free(env->free_string);      free(env->free_string);
1769      env->in_string = env->free_string = NULL;      env->in_string = env->free_string = NULL;
1770    }    }
1771    if ( env->in_string != NULL) {    if (env->in_string != NULL) {
1772      env->in_string += readlength;      env->in_string += readlength;
1773    }    }
1774    
# Line 1434  extern void sx_72656164(environment *env Line 1778  extern void sx_72656164(environment *env
1778      return sx_72656164(env);      return sx_72656164(env);
1779  }  }
1780    
1781  extern void beep(environment *env) {  #ifdef __linux__
1782    extern void beep(environment *env)
1783    {
1784    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1785    
1786    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1787      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1788      env->err=1;      env->err= 1;
1789      return;      return;
1790    }    }
1791    
1792    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1793       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1794      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1795      env->err=2;      env->err= 2;
1796      return;      return;
1797    }    }
1798    
1799    dur=env->head->item->content.val;    dur= CAR(env->head)->content.i;
1800    toss(env);    toss(env);
1801    freq=env->head->item->content.val;    freq= CAR(env->head)->content.i;
1802    toss(env);    toss(env);
1803    
1804    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1805                                     length */                                     length */
1806    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1807                                     timer ticks */                                     timer ticks */
1808    
1809  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1810    
1811    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1812    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1813    case 0:    case 0:
1814      usleep(dur);      usleep(dur);
1815      return;      return;
1816    case -1:    case -1:
1817      perror("beep");      perror("beep");
1818      env->err=5;      env->err= 5;
1819      return;      return;
1820    default:    default:
1821      abort();      abort();
1822    }    }
1823  };  }
1824    #endif /* __linux__ */
1825    
1826  /* "wait" */  /* "wait" */
1827  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1828    {
1829    int dur;    int dur;
1830    
1831    if((env->head)==NULL) {    if(env->head->type==empty) {
1832      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1833      env->err=1;      env->err= 1;
1834      return;      return;
1835    }    }
1836    
1837    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1838      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1839      env->err=2;      env->err= 2;
1840      return;      return;
1841    }    }
1842    
1843    dur=env->head->item->content.val;    dur= CAR(env->head)->content.i;
1844    toss(env);    toss(env);
1845    
1846    usleep(dur);    usleep(dur);
1847  };  }
1848    
1849  extern void copying(environment *env){  extern void copying(environment *env)
1850    printf("GNU GENERAL PUBLIC LICENSE\n\  {
1851      printf("                  GNU GENERAL PUBLIC LICENSE\n\
1852                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1853  \n\  \n\
1854   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 1759  of preserving the free status of all der Line 2106  of preserving the free status of all der
2106  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
2107  }  }
2108    
2109  extern void warranty(environment *env){  extern void warranty(environment *env)
2110    {
2111    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
2112  \n\  \n\
2113    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 1782  YOU OR THIRD PARTIES OR A FAILURE OF THE Line 2130  YOU OR THIRD PARTIES OR A FAILURE OF THE
2130  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE\n\  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE\n\
2131  POSSIBILITY OF SUCH DAMAGES.\n");  POSSIBILITY OF SUCH DAMAGES.\n");
2132  }  }
2133    
2134    /* "*" */
2135    extern void sx_2a(environment *env)
2136    {
2137      int a, b;
2138      float fa, fb;
2139    
2140      if(env->head->type==empty || CDR(env->head)->type==empty) {
2141        printerr("Too Few Arguments");
2142        env->err= 1;
2143        return;
2144      }
2145      
2146      if(CAR(env->head)->type==integer
2147         && CAR(CDR(env->head))->type==integer) {
2148        a= CAR(env->head)->content.i;
2149        toss(env); if(env->err) return;
2150        b= CAR(env->head)->content.i;
2151        toss(env); if(env->err) return;
2152        push_int(env, b*a);
2153    
2154        return;
2155      }
2156    
2157      if(CAR(env->head)->type==tfloat
2158         && CAR(CDR(env->head))->type==tfloat) {
2159        fa= CAR(env->head)->content.f;
2160        toss(env); if(env->err) return;
2161        fb= CAR(env->head)->content.f;
2162        toss(env); if(env->err) return;
2163        push_float(env, fb*fa);
2164        
2165        return;
2166      }
2167    
2168      if(CAR(env->head)->type==tfloat
2169         && CAR(CDR(env->head))->type==integer) {
2170        fa= CAR(env->head)->content.f;
2171        toss(env); if(env->err) return;
2172        b= CAR(env->head)->content.i;
2173        toss(env); if(env->err) return;
2174        push_float(env, b*fa);
2175        
2176        return;
2177      }
2178    
2179      if(CAR(env->head)->type==integer
2180         && CAR(CDR(env->head))->type==tfloat) {
2181        a= CAR(env->head)->content.i;
2182        toss(env); if(env->err) return;
2183        fb= CAR(env->head)->content.f;
2184        toss(env); if(env->err) return;
2185        push_float(env, fb*a);
2186    
2187        return;
2188      }
2189    
2190      printerr("Bad Argument Type");
2191      env->err= 2;
2192    }
2193    
2194    /* "/" */
2195    extern void sx_2f(environment *env)
2196    {
2197      int a, b;
2198      float fa, fb;
2199    
2200      if(env->head->type==empty || CDR(env->head)->type==empty) {
2201        printerr("Too Few Arguments");
2202        env->err= 1;
2203        return;
2204      }
2205      
2206      if(CAR(env->head)->type==integer
2207         && CAR(CDR(env->head))->type==integer) {
2208        a= CAR(env->head)->content.i;
2209        toss(env); if(env->err) return;
2210        b= CAR(env->head)->content.i;
2211        toss(env); if(env->err) return;
2212        push_float(env, b/a);
2213    
2214        return;
2215      }
2216    
2217      if(CAR(env->head)->type==tfloat
2218         && CAR(CDR(env->head))->type==tfloat) {
2219        fa= CAR(env->head)->content.f;
2220        toss(env); if(env->err) return;
2221        fb= CAR(env->head)->content.f;
2222        toss(env); if(env->err) return;
2223        push_float(env, fb/fa);
2224        
2225        return;
2226      }
2227    
2228      if(CAR(env->head)->type==tfloat
2229         && CAR(CDR(env->head))->type==integer) {
2230        fa= CAR(env->head)->content.f;
2231        toss(env); if(env->err) return;
2232        b= CAR(env->head)->content.i;
2233        toss(env); if(env->err) return;
2234        push_float(env, b/fa);
2235        
2236        return;
2237      }
2238    
2239      if(CAR(env->head)->type==integer
2240         && CAR(CDR(env->head))->type==tfloat) {
2241        a= CAR(env->head)->content.i;
2242        toss(env); if(env->err) return;
2243        fb= CAR(env->head)->content.f;
2244        toss(env); if(env->err) return;
2245        push_float(env, fb/a);
2246    
2247        return;
2248      }
2249    
2250      printerr("Bad Argument Type");
2251      env->err= 2;
2252    }
2253    
2254    /* "mod" */
2255    extern void mod(environment *env)
2256    {
2257      int a, b;
2258    
2259      if(env->head->type==empty || CDR(env->head)->type==empty) {
2260        printerr("Too Few Arguments");
2261        env->err= 1;
2262        return;
2263      }
2264      
2265      if(CAR(env->head)->type==integer
2266         && CAR(CDR(env->head))->type==integer) {
2267        a= CAR(env->head)->content.i;
2268        toss(env); if(env->err) return;
2269        b= CAR(env->head)->content.i;
2270        toss(env); if(env->err) return;
2271        push_int(env, b%a);
2272    
2273        return;
2274      }
2275    
2276      printerr("Bad Argument Type");
2277      env->err= 2;
2278    }
2279    
2280    /* "div" */
2281    extern void sx_646976(environment *env)
2282    {
2283      int a, b;
2284      
2285      if(env->head->type==empty || CDR(env->head)->type==empty) {
2286        printerr("Too Few Arguments");
2287        env->err= 1;
2288        return;
2289      }
2290    
2291      if(CAR(env->head)->type==integer
2292         && CAR(CDR(env->head))->type==integer) {
2293        a= CAR(env->head)->content.i;
2294        toss(env); if(env->err) return;
2295        b= CAR(env->head)->content.i;
2296        toss(env); if(env->err) return;
2297        push_int(env, (int)b/a);
2298    
2299        return;
2300      }
2301    
2302      printerr("Bad Argument Type");
2303      env->err= 2;
2304    }
2305    
2306    extern void setcar(environment *env)
2307    {
2308      if(env->head->type==empty || CDR(env->head)->type==empty) {
2309        printerr("Too Few Arguments");
2310        env->err= 1;
2311        return;
2312      }
2313    
2314      if(CDR(env->head)->type!=tcons) {
2315        printerr("Bad Argument Type");
2316        env->err= 2;
2317        return;
2318      }
2319    
2320      CAR(CAR(CDR(env->head)))=CAR(env->head);
2321      toss(env);
2322    }
2323    
2324    extern void setcdr(environment *env)
2325    {
2326      if(env->head->type==empty || CDR(env->head)->type==empty) {
2327        printerr("Too Few Arguments");
2328        env->err= 1;
2329        return;
2330      }
2331    
2332      if(CDR(env->head)->type!=tcons) {
2333        printerr("Bad Argument Type");
2334        env->err= 2;
2335        return;
2336      }
2337    
2338      CDR(CAR(CDR(env->head)))=CAR(env->head);
2339      toss(env);
2340    }
2341    
2342    extern void car(environment *env)
2343    {
2344      if(env->head->type==empty) {
2345        printerr("Too Few Arguments");
2346        env->err= 1;
2347        return;
2348      }
2349    
2350      if(CAR(env->head)->type!=tcons) {
2351        printerr("Bad Argument Type");
2352        env->err= 2;
2353        return;
2354      }
2355    
2356      CAR(env->head)=CAR(CAR(env->head));
2357    }
2358    
2359    extern void cdr(environment *env)
2360    {
2361      if(env->head->type==empty) {
2362        printerr("Too Few Arguments");
2363        env->err= 1;
2364        return;
2365      }
2366    
2367      if(CAR(env->head)->type!=tcons) {
2368        printerr("Bad Argument Type");
2369        env->err= 2;
2370        return;
2371      }
2372    
2373      CAR(env->head)=CDR(CAR(env->head));
2374    }
2375    
2376    extern void cons(environment *env)
2377    {
2378      value *val;
2379    
2380      if(env->head->type==empty || CDR(env->head)->type==empty) {
2381        printerr("Too Few Arguments");
2382        env->err= 1;
2383        return;
2384      }
2385    
2386      val=new_val(env);
2387      val->content.c= malloc(sizeof(pair));
2388      assert(val->content.c!=NULL);
2389    
2390      env->gc_count += sizeof(pair);
2391      val->type=tcons;
2392    
2393      CAR(val)= CAR(CDR(env->head));
2394      CDR(val)= CAR(env->head);
2395    
2396      push_val(env, val);
2397    
2398      swap(env); if(env->err) return;
2399      toss(env); if(env->err) return;
2400      swap(env); if(env->err) return;
2401      toss(env); if(env->err) return;
2402    }
Legend:
Removed from v.1.91  
changed lines
  Added in v.1.116
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26