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

Diff of /stack/stack.c

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

revision 1.92 by masse, Fri Mar 8 06:44:15 2002 UTC revision 1.110 by teddy, Sat Mar 16 09:12:39 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= NULL;
64    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
# Line 63  void init_env(environment *env) Line 70  void init_env(environment *env)
70    env->interactive= 1;    env->interactive= 1;
71  }  }
72    
73  void printerr(const char* in_string) {  void printerr(const char* in_string)
74    {
75    fprintf(stderr, "Err: %s\n", in_string);    fprintf(stderr, "Err: %s\n", in_string);
76  }  }
77    
78  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
79  extern void toss(environment *env)  extern void toss(environment *env)
80  {  {
81    stackitem *temp= env->head;    if(env->head==NULL) {
   
   if((env->head)==NULL) {  
82      printerr("Too Few Arguments");      printerr("Too Few Arguments");
83      env->err= 1;      env->err= 1;
84      return;      return;
85    }    }
86        
87    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);  
88  }  }
89    
90  /* 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 116  symbol **hash(hashtbl in_hashtbl, const
116    }    }
117  }  }
118    
119  value* new_val(environment *env) {  /* Create new value */
120    value* new_val(environment *env)
121    {
122    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
123    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
124    
125    nval->content.ptr= NULL;    nval->content.ptr= NULL;
126    protect(env, nval);    nval->type= integer;
   
   gc_init(env);  
127    
128    nitem->item= nval;    nitem->item= nval;
129    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
130    
131    env->gc_ref= nitem;    env->gc_ref= nitem;
132    
133    env->gc_count++;    env->gc_count += sizeof(value);
134    unprotect(env);    nval->gc.flag.mark= 0;
135      nval->gc.flag.protect= 0;
136    
137    return nval;    return nval;
138  }  }
139    
140  void gc_mark(value *val) {  /* Mark values recursively.
141    stackitem *iterator;     Marked values are not collected by the GC. */
142    inline void gc_mark(value *val)
143    if(val==NULL || val->gc_garb==0)  {
144      if(val==NULL || val->gc.flag.mark)
145      return;      return;
146    
147    val->gc_garb= 0;    val->gc.flag.mark= 1;
   
   if(val->type==list) {  
     iterator= val->content.ptr;  
148    
149      while(iterator!=NULL) {    if(val->type==tcons) {
150        gc_mark(iterator->item);      gc_mark(CAR(val));
151        iterator= iterator->next;      gc_mark(CDR(val));
     }  
152    }    }
153  }  }
154    
155  extern void gc_init(environment *env) {  inline void gc_maybe(environment *env)
156    stackitem *new_head= NULL, *titem, *iterator= env->gc_ref;  {
157      if(env->gc_count < env->gc_limit)
158        return;
159      else
160        return gc_init(env);
161    }
162    
163    /* Start GC */
164    extern void gc_init(environment *env)
165    {
166      stackitem *new_head= NULL, *titem;
167      cons *iterator;
168    symbol *tsymb;    symbol *tsymb;
169    int i;    int i;
170    
171    if(env->gc_count < env->gc_limit)    if(env->interactive)
172      return;      printf("Garbage collecting.");
173    
174    while(iterator!=NULL) {    /* Mark values on stack */
175      iterator->item->gc_garb= 1;    gc_mark(env->head);
     iterator= iterator->next;  
   }  
176    
177    /* Mark */    if(env->interactive)
178    iterator= env->gc_protect;      printf(".");
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
179    
   iterator= env->head;  
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
180    
181    for(i= 0; i<HASHTBLSIZE; i++) {    /* Mark values in hashtable */
182      tsymb= env->symbols[i];    for(i= 0; i<HASHTBLSIZE; i++)
183      while(tsymb!=NULL) {      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
184        gc_mark(tsymb->val);        if (tsymb->val != NULL)
185        tsymb= tsymb->next;          gc_mark(tsymb->val);
186      }  
187    }  
188      if(env->interactive)
189        printf(".");
190    
191    env->gc_count= 0;    env->gc_count= 0;
192    
193    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
   while(env->gc_ref!=NULL) {  
194    
195      if(env->gc_ref->item->gc_garb) {      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
196        switch(env->gc_ref->item->type) {  
197        case string:        if(env->gc_ref->item->type==string) /* Remove content */
198          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
199          break;  
200        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 {  
201        titem= env->gc_ref->next;        titem= env->gc_ref->next;
202        env->gc_ref->next= new_head;        free(env->gc_ref);        /* Remove value */
       new_head= env->gc_ref;  
203        env->gc_ref= titem;        env->gc_ref= titem;
204        env->gc_count++;        continue;
205      }      }
206    #ifdef DEBUG
207        printf("Kept value (%p)", env->gc_ref->item);
208        if(env->gc_ref->item->gc.flag.mark)
209          printf(" (marked)");
210        if(env->gc_ref->item->gc.flag.protect)
211          printf(" (protected)");
212        switch(env->gc_ref->item->type){
213        case integer:
214          printf(" integer: %d", env->gc_ref->item->content.i);
215          break;
216        case func:
217          printf(" func: %p", env->gc_ref->item->content.ptr);
218          break;
219        case symb:
220          printf(" symb: %s", env->gc_ref->item->content.sym->id);
221          break;
222        case tcons:
223          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
224                 env->gc_ref->item->content.c->cdr);
225          break;
226        default:
227          printf(" <unknown %d>", (env->gc_ref->item->type));
228        }
229        printf("\n");
230    #endif /* DEBUG */
231    
232        /* Keep values */    
233        env->gc_count += sizeof(value);
234        if(env->gc_ref->item->type==string)
235          env->gc_count += strlen(env->gc_ref->item->content.ptr);
236        
237        titem= env->gc_ref->next;
238        env->gc_ref->next= new_head;
239        new_head= env->gc_ref;
240        new_head->item->gc.flag.mark= 0;
241        env->gc_ref= titem;
242    }    }
243    
244    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
245        env->gc_limit= env->gc_count*2;
246    
247    env->gc_ref= new_head;    env->gc_ref= new_head;
248    
249      if(env->interactive)
250        printf("done (%d bytes still allocated)\n", env->gc_count);
251    
252  }  }
253    
254  void protect(environment *env, value *val)  /* Protect values from GC */
255    void protect(value *val)
256  {  {
257    stackitem *new_item= malloc(sizeof(stackitem));    if(val==NULL || val->gc.flag.protect)
258    new_item->item= val;      return;
259    new_item->next= env->gc_protect;  
260    env->gc_protect= new_item;    val->gc.flag.protect= 1;
261    
262      if(val->type==tcons) {
263        protect(CAR(val));
264        protect(CDR(val));
265      }
266  }  }
267    
268  void unprotect(environment *env)  /* Unprotect values from GC */
269    void unprotect(value *val)
270  {  {
271    stackitem *temp= env->gc_protect;    if(val==NULL || !(val->gc.flag.protect))
272    env->gc_protect= env->gc_protect->next;      return;
273    free(temp);  
274      val->gc.flag.protect= 0;
275    
276      if(val->type==tcons) {
277        unprotect(CAR(val));
278        unprotect(CDR(val));
279      }
280  }  }
281    
282  /* Push a value onto the stack */  /* Push a value onto the stack */
283  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
284  {  {
285    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
286    new_item->item= val;  
287    new_item->next= env->head;    new_value->content.c= malloc(sizeof(cons));
288    env->head= new_item;    assert(new_value->content.c!=NULL);
289      new_value->type= tcons;
290      CAR(new_value)= val;
291      CDR(new_value)= env->head;
292      env->head= new_value;
293  }  }
294    
295  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
296  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
297  {  {
298    value *new_value= new_val(env);    value *new_value= new_val(env);
299        
300    new_value->content.val= in_val;    new_value->content.i= in_val;
301    new_value->type= integer;    new_value->type= integer;
302    
303    push_val(env, new_value);    push_val(env, new_value);
304  }  }
305    
306    /* Push a floating point number onto the stack */
307    void push_float(environment *env, float in_val)
308    {
309      value *new_value= new_val(env);
310    
311      new_value->content.f= in_val;
312      new_value->type= tfloat;
313    
314      push_val(env, new_value);
315    }
316    
317  /* Copy a string onto the stack. */  /* Copy a string onto the stack. */
318  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
319  {  {
320    value *new_value= new_val(env);    value *new_value= new_val(env);
321      int length= strlen(in_string)+1;
322    
323    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
324      env->gc_count += length;
325    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
326    new_value->type= string;    new_value->type= string;
327    
# Line 271  void push_cstring(environment *env, cons Line 329  void push_cstring(environment *env, cons
329  }  }
330    
331  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
332  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
333    {
334    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
335    char *new_string, *current;    char *new_string, *current;
336    
# Line 289  char *mangle_str(const char *old_string) Line 348  char *mangle_str(const char *old_string)
348    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
349  }  }
350    
351  extern void mangle(environment *env){  extern void mangle(environment *env)
352    {
353    char *new_string;    char *new_string;
354    
355    if((env->head)==NULL) {    if(env->head==NULL) {
356      printerr("Too Few Arguments");      printerr("Too Few Arguments");
357      env->err= 1;      env->err= 1;
358      return;      return;
359    }    }
360    
361    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
362      printerr("Bad Argument Type");      printerr("Bad Argument Type");
363      env->err= 2;      env->err= 2;
364      return;      return;
365    }    }
366    
367    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
368        mangle_str((const char *)(CAR(env->head)->content.ptr));
369    
370    toss(env);    toss(env);
371    if(env->err) return;    if(env->err) return;
# Line 328  void push_sym(environment *env, const ch Line 389  void push_sym(environment *env, const ch
389    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
390    
391    new_value= new_val(env);    new_value= new_val(env);
392      protect(new_value);
393      new_fvalue= new_val(env);
394      protect(new_fvalue);
395    
396    /* The new value is a symbol */    /* The new value is a symbol */
397    new_value->type= symb;    new_value->type= symb;
# Line 355  void push_sym(environment *env, const ch Line 419  void push_sym(environment *env, const ch
419    
420      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
421      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
422      free(mangled);  
423      dlerr= dlerror();      dlerr= dlerror();
424      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
425        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
426        dlerr= dlerror();        dlerr= dlerror();
427      }      }
428    
429      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 */  
430        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
431        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
432        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
433                                           function value */                                           function value */
434      }      }
435    
436        free(mangled);
437    }    }
438    
439    push_val(env, new_value);    push_val(env, new_value);
440      unprotect(new_value); unprotect(new_fvalue);
441  }  }
442    
443  /* Print newline. */  /* Print newline. */
# Line 379  extern void nl() Line 447  extern void nl()
447  }  }
448    
449  /* Gets the type of a value */  /* Gets the type of a value */
450  extern void type(environment *env){  extern void type(environment *env)
451    {
452    int typenum;    int typenum;
453    
454    if((env->head)==NULL) {    if(env->head==NULL) {
455      printerr("Too Few Arguments");      printerr("Too Few Arguments");
456      env->err=1;      env->err= 1;
457      return;      return;
458    }    }
459    typenum=env->head->item->type;  
460      typenum= CAR(env->head)->type;
461    toss(env);    toss(env);
462    switch(typenum){    switch(typenum){
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  }      }    
483    
484  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
485  void print_h(stackitem *stack_head, int noquote)  void print_h(value *stack_head, int noquote)
486  {  {
487    switch(stack_head->item->type) {    switch(CAR(stack_head)->type) {
488    case integer:    case integer:
489      printf("%d", stack_head->item->content.val);      printf("%d", CAR(stack_head)->content.i);
490        break;
491      case tfloat:
492        printf("%f", CAR(stack_head)->content.f);
493      break;      break;
494    case string:    case string:
495      if(noquote)      if(noquote)
496        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)CAR(stack_head)->content.ptr);
497      else      else
498        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);
499      break;      break;
500    case symb:    case symb:
501      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
502      break;      break;
503    case func:    case func:
504      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
505      break;      break;
506    case list:    case tcons:
507      /* 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 */
508      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head= CAR(stack_head);
509      printf("[ ");      printf("[ ");
510      while(stack_head != NULL) {      while(stack_head != NULL) {
511        print_h(stack_head, noquote);        print_h(stack_head, noquote);
512        printf(" ");        printf(" ");
513        stack_head=stack_head->next;        stack_head= CDR(stack_head);
514      }      }
515      printf("]");      printf("]");
516      break;      break;
517    }    }
518  }  }
519    
520  extern void print_(environment *env) {  extern void print_(environment *env)
521    {
522    if(env->head==NULL) {    if(env->head==NULL) {
523      printerr("Too Few Arguments");      printerr("Too Few Arguments");
524      env->err=1;      env->err= 1;
525      return;      return;
526    }    }
527    print_h(env->head, 0);    print_h(env->head, 0);
# Line 459  extern void print(environment *env) Line 536  extern void print(environment *env)
536    toss(env);    toss(env);
537  }  }
538    
539  extern void princ_(environment *env) {  extern void princ_(environment *env)
540    {
541    if(env->head==NULL) {    if(env->head==NULL) {
542      printerr("Too Few Arguments");      printerr("Too Few Arguments");
543      env->err=1;      env->err= 1;
544      return;      return;
545    }    }
546    print_h(env->head, 1);    print_h(env->head, 1);
# Line 477  extern void princ(environment *env) Line 555  extern void princ(environment *env)
555  }  }
556    
557  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
558  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
559  {  {
560    if(stack_head->next != NULL)    if(CDR(stack_head) != NULL)
561      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
562    printf("%ld: ", counter);    printf("%ld: ", counter);
563    print_h(stack_head, 0);    print_h(stack_head, 0);
564    nl();    nl();
# Line 493  extern void printstack(environment *env) Line 571  extern void printstack(environment *env)
571      printf("Stack Empty\n");      printf("Stack Empty\n");
572      return;      return;
573    }    }
574    
575    print_st(env->head, 1);    print_st(env->head, 1);
576  }  }
577    
578  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
579  extern void swap(environment *env)  extern void swap(environment *env)
580  {  {
581    stackitem *temp= env->head;    value *temp= env->head;
582        
583    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
584      printerr("Too Few Arguments");      printerr("Too Few Arguments");
585      env->err=1;      env->err=1;
586      return;      return;
587    }    }
588    
589    env->head= env->head->next;    env->head= CDR(env->head);
590    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
591    env->head->next= temp;    CDR(env->head)= temp;
592  }  }
593    
594  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
595  extern void rot(environment *env)  extern void rot(environment *env)
596  {  {
597    stackitem *temp= env->head;    value *temp= env->head;
598        
599    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
600        || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
601      printerr("Too Few Arguments");      printerr("Too Few Arguments");
602      env->err=1;      env->err= 1;
603      return;      return;
604    }    }
605      
606    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
607    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
608    env->head->next= temp;    CDR(env->head)= temp;
609  }  }
610    
611  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 534  extern void rcl(environment *env) Line 613  extern void rcl(environment *env)
613  {  {
614    value *val;    value *val;
615    
616    if(env->head == NULL) {    if(env->head==NULL) {
617      printerr("Too Few Arguments");      printerr("Too Few Arguments");
618      env->err=1;      env->err= 1;
619      return;      return;
620    }    }
621    
622    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
623      printerr("Bad Argument Type");      printerr("Bad Argument Type");
624      env->err=2;      env->err= 2;
625      return;      return;
626    }    }
627    
628    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
629    if(val == NULL){    if(val == NULL){
630      printerr("Unbound Variable");      printerr("Unbound Variable");
631      env->err=3;      env->err= 3;
632      return;      return;
633    }    }
634    protect(env, val);    push_val(env, val);           /* Return the symbol's bound value */
635    toss(env);            /* toss the symbol */    swap(env);
636      if(env->err) return;
637      toss(env);                    /* toss the symbol */
638    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(env);  
639  }  }
640    
641  /* 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 645  extern void eval(environment *env)
645  {  {
646    funcp in_func;    funcp in_func;
647    value* temp_val;    value* temp_val;
648    stackitem* iterator;    value* iterator;
649    
650   eval_start:   eval_start:
651    
652      gc_maybe(env);
653    
654    if(env->head==NULL) {    if(env->head==NULL) {
655      printerr("Too Few Arguments");      printerr("Too Few Arguments");
656      env->err=1;      env->err= 1;
657      return;      return;
658    }    }
659    
660    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
661      /* if it's a symbol */      /* if it's a symbol */
662    case symb:    case symb:
663      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
664      if(env->err) return;      if(env->err) return;
665      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
666        goto eval_start;        goto eval_start;
667      }      }
668      return;      return;
669    
670      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
671    case func:    case func:
672      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
673      toss(env);      toss(env);
674      if(env->err) return;      if(env->err) return;
675      return in_func(env);      return in_func(env);
676    
677      /* If it's a list */      /* If it's a list */
678    case list:    case tcons:
679      temp_val= env->head->item;      temp_val= CAR(env->head);
680      protect(env, temp_val);      protect(temp_val);
681      toss(env);  
682      if(env->err) return;      toss(env); if(env->err) return;
683      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
     unprotect(env);  
