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

Diff of /stack/stack.c

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

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