/[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.112 by teddy, Sat Mar 16 20:09:51 2002 UTC
# Line 20  Line 20 
20               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
21  */  */
22    
23    #define CAR(X) X->content.c->car
24    #define CDR(X) X->content.c->cdr
25    
26  /* printf, sscanf, fgets, fprintf, fopen, perror */  /* printf, sscanf, fgets, fprintf, fopen, perror */
27  #include <stdio.h>  #include <stdio.h>
28  /* exit, EXIT_SUCCESS, malloc, free */  /* exit, EXIT_SUCCESS, malloc, free */
# Line 34  Line 37 
37  #include <unistd.h>  #include <unistd.h>
38  /* EX_NOINPUT, EX_USAGE */  /* EX_NOINPUT, EX_USAGE */
39  #include <sysexits.h>  #include <sysexits.h>
40    /* assert */
41    #include <assert.h>
42    
43    #ifdef __linux__
44  /* mtrace, muntrace */  /* mtrace, muntrace */
45  #include <mcheck.h>  #include <mcheck.h>
46  /* ioctl */  /* ioctl */
47  #include <sys/ioctl.h>  #include <sys/ioctl.h>
48  /* KDMKTONE */  /* KDMKTONE */
49  #include <linux/kd.h>  #include <linux/kd.h>
50    #endif /* __linux__ */
51    
52  #include "stack.h"  #include "stack.h"
53    
# Line 48  void init_env(environment *env) Line 56  void init_env(environment *env)
56  {  {
57    int i;    int i;
58    
59    env->gc_limit= 20;    env->gc_limit= 400000;
60    env->gc_count= 0;    env->gc_count= 0;
61    env->gc_ref= NULL;    env->gc_ref= NULL;
   env->gc_protect= NULL;  
62    
63    env->head= NULL;    env->head= new_val(env);
64      env->head->type= empty;
65    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
66      env->symbols[i]= NULL;      env->symbols[i]= NULL;
67    env->err= 0;    env->err= 0;
# Line 63  void init_env(environment *env) Line 71  void init_env(environment *env)
71    env->interactive= 1;    env->interactive= 1;
72  }  }
73    
74  void printerr(const char* in_string) {  void printerr(const char* in_string)
75    {
76    fprintf(stderr, "Err: %s\n", in_string);    fprintf(stderr, "Err: %s\n", in_string);
77  }  }
78    
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 */  
   
   gc_init(env);  
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 113  symbol **hash(hashtbl in_hashtbl, const Line 117  symbol **hash(hashtbl in_hashtbl, const
117    }    }
118  }  }
119    
120  value* new_val(environment *env) {  /* Create new value */
121    value* new_val(environment *env)
122    {
123    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
124    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
125    
126    nval->content.ptr= NULL;    nval->content.ptr= NULL;
127    protect(env, nval);    nval->type= integer;
   
   gc_init(env);  
128    
129    nitem->item= nval;    nitem->item= nval;
130    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
131    
132    env->gc_ref= nitem;    env->gc_ref= nitem;
133    
134    env->gc_count++;    env->gc_count += sizeof(value);
135    unprotect(env);    nval->gc.flag.mark= 0;
136      nval->gc.flag.protect= 0;
137    
138    return nval;    return nval;
139  }  }
140    
141  void gc_mark(value *val) {  /* Mark values recursively.
142    stackitem *iterator;     Marked values are not collected by the GC. */
143    inline void gc_mark(value *val)
144    if(val==NULL || val->gc_garb==0)  {
145      if(val==NULL || val->gc.flag.mark)
146      return;      return;
147    
148    val->gc_garb= 0;    val->gc.flag.mark= 1;
   
   if(val->type==list) {  
     iterator= val->content.ptr;  
149    
150      while(iterator!=NULL) {    if(val->type==tcons) {
151        gc_mark(iterator->item);      gc_mark(CAR(val));
152        iterator= iterator->next;      gc_mark(CDR(val));
     }  
153    }    }
154  }  }
155    
156  extern void gc_init(environment *env) {  inline void gc_maybe(environment *env)
157    stackitem *new_head= NULL, *titem, *iterator= env->gc_ref;  {
158      if(env->gc_count < env->gc_limit)
159        return;
160      else
161        return gc_init(env);
162    }
163    
164    /* Start GC */
165    extern void gc_init(environment *env)
166    {
167      stackitem *new_head= NULL, *titem;
168      cons *iterator;
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        case string:        if(env->gc_ref->item->type==string) /* Remove content */
199          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
200          break;  
201        case integer:        free(env->gc_ref->item);  /* Remove from gc_ref */
         break;  
       case list:  
         while(env->gc_ref->item->content.ptr!=NULL) {  
           titem= env->gc_ref->item->content.ptr;  
           env->gc_ref->item->content.ptr= titem->next;  
           free(titem);  
         }  
         break;  
       default:  
         break;  
       }  
       free(env->gc_ref->item);  
       titem= env->gc_ref->next;  
       free(env->gc_ref);  
       env->gc_ref= titem;  
     } else {  
202        titem= env->gc_ref->next;        titem= env->gc_ref->next;
203        env->gc_ref->next= new_head;        free(env->gc_ref);        /* Remove value */
       new_head= env->gc_ref;  
204        env->gc_ref= titem;        env->gc_ref= titem;
205        env->gc_count++;        continue;
206      }      }
207    #ifdef DEBUG
208        printf("Kept value (%p)", env->gc_ref->item);
209        if(env->gc_ref->item->gc.flag.mark)
210          printf(" (marked)");
211        if(env->gc_ref->item->gc.flag.protect)
212          printf(" (protected)");
213        switch(env->gc_ref->item->type){
214        case integer:
215          printf(" integer: %d", env->gc_ref->item->content.i);
216          break;
217        case func:
218          printf(" func: %p", env->gc_ref->item->content.ptr);
219          break;
220        case symb:
221          printf(" symb: %s", env->gc_ref->item->content.sym->id);
222          break;
223        case tcons:
224          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
225                 env->gc_ref->item->content.c->cdr);
226          break;
227        default:
228          printf(" <unknown %d>", (env->gc_ref->item->type));
229        }
230        printf("\n");
231    #endif /* DEBUG */
232    
233        /* Keep values */    
234        env->gc_count += sizeof(value);
235        if(env->gc_ref->item->type==string)
236          env->gc_count += strlen(env->gc_ref->item->content.ptr);
237        
238        titem= env->gc_ref->next;
239        env->gc_ref->next= new_head;
240        new_head= env->gc_ref;
241        new_head->item->gc.flag.mark= 0;
242        env->gc_ref= titem;
243    }    }
244    
245    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
246        env->gc_limit= env->gc_count*2;
247    
248    env->gc_ref= new_head;    env->gc_ref= new_head;
249    
250      if(env->interactive)
251        printf("done (%d bytes still allocated)\n", env->gc_count);
252    
253  }  }
254    
255  void protect(environment *env, value *val)  /* Protect values from GC */
256    void protect(value *val)
257  {  {
258    stackitem *new_item= malloc(sizeof(stackitem));    if(val==NULL || val->gc.flag.protect)
259    new_item->item= val;      return;
260    new_item->next= env->gc_protect;  
261    env->gc_protect= new_item;    val->gc.flag.protect= 1;
262    
263      if(val->type==tcons) {
264        protect(CAR(val));
265        protect(CDR(val));
266      }
267  }  }
268    
269  void unprotect(environment *env)  /* Unprotect values from GC */
270    void unprotect(value *val)
271  {  {
272    stackitem *temp= env->gc_protect;    if(val==NULL || !(val->gc.flag.protect))
273    env->gc_protect= env->gc_protect->next;      return;
274    free(temp);  
275      val->gc.flag.protect= 0;
276    
277      if(val->type==tcons) {
278        unprotect(CAR(val));
279        unprotect(CDR(val));
280      }
281  }  }
282    
283  /* Push a value onto the stack */  /* Push a value onto the stack */
284  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
285  {  {
286    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
287    new_item->item= val;  
288    new_item->next= env->head;    new_value->content.c= malloc(sizeof(cons));
289    env->head= new_item;    assert(new_value->content.c!=NULL);
290      new_value->type= tcons;
291      CAR(new_value)= val;
292      CDR(new_value)= env->head;
293      env->head= new_value;
294  }  }
295    
296  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
297  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
298  {  {
299    value *new_value= new_val(env);    value *new_value= new_val(env);
300        
301    new_value->content.val= in_val;    new_value->content.i= in_val;
302    new_value->type= integer;    new_value->type= integer;
303    
304    push_val(env, new_value);    push_val(env, new_value);
305  }  }
306    
307    /* Push a floating point number onto the stack */
308    void push_float(environment *env, float in_val)
309    {
310      value *new_value= new_val(env);
311    
312      new_value->content.f= in_val;
313      new_value->type= tfloat;
314    
315      push_val(env, new_value);
316    }
317    
318  /* Copy a string onto the stack. */  /* Copy a string onto the stack. */
319  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
320  {  {
321    value *new_value= new_val(env);    value *new_value= new_val(env);
322      int length= strlen(in_string)+1;
323    
324    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
325      env->gc_count += length;
326    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
327    new_value->type= string;    new_value->type= string;
328    
# Line 271  void push_cstring(environment *env, cons Line 330  void push_cstring(environment *env, cons
330  }  }
331    
332  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
333  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
334    {
335    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
336    char *new_string, *current;    char *new_string, *current;
337    
# Line 289  char *mangle_str(const char *old_string) Line 349  char *mangle_str(const char *old_string)
349    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
350  }  }
351    
352  extern void mangle(environment *env){  extern void mangle(environment *env)
353    {
354    char *new_string;    char *new_string;
355    
356    if((env->head)==NULL) {    if(env->head->type==empty) {
357      printerr("Too Few Arguments");      printerr("Too Few Arguments");
358      env->err= 1;      env->err= 1;
359      return;      return;
360    }    }
361    
362    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
363      printerr("Bad Argument Type");      printerr("Bad Argument Type");
364      env->err= 2;      env->err= 2;
365      return;      return;
366    }    }
367    
368    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
369        mangle_str((const char *)(CAR(env->head)->content.ptr));
370    
371    toss(env);    toss(env);
372    if(env->err) return;    if(env->err) return;
# Line 328  void push_sym(environment *env, const ch Line 390  void push_sym(environment *env, const ch
390    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
391    
392    new_value= new_val(env);    new_value= new_val(env);
393      protect(new_value);
394      new_fvalue= new_val(env);
395      protect(new_fvalue);
396    
397    /* The new value is a symbol */    /* The new value is a symbol */
398    new_value->type= symb;    new_value->type= symb;
# Line 355  void push_sym(environment *env, const ch Line 420  void push_sym(environment *env, const ch
420    
421      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
422      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
423      free(mangled);  
424      dlerr= dlerror();      dlerr= dlerror();
425      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
426        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
427        dlerr= dlerror();        dlerr= dlerror();
428      }      }
429    
430      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 */  
431        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
432        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
433        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
434                                           function value */                                           function value */
435      }      }
436    
437        free(mangled);
438    }    }
439    
440    push_val(env, new_value);    push_val(env, new_value);
441      unprotect(new_value); unprotect(new_fvalue);
442  }  }
443    
444  /* Print newline. */  /* Print newline. */
# Line 379  extern void nl() Line 448  extern void nl()
448  }  }
449    
450  /* Gets the type of a value */  /* Gets the type of a value */
451  extern void type(environment *env){  extern void type(environment *env)
452    int typenum;  {
453      if(env->head->type==empty) {
   if((env->head)==NULL) {  
454      printerr("Too Few Arguments");      printerr("Too Few Arguments");
455      env->err=1;      env->err= 1;
456      return;      return;
457    }    }
458    typenum=env->head->item->type;  
459    toss(env);    switch(CAR(env->head)->type){
460    switch(typenum){    case empty:
461        push_sym(env, "empty");
462        break;
463    case integer:    case integer:
464      push_sym(env, "integer");      push_sym(env, "integer");
465      break;      break;
466      case tfloat:
467        push_sym(env, "float");
468        break;
469    case string:    case string:
470      push_sym(env, "string");      push_sym(env, "string");
471      break;      break;
# Line 402  extern void type(environment *env){ Line 475  extern void type(environment *env){
475    case func:    case func:
476      push_sym(env, "function");      push_sym(env, "function");
477      break;      break;
478    case list:    case tcons:
479      push_sym(env, "list");      push_sym(env, "list");
480      break;      break;
481    }    }
482      swap(env);
483      if (env->err) return;
484      toss(env);
485  }      }    
486    
487  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
488  void print_h(stackitem *stack_head, int noquote)  void print_h(value *stack_head, int noquote)
489  {  {
490    switch(stack_head->item->type) {    switch(CAR(stack_head)->type) {
491      case empty:
492        printf("[]");
493        break;
494    case integer:    case integer:
495      printf("%d", stack_head->item->content.val);      printf("%d", CAR(stack_head)->content.i);
496        break;
497      case tfloat:
498        printf("%f", CAR(stack_head)->content.f);
499      break;      break;
500    case string:    case string:
501      if(noquote)      if(noquote)
502        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)(CAR(stack_head)->content.ptr));
503      else      else
504        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)(CAR(stack_head)->content.ptr));
505      break;      break;
506    case symb:    case symb:
507      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
508      break;      break;
509    case func:    case func:
510      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
511      break;      break;
512    case list:    case tcons:
513      /* A list is just a stack, so make stack_head point to it */      /* A list is just a stack, so make stack_head point to it */
514      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head= CAR(stack_head);
515      printf("[ ");      printf("[ ");
516      while(stack_head != NULL) {      while(stack_head->type != empty) {
517        print_h(stack_head, noquote);        print_h(stack_head, noquote);
518        printf(" ");        switch(CDR(stack_head)->type){
519        stack_head=stack_head->next;        case empty:
520            break;
521          case tcons:
522            printf(" ");
523            break;
524          default:
525            printf(" . ");          /* Improper list */
526          }
527          stack_head= CDR(stack_head);
528      }      }
529      printf("]");      printf(" ]");
530      break;      break;
531    }    }
532  }  }
533    
534  extern void print_(environment *env) {  extern void print_(environment *env)
535    if(env->head==NULL) {  {
536      if(env->head->type==empty) {
537      printerr("Too Few Arguments");      printerr("Too Few Arguments");
538      env->err=1;      env->err= 1;
539      return;      return;
540    }    }
541    print_h(env->head, 0);    print_h(env->head, 0);
# Line 459  extern void print(environment *env) Line 550  extern void print(environment *env)
550    toss(env);    toss(env);
551  }  }
552    
553  extern void princ_(environment *env) {  extern void princ_(environment *env)
554    if(env->head==NULL) {  {
555      if(env->head->type==empty) {
556      printerr("Too Few Arguments");      printerr("Too Few Arguments");
557      env->err=1;      env->err= 1;
558      return;      return;
559    }    }
560    print_h(env->head, 1);    print_h(env->head, 1);
# Line 477  extern void princ(environment *env) Line 569  extern void princ(environment *env)
569  }  }
570    
571  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
572  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
573  {  {
574    if(stack_head->next != NULL)    if(CDR(stack_head)->type != empty)
575      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
576    printf("%ld: ", counter);    printf("%ld: ", counter);
577    print_h(stack_head, 0);    print_h(stack_head, 0);
578    nl();    nl();
# Line 489  void print_st(stackitem *stack_head, lon Line 581  void print_st(stackitem *stack_head, lon
581  /* Prints the stack. */  /* Prints the stack. */
582  extern void printstack(environment *env)  extern void printstack(environment *env)
583  {  {
584    if(env->head == NULL) {    if(env->head->type == empty) {
585      printf("Stack Empty\n");      printf("Stack Empty\n");
586      return;      return;
587    }    }
588    
589    print_st(env->head, 1);    print_st(env->head, 1);
590  }  }
591    
592  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
593  extern void swap(environment *env)  extern void swap(environment *env)
594  {  {
595    stackitem *temp= env->head;    value *temp= env->head;
596        
597    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
598      printerr("Too Few Arguments");      printerr("Too Few Arguments");
599      env->err=1;      env->err=1;
600      return;      return;
601    }    }
602    
603    env->head= env->head->next;    env->head= CDR(env->head);
604    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
605    env->head->next= temp;    CDR(env->head)= temp;
606  }  }
607    
608  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
609  extern void rot(environment *env)  extern void rot(environment *env)
610  {  {
611    stackitem *temp= env->head;    value *temp= env->head;
612        
613    if(env->head==NULL || env->head->next==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
614        || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type == empty) {
615      printerr("Too Few Arguments");      printerr("Too Few Arguments");
616      env->err=1;      env->err= 1;
617      return;      return;
618    }    }
619      
620    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
621    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
622    env->head->next= temp;    CDR(env->head)= temp;
623  }  }
624    
625  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 534  extern void rcl(environment *env) Line 627  extern void rcl(environment *env)
627  {  {
628    value *val;    value *val;
629    
630    if(env->head == NULL) {    if(env->head->type==empty) {
631      printerr("Too Few Arguments");      printerr("Too Few Arguments");
632      env->err=1;      env->err= 1;
633      return;      return;
634    }    }
635    
636    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
637      printerr("Bad Argument Type");      printerr("Bad Argument Type");
638      env->err=2;      env->err= 2;
639      return;      return;
640    }    }
641    
642    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
643    if(val == NULL){    if(val == NULL){
644      printerr("Unbound Variable");      printerr("Unbound Variable");
645      env->err=3;      env->err= 3;
646      return;      return;
647    }    }
648    protect(env, val);    push_val(env, val);           /* Return the symbol's bound value */
649    toss(env);            /* toss the symbol */    swap(env);
650      if(env->err) return;
651      toss(env);                    /* toss the symbol */
652    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(env);  
653  }  }
654    
655  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
# Line 566  extern void eval(environment *env) Line 659  extern void eval(environment *env)
659  {  {
660    funcp in_func;    funcp in_func;
661    value* temp_val;    value* temp_val;
662    stackitem* iterator;    value* iterator;
663    
664   eval_start:   eval_start:
665    
666    if(env->head==NULL) {    gc_maybe(env);
667    
668      if(env->head->type==empty) {
669      printerr("Too Few Arguments");      printerr("Too Few Arguments");
670      env->err=1;      env->err= 1;
671      return;      return;
672    }    }
673    
674    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
675      /* if it's a symbol */      /* if it's a symbol */
676    case symb:    case symb:
677      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
678      if(env->err) return;      if(env->err) return;
679      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
680        goto eval_start;        goto eval_start;
681      }      }
682      return;      return;
683    
684      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
685    case func:    case func:
686      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
687      toss(env);      toss(env);
688      if(env->err) return;      if(env->err) return;
689      return in_func(env);      return in_func(env);
690    
691      /* If it's a list */      /* If it's a list */
692    case list:    case tcons:
693      temp_val= env->head->item;      temp_val= CAR(env->head);
694      protect(env, temp_val);      protect(temp_val);
695      toss(env);  
696      if(env->err) return;      toss(env); if(env->err) return;
697      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
     unprotect(env);  
