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

Diff of /stack/stack.c

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

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