/[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.117 by teddy, Wed Mar 20 05:29:29 2002 UTC
# Line 1  Line 1 
1    /* -*- coding: utf-8; -*- */
2  /*  /*
3      stack - an interactive interpreter for a stack-based language      stack - an interactive interpreter for a stack-based language
4      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
# Line 20  Line 21 
21               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
22  */  */
23    
24    #define CAR(X) ((X)->content.c->car)
25    #define CDR(X) ((X)->content.c->cdr)
26    
27  /* printf, sscanf, fgets, fprintf, fopen, perror */  /* printf, sscanf, fgets, fprintf, fopen, perror */
28  #include <stdio.h>  #include <stdio.h>
29  /* exit, EXIT_SUCCESS, malloc, free */  /* exit, EXIT_SUCCESS, malloc, free */
# Line 34  Line 38 
38  #include <unistd.h>  #include <unistd.h>
39  /* EX_NOINPUT, EX_USAGE */  /* EX_NOINPUT, EX_USAGE */
40  #include <sysexits.h>  #include <sysexits.h>
41    /* assert */
42    #include <assert.h>
43    
44    #ifdef __linux__
45  /* mtrace, muntrace */  /* mtrace, muntrace */
46  #include <mcheck.h>  #include <mcheck.h>
47  /* ioctl */  /* ioctl */
48  #include <sys/ioctl.h>  #include <sys/ioctl.h>
49  /* KDMKTONE */  /* KDMKTONE */
50  #include <linux/kd.h>  #include <linux/kd.h>
51    #endif /* __linux__ */
52    
53  #include "stack.h"  #include "stack.h"
54    
# Line 48  void init_env(environment *env) Line 57  void init_env(environment *env)
57  {  {
58    int i;    int i;
59    
60    env->gc_limit= 20;    env->gc_limit= 400000;
61    env->gc_count= 0;    env->gc_count= 0;
62    env->gc_ref= NULL;    env->gc_ref= NULL;
   env->gc_protect= NULL;  
63    
64    env->head= NULL;    env->head= new_val(env);
65    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= empty;
   
   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;
149    
150    if(val->type==list) {    if(val->type==tcons) {
151      iterator= val->content.ptr;      gc_mark(CAR(val));
152        gc_mark(CDR(val));
     while(iterator!=NULL) {  
       gc_mark(iterator->item);  
       iterator= iterator->next;  
     }  
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    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          /* Remove content */
198          switch(env->gc_ref->item->type){
199        case string:        case string:
200          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
201          break;          break;
202        case integer:        case tcons:
203          break;          free(env->gc_ref->item->content.c);
       case list:  
         while(env->gc_ref->item->content.ptr!=NULL) {  
           titem= env->gc_ref->item->content.ptr;  
           env->gc_ref->item->content.ptr= titem->next;  
           free(titem);  
         }  
         break;  
       default:  
204          break;          break;
205          case empty:
206          case integer:
207          case tfloat:
208          case func:
209          case symb:
210            /* Symbol strings are freed when walking the hash table */
211        }        }
212        free(env->gc_ref->item);  
213        titem= env->gc_ref->next;        free(env->gc_ref->item);  /* Remove from gc_ref */
       free(env->gc_ref);  
       env->gc_ref= titem;  
     } else {  
214        titem= env->gc_ref->next;        titem= env->gc_ref->next;
215        env->gc_ref->next= new_head;        free(env->gc_ref);        /* Remove value */
       new_head= env->gc_ref;  
216        env->gc_ref= titem;        env->gc_ref= titem;
217        env->gc_count++;        continue;
218      }      }
219    #ifdef DEBUG
220        printf("Kept value (%p)", env->gc_ref->item);
221        if(env->gc_ref->item->gc.flag.mark)
222          printf(" (marked)");
223        if(env->gc_ref->item->gc.flag.protect)
224          printf(" (protected)");
225        switch(env->gc_ref->item->type){
226        case integer:
227          printf(" integer: %d", env->gc_ref->item->content.i);
228          break;
229        case func:
230          printf(" func: %p", env->gc_ref->item->content.ptr);
231          break;
232        case symb:
233          printf(" symb: %s", env->gc_ref->item->content.sym->id);
234          break;
235        case tcons:
236          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
237                 env->gc_ref->item->content.c->cdr);
238          break;
239        default:
240          printf(" <unknown %d>", (env->gc_ref->item->type));
241        }
242        printf("\n");
243    #endif /* DEBUG */
244    
245        /* Keep values */    
246        env->gc_count += sizeof(value);
247        if(env->gc_ref->item->type==string)
248          env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
249        
250        titem= env->gc_ref->next;
251        env->gc_ref->next= new_head;
252        new_head= env->gc_ref;
253        new_head->item->gc.flag.mark= 0;
254        env->gc_ref= titem;
255    }    }
256    
257    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
258        env->gc_limit= env->gc_count*2;
259    
260    env->gc_ref= new_head;    env->gc_ref= new_head;
261    
262      if(env->interactive)
263        printf("done (%d bytes still allocated)\n", env->gc_count);
264    
265  }  }
266    
267  void protect(environment *env, value *val)  /* Protect values from GC */
268    void protect(value *val)
269  {  {
270    stackitem *new_item= malloc(sizeof(stackitem));    if(val==NULL || val->gc.flag.protect)
271    new_item->item= val;      return;
272    new_item->next= env->gc_protect;  
273    env->gc_protect= new_item;    val->gc.flag.protect= 1;
274    
275      if(val->type==tcons) {
276        protect(CAR(val));
277        protect(CDR(val));
278      }
279  }  }
280    
281  void unprotect(environment *env)  /* Unprotect values from GC */
282    void unprotect(value *val)
283  {  {
284    stackitem *temp= env->gc_protect;    if(val==NULL || !(val->gc.flag.protect))
285    env->gc_protect= env->gc_protect->next;      return;
286    free(temp);  
287      val->gc.flag.protect= 0;
288    
289      if(val->type==tcons) {
290        unprotect(CAR(val));
291        unprotect(CDR(val));
292      }
293  }  }
294    
295  /* Push a value onto the stack */  /* Push a value onto the stack */
296  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
297  {  {
298    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
299    new_item->item= val;  
300    new_item->next= env->head;    new_value->content.c= malloc(sizeof(pair));
301    env->head= new_item;    assert(new_value->content.c!=NULL);
302      env->gc_count += sizeof(pair);
303      new_value->type= tcons;
304      CAR(new_value)= val;
305      CDR(new_value)= env->head;
306      env->head= new_value;
307  }  }
308    
309  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
310  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
311  {  {
312    value *new_value= new_val(env);    value *new_value= new_val(env);
313        
314    new_value->content.val= in_val;    new_value->content.i= in_val;
315    new_value->type= integer;    new_value->type= integer;
316    
317    push_val(env, new_value);    push_val(env, new_value);
318  }  }
319    
320    /* Push a floating point number onto the stack */
321    void push_float(environment *env, float in_val)
322    {
323      value *new_value= new_val(env);
324    
325      new_value->content.f= in_val;
326      new_value->type= tfloat;
327    
328      push_val(env, new_value);
329    }
330    
331  /* Copy a string onto the stack. */  /* Copy a string onto the stack. */
332  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
333  {  {
334    value *new_value= new_val(env);    value *new_value= new_val(env);
335      int length= strlen(in_string)+1;
336    
337    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
338      env->gc_count += length;
339    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
340    new_value->type= string;    new_value->type= string;
341    
# Line 271  void push_cstring(environment *env, cons Line 343  void push_cstring(environment *env, cons
343  }  }
344    
345  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
346  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
347    {
348    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
349    char *new_string, *current;    char *new_string, *current;
350    
# Line 289  char *mangle_str(const char *old_string) Line 362  char *mangle_str(const char *old_string)
362    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
363  }  }
364    
365  extern void mangle(environment *env){  extern void mangle(environment *env)
366    {
367    char *new_string;    char *new_string;
368    
369    if((env->head)==NULL) {    if(env->head->type==empty) {
370      printerr("Too Few Arguments");      printerr("Too Few Arguments");
371      env->err= 1;      env->err= 1;
372      return;      return;
373    }    }
374    
375    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
376      printerr("Bad Argument Type");      printerr("Bad Argument Type");
377      env->err= 2;      env->err= 2;
378      return;      return;
379    }    }
380    
381    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
382        mangle_str((const char *)(CAR(env->head)->content.ptr));
383    
384    toss(env);    toss(env);
385    if(env->err) return;    if(env->err) return;
# Line 328  void push_sym(environment *env, const ch Line 403  void push_sym(environment *env, const ch
403    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
404    
405    new_value= new_val(env);    new_value= new_val(env);
406      protect(new_value);
407      new_fvalue= new_val(env);
408      protect(new_fvalue);
409    
410    /* The new value is a symbol */    /* The new value is a symbol */
411    new_value->type= symb;    new_value->type= symb;
# Line 355  void push_sym(environment *env, const ch Line 433  void push_sym(environment *env, const ch
433    
434      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
435      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
436      free(mangled);  
437      dlerr= dlerror();      dlerr= dlerror();
438      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
439        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
440        dlerr= dlerror();        dlerr= dlerror();
441      }      }
442    
443      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 */  
444        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
445        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
446        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
447                                           function value */                                           function value */
448      }      }
449    
450        free(mangled);
451    }    }
452    
453    push_val(env, new_value);    push_val(env, new_value);
454      unprotect(new_value); unprotect(new_fvalue);
455  }  }
456    
457  /* Print newline. */  /* Print newline. */
# Line 379  extern void nl() Line 461  extern void nl()
461  }  }
462    
463  /* Gets the type of a value */  /* Gets the type of a value */
464  extern void type(environment *env){  extern void type(environment *env)
465    int typenum;  {
466      if(env->head->type==empty) {
   if((env->head)==NULL) {  
467      printerr("Too Few Arguments");      printerr("Too Few Arguments");
468      env->err=1;      env->err= 1;
469      return;      return;
470    }    }
471    typenum=env->head->item->type;  
472    toss(env);    switch(CAR(env->head)->type){
473    switch(typenum){    case empty:
474        push_sym(env, "empty");
475        break;
476    case integer:    case integer:
477      push_sym(env, "integer");      push_sym(env, "integer");
478      break;      break;
479      case tfloat:
480        push_sym(env, "float");
481        break;
482    case string:    case string:
483      push_sym(env, "string");      push_sym(env, "string");
484      break;      break;
# Line 402  extern void type(environment *env){ Line 488  extern void type(environment *env){
488    case func:    case func:
489      push_sym(env, "function");      push_sym(env, "function");
490      break;      break;
491    case list:    case tcons:
492      push_sym(env, "list");      push_sym(env, "pair");
493      break;      break;
494    }    }
495      swap(env);
496      if (env->err) return;
497      toss(env);
498  }      }    
499    
500  /* Prints the top element of the stack. */  /* Print a value */
501  void print_h(stackitem *stack_head, int noquote)  void print_val(value *val, int noquote, stackitem *stack)
502  {  {
503    switch(stack_head->item->type) {    stackitem *titem, *tstack;
504      int depth;
505    
506      switch(val->type) {
507      case empty:
508        printf("[]");
509        break;
510    case integer:    case integer:
511      printf("%d", stack_head->item->content.val);      printf("%d", val->content.i);
512        break;
513      case tfloat:
514        printf("%f", val->content.f);
515      break;      break;
516    case string:    case string:
517      if(noquote)      if(noquote)
518        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)(val->content.ptr));
519      else      else
520        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)(val->content.ptr));
521      break;      break;
522    case symb:    case symb:
523      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", val->content.sym->id);
524      break;      break;
525    case func:    case func:
526      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(val->content.ptr));
527      break;      break;
528    case list:    case tcons:
     /* A list is just a stack, so make stack_head point to it */  
     stack_head=(stackitem *)(stack_head->item->content.ptr);  
