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

Diff of /stack/stack.c

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

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