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

Diff of /stack/stack.c

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

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