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