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

Diff of /stack/stack.c

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

revision 1.43 by masse, Wed Feb 6 23:27:22 2002 UTC revision 1.102 by masse, Sun Mar 10 20:08:47 2002 UTC
# Line 1  Line 1 
1  /* printf */  /*
2        stack - an interactive interpreter for a stack-based language
3        Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
4    
5        This program is free software; you can redistribute it and/or modify
6        it under the terms of the GNU General Public License as published by
7        the Free Software Foundation; either version 2 of the License, or
8        (at your option) any later version.
9    
10        This program is distributed in the hope that it will be useful,
11        but WITHOUT ANY WARRANTY; without even the implied warranty of
12        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13        GNU General Public License for more details.
14    
15        You should have received a copy of the GNU General Public License
16        along with this program; if not, write to the Free Software
17        Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
18    
19        Authors: Mats Alritzson <masse@fukt.bth.se>
20                 Teddy Hogeborn <teddy@fukt.bth.se>
21    */
22    
23    /* printf, sscanf, fgets, fprintf, fopen, perror */
24  #include <stdio.h>  #include <stdio.h>
25  /* EXIT_SUCCESS */  /* exit, EXIT_SUCCESS, malloc, free */
26  #include <stdlib.h>  #include <stdlib.h>
27  /* NULL */  /* NULL */
28  #include <stddef.h>  #include <stddef.h>
29  /* dlopen, dlsym, dlerror */  /* dlopen, dlsym, dlerror */
30  #include <dlfcn.h>  #include <dlfcn.h>
31  /* assert */  /* strcmp, strcpy, strlen, strcat, strdup */
32  #include <assert.h>  #include <string.h>
33    /* getopt, STDIN_FILENO, STDOUT_FILENO, usleep */
34  #define HASHTBLSIZE 65536  #include <unistd.h>
35    /* EX_NOINPUT, EX_USAGE */
36  /* First, define some types. */  #include <sysexits.h>
37    /* mtrace, muntrace */
38    #include <mcheck.h>
39    /* ioctl */
40    #include <sys/ioctl.h>
41    /* KDMKTONE */
42    #include <linux/kd.h>
43    
44  /* A value of some type */  #include "stack.h"
 typedef struct {  
   enum {  
     integer,  
     string,  
     func,                       /* Function pointer */  
     symb,  
     list  
   } type;                       /* Type of stack element */  
   
   union {  
     void *ptr;                  /* Pointer to the content */  
     int val;                    /* ...or an integer */  
   } content;                    /* Stores a pointer or an integer */  
   
   int refcount;                 /* Reference counter */  
   
 } value;  
   
 /* A symbol with a name and possible value */  
 /* (These do not need reference counters, they are kept unique by  
    hashing.) */  
 typedef struct symbol_struct {  
   char *id;                     /* Symbol name */  
   value *val;                   /* The value (if any) bound to it */  
   struct symbol_struct *next;   /* In case of hashing conflicts, a */  
 } symbol;                       /* symbol is a kind of stack item. */  
   
 /* A type for a hash table for symbols */  
 typedef symbol *hashtbl[HASHTBLSIZE]; /* Hash table declaration */  
   
 /* An item (value) on a stack */  
 typedef struct stackitem_struct  
 {  
   value *item;                  /* The value on the stack */  
   struct stackitem_struct *next; /* Next item */  
 } stackitem;  
   
 /* An environment; gives access to the stack and a hash table of  
    defined symbols */  
 typedef struct {  
   stackitem *head;              /* Head of the stack */  
   hashtbl symbols;              /* Hash table of all variable bindings */  
   int err;                      /* Error flag */  
 } environment;  
   
 /* A type for pointers to external functions */  
 typedef void (*funcp)(environment *); /* funcp is a pointer to a void  
                                          function (environment *) */  
45    
46  /* Initialize a newly created environment */  /* Initialize a newly created environment */
47  void init_env(environment *env)  void init_env(environment *env)
48  {  {
49    long i;    int i;
50    
51      env->gc_limit= 400000;
52      env->gc_count= 0;
53      env->gc_ref= NULL;
54    
55    env->err=0;    env->head= NULL;
56    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
57      env->symbols[i]= NULL;      env->symbols[i]= NULL;
58      env->err= 0;
59      env->in_string= NULL;
60      env->free_string= NULL;
61      env->inputstream= stdin;
62      env->interactive= 1;
63    }
64    
65    void printerr(const char* in_string)
66    {
67      fprintf(stderr, "Err: %s\n", in_string);
68    }
69    
70    /* Discard the top element of the stack. */
71    extern void toss(environment *env)
72    {
73      cons *temp= env->head;
74    
75      if(env->head==NULL) {
76        printerr("Too Few Arguments");
77        env->err= 1;
78        return;
79      }
80      
81      env->head= env->head->cdr->content.c; /* Remove the top stack item */
82      free(temp);                   /* Free the old top stack item */
83  }  }
84    
85  /* 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. */
86  symbol **hash(hashtbl in_hashtbl, const char *in_string)  symbol **hash(hashtbl in_hashtbl, const char *in_string)
87  {  {
88    long i= 0;    int i= 0;
89    unsigned long out_hash= 0;    unsigned int out_hash= 0;
90    char key= '\0';    char key= '\0';
91    symbol **position;    symbol **position;
92        
# Line 102  symbol **hash(hashtbl in_hashtbl, const Line 111  symbol **hash(hashtbl in_hashtbl, const
111    }    }
112  }  }
113    
114  /* Generic push function. */  /* Create new value */
115  void push(stackitem** stack_head, stackitem* in_item)  value* new_val(environment *env)
116  {  {
117    in_item->next= *stack_head;    value *nval= malloc(sizeof(value));
118    *stack_head= in_item;    stackitem *nitem= malloc(sizeof(stackitem));
119    
120      nval->content.ptr= NULL;
121    
122      nitem->item= nval;
123      nitem->next= env->gc_ref;
124    
125      env->gc_ref= nitem;
126    
127      env->gc_count += sizeof(value);
128      nval->gc.flag.mark= 0;
129      nval->gc.flag.protect= 0;
130    
131      return nval;
132    }
133    
134    /* Mark values recursively.
135       Marked values are not collected by the GC. */
136    inline void gc_mark(value *val)
137    {
138      if(val==NULL || val->gc.flag.mark)
139        return;
140    
141      val->gc.flag.mark= 1;
142    
143      if(val->type==tcons && val->content.c!=NULL) {
144        gc_mark(val->content.c->car);
145        gc_mark(val->content.c->cdr);
146      }
147    }
148    
149    inline void gc_maybe(environment *env)
150    {
151      if(env->gc_count < env->gc_limit)
152        return;
153      else
154        return gc_init(env);
155    }
156    
157    /* Start GC */
158    extern void gc_init(environment *env)
159    {
160      stackitem *new_head= NULL, *titem;
161      cons *iterator;
162      symbol *tsymb;
163      int i;
164    
165      if(env->interactive)
166        printf("Garbage collecting.");
167    
168      /* Mark values on stack */
169      if(env->head!=NULL) {
170        gc_mark(env->head->car);
171        gc_mark(env->head->cdr);
172      }
173    
174      if(env->interactive)
175        printf(".");
176    
177    
178      /* Mark values in hashtable */
179      for(i= 0; i<HASHTBLSIZE; i++)
180        for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
181          if (tsymb->val != NULL)
182            gc_mark(tsymb->val);
183    
184    
185      if(env->interactive)
186        printf(".");
187    
188    
189      env->gc_count= 0;
190    
191      while(env->gc_ref!=NULL) {    /* Sweep unused values */
192    
193        if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
194    
195          if(env->gc_ref->item->type==string) /* Remove content */
196            free(env->gc_ref->item->content.ptr);
197    
198          free(env->gc_ref->item);  /* Remove from gc_ref */
199          titem= env->gc_ref->next;
200          free(env->gc_ref);        /* Remove value */
201          env->gc_ref= titem;
202          continue;
203        }
204    
205        /* Keep values */    
206        env->gc_count += sizeof(value);
207        if(env->gc_ref->item->type==string)
208          env->gc_count += strlen(env->gc_ref->item->content.ptr);
209        
210        titem= env->gc_ref->next;
211        env->gc_ref->next= new_head;
212        new_head= env->gc_ref;
213        new_head->item->gc.flag.mark= 0;
214        env->gc_ref= titem;
215      }
216    
217      if (env->gc_limit < env->gc_count*2)
218        env->gc_limit= env->gc_count*2;
219    
220      env->gc_ref= new_head;
221    
222      if(env->interactive)
223        printf("done\n");
224    
225    }
226    
227    /* Protect values from GC */
228    void protect(value *val)
229    {
230      if(val==NULL || val->gc.flag.protect)
231        return;
232    
233      val->gc.flag.protect= 1;
234    
235      if(val->type==tcons && val->content.c!=NULL) {
236        protect(val->content.c->car);
237        protect(val->content.c->cdr);
238      }
239    }
240    
241    /* Unprotect values from GC */
242    void unprotect(value *val)
243    {
244      if(val==NULL || !(val->gc.flag.protect))
245        return;
246    
247      val->gc.flag.protect= 0;
248    
249      if(val->type==tcons && val->content.c!=NULL) {
250        unprotect(val->content.c->car);
251        unprotect(val->content.c->cdr);
252      }
253  }  }
254    
255  /* Push a value onto the stack */  /* Push a value onto the stack */
256  void push_val(stackitem **stack_head, value *val)  void push_val(environment *env, value *val)
257  {  {
258    stackitem *new_item= malloc(sizeof(stackitem));    cons *new_item= malloc(sizeof(cons));
259    new_item->item= val;    new_item->car= val;
260    val->refcount++;  
261    push(stack_head, new_item);    new_item->cdr= new_val(env);
262      new_item->cdr->type= tcons;
263      new_item->cdr->content.c= env->head;
264      env->head= new_item;
265  }  }
266    
267  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
268  void push_int(stackitem **stack_head, int in_val)  void push_int(environment *env, int in_val)
269  {  {
270    value *new_value= malloc(sizeof(value));    value *new_value= new_val(env);
   stackitem *new_item= malloc(sizeof(stackitem));  
   new_item->item= new_value;  
271        
272    new_value->content.val= in_val;    new_value->content.i= in_val;
273    new_value->type= integer;    new_value->type= integer;
   new_value->refcount=1;  
274    
275    push(stack_head, new_item);    push_val(env, new_value);
276    }
277    
278    /* Push a floating point number onto the stack */
279    void push_float(environment *env, float in_val)
280    {
281      value *new_value= new_val(env);
282    
283      new_value->content.f= in_val;
284      new_value->type= tfloat;
285    
286      push_val(env, new_value);
287  }  }
288    
289  /* Copy a string onto the stack. */  /* Copy a string onto the stack. */
290  void push_cstring(stackitem **stack_head, const char *in_string)  void push_cstring(environment *env, const char *in_string)
291  {  {
292    value *new_value= malloc(sizeof(value));    value *new_value= new_val(env);
293    stackitem *new_item= malloc(sizeof(stackitem));    int length= strlen(in_string)+1;
   new_item->item=new_value;  
294    
295    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
296      env->gc_count += length;
297    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
298    new_value->type= string;    new_value->type= string;
   new_value->refcount=1;  
299    
300    push(stack_head, new_item);    push_val(env, new_value);
301    }
302    
303    /* Mangle a symbol name to a valid C identifier name */
304    char *mangle_str(const char *old_string)
305    {
306      char validchars[]= "0123456789abcdef";
307      char *new_string, *current;
308    
309      new_string= malloc((strlen(old_string)*2)+4);
310      strcpy(new_string, "sx_");    /* Stack eXternal */
311      current= new_string+3;
312      while(old_string[0] != '\0'){
313        current[0]= validchars[(unsigned char)(old_string[0])/16];
314        current[1]= validchars[(unsigned char)(old_string[0])%16];
315        current+= 2;
316        old_string++;
317      }
318      current[0]= '\0';
319    
320      return new_string;            /* The caller must free() it */
321    }
322    
323    extern void mangle(environment *env)
324    {
325      char *new_string;
326    
327      if((env->head)==NULL) {
328        printerr("Too Few Arguments");
329        env->err= 1;
330        return;
331      }
332    
333      if(env->head->car->type!=string) {
334        printerr("Bad Argument Type");
335        env->err= 2;
336        return;
337      }
338    
339      new_string= mangle_str((const char *)(env->head->car->content.ptr));
340    
341      toss(env);
342      if(env->err) return;
343    
344      push_cstring(env, new_string);
345  }  }
346    
347  /* Push a symbol onto the stack. */  /* Push a symbol onto the stack. */
348  void push_sym(environment *env, const char *in_string)  void push_sym(environment *env, const char *in_string)
349  {  {
   stackitem *new_item;          /* The new stack item */  
   /* ...which will contain... */  
350    value *new_value;             /* A new symbol value */    value *new_value;             /* A new symbol value */
351    /* ...which might point to... */    /* ...which might point to... */
352    symbol **new_symbol;          /* (if needed) A new actual symbol */    symbol **new_symbol;          /* (if needed) A new actual symbol */
# Line 161  void push_sym(environment *env, const ch Line 356  void push_sym(environment *env, const ch
356    void *funcptr;                /* A function pointer */    void *funcptr;                /* A function pointer */
357    
358    static void *handle= NULL;    /* Dynamic linker handle */    static void *handle= NULL;    /* Dynamic linker handle */
359      const char *dlerr;            /* Dynamic linker error */
360      char *mangled;                /* Mangled function name */
361    
362    /* Create a new stack item containing a new value */    new_value= new_val(env);
363    new_item= malloc(sizeof(stackitem));    protect(new_value);
364    new_value= malloc(sizeof(value));    new_fvalue= new_val(env);
365    new_item->item=new_value;    protect(new_fvalue);
366    
367    /* The new value is a symbol */    /* The new value is a symbol */
368    new_value->type= symb;    new_value->type= symb;
   new_value->refcount= 1;  
369    
370    /* Look up the symbol name in the hash table */    /* Look up the symbol name in the hash table */
371    new_symbol= hash(env->symbols, in_string);    new_symbol= hash(env->symbols, in_string);
# Line 192  void push_sym(environment *env, const ch Line 388  void push_sym(environment *env, const ch
388      if(handle==NULL)            /* If no handle */      if(handle==NULL)            /* If no handle */
389        handle= dlopen(NULL, RTLD_LAZY);        handle= dlopen(NULL, RTLD_LAZY);
390    
391      funcptr= dlsym(handle, in_string); /* Get function pointer */      mangled= mangle_str(in_string); /* mangle the name */
392      if(dlerror()==NULL) {       /* If a function was found */      funcptr= dlsym(handle, mangled); /* and try to find it */
393        new_fvalue= malloc(sizeof(value)); /* Create a new value */  
394        new_fvalue->type=func;    /* The new value is a function pointer */      dlerr= dlerror();
395        new_fvalue->content.ptr=funcptr; /* Store function pointer */      if(dlerr != NULL) {         /* If no function was found */
396          funcptr= dlsym(handle, in_string); /* Get function pointer */
397          dlerr= dlerror();
398        }
399    
400        if(dlerr==NULL) {           /* If a function was found */
401          new_fvalue->type= func;   /* The new value is a function pointer */
402          new_fvalue->content.ptr= funcptr; /* Store function pointer */
403        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
404                                           function value */                                           function value */
       new_fvalue->refcount= 1;  
405      }      }
   }  
   push(&(env->head), new_item);  
 }  
   
 void printerr(const char* in_string) {  
   fprintf(stderr, "Err: %s\n", in_string);  
 }  
