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

Diff of /stack/stack.c

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

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