698            
699      while(iterator!=NULL) {      while(iterator->type != empty) {
700        push_val(env, iterator->item);        push_val(env, CAR(iterator));
701                
702        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
703          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
704          toss(env);          toss(env);
705          if(env->err) return;          if(env->err) return;
706                    
707          if(iterator->next == NULL){          if(CDR(iterator)->type == empty){
708            goto eval_start;            goto eval_start;
709          }          }
710          eval(env);          eval(env);
711          if(env->err) return;          if(env->err) return;
712        }        }
713        iterator= iterator->next;        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
714            iterator= CDR(iterator);
715          else {
716            printerr("Bad Argument Type"); /* Improper list */
717            env->err= 2;
718            return;
719          }
720      }      }
721        unprotect(temp_val);
722      return;      return;
723    
724    default:    default:
# Line 626  extern void eval(environment *env) Line 727  extern void eval(environment *env)
727  }  }
728    
729  /* Reverse (flip) a list */  /* Reverse (flip) a list */
730  extern void rev(environment *env){  extern void rev(environment *env)
731    stackitem *old_head, *new_head, *item;  {
732      value *old_head, *new_head, *item;
733    
734    if((env->head)==NULL) {    if(env->head->type==empty) {
735      printerr("Too Few Arguments");      printerr("Too Few Arguments");
736      env->err= 1;      env->err= 1;
737      return;      return;
738    }    }
739    
740    if(env->head->item->type!=list) {    if(CAR(env->head)->type==empty)
741        return;                     /* Don't reverse an empty list */
742    
743      if(CAR(env->head)->type!=tcons) {
744      printerr("Bad Argument Type");      printerr("Bad Argument Type");
745      env->err= 2;      env->err= 2;
746      return;      return;
747    }    }
748    
749    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
750    new_head= NULL;    new_head= new_val(env);
751    while(old_head != NULL){    new_head->type= empty;
752      while(old_head->type != empty) {
753      item= old_head;      item= old_head;
754      old_head= old_head->next;      old_head= CDR(old_head);
755      item->next= new_head;      CDR(item)= new_head;
756      new_head= item;      new_head= item;
757    }    }
758    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
759  }  }
760    
761  /* Make a list. */  /* Make a list. */
762  extern void pack(environment *env)  extern void pack(environment *env)
763  {  {
764    stackitem *iterator, *temp;    value *iterator, *temp, *ending;
   value *pack;  
765    
766    iterator= env->head;    ending=new_val(env);
767      ending->type=empty;
768    
769    if(iterator==NULL    iterator= env->head;
770       || (iterator->item->type==symb    if(iterator->type == empty
771       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       || (CAR(iterator)->type==symb
772      temp= NULL;       && CAR(iterator)->content.sym->id[0]=='[')) {
773        temp= ending;
774      toss(env);      toss(env);
775    } else {    } else {
776      /* Search for first delimiter */      /* Search for first delimiter */
777      while(iterator->next!=NULL      while(CDR(iterator)->type != empty
778            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
779            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
780        iterator= iterator->next;        iterator= CDR(iterator);
781            
782      /* Extract list */      /* Extract list */
783      temp= env->head;      temp= env->head;
784      env->head= iterator->next;      env->head= CDR(iterator);
785      iterator->next= NULL;      CDR(iterator)= ending;
786        
787      if(env->head!=NULL)      if(env->head->type != empty)
788        toss(env);        toss(env);
789    }    }
790    
791    /* Push list */    /* Push list */
   pack= new_val(env);  
   pack->type= list;  
   pack->content.ptr= temp;  
792    
793    push_val(env, pack);    push_val(env, temp);
794    rev(env);    rev(env);
795  }  }
796    
797  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
798  extern void expand(environment *env)  extern void expand(environment *env)
799  {  {
800    stackitem *temp, *new_head;    value *temp, *new_head;
801    
802    /* Is top element a list? */    /* Is top element a list? */
803    if(env->head==NULL) {    if(env->head->type==empty) {
804      printerr("Too Few Arguments");      printerr("Too Few Arguments");
805      env->err= 1;      env->err= 1;
806      return;      return;
807    }    }
808    if(env->head->item->type!=list) {  
809      if(CAR(env->head)->type!=tcons) {
810      printerr("Bad Argument Type");      printerr("Bad Argument Type");
811      env->err= 2;      env->err= 2;
812      return;      return;
# Line 713  extern void expand(environment *env) Line 818  extern void expand(environment *env)
818      return;      return;
819    
820    /* The first list element is the new stack head */    /* The first list element is the new stack head */
821    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
822    
823    toss(env);    toss(env);
824    
825    /* Find the end of the list */    /* Find the end of the list */
826    while(temp->next!=NULL)    while(CDR(temp)->type != empty) {
827      temp= temp->next;      if (CDR(temp)->type == tcons)
828          temp= CDR(temp);
829        else {
830          printerr("Bad Argument Type"); /* Improper list */
831          env->err= 2;
832          return;
833        }
834      }
835    
836    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
837    temp->next= env->head;    CDR(temp)= env->head;
838    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
839    
840  }  }
# Line 731  extern void expand(environment *env) Line 843  extern void expand(environment *env)
843  extern void eq(environment *env)  extern void eq(environment *env)
844  {  {
845    void *left, *right;    void *left, *right;
   int result;  
846    
847    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
848      printerr("Too Few Arguments");      printerr("Too Few Arguments");
849      env->err= 1;      env->err= 1;
850      return;      return;
851    }    }
852    
853    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
854    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
855    toss(env); toss(env);    toss(env); toss(env);
856    push_int(env, result);  
857      push_int(env, left==right);
858  }  }
859    
860  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 753  extern void not(environment *env) Line 862  extern void not(environment *env)
862  {  {
863    int val;    int val;
864    
865    if((env->head)==NULL) {    if(env->head->type==empty) {
866      printerr("Too Few Arguments");      printerr("Too Few Arguments");
867      env->err= 1;      env->err= 1;
868      return;      return;
869    }    }
870    
871    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
872      printerr("Bad Argument Type");      printerr("Bad Argument Type");
873      env->err= 2;      env->err= 2;
874      return;      return;
875    }    }
876    
877    val= env->head->item->content.val;    val= CAR(env->head)->content.i;
878    toss(env);    toss(env);
879    push_int(env, !val);    push_int(env, !val);
880  }  }
# Line 784  extern void def(environment *env) Line 893  extern void def(environment *env)
893    symbol *sym;    symbol *sym;
894    
895    /* Needs two values on the stack, the top one must be a symbol */    /* Needs two values on the stack, the top one must be a symbol */
896    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
897      printerr("Too Few Arguments");      printerr("Too Few Arguments");
898      env->err= 1;      env->err= 1;
899      return;      return;
900    }    }
901    
902    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
903      printerr("Bad Argument Type");      printerr("Bad Argument Type");
904      env->err= 2;      env->err= 2;
905      return;      return;
906    }    }
907    
908    /* long names are a pain */    /* long names are a pain */
909    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
910    
911    /* Bind the symbol to the value */    /* Bind the symbol to the value */
912    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
913    
914    toss(env); toss(env);    toss(env); toss(env);
915  }  }
# Line 808  extern void def(environment *env) Line 917  extern void def(environment *env)
917  /* Quit stack. */  /* Quit stack. */
918  extern void quit(environment *env)  extern void quit(environment *env)
919  {  {
920    long i;    int i;
921    
922    clear(env);    clear(env);
923    
# Line 821  extern void quit(environment *env) Line 930  extern void quit(environment *env)
930    }    }
931    
932    env->gc_limit= 0;    env->gc_limit= 0;
933    gc_init(env);    gc_maybe(env);
934    
935      words(env);
936    
937    if(env->free_string!=NULL)    if(env->free_string!=NULL)
938      free(env->free_string);      free(env->free_string);
939        
940    #ifdef __linux__
941    muntrace();    muntrace();
942    #endif
943    
944    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
945  }  }
# Line 834  extern void quit(environment *env) Line 947  extern void quit(environment *env)
947  /* Clear stack */  /* Clear stack */
948  extern void clear(environment *env)  extern void clear(environment *env)
949  {  {
950    while(env->head!=NULL)    while(env->head->type != empty)
951      toss(env);      toss(env);
952  }  }
953    
# Line 847  extern void words(environment *env) Line 960  extern void words(environment *env)
960    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
961      temp= env->symbols[i];      temp= env->symbols[i];
962      while(temp!=NULL) {      while(temp!=NULL) {
963    #ifdef DEBUG
964          if (temp->val != NULL && temp->val->gc.flag.protect)
965            printf("(protected) ");
966    #endif /* DEBUG */
967        printf("%s\n", temp->id);        printf("%s\n", temp->id);
968        temp= temp->next;        temp= temp->next;
969      }      }
# Line 854  extern void words(environment *env) Line 971  extern void words(environment *env)
971  }  }
972    
973  /* Internal forget function */  /* Internal forget function */
974  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
975    {
976    symbol *temp;    symbol *temp;
977    
978    temp= *hash_entry;    temp= *hash_entry;
# Line 868  void forget_sym(symbol **hash_entry) { Line 986  void forget_sym(symbol **hash_entry) {
986  extern void forget(environment *env)  extern void forget(environment *env)
987  {  {
988    char* sym_id;    char* sym_id;
   stackitem *stack_head= env->head;  
989    
990    if(stack_head==NULL) {    if(env->head->type==empty) {
991      printerr("Too Few Arguments");      printerr("Too Few Arguments");
992      env->err=1;      env->err= 1;
993      return;      return;
994    }    }
995        
996    if(stack_head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
997      printerr("Bad Argument Type");      printerr("Bad Argument Type");
998      env->err=2;      env->err= 2;
999      return;      return;
1000    }    }
1001    
1002    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(env->head)->content.sym->id;
1003    toss(env);    toss(env);
1004    
1005    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
1006  }  }
1007    
1008  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
1009  extern void errn(environment *env){  extern void errn(environment *env)
1010    {
1011    push_int(env, env->err);    push_int(env, env->err);
1012  }  }
1013    
# Line 899  int main(int argc, char **argv) Line 1017  int main(int argc, char **argv)
1017    
1018    int c;                        /* getopt option character */    int c;                        /* getopt option character */
1019    
1020    #ifdef __linux__
1021    mtrace();    mtrace();
1022    #endif
1023    
1024    init_env(&myenv);    init_env(&myenv);
1025    
# Line 913  int main(int argc, char **argv) Line 1033  int main(int argc, char **argv)
1033          break;          break;
1034        case '?':        case '?':
1035          fprintf (stderr,          fprintf (stderr,
1036                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1037                   optopt);                   optopt);
1038          return EX_USAGE;          return EX_USAGE;
1039        default:        default:
# Line 932  int main(int argc, char **argv) Line 1052  int main(int argc, char **argv)
1052    if(myenv.interactive) {    if(myenv.interactive) {
1053      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1054  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1055  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1056  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1057  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1058    }    }
1059    
1060    while(1) {    while(1) {
# Line 949  under certain conditions; type `copying; Line 1069  under certain conditions; type `copying;
1069        }        }
1070        myenv.err=0;        myenv.err=0;
1071      }      }
1072      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1073      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1074        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1075      } else if(myenv.head!=NULL        quit(&myenv);
1076                && myenv.head->item->type==symb      } else if(myenv.head->type!=empty
1077                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->type==symb
1078                  && CAR(myenv.head)->content.sym->id[0]
1079                  ==';') {
1080        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1081        eval(&myenv);        eval(&myenv);
1082      }      }
1083      gc_init(&myenv);      gc_maybe(&myenv);
1084    }    }
1085    quit(&myenv);    quit(&myenv);
1086    return EXIT_FAILURE;    return EXIT_FAILURE;
1087  }  }
1088    
1089  /* "+" */  /* "+" */
1090  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1091    {
1092    int a, b;    int a, b;
1093      float fa, fb;
1094    size_t len;    size_t len;
1095    char* new_string;    char* new_string;
1096    value *a_val, *b_val;    value *a_val, *b_val;
1097    
1098    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1099      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1100      env->err= 1;      env->err= 1;
1101      return;      return;
1102    }    }
1103    
1104    if(env->head->item->type==string    if(CAR(env->head)->type==string
1105       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1106      a_val= env->head->item;      a_val= CAR(env->head);
1107      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1108      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1109      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1110      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1111      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 1113  extern void sx_2b(environment *env) {
1113      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1114      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1115      push_cstring(env, new_string);      push_cstring(env, new_string);
1116      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1117      free(new_string);      free(new_string);
1118        
1119      return;      return;
1120    }    }
1121        
1122    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1123       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1124      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1125      env->err=2;      toss(env); if(env->err) return;
1126        b= CAR(env->head)->content.i;
1127        toss(env); if(env->err) return;
1128        push_int(env, b+a);
1129    
1130      return;      return;
1131    }    }
1132    a= env->head->item->content.val;  
1133    toss(env); if(env->err) return;    if(CAR(env->head)->type==tfloat
1134           && CAR(CDR(env->head))->type==tfloat) {
1135    b= env->head->item->content.val;      fa= CAR(env->head)->content.f;
1136    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1137    push_int(env, a+b);      fb= CAR(env->head)->content.f;
1138        toss(env); if(env->err) return;
1139        push_float(env, fb+fa);
1140        
1141        return;
1142      }
1143    
1144      if(CAR(env->head)->type==tfloat
1145         && CAR(CDR(env->head))->type==integer) {
1146        fa= CAR(env->head)->content.f;
1147        toss(env); if(env->err) return;
1148        b= CAR(env->head)->content.i;
1149        toss(env); if(env->err) return;
1150        push_float(env, b+fa);
1151        
1152        return;
1153      }
1154    
1155      if(CAR(env->head)->type==integer
1156         && CAR(CDR(env->head))->type==tfloat) {
1157        a= CAR(env->head)->content.i;
1158        toss(env); if(env->err) return;
1159        fb= CAR(env->head)->content.f;
1160        toss(env); if(env->err) return;
1161        push_float(env, fb+a);
1162    
1163        return;
1164      }
1165    
1166      printerr("Bad Argument Type");
1167      env->err=2;
1168  }  }
1169    
1170  /* "-" */  /* "-" */
1171  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1172    {
1173    int a, b;    int a, b;
1174      float fa, fb;
1175    
1176    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1177      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1178      env->err=1;      env->err=1;
1179      return;      return;
1180    }    }
1181        
1182    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1183       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1184      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1185      env->err=2;      toss(env); if(env->err) return;
1186        b= CAR(env->head)->content.i;
1187        toss(env); if(env->err) return;
1188        push_int(env, b-a);
1189    
1190      return;      return;
1191    }    }
1192    
1193    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
1194    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
1195    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
1196    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1197    push_int(env, b-a);      fb= CAR(env->head)->content.f;
1198        toss(env); if(env->err) return;
1199        push_float(env, fb-fa);
1200        
1201        return;
1202      }
1203    
1204      if(CAR(env->head)->type==tfloat
1205         && CAR(CDR(env->head))->type==integer) {
1206        fa= CAR(env->head)->content.f;
1207        toss(env); if(env->err) return;
1208        b= CAR(env->head)->content.i;
1209        toss(env); if(env->err) return;
1210        push_float(env, b-fa);
1211        
1212        return;
1213      }
1214    
1215      if(CAR(env->head)->type==integer
1216         && CAR(CDR(env->head))->type==tfloat) {
1217        a= CAR(env->head)->content.i;
1218        toss(env); if(env->err) return;
1219        fb= CAR(env->head)->content.f;
1220        toss(env); if(env->err) return;
1221        push_float(env, fb-a);
1222    
1223        return;
1224      }
1225    
1226      printerr("Bad Argument Type");
1227      env->err=2;
1228  }  }
1229    
1230  /* ">" */  /* ">" */
1231  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1232    {
1233    int a, b;    int a, b;
1234      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      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1245      env->err=2;      toss(env); if(env->err) return;
1246        b= CAR(env->head)->content.i;
1247        toss(env); if(env->err) return;
1248        push_int(env, b>a);
1249    
1250      return;      return;
1251    }    }
1252    
1253    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
1254    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
1255    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
1256    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1257    push_int(env, b>a);      fb= CAR(env->head)->content.f;
1258        toss(env); if(env->err) return;
1259        push_int(env, fb>fa);
1260        
1261        return;
1262      }
1263    
1264      if(CAR(env->head)->type==tfloat
1265         && CAR(CDR(env->head))->type==integer) {
1266        fa= CAR(env->head)->content.f;
1267        toss(env); if(env->err) return;
1268        b= CAR(env->head)->content.i;
1269        toss(env); if(env->err) return;
1270        push_int(env, b>fa);
1271        
1272        return;
1273      }
1274    
1275      if(CAR(env->head)->type==integer
1276         && CAR(CDR(env->head))->type==tfloat) {
1277        a= CAR(env->head)->content.i;
1278        toss(env); if(env->err) return;
1279        fb= CAR(env->head)->content.f;
1280        toss(env); if(env->err) return;
1281        push_int(env, fb>a);
1282    
1283        return;
1284      }
1285    
1286      printerr("Bad Argument Type");
1287      env->err= 2;
1288    }
1289    
1290    /* "<" */
1291    extern void sx_3c(environment *env)
1292    {
1293      swap(env); if(env->err) return;
1294      sx_3e(env);
1295    }
1296    
1297    /* "<=" */
1298    extern void sx_3c3d(environment *env)
1299    {
1300      sx_3e(env); if(env->err) return;
1301      not(env);
1302    }
1303    
1304    /* ">=" */
1305    extern void sx_3e3d(environment *env)
1306    {
1307      sx_3c(env); if(env->err) return;
1308      not(env);
1309  }  }
1310    
1311  /* Return copy of a value */  /* Return copy of a value */
1312  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1313    stackitem *old_item, *new_item, *prev_item;  {
1314      value *new_value;
1315    
1316    value *new_value= new_val(env);    if(old_value==NULL)
1317        return NULL;
1318    
1319    protect(env, old_value);    protect(old_value);
1320      new_value= new_val(env);
1321    new_value->type= old_value->type;    new_value->type= old_value->type;
1322    
1323    switch(old_value->type){    switch(old_value->type){
1324      case tfloat:
1325    case integer:    case integer:
1326      new_value->content.val= old_value->content.val;    case func:
1327      case symb:
1328        new_value->content= old_value->content;
1329      break;      break;
1330    case string:    case string:
1331      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1332        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1333      break;      break;
1334    case func:    case tcons:
   case symb:  
     new_value->content.ptr= old_value->content.ptr;  
     break;  
   case list:  
     new_value->content.ptr= NULL;  
1335    
1336      prev_item= NULL;      new_value->content.c= malloc(sizeof(cons));
1337      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
1338    
1339      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1340        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;  
     }      
1341      break;      break;
1342    }    }
1343    
1344    unprotect(env);    unprotect(old_value);
1345    
1346    return new_value;    return new_value;
1347  }  }
1348    
1349  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1350  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1351    if((env->head)==NULL) {  {
1352      if(env->head->type==empty) {
1353      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1354      env->err= 1;      env->err= 1;
1355      return;      return;
1356    }    }
1357    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1358  }  }
1359    
1360  /* "if", If-Then */  /* "if", If-Then */
1361  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1362    {
1363    int truth;    int truth;
1364    
1365    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1366      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1367      env->err= 1;      env->err= 1;
1368      return;      return;
1369    }    }
1370    
1371    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1372      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1373      env->err=2;      env->err= 2;
1374      return;      return;
1375    }    }
1376        
1377    swap(env);    swap(env);
1378    if(env->err) return;    if(env->err) return;
1379        
1380    truth=env->head->item->content.val;    truth= CAR(env->head)->content.i;
1381    
1382    toss(env);    toss(env);
1383    if(env->err) return;    if(env->err) return;
# Line 1145  extern void sx_6966(environment *env) { Line 1389  extern void sx_6966(environment *env) {
1389  }  }
1390    
1391  /* If-Then-Else */  /* If-Then-Else */
1392  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1393    {
1394    int truth;    int truth;
1395    
1396    if((env->head)==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1397       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1398      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1399      env->err=1;      env->err= 1;
1400      return;      return;
1401    }    }
1402    
1403    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1404      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1405      env->err=2;      env->err= 2;
1406      return;      return;
1407    }    }
1408        
1409    rot(env);    rot(env);
1410    if(env->err) return;    if(env->err) return;
1411        
1412    truth=env->head->item->content.val;    truth= CAR(env->head)->content.i;
1413    
1414    toss(env);    toss(env);
1415    if(env->err) return;    if(env->err) return;
# Line 1180  extern void ifelse(environment *env) { Line 1424  extern void ifelse(environment *env) {
1424    eval(env);    eval(env);
1425  }  }
1426    
1427  /* "while" */  extern void sx_656c7365(environment *env)
1428  extern void sx_7768696c65(environment *env) {  {
1429      if(env->head->type==empty || CDR(env->head)->type==empty
1430         || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1431         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1432        printerr("Too Few Arguments");
1433        env->err= 1;
1434        return;
1435      }
1436    
1437      if(CAR(CDR(env->head))->type!=symb
1438         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1439         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1440         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1441        printerr("Bad Argument Type");
1442        env->err= 2;
1443        return;
1444      }
1445    
1446      swap(env); toss(env); rot(env); toss(env);
1447      ifelse(env);
1448    }
1449    
1450    extern void then(environment *env)
1451    {
1452      if(env->head->type==empty || CDR(env->head)->type==empty
1453         || CDR(CDR(env->head))->type==empty) {
1454        printerr("Too Few Arguments");
1455        env->err= 1;
1456        return;
1457      }
1458    
1459      if(CAR(CDR(env->head))->type!=symb
1460         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1461        printerr("Bad Argument Type");
1462        env->err= 2;
1463        return;
1464      }
1465    
1466      swap(env); toss(env);
1467      sx_6966(env);
1468    }
1469    
1470    /* "while" */
1471    extern void sx_7768696c65(environment *env)
1472    {
1473    int truth;    int truth;
1474    value *loop, *test;    value *loop, *test;
1475    
1476    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1477      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1478      env->err=1;      env->err= 1;
1479      return;      return;
1480    }    }
1481    
1482    loop= env->head->item;    loop= CAR(env->head);
1483    protect(env, loop);    protect(loop);
1484    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1485    
1486    test= env->head->item;    test= CAR(env->head);
1487    protect(env, test);    protect(test);
1488    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1489    
1490    do {    do {
1491      push_val(env, test);      push_val(env, test);
1492      eval(env);      eval(env);
1493            
1494      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1495        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1496        env->err= 2;        env->err= 2;
1497        return;        return;
1498      }      }
1499            
1500      truth= env->head->item->content.val;      truth= CAR(env->head)->content.i;
1501      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1502            
1503      if(truth) {      if(truth) {
# Line 1222  extern void sx_7768696c65(environment *e Line 1509  extern void sx_7768696c65(environment *e
1509        
1510    } while(truth);    } while(truth);
1511    
1512    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1513  }  }
1514    
1515    
1516  /* "for"; for-loop */  /* "for"; for-loop */
1517  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1518    {
1519    value *loop;    value *loop;
1520    int foo1, foo2;    int foo1, foo2;
1521    
1522    if(env->head==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1523       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1524      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1525      env->err= 1;      env->err= 1;
1526      return;      return;
1527    }    }
1528    
1529    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1530       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1531      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1532      env->err= 2;      env->err= 2;
1533      return;      return;
1534    }    }
1535    
1536    loop= env->head->item;    loop= CAR(env->head);
1537    protect(env, loop);    protect(loop);
1538    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1539    
1540    foo2= env->head->item->content.val;    foo2= CAR(env->head)->content.i;
1541    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1542    
1543    foo1= env->head->item->content.val;    foo1= CAR(env->head)->content.i;
1544    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1545    
1546    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1270  extern void sx_666f72(environment *env) Line 1558  extern void sx_666f72(environment *env)
1558        foo1--;        foo1--;
1559      }      }
1560    }    }
1561    unprotect(env);    unprotect(loop);
1562  }  }
1563    
1564  /* Variant of for-loop */  /* Variant of for-loop */
1565  extern void foreach(environment *env) {  extern void foreach(environment *env)
1566      {  
1567    value *loop, *foo;    value *loop, *foo;
1568    stackitem *iterator;    value *iterator;
1569        
1570    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1571      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1572      env->err= 1;      env->err= 1;
1573      return;      return;
1574    }    }
1575    
1576    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1577      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1578      env->err= 2;      env->err= 2;
1579      return;      return;
1580    }    }
1581    
1582    loop= env->head->item;    loop= CAR(env->head);
1583    protect(env, loop);    protect(loop);
1584    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1585    
1586    foo= env->head->item;    foo= CAR(env->head);
1587    protect(env, foo);    protect(foo);
1588    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1589    
1590    iterator= foo->content.ptr;    iterator= foo;
1591    
1592    while(iterator!=NULL) {    while(iterator!=NULL) {
1593      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1594      push_val(env, loop);      push_val(env, loop);
1595      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1596      iterator= iterator->next;      if (iterator->type == tcons){
1597          iterator= CDR(iterator);
1598        } else {
1599          printerr("Bad Argument Type"); /* Improper list */
1600          env->err= 2;
1601          break;
1602        }
1603    }    }
1604    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1605  }  }
1606    
1607  /* "to" */  /* "to" */
1608  extern void to(environment *env) {  extern void to(environment *env)
1609    int i, start, ending;  {
1610    stackitem *temp_head;    int ending, start, i;
1611    value *temp_val;    value *iterator, *temp;
1612      
1613    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1614      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1615      env->err=1;      env->err= 1;
1616      return;      return;
1617    }    }
1618    
1619    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1620       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1621      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1622      env->err=2;      env->err= 2;
1623      return;      return;
1624    }    }
1625    
1626    ending= env->head->item->content.val;    ending= CAR(env->head)->content.i;
1627    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1628    start= env->head->item->content.val;    start= CAR(env->head)->content.i;
1629    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1630    
1631    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1632    
1633    if(ending>=start) {    if(ending>=start) {
1634      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1345  extern void to(environment *env) { Line 1638  extern void to(environment *env) {
1638        push_int(env, i);        push_int(env, i);
1639    }    }
1640    
1641    temp_val= new_val(env);    iterator= env->head;
1642    temp_val->content.ptr= env->head;  
1643    temp_val->type= list;    if(iterator->type==empty
1644    env->head= temp_head;       || (CAR(iterator)->type==symb
1645    push_val(env, temp_val);           && CAR(iterator)->content.sym->id[0]=='[')) {
1646        temp= NULL;
1647        toss(env);
1648      } else {
1649        /* Search for first delimiter */
1650        while(CDR(iterator)!=NULL
1651              && (CAR(CDR(iterator))->type!=symb
1652                  || CAR(CDR(iterator))->content.sym->id[0]!='['))
1653          iterator= CDR(iterator);
1654        
1655        /* Extract list */
1656        temp= env->head;
1657        env->head= CDR(iterator);
1658        CDR(iterator)= NULL;
1659    
1660        if(env->head!=NULL)
1661          toss(env);
1662      }
1663    
1664      /* Push list */
1665      push_val(env, temp);
1666  }  }
1667    
1668  /* Read a string */  /* Read a string */
1669  extern void readline(environment *env) {  extern void readline(environment *env)
1670    {
1671    char in_string[101];    char in_string[101];
1672    
1673    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1363  extern void readline(environment *env) { Line 1677  extern void readline(environment *env) {
1677  }  }
1678    
1679  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1680  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1681    {
1682    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1683    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1684    const char intform[]= "%i%n";    const char intform[]= "%i%n";
1685      const char fltform[]= "%f%n";
1686    const char blankform[]= "%*[ \t]%n";    const char blankform[]= "%*[ \t]%n";
1687    const char ebrackform[]= "]%n";    const char ebrackform[]= "]%n";
1688    const char semicform[]= ";%n";    const char semicform[]= ";%n";
1689    const char bbrackform[]= "[%n";    const char bbrackform[]= "[%n";
1690    
1691    int itemp, readlength= -1;    int itemp, readlength= -1;
1692      int count= -1;
1693      float ftemp;
1694    static int depth= 0;    static int depth= 0;
1695    char *match;    char *match, *ctemp;
1696    size_t inlength;    size_t inlength;
1697    
1698    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1383  extern void sx_72656164(environment *env Line 1701  extern void sx_72656164(environment *env
1701      }      }
1702      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1703    
1704      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1705        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1706        return;        return;
1707      }      }
1708            
1709      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1710      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1711      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1712      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1713    }    }
1714        
1715    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1716    match= malloc(inlength);    match= malloc(inlength);
1717    
1718    if(sscanf(env->in_string, blankform, &readlength)!=EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1719       && readlength != -1) {       && readlength != -1) {
1720      ;      ;
1721    } else if(sscanf(env->in_string, intform, &itemp, &readlength) != EOF    } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
1722              && readlength != -1) {              && readlength != -1) {
1723      push_int(env, itemp);      if(sscanf(env->in_string, intform, &itemp, &count) != EOF
1724           && count==readlength) {
1725          push_int(env, itemp);
1726        } else {
1727          push_float(env, ftemp);
1728        }
1729    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1730              && readlength != -1) {              && readlength != -1) {
1731      push_cstring(env, match);      push_cstring(env, match);
# Line 1424  extern void sx_72656164(environment *env Line 1747  extern void sx_72656164(environment *env
1747      free(env->free_string);      free(env->free_string);
1748      env->in_string = env->free_string = NULL;      env->in_string = env->free_string = NULL;
1749    }    }
1750    if ( env->in_string != NULL) {    if (env->in_string != NULL) {
1751      env->in_string += readlength;      env->in_string += readlength;
1752    }    }
1753    
# Line 1434  extern void sx_72656164(environment *env Line 1757  extern void sx_72656164(environment *env
1757      return sx_72656164(env);      return sx_72656164(env);
1758  }  }
1759    
1760  extern void beep(environment *env) {  #ifdef __linux__
1761    extern void beep(environment *env)
1762    {
1763    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1764    
1765    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1766      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1767      env->err=1;      env->err= 1;
1768      return;      return;
1769    }    }
1770    
1771    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1772       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1773      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1774      env->err=2;      env->err= 2;
1775      return;      return;
1776    }    }
1777    
1778    dur=env->head->item->content.val;    dur= CAR(env->head)->content.i;
1779    toss(env);    toss(env);
1780    freq=env->head->item->content.val;    freq= CAR(env->head)->content.i;
1781    toss(env);    toss(env);
1782    
1783    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1784                                     length */                                     length */
1785    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1786                                     timer ticks */                                     timer ticks */
1787    
1788  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1789    
1790    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1791    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1792    case 0:    case 0:
1793      usleep(dur);      usleep(dur);
1794      return;      return;
1795    case -1:    case -1:
1796      perror("beep");      perror("beep");
1797      env->err=5;      env->err= 5;
1798      return;      return;
1799    default:    default:
1800      abort();      abort();
1801    }    }
1802  };  }
1803    #endif /* __linux__ */
1804    
1805  /* "wait" */  /* "wait" */
1806  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1807    {
1808    int dur;    int dur;
1809    
1810    if((env->head)==NULL) {    if(env->head->type==empty) {
1811      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1812      env->err=1;      env->err= 1;
1813      return;      return;
1814    }    }
1815    
1816    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1817      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1818      env->err=2;      env->err= 2;
1819      return;      return;
1820    }    }
1821    
1822    dur=env->head->item->content.val;    dur= CAR(env->head)->content.i;
1823    toss(env);    toss(env);
1824    
1825    usleep(dur);    usleep(dur);
1826  };  }
1827    
1828  extern void copying(environment *env){  extern void copying(environment *env)
1829    printf("GNU GENERAL PUBLIC LICENSE\n\  {
1830      printf("                  GNU GENERAL PUBLIC LICENSE\n\
1831                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1832  \n\  \n\
1833   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 1759  of preserving the free status of all der Line 2085  of preserving the free status of all der
2085  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
2086  }  }
2087    
2088  extern void warranty(environment *env){  extern void warranty(environment *env)
2089    {
2090    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
2091  \n\  \n\
2092    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 2109  YOU OR THIRD PARTIES OR A FAILURE OF THE
2109  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\
2110  POSSIBILITY OF SUCH DAMAGES.\n");  POSSIBILITY OF SUCH DAMAGES.\n");
2111  }  }
2112    
2113    /* "*" */
2114    extern void sx_2a(environment *env)
2115    {
2116      int a, b;
2117      float fa, fb;
2118    
2119      if(env->head->type==empty || CDR(env->head)->type==empty) {
2120        printerr("Too Few Arguments");
2121        env->err= 1;
2122        return;
2123      }
2124      
2125      if(CAR(env->head)->type==integer
2126         && CAR(CDR(env->head))->type==integer) {
2127        a= CAR(env->head)->content.i;
2128        toss(env); if(env->err) return;
2129        b= CAR(env->head)->content.i;
2130        toss(env); if(env->err) return;
2131        push_int(env, b*a);
2132    
2133        return;
2134      }
2135    
2136      if(CAR(env->head)->type==tfloat
2137         && CAR(CDR(env->head))->type==tfloat) {
2138        fa= CAR(env->head)->content.f;
2139        toss(env); if(env->err) return;
2140        fb= CAR(env->head)->content.f;
2141        toss(env); if(env->err) return;
2142        push_float(env, fb*fa);
2143        
2144        return;
2145      }
2146    
2147      if(CAR(env->head)->type==tfloat
2148         && CAR(CDR(env->head))->type==integer) {
2149        fa= CAR(env->head)->content.f;
2150        toss(env); if(env->err) return;
2151        b= CAR(env->head)->content.i;
2152        toss(env); if(env->err) return;
2153        push_float(env, b*fa);
2154        
2155        return;
2156      }
2157    
2158      if(CAR(env->head)->type==integer
2159         && CAR(CDR(env->head))->type==tfloat) {
2160        a= CAR(env->head)->content.i;
2161        toss(env); if(env->err) return;
2162        fb= CAR(env->head)->content.f;
2163        toss(env); if(env->err) return;
2164        push_float(env, fb*a);
2165    
2166        return;
2167      }
2168    
2169      printerr("Bad Argument Type");
2170      env->err= 2;
2171    }
2172    
2173    /* "/" */
2174    extern void sx_2f(environment *env)
2175    {
2176      int a, b;
2177      float fa, fb;
2178    
2179      if(env->head->type==empty || CDR(env->head)->type==empty) {
2180        printerr("Too Few Arguments");
2181        env->err= 1;
2182        return;
2183      }
2184      
2185      if(CAR(env->head)->type==integer
2186         && CAR(CDR(env->head))->type==integer) {
2187        a= CAR(env->head)->content.i;
2188        toss(env); if(env->err) return;
2189        b= CAR(env->head)->content.i;
2190        toss(env); if(env->err) return;
2191        push_float(env, b/a);
2192    
2193        return;
2194      }
2195    
2196      if(CAR(env->head)->type==tfloat
2197         && CAR(CDR(env->head))->type==tfloat) {
2198        fa= CAR(env->head)->content.f;
2199        toss(env); if(env->err) return;
2200        fb= CAR(env->head)->content.f;
2201        toss(env); if(env->err) return;
2202        push_float(env, fb/fa);
2203        
2204        return;
2205      }
2206    
2207      if(CAR(env->head)->type==tfloat
2208         && CAR(CDR(env->head))->type==integer) {
2209        fa= CAR(env->head)->content.f;
2210        toss(env); if(env->err) return;
2211        b= CAR(env->head)->content.i;
2212        toss(env); if(env->err) return;
2213        push_float(env, b/fa);
2214        
2215        return;
2216      }
2217    
2218      if(CAR(env->head)->type==integer
2219         && CAR(CDR(env->head))->type==tfloat) {
2220        a= CAR(env->head)->content.i;
2221        toss(env); if(env->err) return;
2222        fb= CAR(env->head)->content.f;
2223        toss(env); if(env->err) return;
2224        push_float(env, fb/a);
2225    
2226        return;
2227      }
2228    
2229      printerr("Bad Argument Type");
2230      env->err= 2;
2231    }
2232    
2233    /* "mod" */
2234    extern void mod(environment *env)
2235    {
2236      int a, b;
2237    
2238      if(env->head->type==empty || CDR(env->head)->type==empty) {
2239        printerr("Too Few Arguments");
2240        env->err= 1;
2241        return;
2242      }
2243      
2244      if(CAR(env->head)->type==integer
2245         && CAR(CDR(env->head))->type==integer) {
2246        a= CAR(env->head)->content.i;
2247        toss(env); if(env->err) return;
2248        b= CAR(env->head)->content.i;
2249        toss(env); if(env->err) return;
2250        push_int(env, b%a);
2251    
2252        return;
2253      }
2254    
2255      printerr("Bad Argument Type");
2256      env->err= 2;
2257    }
2258    
2259    /* "div" */
2260    extern void sx_646976(environment *env)
2261    {
2262      int a, b;
2263      
2264      if(env->head->type==empty || CDR(env->head)->type==empty) {
2265        printerr("Too Few Arguments");
2266        env->err= 1;
2267        return;
2268      }
2269    
2270      if(CAR(env->head)->type==integer
2271         && CAR(CDR(env->head))->type==integer) {
2272        a= CAR(env->head)->content.i;
2273        toss(env); if(env->err) return;
2274        b= CAR(env->head)->content.i;
2275        toss(env); if(env->err) return;
2276        push_int(env, (int)b/a);
2277    
2278        return;
2279      }
2280    
2281      printerr("Bad Argument Type");
2282      env->err= 2;
2283    }
Legend:
Removed from v.1.91  
changed lines
  Added in v.1.112
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26