406    
407  /* Throw away a value */      free(mangled);
 void free_val(value *val){  
   stackitem *item, *temp;  
   
   val->refcount--;              /* Decrease the reference count */  
   if(val->refcount == 0){  
     switch (val->type){         /* and free the contents if necessary */  
     case string:  
       free(val->content.ptr);  
       break;  
     case list:                  /* lists needs to be freed recursively */  
       item=val->content.ptr;  
       while(item != NULL) {     /* for all stack items */  
         free_val(item->item);   /* free the value */  
         temp=item->next;        /* save next ptr */  
         free(item);             /* free the stackitem */  
         item=temp;              /* go to next stackitem */  
       }  
       free(val);                /* Free the actual list value */  
       break;  
     default:  
       break;  
     }  
408    }    }
 }  
   
 /* Discard the top element of the stack. */  
 extern void toss(environment *env)  
 {  
   stackitem *temp= env->head;  
409    
410    if((env->head)==NULL) {    push_val(env, new_value);
411      printerr("Too Few Arguments");    unprotect(new_value); unprotect(new_fvalue);
     env->err=1;  
     return;  
   }  
     
   free_val(env->head->item);    /* Free the value */  
   env->head= env->head->next;   /* Remove the top stack item */  
   free(temp);                   /* Free the old top stack item */  
412  }  }
413    
414  /* Print newline. */  /* Print newline. */
# Line 258  extern void nl() Line 418  extern void nl()
418  }  }
419    
420  /* Gets the type of a value */  /* Gets the type of a value */
421  extern void type(environment *env){  extern void type(environment *env)
422    {
423    int typenum;    int typenum;
424    
425    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 266  extern void type(environment *env){ Line 427  extern void type(environment *env){
427      env->err=1;      env->err=1;
428      return;      return;
429    }    }
430    typenum=env->head->item->type;    typenum=env->head->car->type;
431    toss(env);    toss(env);
432    switch(typenum){    switch(typenum){
433    case integer:    case integer:
434      push_sym(env, "integer");      push_sym(env, "integer");
435      break;      break;
436      case tfloat:
437        push_sym(env, "float");
438        break;
439    case string:    case string:
440      push_sym(env, "string");      push_sym(env, "string");
441      break;      break;
# Line 281  extern void type(environment *env){ Line 445  extern void type(environment *env){
445    case func:    case func:
446      push_sym(env, "function");      push_sym(env, "function");
447      break;      break;
448    case list:    case tcons:
449      push_sym(env, "list");      push_sym(env, "list");
450      break;      break;
   default:  
     push_sym(env, "unknown");  
     break;  
451    }    }
452  }      }    
453    
454  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
455  void print_h(stackitem *stack_head)  void print_h(cons *stack_head, int noquote)
456  {  {
457    switch(stack_head->item->type) {    switch(stack_head->car->type) {
458    case integer:    case integer:
459      printf("%d", stack_head->item->content.val);      printf("%d", stack_head->car->content.i);
460        break;
461      case tfloat:
462        printf("%f", stack_head->car->content.f);
463      break;      break;
464    case string:    case string:
465      printf("\"%s\"", (char*)stack_head->item->content.ptr);      if(noquote)
466          printf("%s", (char*)stack_head->car->content.ptr);
467        else
468          printf("\"%s\"", (char*)stack_head->car->content.ptr);
469      break;      break;
470    case symb:    case symb:
471      printf("'%s'", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", ((symbol *)(stack_head->car->content.ptr))->id);
472      break;      break;
473    case func:    case func:
474      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(stack_head->car->content.ptr));
475      break;      break;
476    case list:    case tcons:
477      /* 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 */
478      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head=(cons*)(stack_head->car->content.ptr);
479      printf("[ ");      printf("[ ");
480      while(stack_head != NULL) {      while(stack_head != NULL) {
481        print_h(stack_head);        print_h(stack_head, noquote);
482        printf(" ");        printf(" ");
483        stack_head=stack_head->next;        stack_head= stack_head->cdr->content.c;
484      }      }
485      printf("]");      printf("]");
486      break;      break;
   default:  
     printf("#<unknown %p>", (stack_head->item->content.ptr));  
     break;  
487    }    }
488  }  }
489    
490  extern void print_(environment *env) {  extern void print_(environment *env)
491    {
492    if(env->head==NULL) {    if(env->head==NULL) {
493      printerr("Too Few Arguments");      printerr("Too Few Arguments");
494      env->err=1;      env->err=1;
495      return;      return;
496    }    }
497    print_h(env->head);    print_h(env->head, 0);
498      nl();
499  }  }
500    
501  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack and then discards it. */
# Line 340  extern void print(environment *env) Line 506  extern void print(environment *env)
506    toss(env);    toss(env);
507  }  }
508    
509    extern void princ_(environment *env)
510    {
511      if(env->head==NULL) {
512        printerr("Too Few Arguments");
513        env->err=1;
514        return;
515      }
516      print_h(env->head, 1);
517    }
518    
519    /* Prints the top element of the stack and then discards it. */
520    extern void princ(environment *env)
521    {
522      princ_(env);
523      if(env->err) return;
524      toss(env);
525    }
526    
527  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
528  void print_st(stackitem *stack_head, long counter)  void print_st(cons *stack_head, long counter)
529  {  {
530    if(stack_head->next != NULL)    if(stack_head->cdr->content.c != NULL)
531      print_st(stack_head->next, counter+1);      print_st(stack_head->cdr->content.c, counter+1);
532    printf("%ld: ", counter);    printf("%ld: ", counter);
533    print_h(stack_head);    print_h(stack_head, 0);
534    nl();    nl();
535  }  }
536    
   
   
537  /* Prints the stack. */  /* Prints the stack. */
538  extern void printstack(environment *env)  extern void printstack(environment *env)
539  {  {
540    if(env->head == NULL) {    if(env->head == NULL) {
541        printf("Stack Empty\n");
542      return;      return;
543    }    }
544    
545    print_st(env->head, 1);    print_st(env->head, 1);
   nl();  
546  }  }
547    
548  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
549  extern void swap(environment *env)  extern void swap(environment *env)
550  {  {
551    stackitem *temp= env->head;    cons *temp= env->head;
552        
553    if((env->head)==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
554      printerr("Too Few Arguments");      printerr("Too Few Arguments");
555      env->err=1;      env->err=1;
556      return;      return;
557    }    }
558    
559    if(env->head->next==NULL) {    env->head= env->head->cdr->content.c;
560      temp->cdr->content.c= env->head->cdr->content.c;
561      env->head->cdr->content.c= temp;
562    }
563    
564    /* Rotate the first three elements on the stack. */
565    extern void rot(environment *env)
566    {
567      cons *temp= env->head;
568      
569      if(env->head==NULL || env->head->cdr->content.c==NULL
570          || env->head->cdr->content.c->cdr->content.c==NULL) {
571      printerr("Too Few Arguments");      printerr("Too Few Arguments");
572      env->err=1;      env->err=1;
573      return;      return;
574    }    }
575    
576    env->head= env->head->next;    env->head= env->head->cdr->content.c->cdr->content.c;
577    temp->next= env->head->next;    temp->cdr->content.c->cdr->content.c= env->head->cdr->content.c;
578    env->head->next= temp;    env->head->cdr->content.c= temp;
 }  
   
 stackitem* copy(stackitem* in_item)  
 {  
   stackitem *out_item= malloc(sizeof(stackitem));  
   
   memcpy(out_item, in_item, sizeof(stackitem));  
   out_item->next= NULL;  
   
   return out_item;  
579  }  }
580    
581  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 399  extern void rcl(environment *env) Line 583  extern void rcl(environment *env)
583  {  {
584    value *val;    value *val;
585    
586    if(env->head == NULL) {    if(env->head==NULL) {
587      printerr("Too Few Arguments");      printerr("Too Few Arguments");
588      env->err=1;      env->err= 1;
589      return;      return;
590    }    }
591    
592    if(env->head->item->type!=symb) {    if(env->head->car->type!=symb) {
593      printerr("Bad Argument Type");      printerr("Bad Argument Type");
594      env->err=2;      env->err= 2;
595      return;      return;
596    }    }
597    
598    val=((symbol *)(env->head->item->content.ptr))->val;    val= ((symbol *)(env->head->car->content.ptr))->val;
599    if(val == NULL){    if(val == NULL){
600      printerr("Unbound Variable");      printerr("Unbound Variable");
601      env->err=3;      env->err= 3;
602      return;      return;
603    }    }
604      protect(val);
605    toss(env);            /* toss the symbol */    toss(env);            /* toss the symbol */
606    if(env->err) return;    if(env->err) return;
607    push_val(&(env->head), val); /* Return its bound value */    push_val(env, val); /* Return its bound value */
608      unprotect(val);
609  }  }
610    
611  /* 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 428  extern void rcl(environment *env) Line 614  extern void rcl(environment *env)
614  extern void eval(environment *env)  extern void eval(environment *env)
615  {  {
616    funcp in_func;    funcp in_func;
617      value* temp_val;
618      cons* iterator;
619    
620     eval_start:
621    
622      gc_maybe(env);
623    
624    if(env->head==NULL) {    if(env->head==NULL) {
625      printerr("Too Few Arguments");      printerr("Too Few Arguments");
626      env->err=1;      env->err= 1;
627      return;      return;
628    }    }
629    
630    /* if it's a symbol */    switch(env->head->car->type) {
631    if(env->head->item->type==symb) {      /* if it's a symbol */
632      case symb:
633      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
634      if(env->err) return;      if(env->err) return;
635      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(env->head->car->type!=symb){ /* don't recurse symbols */
636        eval(env);                        /* evaluate the value */        goto eval_start;
       return;  
637      }      }
638    }      return;
639    
640    /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
641    if(env->head->item->type==func) {    case func:
642      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(env->head->car->content.ptr);
643      toss(env);      toss(env);
644      if(env->err) return;      if(env->err) return;
645      (*in_func)(env);      return in_func(env);
646    
647        /* If it's a list */
648      case tcons:
649        temp_val= env->head->car;
650        protect(temp_val);
651    
652        toss(env); if(env->err) return;
653        iterator= (cons*)temp_val->content.ptr;
654        
655        while(iterator!=NULL) {
656          push_val(env, iterator->car);
657          
658          if(env->head->car->type==symb
659             && (((symbol*)(env->head->car->content.ptr))->id[0] == ';')) {
660            toss(env);
661            if(env->err) return;
662            
663            if(iterator->cdr->content.c==NULL){
664              goto eval_start;
665            }
666            eval(env);
667            if(env->err) return;
668          }
669          iterator= iterator->cdr->content.c;
670        }
671        unprotect(temp_val);
672        return;
673    
674      default:
675        return;
676    }    }
677  }  }
678    
679  /* Reverse a list */  /* Reverse (flip) a list */
680  extern void rev(environment *env){  extern void rev(environment *env)
681    stackitem *old_head, *new_head, *item;  {
682      cons *old_head, *new_head, *item;
683    
684    if((env->head)==NULL) {    if((env->head)==NULL) {
685      printerr("Too Few Arguments");      printerr("Too Few Arguments");
686      env->err=1;      env->err= 1;
687      return;      return;
688    }    }
689    
690    if(env->head->item->type!=list) {    if(env->head->car->type!=tcons) {
691      printerr("Bad Argument Type");      printerr("Bad Argument Type");
692      env->err=2;      env->err= 2;
693      return;      return;
694    }    }
695    
696    old_head=(stackitem *)(env->head->item->content.ptr);    old_head= (cons*)(env->head->car->content.ptr);
697    new_head=NULL;    new_head= NULL;
698    while(old_head != NULL){    while(old_head!=NULL) {
699      item=old_head;      item= old_head;
700      old_head=old_head->next;      old_head= old_head->cdr->content.c;
701      item->next=new_head;      item->cdr->content.c= new_head;
702      new_head=item;      new_head= item;
703    }    }
704    env->head->item->content.ptr=new_head;    env->head->car->content.ptr= new_head;
705  }  }
706    
707  /* Make a list. */  /* Make a list. */
708  extern void pack(environment *env)  extern void pack(environment *env)
709  {  {
710    void* delimiter;    cons *iterator, *temp;
   stackitem *iterator, *temp;  
711    value *pack;    value *pack;
712    
   delimiter= env->head->item->content.ptr; /* Get delimiter */  
   toss(env);  
   
713    iterator= env->head;    iterator= env->head;
714      pack= new_val(env);
715      protect(pack);
716    
717    if(iterator==NULL || iterator->item->content.ptr==delimiter) {    if(iterator==NULL
718         || (iterator->car->type==symb
719         && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) {
720      temp= NULL;      temp= NULL;
721      toss(env);      toss(env);
722    } else {    } else {
723      /* Search for first delimiter */      /* Search for first delimiter */
724      while(iterator->next!=NULL      while(iterator->cdr->content.c!=NULL
725            && iterator->next->item->content.ptr!=delimiter)            && (iterator->cdr->content.c->car->type!=symb
726        iterator= iterator->next;            || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0]
727                  !='['))
728          iterator= iterator->cdr->content.c;
729            
730      /* Extract list */      /* Extract list */
731      temp= env->head;      temp= env->head;
732      env->head= iterator->next;      env->head= iterator->cdr->content.c;
733      iterator->next= NULL;      iterator->cdr->content.c= NULL;
734    
735        pack->type= tcons;
736        pack->content.ptr= temp;
737            
738      if(env->head!=NULL)      if(env->head!=NULL)
739        toss(env);        toss(env);
740    }    }
741    
742    /* Push list */    /* Push list */
   pack= malloc(sizeof(value));  
   pack->type= list;  
   pack->content.ptr= temp;  
   pack->refcount= 1;  
   
   temp= malloc(sizeof(stackitem));  
   temp->item= pack;  
743    
744    push(&(env->head), temp);    push_val(env, pack);
745    rev(env);    rev(env);
 }  
   
 /* Parse input. */  
 void stack_read(environment *env, char *in_line)  
 {  
   char *temp, *rest;  
   int itemp;  
   size_t inlength= strlen(in_line)+1;  
   int convert= 0;  
   static int non_eval_flag= 0;  
   
   temp= malloc(inlength);  
   rest= malloc(inlength);  
   
   do {  
     /* If comment */  
     if((convert= sscanf(in_line, "#%[^\n\r]", rest))) {  
       free(temp); free(rest);  
       return;  
     }  
746    
747      /* If string */    unprotect(pack);
     if((convert= sscanf(in_line, "\"%[^\"\n\r]\" %[^\n\r]", temp, rest))) {  
       push_cstring(&(env->head), temp);  
       break;  
     }  
     /* If integer */  
     if((convert= sscanf(in_line, "%d %[^\n\r]", &itemp, rest))) {  
       push_int(&(env->head), itemp);  
       break;  
     }  
     /* Escape ';' with '\' */  
     if((convert= sscanf(in_line, "\\%c%[^\n\r]", temp, rest))) {  
       temp[1]= '\0';  
       push_sym(env, temp);  
       break;  
     }  
     /* If symbol */  
     if((convert= sscanf(in_line, "%[^][ ;\n\r]%[^\n\r]", temp, rest))) {  
         push_sym(env, temp);  
         break;  
     }  
     /* If single char */  
     if((convert= sscanf(in_line, "%c%[^\n\r]", temp, rest))) {  
       if(*temp==';') {  
         if(!non_eval_flag) {  
           eval(env);            /* Evaluate top element */  
           break;  
         }  
           
         push_sym(env, ";");  
         break;  
       }  
   
       if(*temp==']') {  
         push_sym(env, "[");  
         pack(env);  
         if(non_eval_flag!=0)  
           non_eval_flag--;  
         break;  
       }  
   
       if(*temp=='[') {  
         push_sym(env, "[");  
         non_eval_flag++;  
         break;  
       }  
     }  
   } while(0);  
   
   free(temp);  
   
   if(convert<2) {  
     free(rest);  
     return;  
   }  
     
   stack_read(env, rest);  
     
   free(rest);  
748  }  }
749    
750  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
751  extern void expand(environment *env)  extern void expand(environment *env)
752  {  {
753    stackitem *temp, *new_head;    cons *temp, *new_head;
754    
755    /* Is top element a list? */    /* Is top element a list? */
756    if(env->head==NULL) {    if(env->head==NULL) {
757      printerr("Too Few Arguments");      printerr("Too Few Arguments");
758      env->err=1;      env->err= 1;
759      return;      return;
760    }    }
761    if(env->head->item->type!=list) {    if(env->head->car->type!=tcons) {
762      printerr("Bad Argument Type");      printerr("Bad Argument Type");
763      env->err=2;      env->err= 2;
764      return;      return;
765    }    }
766    
# Line 627  extern void expand(environment *env) Line 770  extern void expand(environment *env)
770      return;      return;
771    
772    /* The first list element is the new stack head */    /* The first list element is the new stack head */
773    new_head= temp= env->head->item->content.ptr;    new_head= temp= env->head->car->content.ptr;
774    
   env->head->item->refcount++;  
775    toss(env);    toss(env);
776    
777    /* Find the end of the list */    /* Find the end of the list */
778    while(temp->next!=NULL)    while(temp->cdr->content.c!=NULL)
779      temp= temp->next;      temp= temp->cdr->content.c;
780    
781    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
782    temp->next= env->head;    temp->cdr->content.c= env->head;
783    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
784    
785  }  }
# Line 646  extern void expand(environment *env) Line 788  extern void expand(environment *env)
788  extern void eq(environment *env)  extern void eq(environment *env)
789  {  {
790    void *left, *right;    void *left, *right;
   int result;  
791    
792    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
793      printerr("Too Few Arguments");      printerr("Too Few Arguments");
794      env->err=1;      env->err= 1;
795      return;      return;
796    }    }
797    
798    left= env->head->item->content.ptr;    left= env->head->car->content.ptr;
799    swap(env);    swap(env);
800    right= env->head->item->content.ptr;    right= env->head->car->content.ptr;
   result= (left==right);  
     