684            
685      while(iterator!=NULL) {      while(iterator!=NULL) {
686        push_val(env, iterator->item);        push_val(env, CAR(iterator));
687                
688        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
689          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
690          toss(env);          toss(env);
691          if(env->err) return;          if(env->err) return;
692                    
693          if(iterator->next == NULL){          if(CDR(iterator)==NULL){
694            goto eval_start;            goto eval_start;
695          }          }
696          eval(env);          eval(env);
697          if(env->err) return;          if(env->err) return;
698        }        }
699        iterator= iterator->next;        if (CDR(iterator)==NULL || CDR(iterator)->type == tcons)
700            iterator= CDR(iterator);
701          else {
702            printerr("Bad Argument Type"); /* Improper list */
703            env->err= 2;
704            return;
705          }
706      }      }
707        unprotect(temp_val);
708      return;      return;
709    
710    default:    default:
# Line 626  extern void eval(environment *env) Line 713  extern void eval(environment *env)
713  }  }
714    
715  /* Reverse (flip) a list */  /* Reverse (flip) a list */
716  extern void rev(environment *env){  extern void rev(environment *env)
717    stackitem *old_head, *new_head, *item;  {
718      value *old_head, *new_head, *item;
719    
720    if((env->head)==NULL) {    if(env->head==NULL) {
721      printerr("Too Few Arguments");      printerr("Too Few Arguments");
722      env->err= 1;      env->err= 1;
723      return;      return;
724    }    }
725    
726    if(env->head->item->type!=list) {    if(CAR(env->head)->type!=tcons) {
727      printerr("Bad Argument Type");      printerr("Bad Argument Type");
728      env->err= 2;      env->err= 2;
729      return;      return;
730    }    }
731    
732    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
733    new_head= NULL;    new_head= NULL;
734    while(old_head != NULL){    while(old_head!=NULL) {
735      item= old_head;      item= old_head;
736      old_head= old_head->next;      old_head= CDR(old_head);
737      item->next= new_head;      CDR(item)= new_head;
738      new_head= item;      new_head= item;
739    }    }
740    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
741  }  }
742    
743  /* Make a list. */  /* Make a list. */
744  extern void pack(environment *env)  extern void pack(environment *env)
745  {  {
746    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
747    
748    iterator= env->head;    iterator= env->head;
   
749    if(iterator==NULL    if(iterator==NULL
750       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
751       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
752      temp= NULL;      temp= NULL;
753      toss(env);      toss(env);
754    } else {    } else {
755      /* Search for first delimiter */      /* Search for first delimiter */
756      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
757            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
758            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
759        iterator= iterator->next;        iterator= CDR(iterator);
760            
761      /* Extract list */      /* Extract list */
762      temp= env->head;      temp= env->head;
763      env->head= iterator->next;      env->head= CDR(iterator);
764      iterator->next= NULL;      CDR(iterator)= NULL;
765        
766      if(env->head!=NULL)      if(env->head!=NULL)
767        toss(env);        toss(env);
768    }    }
769    
770    /* Push list */    /* Push list */
   pack= new_val(env);  
   pack->type= list;  
   pack->content.ptr= temp;  
771    
772    push_val(env, pack);    push_val(env, temp);
773    rev(env);    rev(env);
774  }  }
775    
776  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
777  extern void expand(environment *env)  extern void expand(environment *env)
778  {  {
779    stackitem *temp, *new_head;    value *temp, *new_head;
780    
781    /* Is top element a list? */    /* Is top element a list? */
782    if(env->head==NULL) {    if(env->head==NULL) {
# Line 701  extern void expand(environment *env) Line 784  extern void expand(environment *env)
784      env->err= 1;      env->err= 1;
785      return;      return;
786    }    }
787    if(env->head->item->type!=list) {  
788      if(CAR(env->head)->type!=tcons) {
789      printerr("Bad Argument Type");      printerr("Bad Argument Type");
790      env->err= 2;      env->err= 2;
791      return;      return;
# Line 713  extern void expand(environment *env) Line 797  extern void expand(environment *env)
797      return;      return;
798    
799    /* The first list element is the new stack head */    /* The first list element is the new stack head */
800    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
801    
802    toss(env);    toss(env);
803    
804    /* Find the end of the list */    /* Find the end of the list */
805    while(temp->next!=NULL)    while(CDR(temp)->content.ptr != NULL) {
806      temp= temp->next;      if (CDR(temp)->type == tcons)
807          temp= CDR(temp);
808        else {
809          printerr("Bad Argument Type"); /* Improper list */
810          env->err= 2;
811          return;
812        }
813      }
814    
815    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
816    temp->next= env->head;    CDR(temp)= env->head;
817    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
818    
819  }  }
# Line 731  extern void expand(environment *env) Line 822  extern void expand(environment *env)
822  extern void eq(environment *env)  extern void eq(environment *env)
823  {  {
824    void *left, *right;    void *left, *right;
   int result;  
825    
826    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
827      printerr("Too Few Arguments");      printerr("Too Few Arguments");
828      env->err= 1;      env->err= 1;
829      return;      return;
830    }    }
831    
832    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
833    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
834    toss(env); toss(env);    toss(env); toss(env);
835    push_int(env, result);  
836      push_int(env, left==right);
837  }  }
838    
839  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 753  extern void not(environment *env) Line 841  extern void not(environment *env)
841  {  {
842    int val;    int val;
843    
844    if((env->head)==NULL) {    if(env->head==NULL) {
845      printerr("Too Few Arguments");      printerr("Too Few Arguments");
846      env->err= 1;      env->err= 1;
847      return;      return;
848    }    }
849    
850    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
851      printerr("Bad Argument Type");      printerr("Bad Argument Type");
852      env->err= 2;      env->err= 2;
853      return;      return;
854    }    }
855    
856    val= env->head->item->content.val;    val= CAR(env->head)->content.i;
857    toss(env);    toss(env);
858    push_int(env, !val);    push_int(env, !val);
859  }  }
# Line 784  extern void def(environment *env) Line 872  extern void def(environment *env)
872    symbol *sym;    symbol *sym;
873    
874    /* 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 */
875    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
876      printerr("Too Few Arguments");      printerr("Too Few Arguments");
877      env->err= 1;      env->err= 1;
878      return;      return;
879    }    }
880    
881    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
882      printerr("Bad Argument Type");      printerr("Bad Argument Type");
883      env->err= 2;      env->err= 2;
884      return;      return;
885    }    }
886    
887    /* long names are a pain */    /* long names are a pain */
888    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
889    
890    /* Bind the symbol to the value */    /* Bind the symbol to the value */
891    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
892    
893    toss(env); toss(env);    toss(env); toss(env);
894  }  }
# Line 808  extern void def(environment *env) Line 896  extern void def(environment *env)
896  /* Quit stack. */  /* Quit stack. */
897  extern void quit(environment *env)  extern void quit(environment *env)
898  {  {
899    long i;    int i;
900    
901    clear(env);    clear(env);
902    
# Line 821  extern void quit(environment *env) Line 909  extern void quit(environment *env)
909    }    }
910    
911    env->gc_limit= 0;    env->gc_limit= 0;
912    gc_init(env);    gc_maybe(env);
913    
914      words(env);
915    
916    if(env->free_string!=NULL)    if(env->free_string!=NULL)
917      free(env->free_string);      free(env->free_string);
918        
919    #ifdef __linux__
920    muntrace();    muntrace();
921    #endif
922    
923    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
924  }  }
# Line 847  extern void words(environment *env) Line 939  extern void words(environment *env)
939    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
940      temp= env->symbols[i];      temp= env->symbols[i];
941      while(temp!=NULL) {      while(temp!=NULL) {
942    #ifdef DEBUG
943          if (temp->val != NULL && temp->val->gc.flag.protect)
944            printf("(protected) ");
945    #endif /* DEBUG */
946        printf("%s\n", temp->id);        printf("%s\n", temp->id);
947        temp= temp->next;        temp= temp->next;
948      }      }
# Line 854  extern void words(environment *env) Line 950  extern void words(environment *env)
950  }  }
951    
952  /* Internal forget function */  /* Internal forget function */
953  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
954    {
955    symbol *temp;    symbol *temp;
956    
957    temp= *hash_entry;    temp= *hash_entry;
# Line 868  void forget_sym(symbol **hash_entry) { Line 965  void forget_sym(symbol **hash_entry) {
965  extern void forget(environment *env)  extern void forget(environment *env)
966  {  {
967    char* sym_id;    char* sym_id;
968    stackitem *stack_head= env->head;    value *stack_head= env->head;
969    
970    if(stack_head==NULL) {    if(stack_head==NULL) {
971      printerr("Too Few Arguments");      printerr("Too Few Arguments");
972      env->err=1;      env->err= 1;
973      return;      return;
974    }    }
975        
976    if(stack_head->item->type!=symb) {    if(CAR(stack_head)->type!=symb) {
977      printerr("Bad Argument Type");      printerr("Bad Argument Type");
978      env->err=2;      env->err= 2;
979      return;      return;
980    }    }
981    
982    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(stack_head)->content.sym->id;
983    toss(env);    toss(env);
984    
985    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
986  }  }
987    
988  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
989  extern void errn(environment *env){  extern void errn(environment *env)
990    {
991    push_int(env, env->err);    push_int(env, env->err);
992  }  }
993    
# Line 899  int main(int argc, char **argv) Line 997  int main(int argc, char **argv)
997    
998    int c;                        /* getopt option character */    int c;                        /* getopt option character */
999    
1000    #ifdef __linux__
1001    mtrace();    mtrace();
1002    #endif
1003    
1004    init_env(&myenv);    init_env(&myenv);
1005    
# Line 913  int main(int argc, char **argv) Line 1013  int main(int argc, char **argv)
1013          break;          break;
1014        case '?':        case '?':
1015          fprintf (stderr,          fprintf (stderr,
1016                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1017                   optopt);                   optopt);
1018          return EX_USAGE;          return EX_USAGE;
1019        default:        default:
# Line 932  int main(int argc, char **argv) Line 1032  int main(int argc, char **argv)
1032    if(myenv.interactive) {    if(myenv.interactive) {
1033      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1034  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1035  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1036  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1037  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1038    }    }
1039    
1040    while(1) {    while(1) {
# Line 949  under certain conditions; type `copying; Line 1049  under certain conditions; type `copying;
1049        }        }
1050        myenv.err=0;        myenv.err=0;
1051      }      }
1052      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1053      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1054        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1055          quit(&myenv);
1056      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1057                && myenv.head->item->type==symb                && CAR(myenv.head)->type==symb
1058                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->content.sym->id[0]
1059                  ==';') {
1060        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1061        eval(&myenv);        eval(&myenv);
1062      }      }
1063      gc_init(&myenv);      gc_maybe(&myenv);
1064    }    }
1065    quit(&myenv);    quit(&myenv);
1066    return EXIT_FAILURE;    return EXIT_FAILURE;
1067  }  }
1068    
1069  /* "+" */  /* "+" */
1070  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1071    {
1072    int a, b;    int a, b;
1073      float fa, fb;
1074    size_t len;    size_t len;
1075    char* new_string;    char* new_string;
1076    value *a_val, *b_val;    value *a_val, *b_val;
1077    
1078    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1079      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1080      env->err= 1;      env->err= 1;
1081      return;      return;
1082    }    }
1083    
1084    if(env->head->item->type==string    if(CAR(env->head)->type==string
1085       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1086      a_val= env->head->item;      a_val= CAR(env->head);
1087      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1088      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1089      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1090      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1091      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 1093  extern void sx_2b(environment *env) {
1093      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1094      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1095      push_cstring(env, new_string);      push_cstring(env, new_string);
1096      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1097      free(new_string);      free(new_string);
1098        
1099      return;      return;
1100    }    }
1101        
1102    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1103       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1104      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1105      env->err=2;      toss(env); if(env->err) return;
1106        b= CAR(env->head)->content.i;
1107        toss(env); if(env->err) return;
1108        push_int(env, b+a);
1109    
1110      return;      return;
1111    }    }
1112    a= env->head->item->content.val;  
1113    toss(env); if(env->err) return;    if(CAR(env->head)->type==tfloat
1114           && CAR(CDR(env->head))->type==tfloat) {
1115    b= env->head->item->content.val;      fa= CAR(env->head)->content.f;
1116    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1117    push_int(env, a+b);      fb= CAR(env->head)->content.f;
1118        toss(env); if(env->err) return;
1119        push_float(env, fb+fa);
1120        
1121        return;
1122      }
1123    
1124      if(CAR(env->head)->type==tfloat
1125         && CAR(CDR(env->head))->type==integer) {
1126        fa= CAR(env->head)->content.f;
1127        toss(env); if(env->err) return;
1128        b= CAR(env->head)->content.i;
1129        toss(env); if(env->err) return;
1130        push_float(env, b+fa);
1131        
1132        return;
1133      }
1134    
1135      if(CAR(env->head)->type==integer
1136         && CAR(CDR(env->head))->type==tfloat) {
1137        a= CAR(env->head)->content.i;
1138        toss(env); if(env->err) return;
1139        fb= CAR(env->head)->content.f;
1140        toss(env); if(env->err) return;
1141        push_float(env, fb+a);
1142    
1143        return;
1144      }
1145    
1146      printerr("Bad Argument Type");
1147      env->err=2;
1148  }  }
1149    
1150  /* "-" */  /* "-" */
1151  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1152    {
1153    int a, b;    int a, b;
1154      float fa, fb;
1155    
1156    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1157      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1158      env->err=1;      env->err=1;
1159      return;      return;
1160    }    }
1161        
1162    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1163       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1164      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1165      env->err=2;      toss(env); if(env->err) return;
1166        b= CAR(env->head)->content.i;
1167        toss(env); if(env->err) return;
1168        push_int(env, b-a);
1169    
1170      return;      return;
1171    }    }
1172    
1173    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
1174    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
1175    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
1176    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1177    push_int(env, b-a);      fb= CAR(env->head)->content.f;
1178        toss(env); if(env->err) return;
1179        push_float(env, fb-fa);
1180        
1181        return;
1182      }
1183    
1184      if(CAR(env->head)->type==tfloat
1185         && CAR(CDR(env->head))->type==integer) {
1186        fa= CAR(env->head)->content.f;
1187        toss(env); if(env->err) return;
1188        b= CAR(env->head)->content.i;
1189        toss(env); if(env->err) return;
1190        push_float(env, b-fa);
1191        
1192        return;
1193      }
1194    
1195      if(CAR(env->head)->type==integer
1196         && CAR(CDR(env->head))->type==tfloat) {
1197        a= CAR(env->head)->content.i;
1198        toss(env); if(env->err) return;
1199        fb= CAR(env->head)->content.f;
1200        toss(env); if(env->err) return;
1201        push_float(env, fb-a);
1202    
1203        return;
1204      }
1205    
1206      printerr("Bad Argument Type");
1207      env->err=2;
1208  }  }
1209    
1210  /* ">" */  /* ">" */
1211  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1212    {
1213    int a, b;    int a, b;
1214      float fa, fb;
1215    
1216    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1217      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1218      env->err=1;      env->err= 1;
1219      return;      return;
1220    }    }
1221        
1222    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1223       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1224      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1225      env->err=2;      toss(env); if(env->err) return;
1226        b= CAR(env->head)->content.i;
1227        toss(env); if(env->err) return;
1228        push_int(env, b>a);
1229    
1230      return;      return;
1231    }    }
1232    
1233    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
1234    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
1235    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
1236    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1237    push_int(env, b>a);      fb= CAR(env->head)->content.f;
1238        toss(env); if(env->err) return;
1239        push_int(env, fb>fa);
1240        
1241        return;
1242      }
1243    
1244      if(CAR(env->head)->type==tfloat
1245         && CAR(CDR(env->head))->type==integer) {
1246        fa= CAR(env->head)->content.f;
1247        toss(env); if(env->err) return;
1248        b= CAR(env->head)->content.i;
1249        toss(env); if(env->err) return;
1250        push_int(env, b>fa);
1251        
1252        return;
1253      }
1254    
1255      if(CAR(env->head)->type==integer
1256         && CAR(CDR(env->head))->type==tfloat) {
1257        a= CAR(env->head)->content.i;
1258        toss(env); if(env->err) return;
1259        fb= CAR(env->head)->content.f;
1260        toss(env); if(env->err) return;
1261        push_int(env, fb>a);
1262    
1263        return;
1264      }
1265    
1266      printerr("Bad Argument Type");
1267      env->err= 2;
1268    }
1269    
1270    /* "<" */
1271    extern void sx_3c(environment *env)
1272    {
1273      swap(env); if(env->err) return;
1274      sx_3e(env);
1275    }
1276    
1277    /* "<=" */
1278    extern void sx_3c3d(environment *env)
1279    {
1280      sx_3e(env); if(env->err) return;
1281      not(env);
1282    }
1283    
1284    /* ">=" */
1285    extern void sx_3e3d(environment *env)
1286    {
1287      sx_3c(env); if(env->err) return;
1288      not(env);
1289  }  }
1290    
1291  /* Return copy of a value */  /* Return copy of a value */
1292  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1293    stackitem *old_item, *new_item, *prev_item;  {
1294      value *new_value;
1295    
1296    value *new_value= new_val(env);    if(old_value==NULL)
1297        return NULL;
1298    
1299    protect(env, old_value);    protect(old_value);
1300      new_value= new_val(env);
1301    new_value->type= old_value->type;    new_value->type= old_value->type;
1302    
1303    switch(old_value->type){    switch(old_value->type){
1304      case tfloat:
1305    case integer:    case integer:
1306      new_value->content.val= old_value->content.val;    case func:
1307      case symb:
1308        new_value->content= old_value->content;
1309      break;      break;
1310    case string:    case string:
1311      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1312        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1313      break;      break;
1314    case func:    case tcons:
   case symb:  
     new_value->content.ptr= old_value->content.ptr;  
     break;  
   case list:  
     new_value->content.ptr= NULL;  
1315    
1316      prev_item= NULL;      new_value->content.c= malloc(sizeof(cons));
1317      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
1318    
1319      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1320        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;  
     }      
1321      break;      break;
1322    }    }
1323    
1324    unprotect(env);    unprotect(old_value);
1325    
1326    return new_value;    return new_value;
1327  }  }
1328    
1329  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1330  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1331    if((env->head)==NULL) {  {
1332      if(env->head==NULL) {
1333      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1334      env->err= 1;      env->err= 1;
1335      return;      return;
1336    }    }
1337    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1338  }  }
1339    
1340  /* "if", If-Then */  /* "if", If-Then */
1341  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1342    {
1343    int truth;    int truth;
1344    
1345    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1346      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1347      env->err= 1;      env->err= 1;
1348      return;      return;
1349    }    }
1350    
1351    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1352      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1353      env->err=2;      env->err= 2;
1354      return;      return;
1355    }    }
1356        
1357    swap(env);    swap(env);
1358    if(env->err) return;    if(env->err) return;
1359        
1360    truth=env->head->item->content.val;    truth= CAR(env->head)->content.i;
1361    
1362    toss(env);    toss(env);
1363    if(env->err) return;    if(env->err) return;
# Line 1145  extern void sx_6966(environment *env) { Line 1369  extern void sx_6966(environment *env) {
1369  }  }
1370    
1371  /* If-Then-Else */  /* If-Then-Else */
1372  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1373    {
1374    int truth;    int truth;
1375    
1376    if((env->head)==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1377       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1378      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1379      env->err=1;      env->err= 1;
1380      return;      return;
1381    }    }
1382    
1383    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1384      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1385      env->err=2;      env->err= 2;
1386      return;      return;
1387    }    }
1388        
1389    rot(env);    rot(env);
1390    if(env->err) return;    if(env->err) return;
1391        
1392    truth=env->head->item->content.val;    truth= CAR(env->head)->content.i;
1393    
1394    toss(env);    toss(env);
1395    if(env->err) return;    if(env->err) return;
# Line 1180  extern void ifelse(environment *env) { Line 1404  extern void ifelse(environment *env) {
1404    eval(env);    eval(env);
1405  }  }
1406    
1407  /* "while" */  extern void sx_656c7365(environment *env)
1408  extern void sx_7768696c65(environment *env) {  {
1409      if(env->head==NULL || CDR(env->head)==NULL
1410         || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL
1411         || CDR(CDR(CDR(CDR(env->head))))==NULL) {
1412        printerr("Too Few Arguments");
1413        env->err= 1;
1414        return;
1415      }
1416    
1417      if(CAR(CDR(env->head))->type!=symb
1418         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1419         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1420         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1421        printerr("Bad Argument Type");
1422        env->err= 2;
1423        return;
1424      }
1425    
1426      swap(env); toss(env); rot(env); toss(env);
1427      ifelse(env);
1428    }
1429    
1430    extern void then(environment *env)
1431    {
1432      if(env->head==NULL || CDR(env->head)==NULL
1433         || CDR(CDR(env->head))==NULL) {
1434        printerr("Too Few Arguments");
1435        env->err= 1;
1436        return;
1437      }
1438    
1439      if(CAR(CDR(env->head))->type!=symb
1440         || strcmp(CAR(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);
1447      sx_6966(env);
1448    }
1449    
1450    /* "while" */
1451    extern void sx_7768696c65(environment *env)
1452    {
1453    int truth;    int truth;
1454    value *loop, *test;    value *loop, *test;
1455    
1456    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1457      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1458      env->err=1;      env->err= 1;
1459      return;      return;
1460    }    }
1461    
1462    loop= env->head->item;    loop= CAR(env->head);
1463    protect(env, loop);    protect(loop);
1464    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1465    
1466    test= env->head->item;    test= CAR(env->head);
1467    protect(env, test);    protect(test);
1468    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1469    
1470    do {    do {
1471      push_val(env, test);      push_val(env, test);
1472      eval(env);      eval(env);
1473            
1474      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1475        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1476        env->err= 2;        env->err= 2;
1477        return;        return;
1478      }      }
1479            
1480      truth= env->head->item->content.val;      truth= CAR(env->head)->content.i;
1481      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1482            
1483      if(truth) {      if(truth) {
# Line 1222  extern void sx_7768696c65(environment *e Line 1489  extern void sx_7768696c65(environment *e
1489        
1490    } while(truth);    } while(truth);
1491    
1492    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1493  }  }
1494    
1495    
1496  /* "for"; for-loop */  /* "for"; for-loop */
1497  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1498    {
1499    value *loop;    value *loop;
1500    int foo1, foo2;    int foo1, foo2;
1501    
1502    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1503       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1504      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1505      env->err= 1;      env->err= 1;
1506      return;      return;
1507    }    }
1508    
1509    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1510       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1511      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1512      env->err= 2;      env->err= 2;
1513      return;      return;
1514    }    }
1515    
1516    loop= env->head->item;    loop= CAR(env->head);
1517    protect(env, loop);    protect(loop);
1518    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1519    
1520    foo2= env->head->item->content.val;    foo2= CAR(env->head)->content.i;
1521    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1522    
1523    foo1= env->head->item->content.val;    foo1= CAR(env->head)->content.i;
1524    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1525    
1526    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1270  extern void sx_666f72(environment *env) Line 1538  extern void sx_666f72(environment *env)
1538        foo1--;        foo1--;
1539      }      }
1540    }    }
1541    unprotect(env);    unprotect(loop);
1542  }  }
1543    
1544  /* Variant of for-loop */  /* Variant of for-loop */
1545  extern void foreach(environment *env) {  extern void foreach(environment *env)
1546      {  
1547    value *loop, *foo;    value *loop, *foo;
1548    stackitem *iterator;    value *iterator;
1549        
1550    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1551      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1552      env->err= 1;      env->err= 1;
1553      return;      return;
1554    }    }
1555    
1556    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1557      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1558      env->err= 2;      env->err= 2;
1559      return;      return;
1560    }    }
1561    
1562    loop= env->head->item;    loop= CAR(env->head);
1563    protect(env, loop);    protect(loop);
1564    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1565    
1566    foo= env->head->item;    foo= CAR(env->head);
1567    protect(env, foo);    protect(foo);
1568    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1569    
1570    iterator= foo->content.ptr;    iterator= foo;
1571    
1572    while(iterator!=NULL) {    while(iterator!=NULL) {
1573      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1574      push_val(env, loop);      push_val(env, loop);
1575      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1576      iterator= iterator->next;      if (iterator->type == tcons){
1577          iterator= CDR(iterator);
1578        } else {
1579          printerr("Bad Argument Type"); /* Improper list */
1580          env->err= 2;
1581          break;
1582        }
1583    }    }
1584    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1585  }  }
1586    
1587  /* "to" */  /* "to" */
1588  extern void to(environment *env) {  extern void to(environment *env)
1589    int i, start, ending;  {
1590    stackitem *temp_head;    int ending, start, i;
1591    value *temp_val;    value *iterator, *temp;
1592      
1593    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1594      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1595      env->err=1;      env->err= 1;
1596      return;      return;
1597    }    }
1598    
1599    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1600       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1601      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1602      env->err=2;      env->err= 2;
1603      return;      return;
1604    }    }
1605    
1606    ending= env->head->item->content.val;    ending= CAR(env->head)->content.i;
1607    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1608    start= env->head->item->content.val;    start= CAR(env->head)->content.i;
1609    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1610    
1611    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1612    
1613    if(ending>=start) {    if(ending>=start) {
1614      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1345  extern void to(environment *env) { Line 1618  extern void to(environment *env) {
1618        push_int(env, i);        push_int(env, i);
1619    }    }
1620    
1621    temp_val= new_val(env);    iterator= env->head;
1622    temp_val->content.ptr= env->head;  
1623    temp_val->type= list;    if(iterator==NULL
1624    env->head= temp_head;       || (CAR(iterator)->type==symb
1625    push_val(env, temp_val);           && CAR(iterator)->content.sym->id[0]=='[')) {
1626        temp= NULL;
1627        toss(env);
1628      } else {
1629        /* Search for first delimiter */
1630        while(CDR(iterator)!=NULL
1631              && (CAR(CDR(iterator))->type!=symb
1632                  || CAR(CDR(iterator))->content.sym->id[0]!='['))
1633          iterator= CDR(iterator);
1634        
1635        /* Extract list */
1636        temp= env->head;
1637        env->head= CDR(iterator);
1638        CDR(iterator)= NULL;
1639    
1640        if(env->head!=NULL)
1641          toss(env);
1642      }
1643    
1644      /* Push list */
1645      push_val(env, temp);
1646  }  }
1647    
1648  /* Read a string */  /* Read a string */
1649  extern void readline(environment *env) {  extern void readline(environment *env)
1650    {
1651    char in_string[101];    char in_string[101];
1652    
1653    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1363  extern void readline(environment *env) { Line 1657  extern void readline(environment *env) {
1657  }  }
1658    
1659  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1660  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1661    {
1662    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1663    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1664    const char intform[]= "%i%n";    const char intform[]= "%i%n";
1665      const char fltform[]= "%f%n";
1666    const char blankform[]= "%*[ \t]%n";    const char blankform[]= "%*[ \t]%n";
1667    const char ebrackform[]= "]%n";    const char ebrackform[]= "]%n";
1668    const char semicform[]= ";%n";    const char semicform[]= ";%n";
1669    const char bbrackform[]= "[%n";    const char bbrackform[]= "[%n";
1670    
1671    int itemp, readlength= -1;    int itemp, readlength= -1;
1672      int count= -1;
1673      float ftemp;
1674    static int depth= 0;    static int depth= 0;
1675    char *match;    char *match, *ctemp;
1676    size_t inlength;    size_t inlength;
1677    
1678    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1383  extern void sx_72656164(environment *env Line 1681  extern void sx_72656164(environment *env
1681      }      }
1682      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1683    
1684      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1685        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1686        return;        return;
1687      }      }
1688            
1689      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1690      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1691      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1692      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1693    }    }
1694        
1695    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1696    match= malloc(inlength);    match= malloc(inlength);
1697    
1698    if(sscanf(env->in_string, blankform, &readlength)!=EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1699       && readlength != -1) {       && readlength != -1) {
1700      ;      ;
1701    } else if(sscanf(env->in_string, intform, &itemp, &readlength) != EOF    } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
1702              && readlength != -1) {              && readlength != -1) {
1703      push_int(env, itemp);      if(sscanf(env->in_string, intform, &itemp, &count) != EOF
1704           && count==readlength) {
1705          push_int(env, itemp);
1706        } else {
1707          push_float(env, ftemp);
1708        }
1709    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1710              && readlength != -1) {              && readlength != -1) {
1711      push_cstring(env, match);      push_cstring(env, match);
# Line 1424  extern void sx_72656164(environment *env Line 1727  extern void sx_72656164(environment *env
1727      free(env->free_string);      free(env->free_string);
1728      env->in_string = env->free_string = NULL;      env->in_string = env->free_string = NULL;
1729    }    }
1730    if ( env->in_string != NULL) {    if (env->in_string != NULL) {
1731      env->in_string += readlength;      env->in_string += readlength;
1732    }    }
1733    
# Line 1434  extern void sx_72656164(environment *env Line 1737  extern void sx_72656164(environment *env
1737      return sx_72656164(env);      return sx_72656164(env);
1738  }  }
1739    
1740  extern void beep(environment *env) {  #ifdef __linux__
1741    extern void beep(environment *env)
1742    {
1743    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1744    
1745    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1746      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1747      env->err=1;      env->err= 1;
1748      return;      return;
1749    }    }
1750    
1751    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1752       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1753      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1754      env->err=2;      env->err= 2;
1755      return;      return;
1756    }    }
1757    
1758    dur=env->head->item->content.val;    dur= CAR(env->head)->content.i;
1759    toss(env);    toss(env);
1760    freq=env->head->item->content.val;    freq= CAR(env->head)->content.i;
1761    toss(env);    toss(env);
1762    
1763    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1764                                     length */                                     length */
1765    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1766                                     timer ticks */                                     timer ticks */
1767    
1768  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1769    
1770    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1771    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1772    case 0:    case 0:
1773      usleep(dur);      usleep(dur);
1774      return;      return;
1775    case -1:    case -1:
1776      perror("beep");      perror("beep");
1777      env->err=5;      env->err= 5;
1778      return;      return;
1779    default:    default:
1780      abort();      abort();
1781    }    }
1782  };  }
1783    #endif /* __linux__ */
1784    
1785  /* "wait" */  /* "wait" */
1786  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1787    {
1788    int dur;    int dur;
1789    
1790    if((env->head)==NULL) {    if(env->head==NULL) {
1791      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1792      env->err=1;      env->err= 1;
1793      return;      return;
1794    }    }
1795    
1796    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1797      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1798      env->err=2;      env->err= 2;
1799      return;      return;
1800    }    }
1801    
1802    dur=env->head->item->content.val;    dur= CAR(env->head)->content.i;
1803    toss(env);    toss(env);
1804    
1805    usleep(dur);    usleep(dur);
1806  };  }
1807    
1808  extern void copying(environment *env){  extern void copying(environment *env)
1809    {
1810    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("GNU GENERAL PUBLIC LICENSE\n\
1811                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1812  \n\  \n\
# Line 1759  of preserving the free status of all der Line 2065  of preserving the free status of all der
2065  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
2066  }  }
2067    
2068  extern void warranty(environment *env){  extern void warranty(environment *env)
2069    {
2070    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
2071  \n\  \n\
2072    11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\    11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\
# Line 1787  POSSIBILITY OF SUCH DAMAGES.\n"); Line 2094  POSSIBILITY OF SUCH DAMAGES.\n");
2094  extern void sx_2a(environment *env)  extern void sx_2a(environment *env)
2095  {  {
2096    int a, b;    int a, b;
2097      float fa, fb;
2098    
2099    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2100      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2101      env->err=1;      env->err= 1;
2102      return;      return;
2103    }    }
2104        
2105    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
2106       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
2107      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
2108      env->err=2;      toss(env); if(env->err) return;
2109        b= CAR(env->head)->content.i;
2110        toss(env); if(env->err) return;
2111        push_int(env, b*a);
2112    
2113      return;      return;
2114    }    }
2115    
2116    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
2117    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
2118    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
2119    toss(env); if(env->err) return;      toss(env); if(env->err) return;
2120    push_int(env, b*a);      fb= CAR(env->head)->content.f;
2121        toss(env); if(env->err) return;
2122        push_float(env, fb*fa);
2123        
2124        return;
2125      }
2126    
2127      if(CAR(env->head)->type==tfloat
2128         && CAR(CDR(env->head))->type==integer) {
2129        fa= CAR(env->head)->content.f;
2130        toss(env); if(env->err) return;
2131        b= CAR(env->head)->content.i;
2132        toss(env); if(env->err) return;
2133        push_float(env, b*fa);
2134        
2135        return;
2136      }
2137    
2138      if(CAR(env->head)->type==integer
2139         && CAR(CDR(env->head))->type==tfloat) {
2140        a= CAR(env->head)->content.i;
2141        toss(env); if(env->err) return;
2142        fb= CAR(env->head)->content.f;
2143        toss(env); if(env->err) return;
2144        push_float(env, fb*a);
2145    
2146        return;
2147      }
2148    
2149      printerr("Bad Argument Type");
2150      env->err= 2;
2151  }  }
2152    
2153  /* "/" */  /* "/" */
2154  extern void sx_2f(environment *env)  extern void sx_2f(environment *env)
2155  {  {
2156    int a, b;    int a, b;
2157      float fa, fb;
2158    
2159    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2160      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2161      env->err=1;      env->err= 1;
2162      return;      return;
2163    }    }
2164        
2165    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
2166       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
2167      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
2168      env->err=2;      toss(env); if(env->err) return;
2169        b= CAR(env->head)->content.i;
2170        toss(env); if(env->err) return;
2171        push_float(env, b/a);
2172    
2173      return;      return;
2174    }    }
2175    
2176    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
2177    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
2178    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
2179    toss(env); if(env->err) return;      toss(env); if(env->err) return;
2180    push_int(env, b/a);      fb= CAR(env->head)->content.f;
2181        toss(env); if(env->err) return;
2182        push_float(env, fb/fa);
2183        
2184        return;
2185      }
2186    
2187      if(CAR(env->head)->type==tfloat
2188         && CAR(CDR(env->head))->type==integer) {
2189        fa= CAR(env->head)->content.f;
2190        toss(env); if(env->err) return;
2191        b= CAR(env->head)->content.i;
2192        toss(env); if(env->err) return;
2193        push_float(env, b/fa);
2194        
2195        return;
2196      }
2197    
2198      if(CAR(env->head)->type==integer
2199         && CAR(CDR(env->head))->type==tfloat) {
2200        a= CAR(env->head)->content.i;
2201        toss(env); if(env->err) return;
2202        fb= CAR(env->head)->content.f;
2203        toss(env); if(env->err) return;
2204        push_float(env, fb/a);
2205    
2206        return;
2207      }
2208    
2209      printerr("Bad Argument Type");
2210      env->err= 2;
2211  }  }
2212    
2213  /* "mod" */  /* "mod" */
# Line 1838  extern void mod(environment *env) Line 2215  extern void mod(environment *env)
2215  {  {
2216    int a, b;    int a, b;
2217    
2218    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2219      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2220      env->err=1;      env->err= 1;
2221      return;      return;
2222    }    }
2223        
2224    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
2225       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
2226      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
2227      env->err=2;      toss(env); if(env->err) return;
2228        b= CAR(env->head)->content.i;
2229        toss(env); if(env->err) return;
2230        push_int(env, b%a);
2231    
2232      return;      return;
2233    }    }
2234    
2235    a=env->head->item->content.val;    printerr("Bad Argument Type");
2236    toss(env); if(env->err) return;    env->err= 2;
2237    b=env->head->item->content.val;  }
2238    toss(env); if(env->err) return;  
2239    push_int(env, b%a);  /* "div" */
2240    extern void sx_646976(environment *env)
2241    {
2242      int a, b;
2243      
2244      if(env->head==NULL || CDR(env->head)==NULL) {
2245        printerr("Too Few Arguments");
2246        env->err= 1;
2247        return;
2248      }
2249    
2250      if(CAR(env->head)->type==integer
2251         && CAR(CDR(env->head))->type==integer) {
2252        a= CAR(env->head)->content.i;
2253        toss(env); if(env->err) return;
2254        b= CAR(env->head)->content.i;
2255        toss(env); if(env->err) return;
2256        push_int(env, (int)b/a);
2257    
2258        return;
2259      }
2260    
2261      printerr("Bad Argument Type");
2262      env->err= 2;
2263  }  }
Legend:
Removed from v.1.92  
changed lines
  Added in v.1.110
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26