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