529      printf("[ ");      printf("[ ");
530      while(stack_head != NULL) {      tstack= stack;
531        print_h(stack_head, noquote);      do {
532        printf(" ");        titem=malloc(sizeof(stackitem));
533        stack_head=stack_head->next;        titem->item=val;
534          titem->next=tstack;
535          tstack=titem;             /* Put it on the stack */
536          /* Search a stack of values being printed to see if we are already
537             printing this value */
538          titem=tstack;
539          depth=0;
540          while(titem != NULL && titem->item != CAR(val)){
541            titem=titem->next;
542            depth++;
543          }
544          if(titem != NULL){        /* If we found it on the stack, */
545            printf("#%d#", depth);  /* print a depth reference */
546          } else {
547            print_val(CAR(val), noquote, tstack);
548          }
549          val= CDR(val);
550          switch(val->type){
551          case empty:
552            break;
553          case tcons:
554            /* Search a stack of values being printed to see if we are already
555               printing this value */
556            titem=tstack;
557            depth=0;
558            while(titem != NULL && titem->item != val){
559              titem=titem->next;
560              depth++;
561            }
562            if(titem != NULL){      /* If we found it on the stack, */
563              printf(" . #%d#", depth); /* print a depth reference */
564            } else {
565              printf(" ");
566            }
567            break;
568          default:
569            printf(" . ");          /* Improper list */
570            print_val(val, noquote, tstack);
571          }
572        } while(val->type == tcons && titem == NULL);
573        titem=tstack;
574        while(titem != stack){
575          tstack=titem->next;
576          free(titem);
577          titem=tstack;
578      }      }
579      printf("]");      printf(" ]");
580      break;      break;
581    }    }
582  }  }
583    
584  extern void print_(environment *env) {  extern void print_(environment *env)
585    if(env->head==NULL) {  {
586      if(env->head->type==empty) {
587      printerr("Too Few Arguments");      printerr("Too Few Arguments");
588      env->err=1;      env->err= 1;
589      return;      return;
590    }    }
591    print_h(env->head, 0);    print_val(CAR(env->head), 0, NULL);
592    nl();    nl();
593  }  }
594    
# Line 459  extern void print(environment *env) Line 600  extern void print(environment *env)
600    toss(env);    toss(env);
601  }  }
602    
603  extern void princ_(environment *env) {  extern void princ_(environment *env)
604    if(env->head==NULL) {  {
605      if(env->head->type==empty) {
606      printerr("Too Few Arguments");      printerr("Too Few Arguments");
607      env->err=1;      env->err= 1;
608      return;      return;
609    }    }
610    print_h(env->head, 1);    print_val(CAR(env->head), 1, NULL);
611  }  }
612    
613  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack and then discards it. */
# Line 477  extern void princ(environment *env) Line 619  extern void princ(environment *env)
619  }  }
620    
621  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
622  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
623  {  {
624    if(stack_head->next != NULL)    if(CDR(stack_head)->type != empty)
625      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
626    printf("%ld: ", counter);    printf("%ld: ", counter);
627    print_h(stack_head, 0);    print_val(CAR(stack_head), 0, NULL);
628    nl();    nl();
629  }  }
630    
631  /* Prints the stack. */  /* Prints the stack. */
632  extern void printstack(environment *env)  extern void printstack(environment *env)
633  {  {
634    if(env->head == NULL) {    if(env->head->type == empty) {
635      printf("Stack Empty\n");      printf("Stack Empty\n");
636      return;      return;
637    }    }
638    
639    print_st(env->head, 1);    print_st(env->head, 1);
640  }  }
641    
642  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
643  extern void swap(environment *env)  extern void swap(environment *env)
644  {  {
645    stackitem *temp= env->head;    value *temp= env->head;
646        
647    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
648      printerr("Too Few Arguments");      printerr("Too Few Arguments");
649      env->err=1;      env->err=1;
650      return;      return;
651    }    }
652    
653    env->head= env->head->next;    env->head= CDR(env->head);
654    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
655    env->head->next= temp;    CDR(env->head)= temp;
656  }  }
657    
658  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
659  extern void rot(environment *env)  extern void rot(environment *env)
660  {  {
661    stackitem *temp= env->head;    value *temp= env->head;
662        
663    if(env->head==NULL || env->head->next==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
664        || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type == empty) {
665      printerr("Too Few Arguments");      printerr("Too Few Arguments");
666      env->err=1;      env->err= 1;
667      return;      return;
668    }    }
669      
670    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
671    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
672    env->head->next= temp;    CDR(env->head)= temp;
673  }  }
674    
675  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 534  extern void rcl(environment *env) Line 677  extern void rcl(environment *env)
677  {  {
678    value *val;    value *val;
679    
680    if(env->head == NULL) {    if(env->head->type==empty) {
681      printerr("Too Few Arguments");      printerr("Too Few Arguments");
682      env->err=1;      env->err= 1;
683      return;      return;
684    }    }
685    
686    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
687      printerr("Bad Argument Type");      printerr("Bad Argument Type");
688      env->err=2;      env->err= 2;
689      return;      return;
690    }    }
691    
692    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
693    if(val == NULL){    if(val == NULL){
694      printerr("Unbound Variable");      printerr("Unbound Variable");
695      env->err=3;      env->err= 3;
696      return;      return;
697    }    }
698    protect(env, val);    push_val(env, val);           /* Return the symbol's bound value */
699    toss(env);            /* toss the symbol */    swap(env);
700      if(env->err) return;
701      toss(env);                    /* toss the symbol */
702    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(env);  
703  }  }
704    
705  /* 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 709  extern void eval(environment *env)
709  {  {
710    funcp in_func;    funcp in_func;
711    value* temp_val;    value* temp_val;
712    stackitem* iterator;    value* iterator;
713    
714   eval_start:   eval_start:
715    
716    if(env->head==NULL) {    gc_maybe(env);
717    
718      if(env->head->type==empty) {
719      printerr("Too Few Arguments");      printerr("Too Few Arguments");
720      env->err=1;      env->err= 1;
721      return;      return;
722    }    }
723    
724    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
725      /* if it's a symbol */      /* if it's a symbol */
726    case symb:    case symb:
727      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
728      if(env->err) return;      if(env->err) return;
729      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
730        goto eval_start;        goto eval_start;
731      }      }
732      return;      return;
733    
734      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
735    case func:    case func:
736      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
737      toss(env);      toss(env);
738      if(env->err) return;      if(env->err) return;
739      return in_func(env);      return in_func(env);
740    
741      /* If it's a list */      /* If it's a list */
742    case list:    case tcons:
743      temp_val= env->head->item;      temp_val= CAR(env->head);
744      protect(env, temp_val);      protect(temp_val);
745      toss(env);  
746      if(env->err) return;      toss(env); if(env->err) return;
747      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
     unprotect(env);  
