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