801    toss(env); toss(env);    toss(env); toss(env);
802    push_int(&(env->head), result);  
803      push_int(env, left==right);
804  }  }
805    
806  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 668  extern void not(environment *env) Line 808  extern void not(environment *env)
808  {  {
809    int val;    int val;
810    
811    if((env->head)==NULL) {    if(env->head==NULL) {
812      printerr("Too Few Arguments");      printerr("Too Few Arguments");
813      env->err=1;      env->err= 1;
814      return;      return;
815    }    }
816    
817    if(env->head->item->type!=integer) {    if(env->head->car->type!=integer) {
818      printerr("Bad Argument Type");      printerr("Bad Argument Type");
819      env->err=2;      env->err= 2;
820      return;      return;
821    }    }
822    
823    val= env->head->item->content.val;    val= env->head->car->content.i;
824    toss(env);    toss(env);
825    push_int(&(env->head), !val);    push_int(env, !val);
826  }  }
827    
828  /* Compares the two top elements on the stack and return 0 if they're the  /* Compares the two top elements on the stack and return 0 if they're the
# Line 699  extern void def(environment *env) Line 839  extern void def(environment *env)
839    symbol *sym;    symbol *sym;
840    
841    /* 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 */
842    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || env->head->cdr->content.c==NULL) {
843      printerr("Too Few Arguments");      printerr("Too Few Arguments");
844      env->err=1;      env->err= 1;
845      return;      return;
846    }    }
847    
848    if(env->head->item->type!=symb) {    if(env->head->car->type!=symb) {
849      printerr("Bad Argument Type");      printerr("Bad Argument Type");
850      env->err=2;      env->err= 2;
851      return;      return;
852    }    }
853    
854    /* long names are a pain */    /* long names are a pain */
855    sym=env->head->item->content.ptr;    sym= env->head->car->content.ptr;
   
   /* if the symbol was bound to something else, throw it away */  
   if(sym->val != NULL)  
     free_val(sym->val);  