748            
749      while(iterator!=NULL) {      while(iterator->type != empty) {
750        push_val(env, iterator->item);        push_val(env, CAR(iterator));
751                
752        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
753          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && CAR(env->head)->content.sym->id[0]==';') {
754          toss(env);          toss(env);
755          if(env->err) return;          if(env->err) return;
756                    
757          if(iterator->next == NULL){          if(CDR(iterator)->type == empty){
758            goto eval_start;            goto eval_start;
759          }          }
760          eval(env);          eval(env);
761          if(env->err) return;          if(env->err) return;
762        }        }
763        iterator= iterator->next;        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
764            iterator= CDR(iterator);
765          else {
766            printerr("Bad Argument Type"); /* Improper list */
767            env->err= 2;
768            return;
769          }
770      }      }
771        unprotect(temp_val);
772      return;      return;
773    
774    default:    case empty:
775      case integer:
776      case tfloat:
777      case string:
778      return;      return;
779    }    }
780  }  }
781    
782  /* Reverse (flip) a list */  /* Reverse (flip) a list */
783  extern void rev(environment *env){  extern void rev(environment *env)
784    stackitem *old_head, *new_head, *item;  {
785      value *old_head, *new_head, *item;
786    
787    if((env->head)==NULL) {    if(env->head->type==empty) {
788      printerr("Too Few Arguments");      printerr("Too Few Arguments");
789      env->err= 1;      env->err= 1;
790      return;      return;
791    }    }
792    
793    if(env->head->item->type!=list) {    if(CAR(env->head)->type==empty)
794        return;                     /* Don't reverse an empty list */
795    
796      if(CAR(env->head)->type!=tcons) {
797      printerr("Bad Argument Type");      printerr("Bad Argument Type");
798      env->err= 2;      env->err= 2;
799      return;      return;
800    }    }
801    
802    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
803    new_head= NULL;    new_head= new_val(env);
804    while(old_head != NULL){    while(old_head->type != empty) {
805      item= old_head;      item= old_head;
806      old_head= old_head->next;      old_head= CDR(old_head);
807      item->next= new_head;      CDR(item)= new_head;
808      new_head= item;      new_head= item;
809    }    }
810    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
811  }  }
812    
813  /* Make a list. */  /* Make a list. */
814  extern void pack(environment *env)  extern void pack(environment *env)
815  {  {
816    stackitem *iterator, *temp;    value *iterator, *temp, *ending;
   value *pack;  
817    
818    iterator= env->head;    ending=new_val(env);
819    
820    if(iterator==NULL    iterator= env->head;
821       || (iterator->item->type==symb    if(iterator->type == empty
822       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       || (CAR(iterator)->type==symb
823      temp= NULL;       && CAR(iterator)->content.sym->id[0]=='[')) {
824        temp= ending;
825      toss(env);      toss(env);
826    } else {    } else {
827      /* Search for first delimiter */      /* Search for first delimiter */
828      while(iterator->next!=NULL      while(CDR(iterator)->type != empty
829            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
830            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
831        iterator= iterator->next;        iterator= CDR(iterator);
832            
833      /* Extract list */      /* Extract list */
834      temp= env->head;      temp= env->head;
835      env->head= iterator->next;      env->head= CDR(iterator);
836      iterator->next= NULL;      CDR(iterator)= ending;
837        
838      if(env->head!=NULL)      if(env->head->type != empty)
839        toss(env);        toss(env);
840    }    }
841    
842    /* Push list */    /* Push list */
   pack= new_val(env);  
   pack->type= list;  
   pack->content.ptr= temp;  
843    
844    push_val(env, pack);    push_val(env, temp);
845    rev(env);    rev(env);
846  }  }
847    
848  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
849  extern void expand(environment *env)  extern void expand(environment *env)
850  {  {
851    stackitem *temp, *new_head;    value *temp, *new_head;
852    
853    /* Is top element a list? */    /* Is top element a list? */
854    if(env->head==NULL) {    if(env->head->type==empty) {
855      printerr("Too Few Arguments");      printerr("Too Few Arguments");
856      env->err= 1;      env->err= 1;
857      return;      return;
858    }    }
859    if(env->head->item->type!=list) {  
860      if(CAR(env->head)->type!=tcons) {
861      printerr("Bad Argument Type");      printerr("Bad Argument Type");
862      env->err= 2;      env->err= 2;
863      return;      return;
# Line 713  extern void expand(environment *env) Line 869  extern void expand(environment *env)
869      return;      return;
870    
871    /* The first list element is the new stack head */    /* The first list element is the new stack head */
872    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
873    
874    toss(env);    toss(env);
875    
876    /* Find the end of the list */    /* Find the end of the list */
877    while(temp->next!=NULL)    while(CDR(temp)->type != empty) {
878      temp= temp->next;      if (CDR(temp)->type == tcons)
879          temp= CDR(temp);
880        else {
881          printerr("Bad Argument Type"); /* Improper list */
882          env->err= 2;
883          return;
884        }
885      }
886    
887    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
888    temp->next= env->head;    CDR(temp)= env->head;
889    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
890    
891  }  }
# Line 731  extern void expand(environment *env) Line 894  extern void expand(environment *env)
894  extern void eq(environment *env)  extern void eq(environment *env)
895  {  {
896    void *left, *right;    void *left, *right;
   int result;  
897    
898    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
899      printerr("Too Few Arguments");      printerr("Too Few Arguments");
900      env->err= 1;      env->err= 1;
901      return;      return;
902    }    }
903    
904    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
905    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
906    toss(env); toss(env);    toss(env); toss(env);
907    push_int(env, result);  
908      push_int(env, left==right);
909  }  }
910    
911  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 753  extern void not(environment *env) Line 913  extern void not(environment *env)
913  {  {
914    int val;    int val;
915    
916    if((env->head)==NULL) {    if(env->head->type==empty) {
917      printerr("Too Few Arguments");      printerr("Too Few Arguments");
918      env->err= 1;      env->err= 1;
919      return;      return;
920    }    }
921    
922    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
923      printerr("Bad Argument Type");      printerr("Bad Argument Type");
924      env->err= 2;      env->err= 2;
925      return;      return;
926    }    }
927    
928    val= env->head->item->content.val;    val= CAR(env->head)->content.i;
929    toss(env);    toss(env);
930    push_int(env, !val);    push_int(env, !val);
931  }  }
# Line 784  extern void def(environment *env) Line 944  extern void def(environment *env)
944    symbol *sym;    symbol *sym;
945    
946    /* 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 */
947    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
948      printerr("Too Few Arguments");      printerr("Too Few Arguments");
949      env->err= 1;      env->err= 1;
950      return;      return;
951    }    }
952    
953    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
954      printerr("Bad Argument Type");      printerr("Bad Argument Type");
955      env->err= 2;      env->err= 2;
956      return;      return;
957    }    }
958    
959    /* long names are a pain */    /* long names are a pain */
960    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
961    
962    /* Bind the symbol to the value */    /* Bind the symbol to the value */
963    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
964    
965    toss(env); toss(env);    toss(env); toss(env);
966  }  }
# Line 808  extern void def(environment *env) Line 968  extern void def(environment *env)
968  /* Quit stack. */  /* Quit stack. */
969  extern void quit(environment *env)  extern void quit(environment *env)
970  {  {
971    long i;    int i;
972    
973    clear(env);    clear(env);
974    
# Line 821  extern void quit(environment *env) Line 981  extern void quit(environment *env)
981    }    }
982    
983    env->gc_limit= 0;    env->gc_limit= 0;
984    gc_init(env);    gc_maybe(env);
985    
986      words(env);
987    
988    if(env->free_string!=NULL)    if(env->free_string!=NULL)
989      free(env->free_string);      free(env->free_string);
990        
991    #ifdef __linux__
992    muntrace();    muntrace();
993    #endif
994    
995    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
996  }  }
# Line 834  extern void quit(environment *env) Line 998  extern void quit(environment *env)
998  /* Clear stack */  /* Clear stack */
999  extern void clear(environment *env)  extern void clear(environment *env)
1000  {  {
1001    while(env->head!=NULL)    while(env->head->type != empty)
1002      toss(env);      toss(env);
1003  }  }
1004    
# Line 847  extern void words(environment *env) Line 1011  extern void words(environment *env)
1011    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
1012      temp= env->symbols[i];      temp= env->symbols[i];
1013      while(temp!=NULL) {      while(temp!=NULL) {
1014    #ifdef DEBUG
1015          if (temp->val != NULL && temp->val->gc.flag.protect)
1016            printf("(protected) ");
1017    #endif /* DEBUG */
1018        printf("%s\n", temp->id);        printf("%s\n", temp->id);
1019        temp= temp->next;        temp= temp->next;
1020      }      }
# Line 854  extern void words(environment *env) Line 1022  extern void words(environment *env)
1022  }  }
1023    
1024  /* Internal forget function */  /* Internal forget function */
1025  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
1026    {
1027    symbol *temp;    symbol *temp;
1028    
1029    temp= *hash_entry;    temp= *hash_entry;
# Line 868  void forget_sym(symbol **hash_entry) { Line 1037  void forget_sym(symbol **hash_entry) {
1037  extern void forget(environment *env)  extern void forget(environment *env)
1038  {  {
1039    char* sym_id;    char* sym_id;
   stackitem *stack_head= env->head;  
1040    
1041    if(stack_head==NULL) {    if(env->head->type==empty) {
1042      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1043      env->err=1;      env->err= 1;
1044      return;      return;
1045    }    }
1046        
1047    if(stack_head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
1048      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1049      env->err=2;      env->err= 2;
1050      return;      return;
1051    }    }
1052    
1053    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(env->head)->content.sym->id;
1054    toss(env);    toss(env);
1055    
1056    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
1057  }  }
1058    
1059  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
1060  extern void errn(environment *env){  extern void errn(environment *env)
1061    {
1062    push_int(env, env->err);    push_int(env, env->err);
1063  }  }
1064    
# Line 899  int main(int argc, char **argv) Line 1068  int main(int argc, char **argv)
1068    
1069    int c;                        /* getopt option character */    int c;                        /* getopt option character */
1070    
1071    #ifdef __linux__
1072    mtrace();    mtrace();
1073    #endif
1074    
1075    init_env(&myenv);    init_env(&myenv);
1076    
# Line 913  int main(int argc, char **argv) Line 1084  int main(int argc, char **argv)
1084          break;          break;
1085        case '?':        case '?':
1086          fprintf (stderr,          fprintf (stderr,
1087                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1088                   optopt);                   optopt);
1089          return EX_USAGE;          return EX_USAGE;
1090        default:        default:
# Line 932  int main(int argc, char **argv) Line 1103  int main(int argc, char **argv)
1103    if(myenv.interactive) {    if(myenv.interactive) {
1104      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1105  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1106  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1107  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1108  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1109    }    }
1110    
1111    while(1) {    while(1) {
# Line 949  under certain conditions; type `copying; Line 1120  under certain conditions; type `copying;
1120        }        }
1121        myenv.err=0;        myenv.err=0;
1122      }      }
1123      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1124      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1125        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1126      } else if(myenv.head!=NULL        quit(&myenv);
1127                && myenv.head->item->type==symb      } else if(myenv.head->type!=empty
1128                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->type==symb
1129                  && CAR(myenv.head)->content.sym->id[0]
1130                  ==';') {
1131        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1132        eval(&myenv);        eval(&myenv);
1133      }      }
1134      gc_init(&myenv);      gc_maybe(&myenv);
1135    }    }
1136    quit(&myenv);    quit(&myenv);
1137    return EXIT_FAILURE;    return EXIT_FAILURE;
1138  }  }
1139    
1140  /* "+" */  /* "+" */
1141  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1142    {
1143    int a, b;    int a, b;
1144      float fa, fb;
1145    size_t len;    size_t len;
1146    char* new_string;    char* new_string;
1147    value *a_val, *b_val;    value *a_val, *b_val;
1148    
1149    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1150      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1151      env->err= 1;      env->err= 1;
1152      return;      return;
1153    }    }
1154    
1155    if(env->head->item->type==string    if(CAR(env->head)->type==string
1156       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1157      a_val= env->head->item;      a_val= CAR(env->head);
1158      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1159      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1160      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1161      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1162      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 1164  extern void sx_2b(environment *env) {
1164      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1165      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1166      push_cstring(env, new_string);      push_cstring(env, new_string);
1167      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1168      free(new_string);      free(new_string);
1169        
1170      return;      return;
1171    }    }
1172        
1173    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1174       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1175      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1176      env->err=2;      toss(env); if(env->err) return;
1177        b= CAR(env->head)->content.i;
1178        toss(env); if(env->err) return;
1179        push_int(env, b+a);
1180    
1181      return;      return;
1182    }    }
1183    a= env->head->item->content.val;  
1184    toss(env); if(env->err) return;    if(CAR(env->head)->type==tfloat
1185           && CAR(CDR(env->head))->type==tfloat) {
1186    b= env->head->item->content.val;      fa= CAR(env->head)->content.f;
1187    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1188    push_int(env, a+b);      fb= CAR(env->head)->content.f;
1189        toss(env); if(env->err) return;
1190        push_float(env, fb+fa);
1191        
1192        return;
1193      }
1194    
1195      if(CAR(env->head)->type==tfloat
1196         && CAR(CDR(env->head))->type==integer) {
1197        fa= CAR(env->head)->content.f;
1198        toss(env); if(env->err) return;
1199        b= CAR(env->head)->content.i;
1200        toss(env); if(env->err) return;
1201        push_float(env, b+fa);
1202        
1203        return;
1204      }
1205    
1206      if(CAR(env->head)->type==integer
1207         && CAR(CDR(env->head))->type==tfloat) {
1208        a= CAR(env->head)->content.i;
1209        toss(env); if(env->err) return;
1210        fb= CAR(env->head)->content.f;
1211        toss(env); if(env->err) return;
1212        push_float(env, fb+a);
1213    
1214        return;
1215      }
1216    
1217      printerr("Bad Argument Type");
1218      env->err=2;
1219  }  }
1220    
1221  /* "-" */  /* "-" */
1222  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1223    {
1224    int a, b;    int a, b;
1225      float fa, fb;
1226    
1227    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1228      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1229      env->err=1;      env->err=1;
1230      return;      return;
1231    }    }
1232        
1233    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1234       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1235      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1236      env->err=2;      toss(env); if(env->err) return;
1237        b= CAR(env->head)->content.i;
1238        toss(env); if(env->err) return;
1239        push_int(env, b-a);
1240    
1241      return;      return;
1242    }    }
1243    
1244    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
1245    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
1246    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
1247    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1248    push_int(env, b-a);      fb= CAR(env->head)->content.f;
1249        toss(env); if(env->err) return;
1250        push_float(env, fb-fa);
1251        
1252        return;
1253      }
1254    
1255      if(CAR(env->head)->type==tfloat
1256         && CAR(CDR(env->head))->type==integer) {
1257        fa= CAR(env->head)->content.f;
1258        toss(env); if(env->err) return;
1259        b= CAR(env->head)->content.i;
1260        toss(env); if(env->err) return;
1261        push_float(env, b-fa);
1262        
1263        return;
1264      }
1265    
1266      if(CAR(env->head)->type==integer
1267         && CAR(CDR(env->head))->type==tfloat) {
1268        a= CAR(env->head)->content.i;
1269        toss(env); if(env->err) return;
1270        fb= CAR(env->head)->content.f;
1271        toss(env); if(env->err) return;
1272        push_float(env, fb-a);
1273    
1274        return;
1275      }
1276    
1277      printerr("Bad Argument Type");
1278      env->err=2;
1279  }  }
1280    
1281  /* ">" */  /* ">" */
1282  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1283    {
1284    int a, b;    int a, b;
1285      float fa, fb;
1286    
1287    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1288      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1289      env->err=1;      env->err= 1;
1290      return;      return;
1291    }    }
1292        
1293    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
1294       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
1295      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
1296      env->err=2;      toss(env); if(env->err) return;
1297        b= CAR(env->head)->content.i;
1298        toss(env); if(env->err) return;
1299        push_int(env, b>a);
1300    
1301      return;      return;
1302    }    }
1303    
1304    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
1305    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
1306    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
1307    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1308    push_int(env, b>a);      fb= CAR(env->head)->content.f;
1309        toss(env); if(env->err) return;
1310        push_int(env, fb>fa);
1311        
1312        return;
1313      }
1314    
1315      if(CAR(env->head)->type==tfloat
1316         && CAR(CDR(env->head))->type==integer) {
1317        fa= CAR(env->head)->content.f;
1318        toss(env); if(env->err) return;
1319        b= CAR(env->head)->content.i;
1320        toss(env); if(env->err) return;
1321        push_int(env, b>fa);
1322        
1323        return;
1324      }
1325    
1326      if(CAR(env->head)->type==integer
1327         && CAR(CDR(env->head))->type==tfloat) {
1328        a= CAR(env->head)->content.i;
1329        toss(env); if(env->err) return;
1330        fb= CAR(env->head)->content.f;
1331        toss(env); if(env->err) return;
1332        push_int(env, fb>a);
1333    
1334        return;
1335      }
1336    
1337      printerr("Bad Argument Type");
1338      env->err= 2;
1339    }
1340    
1341    /* "<" */
1342    extern void sx_3c(environment *env)
1343    {
1344      swap(env); if(env->err) return;
1345      sx_3e(env);
1346    }
1347    
1348    /* "<=" */
1349    extern void sx_3c3d(environment *env)
1350    {
1351      sx_3e(env); if(env->err) return;
1352      not(env);
1353    }
1354    
1355    /* ">=" */
1356    extern void sx_3e3d(environment *env)
1357    {
1358      sx_3c(env); if(env->err) return;
1359      not(env);
1360  }  }
1361    
1362  /* Return copy of a value */  /* Return copy of a value */
1363  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1364    stackitem *old_item, *new_item, *prev_item;  {
1365      value *new_value;
1366    
1367    value *new_value= new_val(env);    if(old_value==NULL)
1368        return NULL;
1369    
1370    protect(env, old_value);    protect(old_value);
1371      new_value= new_val(env);
1372    new_value->type= old_value->type;    new_value->type= old_value->type;
1373    
1374    switch(old_value->type){    switch(old_value->type){
1375      case tfloat:
1376    case integer:    case integer:
1377      new_value->content.val= old_value->content.val;    case func:
1378      case symb:
1379      case empty:
1380        new_value->content= old_value->content;
1381      break;      break;
1382    case string:    case string:
1383      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1384        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1385      break;      break;
1386    case func:    case tcons:
   case symb:  
     new_value->content.ptr= old_value->content.ptr;  
     break;  
   case list:  
     new_value->content.ptr= NULL;  
1387    
1388      prev_item= NULL;      new_value->content.c= malloc(sizeof(pair));
1389      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
1390        env->gc_count += sizeof(pair);
1391    
1392      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1393        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;  
     }      
1394      break;      break;
1395    }    }
1396    
1397    unprotect(env);    unprotect(old_value);
1398    
1399    return new_value;    return new_value;
1400  }  }
1401    
1402  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1403  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1404    if((env->head)==NULL) {  {
1405      if(env->head->type==empty) {
1406      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1407      env->err= 1;      env->err= 1;
1408      return;      return;
1409    }    }
1410    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1411  }  }
1412    
1413  /* "if", If-Then */  /* "if", If-Then */
1414  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1415    {
1416    int truth;    int truth;
1417    
1418    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1419      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1420      env->err= 1;      env->err= 1;
1421      return;      return;
1422    }    }
1423    
1424    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1425      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1426      env->err=2;      env->err= 2;
1427      return;      return;
1428    }    }
1429        
1430    swap(env);    swap(env);
1431    if(env->err) return;    if(env->err) return;
1432        
1433    truth=env->head->item->content.val;    truth= CAR(env->head)->content.i;
1434    
1435    toss(env);    toss(env);
1436    if(env->err) return;    if(env->err) return;
# Line 1145  extern void sx_6966(environment *env) { Line 1442  extern void sx_6966(environment *env) {
1442  }  }
1443    
1444  /* If-Then-Else */  /* If-Then-Else */
1445  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1446    {
1447    int truth;    int truth;
1448    
1449    if((env->head)==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1450       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1451      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1452      env->err=1;      env->err= 1;
1453      return;      return;
1454    }    }
1455    
1456    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1457      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1458      env->err=2;      env->err= 2;
1459      return;      return;
1460    }    }
1461        
1462    rot(env);    rot(env);
1463    if(env->err) return;    if(env->err) return;
1464        
1465    truth=env->head->item->content.val;    truth= CAR(env->head)->content.i;
1466    
1467    toss(env);    toss(env);
1468    if(env->err) return;    if(env->err) return;
# Line 1180  extern void ifelse(environment *env) { Line 1477  extern void ifelse(environment *env) {
1477    eval(env);    eval(env);
1478  }  }
1479    
1480  /* "while" */  extern void sx_656c7365(environment *env)
1481  extern void sx_7768696c65(environment *env) {  {
1482      if(env->head->type==empty || CDR(env->head)->type==empty
1483         || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1484         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1485        printerr("Too Few Arguments");
1486        env->err= 1;
1487        return;
1488      }
1489    
1490      if(CAR(CDR(env->head))->type!=symb
1491         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1492         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1493         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1494        printerr("Bad Argument Type");
1495        env->err= 2;
1496        return;
1497      }
1498    
1499      swap(env); toss(env); rot(env); toss(env);
1500      ifelse(env);
1501    }
1502    
1503    extern void then(environment *env)
1504    {
1505      if(env->head->type==empty || CDR(env->head)->type==empty
1506         || CDR(CDR(env->head))->type==empty) {
1507        printerr("Too Few Arguments");
1508        env->err= 1;
1509        return;
1510      }
1511    
1512      if(CAR(CDR(env->head))->type!=symb
1513         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1514        printerr("Bad Argument Type");
1515        env->err= 2;
1516        return;
1517      }
1518    
1519      swap(env); toss(env);
1520      sx_6966(env);
1521    }
1522    
1523    /* "while" */
1524    extern void sx_7768696c65(environment *env)
1525    {
1526    int truth;    int truth;
1527    value *loop, *test;    value *loop, *test;
1528    
1529    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1530      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1531      env->err=1;      env->err= 1;
1532      return;      return;
1533    }    }
1534    
1535    loop= env->head->item;    loop= CAR(env->head);
1536    protect(env, loop);    protect(loop);
1537    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1538    
1539    test= env->head->item;    test= CAR(env->head);
1540    protect(env, test);    protect(test);
1541    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1542    
1543    do {    do {
1544      push_val(env, test);      push_val(env, test);
1545      eval(env);      eval(env);
1546            
1547      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1548        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1549        env->err= 2;        env->err= 2;
1550        return;        return;
1551      }      }
1552            
1553      truth= env->head->item->content.val;      truth= CAR(env->head)->content.i;
1554      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1555            
1556      if(truth) {      if(truth) {
# Line 1222  extern void sx_7768696c65(environment *e Line 1562  extern void sx_7768696c65(environment *e
1562        
1563    } while(truth);    } while(truth);
1564    
1565    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1566  }  }
1567    
1568    
1569  /* "for"; for-loop */  /* "for"; for-loop */
1570  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1571    {
1572    value *loop;    value *loop;
1573    int foo1, foo2;    int foo1, foo2;
1574    
1575    if(env->head==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1576       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1577      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1578      env->err= 1;      env->err= 1;
1579      return;      return;
1580    }    }
1581    
1582    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1583       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1584      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1585      env->err= 2;      env->err= 2;
1586      return;      return;
1587    }    }
1588    
1589    loop= env->head->item;    loop= CAR(env->head);
1590    protect(env, loop);    protect(loop);
1591    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1592    
1593    foo2= env->head->item->content.val;    foo2= CAR(env->head)->content.i;
1594    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1595    
1596    foo1= env->head->item->content.val;    foo1= CAR(env->head)->content.i;
1597    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1598    
1599    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1270  extern void sx_666f72(environment *env) Line 1611  extern void sx_666f72(environment *env)
1611        foo1--;        foo1--;
1612      }      }
1613    }    }
1614    unprotect(env);    unprotect(loop);
1615  }  }
1616    
1617  /* Variant of for-loop */  /* Variant of for-loop */
1618  extern void foreach(environment *env) {  extern void foreach(environment *env)
1619      {  
1620    value *loop, *foo;    value *loop, *foo;
1621    stackitem *iterator;    value *iterator;
1622        
1623    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1624      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1625      env->err= 1;      env->err= 1;
1626      return;      return;
1627    }    }
1628    
1629    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1630      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1631      env->err= 2;      env->err= 2;
1632      return;      return;
1633    }    }
1634    
1635    loop= env->head->item;    loop= CAR(env->head);
1636    protect(env, loop);    protect(loop);
1637    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1638    
1639    foo= env->head->item;    foo= CAR(env->head);
1640    protect(env, foo);    protect(foo);
1641    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1642    
1643    iterator= foo->content.ptr;    iterator= foo;
1644    
1645    while(iterator!=NULL) {    while(iterator!=NULL) {
1646      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1647      push_val(env, loop);      push_val(env, loop);
1648      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1649      iterator= iterator->next;      if (iterator->type == tcons){
1650          iterator= CDR(iterator);
1651        } else {
1652          printerr("Bad Argument Type"); /* Improper list */
1653          env->err= 2;
1654          break;
1655        }
1656    }    }
1657    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1658  }  }
1659    
1660  /* "to" */  /* "to" */
1661  extern void to(environment *env) {  extern void to(environment *env)
1662    int i, start, ending;  {
1663    stackitem *temp_head;    int ending, start, i;
1664    value *temp_val;    value *iterator, *temp;
1665      
1666    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1667      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1668      env->err=1;      env->err= 1;
1669      return;      return;
1670    }    }
1671    
1672    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1673       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1674      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1675      env->err=2;      env->err= 2;
1676      return;      return;
1677    }    }
1678    
1679    ending= env->head->item->content.val;    ending= CAR(env->head)->content.i;
1680    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1681    start= env->head->item->content.val;    start= CAR(env->head)->content.i;
1682    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1683    
1684    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1685    
1686    if(ending>=start) {    if(ending>=start) {
1687      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1345  extern void to(environment *env) { Line 1691  extern void to(environment *env) {
1691        push_int(env, i);        push_int(env, i);
1692    }    }
1693    
1694    temp_val= new_val(env);    iterator= env->head;
1695    temp_val->content.ptr= env->head;  
1696    temp_val->type= list;    if(iterator->type==empty
1697    env->head= temp_head;       || (CAR(iterator)->type==symb
1698    push_val(env, temp_val);           && CAR(iterator)->content.sym->id[0]=='[')) {
1699        temp= NULL;
1700        toss(env);
1701      } else {
1702        /* Search for first delimiter */
1703        while(CDR(iterator)!=NULL
1704              && (CAR(CDR(iterator))->type!=symb
1705                  || CAR(CDR(iterator))->content.sym->id[0]!='['))
1706          iterator= CDR(iterator);
1707        
1708        /* Extract list */
1709        temp= env->head;
1710        env->head= CDR(iterator);
1711        CDR(iterator)= NULL;
1712    
1713        if(env->head!=NULL)
1714          toss(env);
1715      }
1716    
1717      /* Push list */
1718      push_val(env, temp);
1719  }  }
1720    
1721  /* Read a string */  /* Read a string */
1722  extern void readline(environment *env) {  extern void readline(environment *env)
1723    {
1724    char in_string[101];    char in_string[101];
1725    
1726    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1363  extern void readline(environment *env) { Line 1730  extern void readline(environment *env) {
1730  }  }
1731    
1732  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1733  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1734    {
1735    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1736    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1737    const char intform[]= "%i%n";    const char intform[]= "%i%n";
1738      const char fltform[]= "%f%n";
1739    const char blankform[]= "%*[ \t]%n";    const char blankform[]= "%*[ \t]%n";
1740    const char ebrackform[]= "]%n";    const char ebrackform[]= "]%n";
1741    const char semicform[]= ";%n";    const char semicform[]= ";%n";
1742    const char bbrackform[]= "[%n";    const char bbrackform[]= "[%n";
1743    
1744    int itemp, readlength= -1;    int itemp, readlength= -1;
1745      int count= -1;
1746      float ftemp;
1747    static int depth= 0;    static int depth= 0;
1748    char *match;    char *match;
1749    size_t inlength;    size_t inlength;
# Line 1383  extern void sx_72656164(environment *env Line 1754  extern void sx_72656164(environment *env
1754      }      }
1755      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1756    
1757      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1758        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1759        return;        return;
1760      }      }
1761            
1762      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1763      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1764      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1765      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1766    }    }
1767        
1768    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1769    match= malloc(inlength);    match= malloc(inlength);
1770    
1771    if(sscanf(env->in_string, blankform, &readlength)!=EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1772       && readlength != -1) {       && readlength != -1) {
1773      ;      ;
1774    } else if(sscanf(env->in_string, intform, &itemp, &readlength) != EOF    } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
1775              && readlength != -1) {              && readlength != -1) {
1776      push_int(env, itemp);      if(sscanf(env->in_string, intform, &itemp, &count) != EOF
1777           && count==readlength) {
1778          push_int(env, itemp);
1779        } else {
1780          push_float(env, ftemp);
1781        }
1782      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1783                && readlength != -1) {
1784        push_cstring(env, "");
1785    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1786              && readlength != -1) {              && readlength != -1) {
1787      push_cstring(env, match);      push_cstring(env, match);
# Line 1424  extern void sx_72656164(environment *env Line 1803  extern void sx_72656164(environment *env
1803      free(env->free_string);      free(env->free_string);
1804      env->in_string = env->free_string = NULL;      env->in_string = env->free_string = NULL;
1805    }    }
1806    if ( env->in_string != NULL) {    if (env->in_string != NULL) {
1807      env->in_string += readlength;      env->in_string += readlength;
1808    }    }
1809    
# Line 1434  extern void sx_72656164(environment *env Line 1813  extern void sx_72656164(environment *env
1813      return sx_72656164(env);      return sx_72656164(env);
1814  }  }
1815    
1816  extern void beep(environment *env) {  #ifdef __linux__
1817    extern void beep(environment *env)
1818    {
1819    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1820    
1821    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1822      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1823      env->err=1;      env->err= 1;
1824      return;      return;
1825    }    }
1826    
1827    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1828       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1829      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1830      env->err=2;      env->err= 2;
1831      return;      return;
1832    }    }
1833    
1834    dur=env->head->item->content.val;    dur= CAR(env->head)->content.i;
1835    toss(env);    toss(env);
1836    freq=env->head->item->content.val;    freq= CAR(env->head)->content.i;
1837    toss(env);    toss(env);
1838    
1839    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1840                                     length */                                     length */
1841    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1842                                     timer ticks */                                     timer ticks */
1843    
1844  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1845    
1846    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1847    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1848    case 0:    case 0:
1849      usleep(dur);      usleep(dur);
1850      return;      return;
1851    case -1:    case -1:
1852      perror("beep");      perror("beep");
1853      env->err=5;      env->err= 5;
1854      return;      return;
1855    default:    default:
1856      abort();      abort();
1857    }    }
1858  };  }
1859    #endif /* __linux__ */
1860    
1861  /* "wait" */  /* "wait" */
1862  extern void sx_77616974(environment *env) {  extern void sx_77616974(environment *env)
1863    {
1864    int dur;    int dur;
1865    
1866    if((env->head)==NULL) {    if(env->head->type==empty) {
1867      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1868      env->err=1;      env->err= 1;
1869      return;      return;
1870    }    }
1871    
1872    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1873      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1874      env->err=2;      env->err= 2;
1875      return;      return;
1876    }    }
1877    
1878    dur=env->head->item->content.val;    dur= CAR(env->head)->content.i;
1879    toss(env);    toss(env);
1880    
1881    usleep(dur);    usleep(dur);
1882  };  }
1883    
1884  extern void copying(environment *env){  extern void copying(environment *env)
1885    printf("GNU GENERAL PUBLIC LICENSE\n\  {
1886      printf("                  GNU GENERAL PUBLIC LICENSE\n\
1887                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1888  \n\  \n\
1889   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 2141  of preserving the free status of all der
2141  of promoting the sharing and reuse of software generally.\n");  of promoting the sharing and reuse of software generally.\n");
2142  }  }
2143    
2144  extern void warranty(environment *env){  extern void warranty(environment *env)
2145    {
2146    printf("                          NO WARRANTY\n\    printf("                          NO WARRANTY\n\
2147  \n\  \n\
2148    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 2170  POSSIBILITY OF SUCH DAMAGES.\n");
2170  extern void sx_2a(environment *env)  extern void sx_2a(environment *env)
2171  {  {
2172    int a, b;    int a, b;
2173      float fa, fb;
2174    
2175    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2176      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2177      env->err=1;      env->err= 1;
2178      return;      return;
2179    }    }
2180        
2181    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
2182       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
2183      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
2184      env->err=2;      toss(env); if(env->err) return;
2185        b= CAR(env->head)->content.i;
2186        toss(env); if(env->err) return;
2187        push_int(env, b*a);
2188    
2189      return;      return;
2190    }    }
2191    
2192    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
2193    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
2194    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
2195    toss(env); if(env->err) return;      toss(env); if(env->err) return;
2196    push_int(env, b*a);      fb= CAR(env->head)->content.f;
2197        toss(env); if(env->err) return;
2198        push_float(env, fb*fa);
2199        
2200        return;
2201      }
2202    
2203      if(CAR(env->head)->type==tfloat
2204         && CAR(CDR(env->head))->type==integer) {
2205        fa= CAR(env->head)->content.f;
2206        toss(env); if(env->err) return;
2207        b= CAR(env->head)->content.i;
2208        toss(env); if(env->err) return;
2209        push_float(env, b*fa);
2210        
2211        return;
2212      }
2213    
2214      if(CAR(env->head)->type==integer
2215         && CAR(CDR(env->head))->type==tfloat) {
2216        a= CAR(env->head)->content.i;
2217        toss(env); if(env->err) return;
2218        fb= CAR(env->head)->content.f;
2219        toss(env); if(env->err) return;
2220        push_float(env, fb*a);
2221    
2222        return;
2223      }
2224    
2225      printerr("Bad Argument Type");
2226      env->err= 2;
2227  }  }
2228    
2229  /* "/" */  /* "/" */
2230  extern void sx_2f(environment *env)  extern void sx_2f(environment *env)
2231  {  {
2232    int a, b;    int a, b;
2233      float fa, fb;
2234    
2235    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2236      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2237      env->err=1;      env->err= 1;
2238      return;      return;
2239    }    }
2240        
2241    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
2242       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
2243      printerr("Bad Argument Type");      a= CAR(env->head)->content.i;
2244      env->err=2;      toss(env); if(env->err) return;
2245        b= CAR(env->head)->content.i;
2246        toss(env); if(env->err) return;
2247        push_float(env, b/a);
2248    
2249      return;      return;
2250    }    }
2251    
2252    a=env->head->item->content.val;    if(CAR(env->head)->type==tfloat
2253    toss(env); if(env->err) return;       && CAR(CDR(env->head))->type==tfloat) {
2254    b=env->head->item->content.val;      fa= CAR(env->head)->content.f;
2255    toss(env); if(env->err) return;      toss(env); if(env->err) return;
2256    push_int(env, b/a);      fb= CAR(env->head)->content.f;
2257        toss(env); if(env->err) return;
2258        push_float(env, fb/fa);
2259        
2260        return;
2261      }
2262    
2263      if(CAR(env->head)->type==tfloat
2264         && CAR(CDR(env->head))->type==integer) {
2265        fa= CAR(env->head)->content.f;
2266        toss(env); if(env->err) return;
2267        b= CAR(env->head)->content.i;
2268        toss(env); if(env->err) return;
2269        push_float(env, b/fa);
2270        
2271        return;
2272      }
2273    
2274      if(CAR(env->head)->type==integer
2275         && CAR(CDR(env->head))->type==tfloat) {
2276        a= CAR(env->head)->content.i;
2277        toss(env); if(env->err) return;
2278        fb= CAR(env->head)->content.f;
2279        toss(env); if(env->err) return;
2280        push_float(env, fb/a);
2281    
2282        return;
2283      }
2284    
2285      printerr("Bad Argument Type");
2286      env->err= 2;
2287  }  }
2288    
2289  /* "mod" */  /* "mod" */
# Line 1838  extern void mod(environment *env) Line 2291  extern void mod(environment *env)
2291  {  {
2292    int a, b;    int a, b;
2293    
2294    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2295      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2296      env->err=1;      env->err= 1;
2297      return;      return;
2298    }    }
2299        
2300    if(env->head->item->type!=integer    if(CAR(env->head)->type==integer
2301       || env->head->next->item->type!=integer) {       && CAR(CDR(env->head))->type==integer) {
2302        a= CAR(env->head)->content.i;
2303        toss(env); if(env->err) return;
2304        b= CAR(env->head)->content.i;
2305        toss(env); if(env->err) return;
2306        push_int(env, b%a);
2307    
2308        return;
2309      }
2310    
2311      printerr("Bad Argument Type");
2312      env->err= 2;
2313    }
2314    
2315    /* "div" */
2316    extern void sx_646976(environment *env)
2317    {
2318      int a, b;
2319      
2320      if(env->head->type==empty || CDR(env->head)->type==empty) {
2321        printerr("Too Few Arguments");
2322        env->err= 1;
2323        return;
2324      }
2325    
2326      if(CAR(env->head)->type==integer
2327         && CAR(CDR(env->head))->type==integer) {
2328        a= CAR(env->head)->content.i;
2329        toss(env); if(env->err) return;
2330        b= CAR(env->head)->content.i;
2331        toss(env); if(env->err) return;
2332        push_int(env, (int)b/a);
2333    
2334        return;
2335      }
2336    
2337      printerr("Bad Argument Type");
2338      env->err= 2;
2339    }
2340    
2341    extern void setcar(environment *env)
2342    {
2343      if(env->head->type==empty || CDR(env->head)->type==empty) {
2344        printerr("Too Few Arguments");
2345        env->err= 1;
2346        return;
2347      }
2348    
2349      if(CDR(env->head)->type!=tcons) {
2350        printerr("Bad Argument Type");
2351        env->err= 2;
2352        return;
2353      }
2354    
2355      CAR(CAR(CDR(env->head)))=CAR(env->head);
2356      toss(env);
2357    }
2358    
2359    extern void setcdr(environment *env)
2360    {
2361      if(env->head->type==empty || CDR(env->head)->type==empty) {
2362        printerr("Too Few Arguments");
2363        env->err= 1;
2364        return;
2365      }
2366    
2367      if(CDR(env->head)->type!=tcons) {
2368      printerr("Bad Argument Type");      printerr("Bad Argument Type");
2369      env->err=2;      env->err= 2;
2370      return;      return;
2371    }    }
2372    
2373    a=env->head->item->content.val;    CDR(CAR(CDR(env->head)))=CAR(env->head);
2374      toss(env);
2375    }
2376    
2377    extern void car(environment *env)
2378    {
2379      if(env->head->type==empty) {
2380        printerr("Too Few Arguments");
2381        env->err= 1;
2382        return;
2383      }
2384    
2385      if(CAR(env->head)->type!=tcons) {
2386        printerr("Bad Argument Type");
2387        env->err= 2;
2388        return;
2389      }
2390    
2391      CAR(env->head)=CAR(CAR(env->head));
2392    }
2393    
2394    extern void cdr(environment *env)
2395    {
2396      if(env->head->type==empty) {
2397        printerr("Too Few Arguments");
2398        env->err= 1;
2399        return;
2400      }
2401    
2402      if(CAR(env->head)->type!=tcons) {
2403        printerr("Bad Argument Type");
2404        env->err= 2;
2405        return;
2406      }
2407    
2408      CAR(env->head)=CDR(CAR(env->head));
2409    }
2410    
2411    extern void cons(environment *env)
2412    {
2413      value *val;
2414    
2415      if(env->head->type==empty || CDR(env->head)->type==empty) {
2416        printerr("Too Few Arguments");
2417        env->err= 1;
2418        return;
2419      }
2420    
2421      val=new_val(env);
2422      val->content.c= malloc(sizeof(pair));
2423      assert(val->content.c!=NULL);
2424    
2425      env->gc_count += sizeof(pair);
2426      val->type=tcons;
2427    
2428      CAR(val)= CAR(CDR(env->head));
2429      CDR(val)= CAR(env->head);
2430    
2431      push_val(env, val);
2432    
2433      swap(env); if(env->err) return;
2434    toss(env); if(env->err) return;    toss(env); if(env->err) return;
2435    b=env->head->item->content.val;    swap(env); if(env->err) return;
2436    toss(env); if(env->err) return;    toss(env); if(env->err) return;
   push_int(env, b%a);  
2437  }  }
Legend:
Removed from v.1.92  
changed lines
  Added in v.1.117
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26