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

Diff of /stack/stack.c

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

revision 1.90 by masse, Thu Mar 7 01:21:07 2002 UTC revision 1.101 by teddy, Sun Mar 10 13:00:01 2002 UTC
# Line 1  Line 1 
1    /*
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 */  /* printf, sscanf, fgets, fprintf, fopen, perror */
24  #include <stdio.h>  #include <stdio.h>
25  /* exit, EXIT_SUCCESS, malloc, free */  /* exit, EXIT_SUCCESS, malloc, free */
# 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 */  /* getopt, STDIN_FILENO, STDOUT_FILENO, usleep */
34  #include <unistd.h>  #include <unistd.h>
35  /* EX_NOINPUT, EX_USAGE */  /* EX_NOINPUT, EX_USAGE */
36  #include <sysexits.h>  #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  #include "stack.h"  #include "stack.h"
45    
# Line 22  void init_env(environment *env) Line 48  void init_env(environment *env)
48  {  {
49    int i;    int i;
50    
51    env->gc_limit= 20;    env->gc_limit= 400000;
52    env->gc_count= 0;    env->gc_count= 0;
53    env->gc_ref= NULL;    env->gc_ref= NULL;
   env->gc_protect= NULL;  
54    
55    env->head= NULL;    env->head= NULL;
56    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
# Line 37  void init_env(environment *env) Line 62  void init_env(environment *env)
62    env->interactive= 1;    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    
# Line 54  extern void toss(environment *env) Line 80  extern void toss(environment *env)
80        
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 */
   
   gc_init(env);  
83  }  }
84    
85  /* Returns a pointer to a pointer to an element in the hash table. */  /* Returns a pointer to a pointer to an element in the hash table. */
# Line 87  symbol **hash(hashtbl in_hashtbl, const Line 111  symbol **hash(hashtbl in_hashtbl, const
111    }    }
112  }  }
113    
114  value* new_val(environment *env) {  /* Create new value */
115    value* new_val(environment *env)
116    {
117    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
118    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
119    
120    nval->content.ptr= NULL;    nval->content.ptr= NULL;
   protect(env, nval);  
   
   gc_init(env);  
121    
122    nitem->item= nval;    nitem->item= nval;
123    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
124    env->gc_ref= nitem;    env->gc_ref= nitem;
125    
126    env->gc_count++;    env->gc_count += sizeof(value);
127    unprotect(env);    nval->gc.flag.mark= 0;
128      nval->gc.flag.protect= 0;
129    
130    return nval;    return nval;
131  }  }
132    
133  void gc_mark(value *val) {  /* Mark values recursively.
134       Marked values are not collected by the GC. */
135    inline void gc_mark(value *val)
136    {
137    stackitem *iterator;    stackitem *iterator;
138    
139    if(val==NULL || val->gc_garb==0)    if(val->gc.flag.mark)
140      return;      return;
141    
142    val->gc_garb= 0;    val->gc.flag.mark= 1;
143    
144    if(val->type==list) {    if(val->type==list) {
145      iterator= val->content.ptr;      iterator= val->content.ptr;
# Line 124  void gc_mark(value *val) { Line 151  void gc_mark(value *val) {
151    }    }
152  }  }
153    
154  extern void gc_init(environment *env) {  inline void gc_maybe(environment *env)
155    stackitem *new_head= NULL, *titem, *iterator= env->gc_ref;  {
   symbol *tsymb;  
   int i;  
   
156    if(env->gc_count < env->gc_limit)    if(env->gc_count < env->gc_limit)
157      return;      return;
158      else
159        return gc_init(env);
160    }
161    
162    while(iterator!=NULL) {  /* Start GC */
163      iterator->item->gc_garb= 1;  extern void gc_init(environment *env)
164      iterator= iterator->next;  {
165    }    stackitem *new_head= NULL, *titem, *iterator;
166      symbol *tsymb;
167      int i;
168    
169    /* Mark */    if(env->interactive){
170    iterator= env->gc_protect;      printf("Garbage collecting.");
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
171    }    }
172    
173      /* Mark values on stack */
174    iterator= env->head;    iterator= env->head;
175    while(iterator!=NULL) {    while(iterator!=NULL) {
176      gc_mark(iterator->item);      gc_mark(iterator->item);
177      iterator= iterator->next;      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++) {    for(i= 0; i<HASHTBLSIZE; i++) {
186      tsymb= env->symbols[i];      tsymb= env->symbols[i];
187      while(tsymb!=NULL) {      while(tsymb!=NULL) {
188        gc_mark(tsymb->val);        if (tsymb->val != NULL)
189            gc_mark(tsymb->val);
190        tsymb= tsymb->next;        tsymb= tsymb->next;
191      }      }
192    }    }
193    
194      if(env->interactive){
195        printf(".");
196      }
197    
198    env->gc_count= 0;    env->gc_count= 0;
199    
200    /* Sweep */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
201    while(env->gc_ref!=NULL) {  
202        if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
203    
204      if(env->gc_ref->item->gc_garb) {        switch(env->gc_ref->item->type) { /* Remove content */
       switch(env->gc_ref->item->type) {  
205        case string:        case string:
206          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
207          break;          break;
       case integer:  
         break;  
208        case list:        case list:
209          while(env->gc_ref->item->content.ptr!=NULL) {          while(env->gc_ref->item->content.ptr!=NULL) {
210            titem= env->gc_ref->item->content.ptr;            titem= env->gc_ref->item->content.ptr;
211            env->gc_ref->item->content.ptr= titem->next;            env->gc_ref->item->content.ptr= titem->next;
212            free(titem);            free(titem);
213          }          }
         break;  
214        default:        default:
         break;  
215        }        }
216        free(env->gc_ref->item);        free(env->gc_ref->item);  /* Remove from gc_ref */
217        titem= env->gc_ref->next;        titem= env->gc_ref->next;
218        free(env->gc_ref);        free(env->gc_ref);        /* Remove value */
219        env->gc_ref= titem;        env->gc_ref= titem;
220          continue;
221      } else {      } else {
222        titem= env->gc_ref->next;        env->gc_count += sizeof(value);
223        env->gc_ref->next= new_head;        if(env->gc_ref->item->type == string)
224        new_head= env->gc_ref;          env->gc_count += strlen(env->gc_ref->item->content.ptr);
       env->gc_ref= titem;  
       env->gc_count++;  
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    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
236        env->gc_limit= env->gc_count*2;
237    
238    env->gc_ref= new_head;    env->gc_ref= new_head;
239    
240      if(env->interactive){
241        printf("done\n");
242      }
243    
244  }  }
245    
246  void protect(environment *env, value *val)  /* Protect values from GC */
247    void protect(value *val)
248  {  {
249    stackitem *new_item= malloc(sizeof(stackitem));    stackitem *iterator;
250    new_item->item= val;  
251    new_item->next= env->gc_protect;    if(val->gc.flag.protect)
252    env->gc_protect= new_item;      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  void unprotect(environment *env)  /* Unprotect values from GC */
267    void unprotect(value *val)
268  {  {
269    stackitem *temp= env->gc_protect;    stackitem *iterator;
270    env->gc_protect= env->gc_protect->next;  
271    free(temp);    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 */
# Line 221  void push_val(environment *env, value *v Line 292  void push_val(environment *env, value *v
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= new_val(env);    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    
303    push_val(env, new_value);    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);
315    }
316    
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= new_val(env);    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;
327    
# Line 245  void push_cstring(environment *env, cons Line 329  void push_cstring(environment *env, cons
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    {
334    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
335    char *new_string, *current;    char *new_string, *current;
336    
# Line 263  char *mangle_str(const char *old_string) Line 348  char *mangle_str(const char *old_string)
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) {
# Line 302  void push_sym(environment *env, const ch Line 388  void push_sym(environment *env, const ch
388    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
389    
390    new_value= new_val(env);    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;
# Line 329  void push_sym(environment *env, const ch Line 418  void push_sym(environment *env, const ch
418    
419      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
420      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
421      free(mangled);  
422      dlerr= dlerror();      dlerr= dlerror();
423      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
424        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
425        dlerr= dlerror();        dlerr= dlerror();
426      }      }
427    
428      if(dlerr==NULL) {           /* If a function was found */      if(dlerr==NULL) {           /* If a function was found */
       new_fvalue= new_val(env); /* Create a new value */  
429        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
430        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 */
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 353  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 367  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 387  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 415  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 433  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 467  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 526  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(env, val);    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(env);    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 544  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 570  extern void eval(environment *env) Line 675  extern void eval(environment *env)
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      protect(env, temp_val);      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;
     unprotect(env);  
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                    
# Line 592  extern void eval(environment *env) Line 696  extern void eval(environment *env)
696        }        }
697        iterator= iterator->next;        iterator= iterator->next;
698      }      }
699        unprotect(temp_val);
700      return;      return;
701    
702    default:    default:
# Line 600  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) {
# Line 633  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 650  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= new_val(env);  
   pack->type= list;  
   pack->content.ptr= temp;  
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 739  extern void not(environment *env) Line 849  extern void not(environment *env)
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 782  extern void def(environment *env) Line 892  extern void def(environment *env)
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    
# Line 795  extern void quit(environment *env) Line 905  extern void quit(environment *env)
905    }    }
906    
907    env->gc_limit= 0;    env->gc_limit= 0;
908    gc_init(env);    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 828  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;
# Line 863  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    
# Line 903  int main(int argc, char **argv) Line 1015  int main(int argc, char **argv)
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        if (myenv.interactive) {        if (myenv.interactive) {
# Line 917  int main(int argc, char **argv) Line 1037  int main(int argc, char **argv)
1037      }      }
1038      sx_72656164(&myenv);      sx_72656164(&myenv);
1039      if (myenv.err==4) {      if (myenv.err==4) {
1040        return EX_NOINPUT;        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_init(&myenv);      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;
# Line 947  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      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
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;
# Line 955  extern void sx_2b(environment *env) { Line 1077  extern void sx_2b(environment *env) {
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);
1079      push_cstring(env, new_string);      push_cstring(env, new_string);
1080      unprotect(env); unprotect(env);      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->err) return;    if(env->head->item->type==tfloat
1098           && env->head->next->item->type==tfloat) {
1099    b= env->head->item->content.val;      fa= env->head->item->content.f;
1100    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1101    push_int(env, a+b);      fb= env->head->item->content.f;
1102        toss(env); if(env->err) return;
1103        push_float(env, fb+fa);
1104        
1105        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 984  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    
1157    a=env->head->item->content.val;    if(env->head->item->type==tfloat
1158    toss(env); if(env->err) return;       && env->head->next->item->type==tfloat) {
1159    b=env->head->item->content.val;      fa= env->head->item->content.f;
1160    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1161    push_int(env, b-a);      fb= env->head->item->content.f;
1162        toss(env); if(env->err) return;
1163        push_float(env, fb-fa);
1164        
1165        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 1008  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    
1217    a=env->head->item->content.val;    if(env->head->item->type==tfloat
1218    toss(env); if(env->err) return;       && env->head->next->item->type==tfloat) {
1219    b=env->head->item->content.val;      fa= env->head->item->content.f;
1220    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1221    push_int(env, b>a);      fb= env->head->item->content.f;
1222        toss(env); if(env->err) return;
1223        push_int(env, fb>fa);
1224        
1225        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(environment *env, 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= new_val(env);    protect(old_value);
1282      new_value= new_val(env);
1283    protect(env, old_value);    protect(new_value);
1284    new_value->type= old_value->type;    new_value->type= old_value->type;
1285    
1286    switch(old_value->type){    switch(old_value->type){
1287      case tfloat:
1288    case integer:    case integer:
1289      new_value->content.val= old_value->content.val;    case func:
1290      case symb:
1291        new_value->content= old_value->content;
1292      break;      break;
1293    case string:    case string:
1294      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1295        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1296      break;      break;
   case func:  
   case symb:  
     new_value->content.ptr= old_value->content.ptr;  
     break;  
1297    case list:    case list:
1298      new_value->content.ptr= NULL;      new_value->content.ptr= NULL;
1299    
# Line 1064  value *copy_val(environment *env, value Line 1315  value *copy_val(environment *env, value
1315      break;      break;
1316    }    }
1317    
1318    unprotect(env);    unprotect(old_value); unprotect(new_value);
1319    
1320    return new_value;    return new_value;
1321  }  }
1322    
1323  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1324  extern void sx_647570(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;
# Line 1080  extern void sx_647570(environment *env) Line 1332  extern void sx_647570(environment *env)
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) {
# Line 1099  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 1111  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 1131  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 1147  extern void ifelse(environment *env) { Line 1399  extern void ifelse(environment *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 1159  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    protect(env, loop);    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    protect(env, test);    protect(test);
1419    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1420    
1421    do {    do {
# Line 1176  extern void sx_7768696c65(environment *e Line 1428  extern void sx_7768696c65(environment *e
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 1188  extern void sx_7768696c65(environment *e Line 1440  extern void sx_7768696c65(environment *e
1440        
1441    } while(truth);    } while(truth);
1442    
1443    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1444  }  }
1445    
1446    
1447  /* "for"; for-loop */  /* "for"; for-loop */
1448  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1449    {
1450    value *loop;    value *loop;
1451    int foo1, foo2;    int foo1, foo2;
1452    
# Line 1212  extern void sx_666f72(environment *env) Line 1465  extern void sx_666f72(environment *env)
1465    }    }
1466    
1467    loop= env->head->item;    loop= env->head->item;
1468    protect(env, loop);    protect(loop);
1469    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1470    
1471    foo2= env->head->item->content.val;    foo2= env->head->item->content.i;
1472    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1473    
1474    foo1= env->head->item->content.val;    foo1= env->head->item->content.i;
1475    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1476    
1477    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1236  extern void sx_666f72(environment *env) Line 1489  extern void sx_666f72(environment *env)
1489        foo1--;        foo1--;
1490      }      }
1491    }    }
1492    unprotect(env);    unprotect(loop);
1493  }  }
1494    
1495  /* Variant of for-loop */  /* Variant of for-loop */
1496  extern void foreach(environment *env) {  extern void foreach(environment *env)
1497      {  
1498    value *loop, *foo;    value *loop, *foo;
1499    stackitem *iterator;    stackitem *iterator;
1500        
# Line 1258  extern void foreach(environment *env) { Line 1511  extern void foreach(environment *env) {
1511    }    }
1512    
1513    loop= env->head->item;    loop= env->head->item;
1514    protect(env, loop);    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    protect(env, foo);    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 1273  extern void foreach(environment *env) { Line 1526  extern void foreach(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(env); unprotect(env);    unprotect(loop); unprotect(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 1295  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 1311  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= new_val(env);    iterator= env->head;
1568    temp_val->content.ptr= env->head;    pack= new_val(env);
1569    temp_val->type= list;    protect(pack);
1570    env->head= temp_head;  
1571    push_val(env, temp_val);    if(iterator==NULL
1572         || (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    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1329  extern void readline(environment *env) { Line 1611  extern void readline(environment *env) {
1611  }  }
1612    
1613  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1614  extern void sx_72656164(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[]= "]%n";    const char ebrackform[]= "]%n";
1622    const char semicform[]= ";%n";    const char semicform[]= ";%n";
1623    const char bbrackform[]= "[%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) {
# Line 1363  extern void sx_72656164(environment *env Line 1649  extern void sx_72656164(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 1390  extern void sx_72656164(environment *env Line 1681  extern void sx_72656164(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    
# Line 1399  extern void sx_72656164(environment *env Line 1690  extern void sx_72656164(environment *env
1690    if(depth)    if(depth)
1691      return sx_72656164(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.90  
changed lines
  Added in v.1.101
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26