856    
857    /* Bind the symbol to the value */    /* Bind the symbol to the value */
858    sym->val= env->head->next->item;    sym->val= env->head->cdr->content.c->car;
   sym->val->refcount++;         /* Increase the reference counter */  
859    
860    toss(env); toss(env);    toss(env); toss(env);
861  }  }
# Line 728  extern void def(environment *env) Line 863  extern void def(environment *env)
863  /* Quit stack. */  /* Quit stack. */
864  extern void quit(environment *env)  extern void quit(environment *env)
865  {  {
866      int i;
867    
868      clear(env);
869    
870      if (env->err) return;
871      for(i= 0; i<HASHTBLSIZE; i++) {
872        while(env->symbols[i]!= NULL) {
873          forget_sym(&(env->symbols[i]));
874        }
875        env->symbols[i]= NULL;
876      }
877    
878      env->gc_limit= 0;
879      gc_maybe(env);
880    
881      if(env->free_string!=NULL)
882        free(env->free_string);
883      
884      muntrace();
885    
886    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
887  }  }
888    
# Line 753  extern void words(environment *env) Line 908  extern void words(environment *env)
908    }    }
909  }  }
910    
911    /* Internal forget function */
912    void forget_sym(symbol **hash_entry)
913    {
914      symbol *temp;
915    
916      temp= *hash_entry;
917      *hash_entry= (*hash_entry)->next;
918      
919      free(temp->id);
920      free(temp);
921    }
922    
923  /* Forgets a symbol (remove it from the hash table) */  /* Forgets a symbol (remove it from the hash table) */
924  extern void forget(environment *env)  extern void forget(environment *env)
925  {  {
926    char* sym_id;    char* sym_id;
927    stackitem *stack_head= env->head;    cons *stack_head= env->head;
   symbol **hash_entry, *temp;  
928    
929    if(stack_head==NULL) {    if(stack_head==NULL) {
930      printerr("Too Few Arguments");      printerr("Too Few Arguments");
931      env->err=1;      env->err= 1;
932      return;      return;
933    }    }
934        
935    if(stack_head->item->type!=symb) {    if(stack_head->car->type!=symb) {
936      printerr("Bad Argument Type");      printerr("Bad Argument Type");
937      env->err=2;      env->err= 2;
938      return;      return;
939    }    }
940    
941    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= ((symbol*)(stack_head->car->content.ptr))->id;
942    toss(env);    toss(env);
943    
944    hash_entry= hash(env->symbols, sym_id);    return forget_sym(hash(env->symbols, sym_id));
   temp= *hash_entry;  
   *hash_entry= (*hash_entry)->next;  
     
   if(temp->val!=NULL) {  
     free_val(temp->val);  
   }  
   free(temp->id);  
   free(temp);  
945  }  }
946    
947  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
948  extern void errn(environment *env){  extern void errn(environment *env)
949    push_int(&(env->head), env->err);  {
950      push_int(env, env->err);
951  }  }
952    
953  int main()  int main(int argc, char **argv)
954  {  {
955    environment myenv;    environment myenv;
956    char in_string[100];  
957      int c;                        /* getopt option character */
958    
959      mtrace();
960    
961    init_env(&myenv);    init_env(&myenv);
962    
963    printf("okidok\n ");    myenv.interactive = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO);
964    
965      while ((c = getopt (argc, argv, "i")) != -1)
966        switch (c)
967          {
968          case 'i':
969            myenv.interactive = 1;
970            break;
971          case '?':
972            fprintf (stderr,
973                     "Unknown option character `\\x%x'.\n",
974                     optopt);
975            return EX_USAGE;
976          default:
977            abort ();
978          }
979      
980      if (optind < argc) {
981        myenv.interactive = 0;
982        myenv.inputstream= fopen(argv[optind], "r");
983        if(myenv.inputstream== NULL) {
984          perror(argv[0]);
985          exit (EX_NOINPUT);
986        }
987      }
988    
989      if(myenv.interactive) {
990        printf("Stack version $Revision$\n\
991    Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
992    Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\
993    This is free software, and you are welcome to redistribute it\n\
994    under certain conditions; type `copying;' for details.\n");
995      }
996    
997    while(fgets(in_string, 100, stdin) != NULL) {    while(1) {
998      stack_read(&myenv, in_string);      if(myenv.in_string==NULL) {
999      if(myenv.err) {        if (myenv.interactive) {
1000        printf("(error %d) ", myenv.err);          if(myenv.err) {
1001              printf("(error %d)\n", myenv.err);
1002            }
1003            nl();
1004            printstack(&myenv);
1005            printf("> ");
1006          }
1007        myenv.err=0;        myenv.err=0;
1008      }      }
1009      printf("okidok\n ");      sx_72656164(&myenv);
1010        if (myenv.err==4) {
1011          return EXIT_SUCCESS;      /* EOF */
1012        } else if(myenv.head!=NULL
1013                  && myenv.head->car->type==symb
1014                  && ((symbol*)(myenv.head->car->content.ptr))->id[0]==';') {
1015          toss(&myenv);             /* No error check in main */
1016          eval(&myenv);
1017        }
1018        gc_maybe(&myenv);
1019    }    }
1020    quit(&myenv);    quit(&myenv);
1021    return EXIT_FAILURE;    return EXIT_FAILURE;
1022  }  }
1023    
1024    /* "+" */
1025    extern void sx_2b(environment *env)
1026    {
1027      int a, b;
1028      float fa, fb;
1029      size_t len;
1030      char* new_string;
1031      value *a_val, *b_val;
1032    
1033      if(env->head==NULL || env->head->cdr->content.c==NULL) {
1034        printerr("Too Few Arguments");
1035        env->err= 1;
1036        return;
1037      }
1038    
1039      if(env->head->car->type==string
1040         && env->head->cdr->content.c->car->type==string) {
1041        a_val= env->head->car;
1042        b_val= env->head->cdr->content.c->car;
1043        protect(a_val); protect(b_val);
1044        toss(env); if(env->err) return;
1045        toss(env); if(env->err) return;
1046        len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
1047        new_string= malloc(len);
1048        strcpy(new_string, b_val->content.ptr);
1049        strcat(new_string, a_val->content.ptr);
1050        push_cstring(env, new_string);
1051        unprotect(a_val); unprotect(b_val);
1052        free(new_string);
1053        
1054        return;
1055      }
1056      
1057      if(env->head->car->type==integer
1058         && env->head->cdr->content.c->car->type==integer) {
1059        a= env->head->car->content.i;
1060        toss(env); if(env->err) return;
1061        b= env->head->car->content.i;
1062        toss(env); if(env->err) return;
1063        push_int(env, b+a);
1064    
1065        return;
1066      }
1067    
1068      if(env->head->car->type==tfloat
1069         && env->head->cdr->content.c->car->type==tfloat) {
1070        fa= env->head->car->content.f;
1071        toss(env); if(env->err) return;
1072        fb= env->head->car->content.f;
1073        toss(env); if(env->err) return;
1074        push_float(env, fb+fa);
1075        
1076        return;
1077      }
1078    
1079      if(env->head->car->type==tfloat
1080         && env->head->cdr->content.c->car->type==integer) {
1081        fa= env->head->car->content.f;
1082        toss(env); if(env->err) return;
1083        b= env->head->car->content.i;
1084        toss(env); if(env->err) return;
1085        push_float(env, b+fa);
1086        
1087        return;
1088      }
1089    
1090      if(env->head->car->type==integer
1091         && env->head->cdr->content.c->car->type==tfloat) {
1092        a= env->head->car->content.i;
1093        toss(env); if(env->err) return;
1094        fb= env->head->car->content.f;
1095        toss(env); if(env->err) return;
1096        push_float(env, fb+a);
1097    
1098        return;
1099      }
1100    
1101      printerr("Bad Argument Type");
1102      env->err=2;
1103    }
1104    
1105    /* "-" */
1106    extern void sx_2d(environment *env)
1107    {
1108      int a, b;
1109      float fa, fb;
1110    
1111      if(env->head==NULL || env->head->cdr->content.c==NULL) {
1112        printerr("Too Few Arguments");
1113        env->err=1;
1114        return;
1115      }
1116      
1117      if(env->head->car->type==integer
1118         && env->head->cdr->content.c->car->type==integer) {
1119        a= env->head->car->content.i;
1120        toss(env); if(env->err) return;
1121        b= env->head->car->content.i;
1122        toss(env); if(env->err) return;
1123        push_int(env, b-a);
1124    
1125        return;
1126      }
1127    
1128      if(env->head->car->type==tfloat
1129         && env->head->cdr->content.c->car->type==tfloat) {
1130        fa= env->head->car->content.f;
1131        toss(env); if(env->err) return;
1132        fb= env->head->car->content.f;
1133        toss(env); if(env->err) return;
1134        push_float(env, fb-fa);
1135        
1136        return;
1137      }
1138    
1139      if(env->head->car->type==tfloat
1140         && env->head->cdr->content.c->car->type==integer) {
1141        fa= env->head->car->content.f;
1142        toss(env); if(env->err) return;
1143        b= env->head->car->content.i;
1144        toss(env); if(env->err) return;
1145        push_float(env, b-fa);
1146        
1147        return;
1148      }
1149    
1150      if(env->head->car->type==integer
1151         && env->head->cdr->content.c->car->type==tfloat) {
1152        a= env->head->car->content.i;
1153        toss(env); if(env->err) return;
1154        fb= env->head->car->content.f;
1155        toss(env); if(env->err) return;
1156        push_float(env, fb-a);
1157    
1158        return;
1159      }
1160    
1161      printerr("Bad Argument Type");
1162      env->err=2;
1163    }
1164    
1165    /* ">" */
1166    extern void sx_3e(environment *env)
1167    {
1168      int a, b;
1169      float fa, fb;
1170    
1171      if(env->head==NULL || env->head->cdr->content.c==NULL) {
1172        printerr("Too Few Arguments");
1173        env->err= 1;
1174        return;
1175      }
1176      
1177      if(env->head->car->type==integer
1178         && env->head->cdr->content.c->car->type==integer) {
1179        a=env->head->car->content.i;
1180        toss(env); if(env->err) return;
1181        b=env->head->car->content.i;
1182        toss(env); if(env->err) return;
1183        push_int(env, b>a);
1184    
1185        return;
1186      }
1187    
1188      if(env->head->car->type==tfloat
1189         && env->head->cdr->content.c->car->type==tfloat) {
1190        fa= env->head->car->content.f;
1191        toss(env); if(env->err) return;
1192        fb= env->head->car->content.f;
1193        toss(env); if(env->err) return;
1194        push_int(env, fb>fa);
1195        
1196        return;
1197      }
1198    
1199      if(env->head->car->type==tfloat
1200         && env->head->cdr->content.c->car->type==integer) {
1201        fa= env->head->car->content.f;
1202        toss(env); if(env->err) return;
1203        b= env->head->car->content.i;
1204        toss(env); if(env->err) return;
1205        push_int(env, b>fa);
1206        
1207        return;
1208      }
1209    
1210      if(env->head->car->type==integer
1211         && env->head->cdr->content.c->car->type==tfloat) {
1212        a= env->head->car->content.i;
1213        toss(env); if(env->err) return;
1214        fb= env->head->car->content.f;
1215        toss(env); if(env->err) return;
1216        push_int(env, fb>a);
1217    
1218        return;
1219      }
1220    
1221      printerr("Bad Argument Type");
1222      env->err=2;
1223    }
1224    
1225    /* "<" */
1226    extern void sx_3c(environment *env)
1227    {
1228      swap(env); if(env->err) return;
1229      sx_3e(env);
1230    }
1231    
1232    /* "<=" */
1233    extern void sx_3c3d(environment *env)
1234    {
1235      sx_3e(env); if(env->err) return;
1236      not(env);
1237    }
1238    
1239    /* ">=" */
1240    extern void sx_3e3d(environment *env)
1241    {
1242      sx_3c(env); if(env->err) return;
1243      not(env);
1244    }
1245    
1246    /* Return copy of a value */
1247    value *copy_val(environment *env, value *old_value)
1248    {
1249      cons *old_item, *new_item, *prev_item;
1250      value *new_value;
1251    
1252      protect(old_value);
1253      new_value= new_val(env);
1254      protect(new_value);
1255      new_value->type= old_value->type;
1256    
1257      switch(old_value->type){
1258      case tfloat:
1259      case integer:
1260      case func:
1261      case symb:
1262        new_value->content= old_value->content;
1263        break;
1264      case string:
1265        (char *)(new_value->content.ptr)=
1266          strdup((char *)(old_value->content.ptr));
1267        break;
1268      case tcons:
1269        new_value->content.ptr= NULL;
1270    
1271        prev_item= NULL;
1272        old_item= (cons*)(old_value->content.ptr);
1273    
1274        while(old_item != NULL) {   /* While list is not empty */
1275          new_item= malloc(sizeof(cons));
1276          new_item->car= copy_val(env, old_item->car); /* recurse */
1277          new_item->cdr= new_val(env);
1278          new_item->cdr->type= tcons;
1279          new_item->cdr->content.c= NULL;
1280          if(prev_item != NULL)     /* If this wasn't the first item */
1281            prev_item->cdr->content.c= new_item; /* point the previous item to the
1282                                         new item */
1283          else
1284            new_value->content.ptr= new_item;
1285          old_item= old_item->cdr->content.c;
1286          prev_item= new_item;
1287        }    
1288        break;
1289      }
1290    
1291      unprotect(old_value); unprotect(new_value);
1292    
1293      return new_value;
1294    }
1295    
1296    /* "dup"; duplicates an item on the stack */
1297    extern void sx_647570(environment *env)
1298    {
1299      if(env->head==NULL) {
1300        printerr("Too Few Arguments");
1301        env->err= 1;
1302        return;
1303      }
1304      push_val(env, copy_val(env, env->head->car));
1305    }
1306    
1307    /* "if", If-Then */
1308    extern void sx_6966(environment *env)
1309    {
1310      int truth;
1311    
1312      if(env->head==NULL || env->head->cdr->content.c==NULL) {
1313        printerr("Too Few Arguments");
1314        env->err= 1;
1315        return;
1316      }
1317    
1318      if(env->head->cdr->content.c->car->type != integer) {
1319        printerr("Bad Argument Type");
1320        env->err= 2;
1321        return;
1322      }
1323      
1324      swap(env);
1325      if(env->err) return;
1326      
1327      truth=env->head->car->content.i;
1328    
1329      toss(env);
1330      if(env->err) return;
1331    
1332      if(truth)
1333        eval(env);
1334      else
1335        toss(env);
1336    }
1337    
1338    /* If-Then-Else */
1339    extern void ifelse(environment *env)
1340    {
1341      int truth;
1342    
1343      if(env->head==NULL || env->head->cdr->content.c==NULL
1344         || env->head->cdr->content.c->cdr->content.c==NULL) {
1345        printerr("Too Few Arguments");
1346        env->err= 1;
1347        return;
1348      }
1349    
1350      if(env->head->cdr->content.c->cdr->content.c->car->type!=integer) {
1351        printerr("Bad Argument Type");
1352        env->err= 2;
1353        return;
1354      }
1355      
1356      rot(env);
1357      if(env->err) return;
1358      
1359      truth= env->head->car->content.i;
1360    
1361      toss(env);
1362      if(env->err) return;
1363    
1364      if(!truth)
1365        swap(env);
1366      if(env->err) return;
1367    
1368      toss(env);
1369      if(env->err) return;
1370    
1371      eval(env);
1372    }
1373    
1374    /* "while" */
1375    extern void sx_7768696c65(environment *env)
1376    {
1377      int truth;
1378      value *loop, *test;
1379    
1380      if(env->head==NULL || env->head->cdr->content.c==NULL) {
1381        printerr("Too Few Arguments");
1382        env->err= 1;
1383        return;
1384      }
1385    
1386      loop= env->head->car;
1387      protect(loop);
1388      toss(env); if(env->err) return;
1389    
1390      test= env->head->car;
1391      protect(test);
1392      toss(env); if(env->err) return;
1393    
1394      do {
1395        push_val(env, test);
1396        eval(env);
1397        
1398        if(env->head->car->type != integer) {
1399          printerr("Bad Argument Type");
1400          env->err= 2;
1401          return;
1402        }
1403        
1404        truth= env->head->car->content.i;
1405        toss(env); if(env->err) return;
1406        
1407        if(truth) {
1408          push_val(env, loop);
1409          eval(env);
1410        } else {
1411          toss(env);
1412        }
1413      
1414      } while(truth);
1415    
1416      unprotect(loop); unprotect(test);
1417    }
1418    
1419    
1420    /* "for"; for-loop */
1421    extern void sx_666f72(environment *env)
1422    {
1423      value *loop;
1424      int foo1, foo2;
1425    
1426      if(env->head==NULL || env->head->cdr->content.c==NULL
1427         || env->head->cdr->content.c->cdr->content.c==NULL) {
1428        printerr("Too Few Arguments");
1429        env->err= 1;
1430        return;
1431      }
1432    
1433      if(env->head->cdr->content.c->car->type!=integer
1434         || env->head->cdr->content.c->cdr->content.c->car->type!=integer) {
1435        printerr("Bad Argument Type");
1436        env->err= 2;
1437        return;
1438      }
1439    
1440      loop= env->head->car;
1441      protect(loop);
1442      toss(env); if(env->err) return;
1443    
1444      foo2= env->head->car->content.i;
1445      toss(env); if(env->err) return;
1446    
1447      foo1= env->head->car->content.i;
1448      toss(env); if(env->err) return;
1449    
1450      if(foo1<=foo2) {
1451        while(foo1<=foo2) {
1452          push_int(env, foo1);
1453          push_val(env, loop);
1454          eval(env); if(env->err) return;
1455          foo1++;
1456        }
1457      } else {
1458        while(foo1>=foo2) {
1459          push_int(env, foo1);
1460          push_val(env, loop);
1461          eval(env); if(env->err) return;
1462          foo1--;
1463        }
1464      }
1465      unprotect(loop);
1466    }
1467    
1468    /* Variant of for-loop */
1469    extern void foreach(environment *env)
1470    {  
1471      value *loop, *foo;
1472      cons *iterator;
1473      
1474      if(env->head==NULL || env->head->cdr->content.c==NULL) {
1475        printerr("Too Few Arguments");
1476        env->err= 1;
1477        return;
1478      }
1479    
1480      if(env->head->cdr->content.c->car->type!=tcons) {
1481        printerr("Bad Argument Type");
1482        env->err= 2;
1483        return;
1484      }
1485    
1486      loop= env->head->car;
1487      protect(loop);
1488      toss(env); if(env->err) return;
1489    
1490      foo= env->head->car;
1491      protect(foo);
1492      toss(env); if(env->err) return;
1493    
1494      iterator= foo->content.ptr;
1495    
1496      while(iterator!=NULL) {
1497        push_val(env, iterator->car);
1498        push_val(env, loop);
1499        eval(env); if(env->err) return;
1500        iterator= iterator->cdr->content.c;
1501      }
1502      unprotect(loop); unprotect(foo);
1503    }
1504    
1505    /* "to" */
1506    extern void to(environment *env)
1507    {
1508      int ending, start, i;
1509      cons *iterator, *temp;
1510      value *pack;
1511    
1512      if(env->head==NULL || env->head->cdr->content.c==NULL) {
1513        printerr("Too Few Arguments");
1514        env->err= 1;
1515        return;
1516      }
1517    
1518      if(env->head->car->type!=integer
1519         || env->head->cdr->content.c->car->type!=integer) {
1520        printerr("Bad Argument Type");
1521        env->err= 2;
1522        return;
1523      }
1524    
1525      ending= env->head->car->content.i;
1526      toss(env); if(env->err) return;
1527      start= env->head->car->content.i;
1528      toss(env); if(env->err) return;
1529    
1530      push_sym(env, "[");
1531    
1532      if(ending>=start) {
1533        for(i= ending; i>=start; i--)
1534          push_int(env, i);
1535      } else {
1536        for(i= ending; i<=start; i++)
1537          push_int(env, i);
1538      }
1539    
1540      iterator= env->head;
1541      pack= new_val(env);
1542      protect(pack);
1543    
1544      if(iterator==NULL
1545         || (iterator->car->type==symb
1546         && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) {
1547        temp= NULL;
1548        toss(env);
1549      } else {
1550        /* Search for first delimiter */
1551        while(iterator->cdr->content.c!=NULL
1552              && (iterator->cdr->content.c->car->type!=symb
1553              || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0]
1554                  !='['))
1555          iterator= iterator->cdr->content.c;
1556        
1557        /* Extract list */
1558        temp= env->head;
1559        env->head= iterator->cdr->content.c;
1560        iterator->cdr->content.c= NULL;
1561    
1562        pack->type= tcons;
1563        pack->content.ptr= temp;
1564        
1565        if(env->head!=NULL)
1566          toss(env);
1567      }
1568    
1569      /* Push list */
1570    
1571      push_val(env, pack);
1572    
1573      unprotect(pack);
1574    }
1575    
1576    /* Read a string */
1577    extern void readline(environment *env)
1578    {
1579      char in_string[101];
1580    
1581      if(fgets(in_string, 100, env->inputstream)==NULL)
1582        push_cstring(env, "");
1583      else
1584        push_cstring(env, in_string);
1585    }
1586    
1587    /* "read"; Read a value and place on stack */
1588    extern void sx_72656164(environment *env)
1589    {
1590      const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1591      const char strform[]= "\"%[^\"]\"%n";
1592      const char intform[]= "%i%n";
1593      const char fltform[]= "%f%n";
1594      const char blankform[]= "%*[ \t]%n";
1595      const char ebrackform[]= "]%n";
1596      const char semicform[]= ";%n";
1597      const char bbrackform[]= "[%n";
1598    
1599      int itemp, readlength= -1;
1600      int count= -1;
1601      float ftemp;
1602      static int depth= 0;
1603      char *match, *ctemp;
1604      size_t inlength;
1605    
1606      if(env->in_string==NULL) {
1607        if(depth > 0 && env->interactive) {
1608          printf("]> ");
1609        }
1610        readline(env); if(env->err) return;
1611    
1612        if(((char *)(env->head->car->content.ptr))[0]=='\0'){
1613          env->err= 4;              /* "" means EOF */
1614          return;
1615        }
1616        
1617        env->in_string= malloc(strlen(env->head->car->content.ptr)+1);
1618        env->free_string= env->in_string; /* Save the original pointer */
1619        strcpy(env->in_string, env->head->car->content.ptr);
1620        toss(env); if(env->err) return;
1621      }
1622      
1623      inlength= strlen(env->in_string)+1;
1624      match= malloc(inlength);
1625    
1626      if(sscanf(env->in_string, blankform, &readlength) != EOF
1627         && readlength != -1) {
1628        ;
1629      } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
1630                && readlength != -1) {
1631        if(sscanf(env->in_string, intform, &itemp, &count) != EOF
1632           && count==readlength) {
1633          push_int(env, itemp);
1634        } else {
1635          push_float(env, ftemp);
1636        }
1637      } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1638                && readlength != -1) {
1639        push_cstring(env, match);
1640      } else if(sscanf(env->in_string, symbform, match, &readlength) != EOF
1641                && readlength != -1) {
1642        push_sym(env, match);
1643      } else if(sscanf(env->in_string, ebrackform, &readlength) != EOF
1644                && readlength != -1) {
1645        pack(env); if(env->err) return;
1646        if(depth != 0) depth--;
1647      } else if(sscanf(env->in_string, semicform, &readlength) != EOF
1648                && readlength != -1) {
1649        push_sym(env, ";");
1650      } else if(sscanf(env->in_string, bbrackform, &readlength) != EOF
1651                && readlength != -1) {
1652        push_sym(env, "[");
1653        depth++;
1654      } else {
1655        free(env->free_string);
1656        env->in_string = env->free_string = NULL;
1657      }
1658      if (env->in_string != NULL) {
1659        env->in_string += readlength;
1660      }
1661    
1662      free(match);
1663    
1664      if(depth)
1665        return sx_72656164(env);
1666    }
1667    
1668    extern void beep(environment *env)
1669    {
1670      int freq, dur, period, ticks;
1671    
1672      if(env->head==NULL || env->head->cdr->content.c==NULL) {
1673        printerr("Too Few Arguments");
1674        env->err= 1;
1675        return;
1676      }
1677    
1678      if(env->head->car->type!=integer
1679         || env->head->cdr->content.c->car->type!=integer) {
1680        printerr("Bad Argument Type");
1681        env->err= 2;
1682        return;
1683      }
1684    
1685      dur= env->head->car->content.i;
1686      toss(env);
1687      freq= env->head->car->content.i;
1688      toss(env);
1689    
1690      period= 1193180/freq;         /* convert freq from Hz to period
1691                                       length */
1692      ticks= dur*.001193180;        /* convert duration from µseconds to
1693                                       timer ticks */
1694    
1695    /*    ticks=dur/1000; */
1696    
1697          /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1698      switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1699      case 0:
1700        usleep(dur);
1701        return;
1702      case -1:
1703        perror("beep");
1704        env->err= 5;
1705        return;
1706      default:
1707        abort();
1708      }
1709    }
1710    
1711    /* "wait" */
1712    extern void sx_77616974(environment *env)
1713    {
1714      int dur;
1715    
1716      if(env->head==NULL) {
1717        printerr("Too Few Arguments");
1718        env->err= 1;
1719        return;
1720      }
1721    
1722      if(env->head->car->type!=integer) {
1723        printerr("Bad Argument Type");
1724        env->err= 2;
1725        return;
1726      }
1727    
1728      dur=env->head->car->content.i;
1729      toss(env);
1730    
1731      usleep(dur);
1732    }
1733    
1734    extern void copying(environment *env)
1735    {
1736      printf("GNU GENERAL PUBLIC LICENSE\n\
1737                           Version 2, June 1991\n\
1738    \n\
1739     Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
1740         59 Temple Place, Suite 330, Boston, MA  02111-1307  USA\n\
1741     Everyone is permitted to copy and distribute verbatim copies\n\
1742     of this license document, but changing it is not allowed.\n\
1743    \n\
1744                                Preamble\n\
1745    \n\
1746      The licenses for most software are designed to take away your\n\
1747    freedom to share and change it.  By contrast, the GNU General Public\n\
1748    License is intended to guarantee your freedom to share and change free\n\
1749    software--to make sure the software is free for all its users.  This\n\
1750    General Public License applies to most of the Free Software\n\
1751    Foundation's software and to any other program whose authors commit to\n\
1752    using it.  (Some other Free Software Foundation software is covered by\n\
1753    the GNU Library General Public License instead.)  You can apply it to\n\
1754    your programs, too.\n\
1755    \n\
1756      When we speak of free software, we are referring to freedom, not\n\
1757    price.  Our General Public Licenses are designed to make sure that you\n\
1758    have the freedom to distribute copies of free software (and charge for\n\
1759    this service if you wish), that you receive source code or can get it\n\
1760    if you want it, that you can change the software or use pieces of it\n\
1761    in new free programs; and that you know you can do these things.\n\
1762    \n\
1763      To protect your rights, we need to make restrictions that forbid\n\
1764    anyone to deny you these rights or to ask you to surrender the rights.\n\
1765    These restrictions translate to certain responsibilities for you if you\n\
1766    distribute copies of the software, or if you modify it.\n\
1767    \n\
1768      For example, if you distribute copies of such a program, whether\n\
1769    gratis or for a fee, you must give the recipients all the rights that\n\
1770    you have.  You must make sure that they, too, receive or can get the\n\
1771    source code.  And you must show them these terms so they know their\n\
1772    rights.\n\
1773    \n\
1774      We protect your rights with two steps: (1) copyright the software, and\n\
1775    (2) offer you this license which gives you legal permission to copy,\n\
1776    distribute and/or modify the software.\n\
1777    \n\
1778      Also, for each author's protection and ours, we want to make certain\n\
1779    that everyone understands that there is no warranty for this free\n\
1780    software.  If the software is modified by someone else and passed on, we\n\
1781    want its recipients to know that what they have is not the original, so\n\
1782    that any problems introduced by others will not reflect on the original\n\
1783    authors' reputations.\n\
1784    \n\
1785      Finally, any free program is threatened constantly by software\n\
1786    patents.  We wish to avoid the danger that redistributors of a free\n\
1787    program will individually obtain patent licenses, in effect making the\n\
1788    program proprietary.  To prevent this, we have made it clear that any\n\
1789    patent must be licensed for everyone's free use or not licensed at all.\n\
1790    \n\
1791      The precise terms and conditions for copying, distribution and\n\
1792    modification follow.\n\
1793    \n\
1794                        GNU GENERAL PUBLIC LICENSE\n\
1795       TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION\n\
1796    \n\
1797      0. This License applies to any program or other work which contains\n\
1798    a notice placed by the copyright holder saying it may be distributed\n\
1799    under the terms of this General Public License.  The \"Program\", below,\n\
1800    refers to any such program or work, and a \"work based on the Program\"\n\
1801    means either the Program or any derivative work under copyright law:\n\
1802    that is to say, a work containing the Program or a portion of it,\n\
1803    either verbatim or with modifications and/or translated into another\n\
1804    language.  (Hereinafter, translation is included without limitation in\n\
1805    the term \"modification\".)  Each licensee is addressed as \"you\".\n\
1806    \n\
1807    Activities other than copying, distribution and modification are not\n\
1808    covered by this License; they are outside its scope.  The act of\n\
1809    running the Program is not restricted, and the output from the Program\n\
1810    is covered only if its contents constitute a work based on the\n\
1811    Program (independent of having been made by running the Program).\n\
1812    Whether that is true depends on what the Program does.\n\
1813    \n\
1814      1. You may copy and distribute verbatim copies of the Program's\n\
1815    source code as you receive it, in any medium, provided that you\n\
1816    conspicuously and appropriately publish on each copy an appropriate\n\
1817    copyright notice and disclaimer of warranty; keep intact all the\n\
1818    notices that refer to this License and to the absence of any warranty;\n\
1819    and give any other recipients of the Program a copy of this License\n\
1820    along with the Program.\n\
1821    \n\
1822    You may charge a fee for the physical act of transferring a copy, and\n\
1823    you may at your option offer warranty protection in exchange for a fee.\n\
1824    \n\
1825      2. You may modify your copy or copies of the Program or any portion\n\
1826    of it, thus forming a work based on the Program, and copy and\n\
1827    distribute such modifications or work under the terms of Section 1\n\
1828    above, provided that you also meet all of these conditions:\n\
1829    \n\
1830        a) You must cause the modified files to carry prominent notices\n\
1831        stating that you changed the files and the date of any change.\n\
1832    \n\
1833        b) You must cause any work that you distribute or publish, that in\n\
1834        whole or in part contains or is derived from the Program or any\n\
1835        part thereof, to be licensed as a whole at no charge to all third\n\
1836        parties under the terms of this License.\n\
1837    \n\
1838        c) If the modified program normally reads commands interactively\n\
1839        when run, you must cause it, when started running for such\n\
1840        interactive use in the most ordinary way, to print or display an\n\
1841        announcement including an appropriate copyright notice and a\n\
1842        notice that there is no warranty (or else, saying that you provide\n\
1843        a warranty) and that users may redistribute the program under\n\
1844        these conditions, and telling the user how to view a copy of this\n\
1845        License.  (Exception: if the Program itself is interactive but\n\
1846        does not normally print such an announcement, your work based on\n\
1847        the Program is not required to print an announcement.)\n\
1848    \n\
1849    These requirements apply to the modified work as a whole.  If\n\
1850    identifiable sections of that work are not derived from the Program,\n\
1851    and can be reasonably considered independent and separate works in\n\
1852    themselves, then this License, and its terms, do not apply to those\n\
1853    sections when you distribute them as separate works.  But when you\n\
1854    distribute the same sections as part of a whole which is a work based\n\
1855    on the Program, the distribution of the whole must be on the terms of\n\
1856    this License, whose permissions for other licensees extend to the\n\
1857    entire whole, and thus to each and every part regardless of who wrote it.\n\
1858    \n\
1859    Thus, it is not the intent of this section to claim rights or contest\n\
1860    your rights to work written entirely by you; rather, the intent is to\n\
1861    exercise the right to control the distribution of derivative or\n\
1862    collective works based on the Program.\n\
1863    \n\
1864    In addition, mere aggregation of another work not based on the Program\n\
1865    with the Program (or with a work based on the Program) on a volume of\n\
1866    a storage or distribution medium does not bring the other work under\n\
1867    the scope of this License.\n\
1868    \n\
1869      3. You may copy and distribute the Program (or a work based on it,\n\
1870    under Section 2) in object code or executable form under the terms of\n\
1871    Sections 1 and 2 above provided that you also do one of the following:\n\
1872    \n\
1873        a) Accompany it with the complete corresponding machine-readable\n\
1874        source code, which must be distributed under the terms of Sections\n\
1875        1 and 2 above on a medium customarily used for software interchange; or,\n\
1876    \n\
1877        b) Accompany it with a written offer, valid for at least three\n\
1878        years, to give any third party, for a charge no more than your\n\
1879        cost of physically performing source distribution, a complete\n\
1880        machine-readable copy of the corresponding source code, to be\n\
1881        distributed under the terms of Sections 1 and 2 above on a medium\n\
1882        customarily used for software interchange; or,\n\
1883    \n\
1884        c) Accompany it with the information you received as to the offer\n\
1885        to distribute corresponding source code.  (This alternative is\n\
1886        allowed only for noncommercial distribution and only if you\n\
1887        received the program in object code or executable form with such\n\
1888        an offer, in accord with Subsection b above.)\n\
1889    \n\
1890    The source code for a work means the preferred form of the work for\n\
1891    making modifications to it.  For an executable work, complete source\n\
1892    code means all the source code for all modules it contains, plus any\n\
1893    associated interface definition files, plus the scripts used to\n\
1894    control compilation and installation of the executable.  However, as a\n\
1895    special exception, the source code distributed need not include\n\
1896    anything that is normally distributed (in either source or binary\n\
1897    form) with the major components (compiler, kernel, and so on) of the\n\
1898    operating system on which the executable runs, unless that component\n\
1899    itself accompanies the executable.\n\
1900    \n\
1901    If distribution of executable or object code is made by offering\n\
1902    access to copy from a designated place, then offering equivalent\n\
1903    access to copy the source code from the same place counts as\n\
1904    distribution of the source code, even though third parties are not\n\
1905    compelled to copy the source along with the object code.\n\
1906    \n\
1907      4. You may not copy, modify, sublicense, or distribute the Program\n\
1908    except as expressly provided under this License.  Any attempt\n\
1909    otherwise to copy, modify, sublicense or distribute the Program is\n\
1910    void, and will automatically terminate your rights under this License.\n\
1911    However, parties who have received copies, or rights, from you under\n\
1912    this License will not have their licenses terminated so long as such\n\
1913    parties remain in full compliance.\n\
1914    \n\
1915      5. You are not required to accept this License, since you have not\n\
1916    signed it.  However, nothing else grants you permission to modify or\n\
1917    distribute the Program or its derivative works.  These actions are\n\
1918    prohibited by law if you do not accept this License.  Therefore, by\n\
1919    modifying or distributing the Program (or any work based on the\n\
1920    Program), you indicate your acceptance of this License to do so, and\n\
1921    all its terms and conditions for copying, distributing or modifying\n\
1922    the Program or works based on it.\n\
1923    \n\
1924      6. Each time you redistribute the Program (or any work based on the\n\
1925    Program), the recipient automatically receives a license from the\n\
1926    original licensor to copy, distribute or modify the Program subject to\n\
1927    these terms and conditions.  You may not impose any further\n\
1928    restrictions on the recipients' exercise of the rights granted herein.\n\
1929    You are not responsible for enforcing compliance by third parties to\n\
1930    this License.\n\
1931    \n\
1932      7. If, as a consequence of a court judgment or allegation of patent\n\
1933    infringement or for any other reason (not limited to patent issues),\n\
1934    conditions are imposed on you (whether by court order, agreement or\n\
1935    otherwise) that contradict the conditions of this License, they do not\n\
1936    excuse you from the conditions of this License.  If you cannot\n\
1937    distribute so as to satisfy simultaneously your obligations under this\n\
1938    License and any other pertinent obligations, then as a consequence you\n\
1939    may not distribute the Program at all.  For example, if a patent\n\
1940    license would not permit royalty-free redistribution of the Program by\n\
1941    all those who receive copies directly or indirectly through you, then\n\
1942    the only way you could satisfy both it and this License would be to\n\
1943    refrain entirely from distribution of the Program.\n\
1944    \n\
1945    If any portion of this section is held invalid or unenforceable under\n\
1946    any particular circumstance, the balance of the section is intended to\n\
1947    apply and the section as a whole is intended to apply in other\n\
1948    circumstances.\n\
1949    \n\
1950    It is not the purpose of this section to induce you to infringe any\n\
1951    patents or other property right claims or to contest validity of any\n\
1952    such claims; this section has the sole purpose of protecting the\n\
1953    integrity of the free software distribution system, which is\n\
1954    implemented by public license practices.  Many people have made\n\
1955    generous contributions to the wide range of software distributed\n\
1956    through that system in reliance on consistent application of that\n\
1957    system; it is up to the author/donor to decide if he or she is willing\n\
1958    to distribute software through any other system and a licensee cannot\n\
1959    impose that choice.\n\
1960    \n\
1961    This section is intended to make thoroughly clear what is believed to\n\
1962    be a consequence of the rest of this License.\n\
1963    \n\
1964      8. If the distribution and/or use of the Program is restricted in\n\
1965    certain countries either by patents or by copyrighted interfaces, the\n\
1966    original copyright holder who places the Program under this License\n\
1967    may add an explicit geographical distribution limitation excluding\n\
1968    those countries, so that distribution is permitted only in or among\n\
1969    countries not thus excluded.  In such case, this License incorporates\n\
1970    the limitation as if written in the body of this License.\n\
1971    \n\
1972      9. The Free Software Foundation may publish revised and/or new versions\n\
1973    of the General Public License from time to time.  Such new versions will\n\
1974    be similar in spirit to the present version, but may differ in detail to\n\
1975    address new problems or concerns.\n\
1976    \n\
1977    Each version is given a distinguishing version number.  If the Program\n\
1978    specifies a version number of this License which applies to it and \"any\n\
1979    later version\", you have the option of following the terms and conditions\n\
1980    either of that version or of any later version published by the Free\n\
1981    Software Foundation.  If the Program does not specify a version number of\n\
1982    this License, you may choose any version ever published by the Free Software\n\
1983    Foundation.\n\
1984    \n\
1985      10. If you wish to incorporate parts of the Program into other free\n\
1986    programs whose distribution conditions are different, write to the author\n\
1987    to ask for permission.  For software which is copyrighted by the Free\n\
1988    Software Foundation, write to the Free Software Foundation; we sometimes\n\
1989    make exceptions for this.  Our decision will be guided by the two goals\n\
1990    of preserving the free status of all derivatives of our free software and\n\
1991    of promoting the sharing and reuse of software generally.\n");
1992    }
1993    
1994    extern void warranty(environment *env)
1995    {
1996      printf("                          NO WARRANTY\n\
1997    \n\
1998      11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\
1999    FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN\n\
2000    OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES\n\
2001    PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED\n\
2002    OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF\n\
2003    MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS\n\
2004    TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE\n\
2005    PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,\n\
2006    REPAIR OR CORRECTION.\n\
2007    \n\
2008      12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\n\
2009    WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR\n\
2010    REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,\n\
2011    INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING\n\
2012    OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED\n\
2013    TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY\n\
2014    YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER\n\
2015    PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE\n\
2016    POSSIBILITY OF SUCH DAMAGES.\n");
2017    }
2018    
2019    /* "*" */
2020    extern void sx_2a(environment *env)
2021    {
2022      int a, b;
2023      float fa, fb;
2024    
2025      if(env->head==NULL || env->head->cdr->content.c==NULL) {
2026        printerr("Too Few Arguments");
2027        env->err= 1;
2028        return;
2029      }
2030      
2031      if(env->head->car->type==integer
2032         && env->head->cdr->content.c->car->type==integer) {
2033        a= env->head->car->content.i;
2034        toss(env); if(env->err) return;
2035        b= env->head->car->content.i;
2036        toss(env); if(env->err) return;
2037        push_int(env, b*a);
2038    
2039        return;
2040      }
2041    
2042      if(env->head->car->type==tfloat
2043         && env->head->cdr->content.c->car->type==tfloat) {
2044        fa= env->head->car->content.f;
2045        toss(env); if(env->err) return;
2046        fb= env->head->car->content.f;
2047        toss(env); if(env->err) return;
2048        push_float(env, fb*fa);
2049        
2050        return;
2051      }
2052    
2053      if(env->head->car->type==tfloat
2054         && env->head->cdr->content.c->car->type==integer) {
2055        fa= env->head->car->content.f;
2056        toss(env); if(env->err) return;
2057        b= env->head->car->content.i;
2058        toss(env); if(env->err) return;
2059        push_float(env, b*fa);
2060        
2061        return;
2062      }
2063    
2064      if(env->head->car->type==integer
2065         && env->head->cdr->content.c->car->type==tfloat) {
2066        a= env->head->car->content.i;
2067        toss(env); if(env->err) return;
2068        fb= env->head->car->content.f;
2069        toss(env); if(env->err) return;
2070        push_float(env, fb*a);
2071    
2072        return;
2073      }
2074    
2075      printerr("Bad Argument Type");
2076      env->err= 2;
2077    }
2078    
2079    /* "/" */
2080    extern void sx_2f(environment *env)
2081    {
2082      int a, b;
2083      float fa, fb;
2084    
2085      if(env->head==NULL || env->head->cdr->content.c==NULL) {
2086        printerr("Too Few Arguments");
2087        env->err= 1;
2088        return;
2089      }
2090      
2091      if(env->head->car->type==integer
2092         && env->head->cdr->content.c->car->type==integer) {
2093        a= env->head->car->content.i;
2094        toss(env); if(env->err) return;
2095        b= env->head->car->content.i;
2096        toss(env); if(env->err) return;
2097        push_float(env, b/a);
2098    
2099        return;
2100      }
2101    
2102      if(env->head->car->type==tfloat
2103         && env->head->cdr->content.c->car->type==tfloat) {
2104        fa= env->head->car->content.f;
2105        toss(env); if(env->err) return;
2106        fb= env->head->car->content.f;
2107        toss(env); if(env->err) return;
2108        push_float(env, fb/fa);
2109        
2110        return;
2111      }
2112    
2113      if(env->head->car->type==tfloat
2114         && env->head->cdr->content.c->car->type==integer) {
2115        fa= env->head->car->content.f;
2116        toss(env); if(env->err) return;
2117        b= env->head->car->content.i;
2118        toss(env); if(env->err) return;
2119        push_float(env, b/fa);
2120        
2121        return;
2122      }
2123    
2124      if(env->head->car->type==integer
2125         && env->head->cdr->content.c->car->type==tfloat) {
2126        a= env->head->car->content.i;
2127        toss(env); if(env->err) return;
2128        fb= env->head->car->content.f;
2129        toss(env); if(env->err) return;
2130        push_float(env, fb/a);
2131    
2132        return;
2133      }
2134    
2135      printerr("Bad Argument Type");
2136      env->err= 2;
2137    }
2138    
2139    /* "mod" */
2140    extern void mod(environment *env)
2141    {
2142      int a, b;
2143    
2144      if(env->head==NULL || env->head->cdr->content.c==NULL) {
2145        printerr("Too Few Arguments");
2146        env->err= 1;
2147        return;
2148      }
2149      
2150      if(env->head->car->type==integer
2151         && env->head->cdr->content.c->car->type==integer) {
2152        a= env->head->car->content.i;
2153        toss(env); if(env->err) return;
2154        b= env->head->car->content.i;
2155        toss(env); if(env->err) return;
2156        push_int(env, b%a);
2157    
2158        return;
2159      }
2160    
2161      printerr("Bad Argument Type");
2162      env->err= 2;
2163    }
2164    
2165    /* "div" */
2166    extern void sx_646976(environment *env)
2167    {
2168      int a, b;
2169      
2170      if(env->head==NULL || env->head->cdr->content.c==NULL) {
2171        printerr("Too Few Arguments");
2172        env->err= 1;
2173        return;
2174      }
2175    
2176      if(env->head->car->type==integer
2177         && env->head->cdr->content.c->car->type==integer) {
2178        a= env->head->car->content.i;
2179        toss(env); if(env->err) return;
2180        b= env->head->car->content.i;
2181        toss(env); if(env->err) return;
2182        push_int(env, (int)b/a);
2183    
2184        return;
2185      }
2186    
2187      printerr("Bad Argument Type");
2188      env->err= 2;
2189    }
Legend:
Removed from v.1.43  
changed lines
  Added in v.1.102
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26