/[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.100 by teddy, Sun Mar 10 12:05:20 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.", env->gc_count, env->gc_limit);
   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);
       env->gc_ref->next= new_head;  
       new_head= env->gc_ref;  
       env->gc_ref= titem;  
       env->gc_count++;  
223      }      }
224        
225        /* Keep values */
226        titem= env->gc_ref->next;
227        env->gc_ref->next= new_head;
228        new_head= env->gc_ref;
229        new_head->item->gc.flag.mark= 0;
230        env->gc_ref= titem;
231    }    }
232    
233    env->gc_limit= env->gc_count*2;    if (env->gc_limit < env->gc_count*2)
234        env->gc_limit= env->gc_count*2;
235    env->gc_ref= new_head;    env->gc_ref= new_head;
236    
237      if(env->interactive){
238        printf("done\n");
239      }
240    
241  }  }
242    
243  void protect(environment *env, value *val)  /* Protect values from GC */
244    void protect(value *val)
245  {  {
246    stackitem *new_item= malloc(sizeof(stackitem));    stackitem *iterator;
247    new_item->item= val;  
248    new_item->next= env->gc_protect;    if(val->gc.flag.protect)
249    env->gc_protect= new_item;      return;
250    
251      val->gc.flag.protect= 1;
252    
253      if(val->type==list) {
254        iterator= val->content.ptr;
255    
256        while(iterator!=NULL) {
257          protect(iterator->item);
258          iterator= iterator->next;
259        }
260      }
261  }  }
262    
263  void unprotect(environment *env)  /* Unprotect values from GC */
264    void unprotect(value *val)
265  {  {
266    stackitem *temp= env->gc_protect;    stackitem *iterator;
267    env->gc_protect= env->gc_protect->next;  
268    free(temp);    if(!(val->gc.flag.protect))
269        return;
270    
271      val->gc.flag.protect= 0;
272    
273      if(val->type==list) {
274        iterator= val->content.ptr;
275    
276        while(iterator!=NULL) {
277          unprotect(iterator->item);
278          iterator= iterator->next;
279        }
280      }
281  }  }
282    
283  /* Push a value onto the stack */  /* Push a value onto the stack */
# Line 221  void push_val(environment *env, value *v Line 289  void push_val(environment *env, value *v
289    env->head= new_item;    env->head= new_item;
290  }  }
291    
292  /* Push an integer onto the stack. */  /* Push an integer onto the stack */
293  void push_int(environment *env, int in_val)  void push_int(environment *env, int in_val)
294  {  {
295    value *new_value= new_val(env);    value *new_value= new_val(env);
296        
297    new_value->content.val= in_val;    new_value->content.i= in_val;
298    new_value->type= integer;    new_value->type= integer;
299    
300    push_val(env, new_value);    push_val(env, new_value);
301  }  }
302    
303    /* Push a floating point number onto the stack */
304    void push_float(environment *env, float in_val)
305    {
306      value *new_value= new_val(env);
307    
308      new_value->content.f= in_val;
309      new_value->type= tfloat;
310    
311      push_val(env, new_value);
312    }
313    
314  /* Copy a string onto the stack. */  /* Copy a string onto the stack. */
315  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
316  {  {
# Line 245  void push_cstring(environment *env, cons Line 324  void push_cstring(environment *env, cons
324  }  }
325    
326  /* Mangle a symbol name to a valid C identifier name */  /* Mangle a symbol name to a valid C identifier name */
327  char *mangle_str(const char *old_string){  char *mangle_str(const char *old_string)
328    {
329    char validchars[]= "0123456789abcdef";    char validchars[]= "0123456789abcdef";
330    char *new_string, *current;    char *new_string, *current;
331    
# Line 263  char *mangle_str(const char *old_string) Line 343  char *mangle_str(const char *old_string)
343    return new_string;            /* The caller must free() it */    return new_string;            /* The caller must free() it */
344  }  }
345    
346  extern void mangle(environment *env){  extern void mangle(environment *env)
347    {
348    char *new_string;    char *new_string;
349    
350    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 302  void push_sym(environment *env, const ch Line 383  void push_sym(environment *env, const ch
383    char *mangled;                /* Mangled function name */    char *mangled;                /* Mangled function name */
384    
385    new_value= new_val(env);    new_value= new_val(env);
386      protect(new_value);
387      new_fvalue= new_val(env);
388      protect(new_fvalue);
389    
390    /* The new value is a symbol */    /* The new value is a symbol */
391    new_value->type= symb;    new_value->type= symb;
# Line 329  void push_sym(environment *env, const ch Line 413  void push_sym(environment *env, const ch
413    
414      mangled= mangle_str(in_string); /* mangle the name */      mangled= mangle_str(in_string); /* mangle the name */
415      funcptr= dlsym(handle, mangled); /* and try to find it */      funcptr= dlsym(handle, mangled); /* and try to find it */
416      free(mangled);  
417      dlerr= dlerror();      dlerr= dlerror();
418      if(dlerr != NULL) {         /* If no function was found */      if(dlerr != NULL) {         /* If no function was found */
419        funcptr= dlsym(handle, in_string); /* Get function pointer */        funcptr= dlsym(handle, in_string); /* Get function pointer */
420        dlerr= dlerror();        dlerr= dlerror();
421      }      }
422    
423      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 */  
424        new_fvalue->type= func;   /* The new value is a function pointer */        new_fvalue->type= func;   /* The new value is a function pointer */
425        new_fvalue->content.ptr= funcptr; /* Store function pointer */        new_fvalue->content.ptr= funcptr; /* Store function pointer */
426        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new        (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
427                                           function value */                                           function value */
428      }      }
429    
430        free(mangled);
431    }    }
432    
433    push_val(env, new_value);    push_val(env, new_value);
434      unprotect(new_value); unprotect(new_fvalue);
435  }  }
436    
437  /* Print newline. */  /* Print newline. */
# Line 353  extern void nl() Line 441  extern void nl()
441  }  }
442    
443  /* Gets the type of a value */  /* Gets the type of a value */
444  extern void type(environment *env){  extern void type(environment *env)
445    {
446    int typenum;    int typenum;
447    
448    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 367  extern void type(environment *env){ Line 456  extern void type(environment *env){
456    case integer:    case integer:
457      push_sym(env, "integer");      push_sym(env, "integer");
458      break;      break;
459      case tfloat:
460        push_sym(env, "float");
461        break;
462    case string:    case string:
463      push_sym(env, "string");      push_sym(env, "string");
464      break;      break;
# Line 387  void print_h(stackitem *stack_head, int Line 479  void print_h(stackitem *stack_head, int
479  {  {
480    switch(stack_head->item->type) {    switch(stack_head->item->type) {
481    case integer:    case integer:
482      printf("%d", stack_head->item->content.val);      printf("%d", stack_head->item->content.i);
483        break;
484      case tfloat:
485        printf("%f", stack_head->item->content.f);
486      break;      break;
487    case string:    case string:
488      if(noquote)      if(noquote)
# Line 415  void print_h(stackitem *stack_head, int Line 510  void print_h(stackitem *stack_head, int
510    }    }
511  }  }
512    
513  extern void print_(environment *env) {  extern void print_(environment *env)
514    {
515    if(env->head==NULL) {    if(env->head==NULL) {
516      printerr("Too Few Arguments");      printerr("Too Few Arguments");
517      env->err=1;      env->err=1;
# Line 433  extern void print(environment *env) Line 529  extern void print(environment *env)
529    toss(env);    toss(env);
530  }  }
531    
532  extern void princ_(environment *env) {  extern void princ_(environment *env)
533    {
534    if(env->head==NULL) {    if(env->head==NULL) {
535      printerr("Too Few Arguments");      printerr("Too Few Arguments");
536      env->err=1;      env->err=1;
# Line 467  extern void printstack(environment *env) Line 564  extern void printstack(environment *env)
564      printf("Stack Empty\n");      printf("Stack Empty\n");
565      return;      return;
566    }    }
567    
568    print_st(env->head, 1);    print_st(env->head, 1);
569  }  }
570    
# Line 526  extern void rcl(environment *env) Line 624  extern void rcl(environment *env)
624      env->err=3;      env->err=3;
625      return;      return;
626    }    }
627    protect(env, val);    protect(val);
628    toss(env);            /* toss the symbol */    toss(env);            /* toss the symbol */
629    if(env->err) return;    if(env->err) return;
630    push_val(env, val); /* Return its bound value */    push_val(env, val); /* Return its bound value */
631    unprotect(env);    unprotect(val);
632  }  }
633    
634  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
# Line 544  extern void eval(environment *env) Line 642  extern void eval(environment *env)
642    
643   eval_start:   eval_start:
644    
645      gc_maybe(env);
646    
647    if(env->head==NULL) {    if(env->head==NULL) {
648      printerr("Too Few Arguments");      printerr("Too Few Arguments");
649      env->err=1;      env->err=1;
# Line 570  extern void eval(environment *env) Line 670  extern void eval(environment *env)
670      /* If it's a list */      /* If it's a list */
671    case list:    case list:
672      temp_val= env->head->item;      temp_val= env->head->item;
673      protect(env, temp_val);      protect(temp_val);
674      toss(env);  
675      if(env->err) return;      toss(env); if(env->err) return;
676      iterator= (stackitem*)temp_val->content.ptr;      iterator= (stackitem*)temp_val->content.ptr;
     unprotect(env);  
677            
678      while(iterator!=NULL) {      while(iterator!=NULL) {
679        push_val(env, iterator->item);        push_val(env, iterator->item);
680                
681        if(env->head->item->type==symb        if(env->head->item->type==symb
682          && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {           && (((symbol*)(env->head->item->content.ptr))->id[0] == ';')) {
683          toss(env);          toss(env);
684          if(env->err) return;          if(env->err) return;
685                    
# Line 592  extern void eval(environment *env) Line 691  extern void eval(environment *env)
691        }        }
692        iterator= iterator->next;        iterator= iterator->next;
693      }      }
694        unprotect(temp_val);
695      return;      return;
696    
697    default:    default:
# Line 600  extern void eval(environment *env) Line 700  extern void eval(environment *env)
700  }  }
701    
702  /* Reverse (flip) a list */  /* Reverse (flip) a list */
703  extern void rev(environment *env){  extern void rev(environment *env)
704    {
705    stackitem *old_head, *new_head, *item;    stackitem *old_head, *new_head, *item;
706    
707    if((env->head)==NULL) {    if((env->head)==NULL) {
# Line 633  extern void pack(environment *env) Line 734  extern void pack(environment *env)
734    value *pack;    value *pack;
735    
736    iterator= env->head;    iterator= env->head;
737      pack= new_val(env);
738      protect(pack);
739    
740    if(iterator==NULL    if(iterator==NULL
741       || (iterator->item->type==symb       || (iterator->item->type==symb
# Line 650  extern void pack(environment *env) Line 753  extern void pack(environment *env)
753      temp= env->head;      temp= env->head;
754      env->head= iterator->next;      env->head= iterator->next;
755      iterator->next= NULL;      iterator->next= NULL;
756    
757        pack->type= list;
758        pack->content.ptr= temp;
759            
760      if(env->head!=NULL)      if(env->head!=NULL)
761        toss(env);        toss(env);
762    }    }
763    
764    /* Push list */    /* Push list */
   pack= new_val(env);  
   pack->type= list;  
   pack->content.ptr= temp;  
765    
766    push_val(env, pack);    push_val(env, pack);
767    rev(env);    rev(env);
768    
769      unprotect(pack);
770  }  }
771    
772  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
# Line 739  extern void not(environment *env) Line 844  extern void not(environment *env)
844      return;      return;
845    }    }
846    
847    val= env->head->item->content.val;    val= env->head->item->content.i;
848    toss(env);    toss(env);
849    push_int(env, !val);    push_int(env, !val);
850  }  }
# Line 782  extern void def(environment *env) Line 887  extern void def(environment *env)
887  /* Quit stack. */  /* Quit stack. */
888  extern void quit(environment *env)  extern void quit(environment *env)
889  {  {
890    long i;    int i;
891    
892    clear(env);    clear(env);
893    
# Line 795  extern void quit(environment *env) Line 900  extern void quit(environment *env)
900    }    }
901    
902    env->gc_limit= 0;    env->gc_limit= 0;
903    gc_init(env);    gc_maybe(env);
904    
905    if(env->free_string!=NULL)    if(env->free_string!=NULL)
906      free(env->free_string);      free(env->free_string);
# Line 828  extern void words(environment *env) Line 933  extern void words(environment *env)
933  }  }
934    
935  /* Internal forget function */  /* Internal forget function */
936  void forget_sym(symbol **hash_entry) {  void forget_sym(symbol **hash_entry)
937    {
938    symbol *temp;    symbol *temp;
939    
940    temp= *hash_entry;    temp= *hash_entry;
# Line 863  extern void forget(environment *env) Line 969  extern void forget(environment *env)
969  }  }
970    
971  /* Returns the current error number to the stack */  /* Returns the current error number to the stack */
972  extern void errn(environment *env){  extern void errn(environment *env)
973    {
974    push_int(env, env->err);    push_int(env, env->err);
975  }  }
976    
# Line 903  int main(int argc, char **argv) Line 1010  int main(int argc, char **argv)
1010      }      }
1011    }    }
1012    
1013      if(myenv.interactive) {
1014        printf("Stack version $Revision$\n\
1015    Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1016    Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\
1017    This is free software, and you are welcome to redistribute it\n\
1018    under certain conditions; type `copying;' for details.\n");
1019      }
1020    
1021    while(1) {    while(1) {
1022      if(myenv.in_string==NULL) {      if(myenv.in_string==NULL) {
1023        if (myenv.interactive) {        if (myenv.interactive) {
# Line 917  int main(int argc, char **argv) Line 1032  int main(int argc, char **argv)
1032      }      }
1033      sx_72656164(&myenv);      sx_72656164(&myenv);
1034      if (myenv.err==4) {      if (myenv.err==4) {
1035        return EX_NOINPUT;        return EXIT_SUCCESS;      /* EOF */
1036      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1037                && myenv.head->item->type==symb                && myenv.head->item->type==symb
1038                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {
1039        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1040        eval(&myenv);        eval(&myenv);
1041      }      }
1042      gc_init(&myenv);      gc_maybe(&myenv);
1043    }    }
1044    quit(&myenv);    quit(&myenv);
1045    return EXIT_FAILURE;    return EXIT_FAILURE;
1046  }  }
1047    
1048  /* "+" */  /* "+" */
1049  extern void sx_2b(environment *env) {  extern void sx_2b(environment *env)
1050    {
1051    int a, b;    int a, b;
1052      float fa, fb;
1053    size_t len;    size_t len;
1054    char* new_string;    char* new_string;
1055    value *a_val, *b_val;    value *a_val, *b_val;
# Line 947  extern void sx_2b(environment *env) { Line 1064  extern void sx_2b(environment *env) {
1064       && env->head->next->item->type==string) {       && env->head->next->item->type==string) {
1065      a_val= env->head->item;      a_val= env->head->item;
1066      b_val= env->head->next->item;      b_val= env->head->next->item;
1067      protect(env, a_val); protect(env, b_val);      protect(a_val); protect(b_val);
1068      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1069      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1070      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 1072  extern void sx_2b(environment *env) {
1072      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1073      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1074      push_cstring(env, new_string);      push_cstring(env, new_string);
1075      unprotect(env); unprotect(env);      unprotect(a_val); unprotect(b_val);
1076      free(new_string);      free(new_string);
1077        
1078      return;      return;
1079    }    }
1080        
1081    if(env->head->item->type!=integer    if(env->head->item->type==integer
1082       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
1083      printerr("Bad Argument Type");      a=env->head->item->content.i;
1084      env->err=2;      toss(env); if(env->err) return;
1085        b=env->head->item->content.i;
1086        toss(env); if(env->err) return;
1087        push_int(env, b+a);
1088    
1089      return;      return;
1090    }    }
1091    a= env->head->item->content.val;  
1092    toss(env); if(env->err) return;    if(env->head->item->type==tfloat
1093           && env->head->next->item->type==tfloat) {
1094    b= env->head->item->content.val;      fa= env->head->item->content.f;
1095    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1096    push_int(env, a+b);      fb= env->head->item->content.f;
1097        toss(env); if(env->err) return;
1098        push_float(env, fb+fa);
1099        
1100        return;
1101      }
1102    
1103      if(env->head->item->type==tfloat
1104         && env->head->next->item->type==integer) {
1105        fa= env->head->item->content.f;
1106        toss(env); if(env->err) return;
1107        b= env->head->item->content.i;
1108        toss(env); if(env->err) return;
1109        push_float(env, b+fa);
1110        
1111        return;
1112      }
1113    
1114      if(env->head->item->type==integer
1115         && env->head->next->item->type==tfloat) {
1116        a= env->head->item->content.i;
1117        toss(env); if(env->err) return;
1118        fb= env->head->item->content.f;
1119        toss(env); if(env->err) return;
1120        push_float(env, fb+a);
1121    
1122        return;
1123      }
1124    
1125      printerr("Bad Argument Type");
1126      env->err=2;
1127  }  }
1128    
1129  /* "-" */  /* "-" */
1130  extern void sx_2d(environment *env) {  extern void sx_2d(environment *env)
1131    {
1132    int a, b;    int a, b;
1133      float fa, fb;
1134    
1135    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1136      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 984  extern void sx_2d(environment *env) { Line 1138  extern void sx_2d(environment *env) {
1138      return;      return;
1139    }    }
1140        
1141    if(env->head->item->type!=integer    if(env->head->item->type==integer
1142       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
1143      printerr("Bad Argument Type");      a=env->head->item->content.i;
1144      env->err=2;      toss(env); if(env->err) return;
1145        b=env->head->item->content.i;
1146        toss(env); if(env->err) return;
1147        push_int(env, b-a);
1148    
1149      return;      return;
1150    }    }
1151    
1152    a=env->head->item->content.val;    if(env->head->item->type==tfloat
1153    toss(env); if(env->err) return;       && env->head->next->item->type==tfloat) {
1154    b=env->head->item->content.val;      fa= env->head->item->content.f;
1155    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1156    push_int(env, b-a);      fb= env->head->item->content.f;
1157        toss(env); if(env->err) return;
1158        push_float(env, fb-fa);
1159        
1160        return;
1161      }
1162    
1163      if(env->head->item->type==tfloat
1164         && env->head->next->item->type==integer) {
1165        fa= env->head->item->content.f;
1166        toss(env); if(env->err) return;
1167        b= env->head->item->content.i;
1168        toss(env); if(env->err) return;
1169        push_float(env, b-fa);
1170        
1171        return;
1172      }
1173    
1174      if(env->head->item->type==integer
1175         && env->head->next->item->type==tfloat) {
1176        a= env->head->item->content.i;
1177        toss(env); if(env->err) return;
1178        fb= env->head->item->content.f;
1179        toss(env); if(env->err) return;
1180        push_float(env, fb-a);
1181    
1182        return;
1183      }
1184    
1185      printerr("Bad Argument Type");
1186      env->err=2;
1187  }  }
1188    
1189  /* ">" */  /* ">" */
1190  extern void sx_3e(environment *env) {  extern void sx_3e(environment *env)
1191    {
1192    int a, b;    int a, b;
1193      float fa, fb;
1194    
1195    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1196      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 1008  extern void sx_3e(environment *env) { Line 1198  extern void sx_3e(environment *env) {
1198      return;      return;
1199    }    }
1200        
1201    if(env->head->item->type!=integer    if(env->head->item->type==integer
1202       || env->head->next->item->type!=integer) {       && env->head->next->item->type==integer) {
1203      printerr("Bad Argument Type");      a=env->head->item->content.i;
1204      env->err=2;      toss(env); if(env->err) return;
1205        b=env->head->item->content.i;
1206        toss(env); if(env->err) return;
1207        push_int(env, b>a);
1208    
1209      return;      return;
1210    }    }
1211    
1212    a=env->head->item->content.val;    if(env->head->item->type==tfloat
1213    toss(env); if(env->err) return;       && env->head->next->item->type==tfloat) {
1214    b=env->head->item->content.val;      fa= env->head->item->content.f;
1215    toss(env); if(env->err) return;      toss(env); if(env->err) return;
1216    push_int(env, b>a);      fb= env->head->item->content.f;
1217        toss(env); if(env->err) return;
1218        push_int(env, fb>fa);
1219        
1220        return;
1221      }
1222    
1223      if(env->head->item->type==tfloat
1224         && env->head->next->item->type==integer) {
1225        fa= env->head->item->content.f;
1226        toss(env); if(env->err) return;
1227        b= env->head->item->content.i;
1228        toss(env); if(env->err) return;
1229        push_int(env, b>fa);
1230        
1231        return;
1232      }
1233    
1234      if(env->head->item->type==integer
1235         && env->head->next->item->type==tfloat) {
1236        a= env->head->item->content.i;
1237        toss(env); if(env->err) return;
1238        fb= env->head->item->content.f;
1239        toss(env); if(env->err) return;
1240        push_int(env, fb>a);
1241    
1242        return;
1243      }
1244    
1245      printerr("Bad Argument Type");
1246      env->err=2;
1247    }
1248    
1249    /* "<" */
1250    extern void sx_3c(environment *env)
1251    {
1252      swap(env); if(env->err) return;
1253      sx_3e(env);
1254    }
1255    
1256    /* "<=" */
1257    extern void sx_3c3d(environment *env)
1258    {
1259      sx_3e(env); if(env->err) return;
1260      not(env);
1261    }
1262    
1263    /* ">=" */
1264    extern void sx_3e3d(environment *env)
1265    {
1266      sx_3c(env); if(env->err) return;
1267      not(env);
1268  }  }
1269    
1270  /* Return copy of a value */  /* Return copy of a value */
1271  value *copy_val(environment *env, value *old_value){  value *copy_val(environment *env, value *old_value)
1272    {
1273    stackitem *old_item, *new_item, *prev_item;    stackitem *old_item, *new_item, *prev_item;
1274      value *new_value;
1275    
1276    value *new_value= new_val(env);    protect(old_value);
1277      new_value= new_val(env);
1278    protect(env, old_value);    protect(new_value);
1279    new_value->type= old_value->type;    new_value->type= old_value->type;
1280    
1281    switch(old_value->type){    switch(old_value->type){
1282      case tfloat:
1283    case integer:    case integer:
1284      new_value->content.val= old_value->content.val;    case func:
1285      case symb:
1286        new_value->content= old_value->content;
1287      break;      break;
1288    case string:    case string:
1289      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1290        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1291      break;      break;
   case func:  
   case symb:  
     new_value->content.ptr= old_value->content.ptr;  
     break;  
1292    case list:    case list:
1293      new_value->content.ptr= NULL;      new_value->content.ptr= NULL;
1294    
# Line 1064  value *copy_val(environment *env, value Line 1310  value *copy_val(environment *env, value
1310      break;      break;
1311    }    }
1312    
1313    unprotect(env);    unprotect(old_value); unprotect(new_value);
1314    
1315    return new_value;    return new_value;
1316  }  }
1317    
1318  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1319  extern void sx_647570(environment *env) {  extern void sx_647570(environment *env)
1320    {
1321    if((env->head)==NULL) {    if((env->head)==NULL) {
1322      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1323      env->err= 1;      env->err= 1;
# Line 1080  extern void sx_647570(environment *env) Line 1327  extern void sx_647570(environment *env)
1327  }  }
1328    
1329  /* "if", If-Then */  /* "if", If-Then */
1330  extern void sx_6966(environment *env) {  extern void sx_6966(environment *env)
1331    {
1332    int truth;    int truth;
1333    
1334    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 1346  extern void sx_6966(environment *env) {
1346    swap(env);    swap(env);
1347    if(env->err) return;    if(env->err) return;
1348        
1349    truth=env->head->item->content.val;    truth=env->head->item->content.i;
1350    
1351    toss(env);    toss(env);
1352    if(env->err) return;    if(env->err) return;
# Line 1111  extern void sx_6966(environment *env) { Line 1358  extern void sx_6966(environment *env) {
1358  }  }
1359    
1360  /* If-Then-Else */  /* If-Then-Else */
1361  extern void ifelse(environment *env) {  extern void ifelse(environment *env)
1362    {
1363    int truth;    int truth;
1364    
1365    if((env->head)==NULL || env->head->next==NULL    if((env->head)==NULL || env->head->next==NULL
# Line 1131  extern void ifelse(environment *env) { Line 1378  extern void ifelse(environment *env) {
1378    rot(env);    rot(env);
1379    if(env->err) return;    if(env->err) return;
1380        
1381    truth=env->head->item->content.val;    truth=env->head->item->content.i;
1382    
1383    toss(env);    toss(env);
1384    if(env->err) return;    if(env->err) return;
# Line 1147  extern void ifelse(environment *env) { Line 1394  extern void ifelse(environment *env) {
1394  }  }
1395    
1396  /* "while" */  /* "while" */
1397  extern void sx_7768696c65(environment *env) {  extern void sx_7768696c65(environment *env)
1398    {
1399    int truth;    int truth;
1400    value *loop, *test;    value *loop, *test;
1401    
# Line 1159  extern void sx_7768696c65(environment *e Line 1406  extern void sx_7768696c65(environment *e
1406    }    }
1407    
1408    loop= env->head->item;    loop= env->head->item;
1409    protect(env, loop);    protect(loop);
1410    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1411    
1412    test= env->head->item;    test= env->head->item;
1413    protect(env, test);    protect(test);
1414    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1415    
1416    do {    do {
# Line 1176  extern void sx_7768696c65(environment *e Line 1423  extern void sx_7768696c65(environment *e
1423        return;        return;
1424      }      }
1425            
1426      truth= env->head->item->content.val;      truth= env->head->item->content.i;
1427      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1428            
1429      if(truth) {      if(truth) {
# Line 1188  extern void sx_7768696c65(environment *e Line 1435  extern void sx_7768696c65(environment *e
1435        
1436    } while(truth);    } while(truth);
1437    
1438    unprotect(env); unprotect(env);    unprotect(loop); unprotect(test);
1439  }  }
1440    
1441    
1442  /* "for"; for-loop */  /* "for"; for-loop */
1443  extern void sx_666f72(environment *env) {  extern void sx_666f72(environment *env)
1444    {
1445    value *loop;    value *loop;
1446    int foo1, foo2;    int foo1, foo2;
1447    
# Line 1212  extern void sx_666f72(environment *env) Line 1460  extern void sx_666f72(environment *env)
1460    }    }
1461    
1462    loop= env->head->item;    loop= env->head->item;
1463    protect(env, loop);    protect(loop);
1464    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1465    
1466    foo2= env->head->item->content.val;    foo2= env->head->item->content.i;
1467    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1468    
1469    foo1= env->head->item->content.val;    foo1= env->head->item->content.i;
1470    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1471    
1472    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1236  extern void sx_666f72(environment *env) Line 1484  extern void sx_666f72(environment *env)
1484        foo1--;        foo1--;
1485      }      }
1486    }    }
1487    unprotect(env);    unprotect(loop);
1488  }  }
1489    
1490  /* Variant of for-loop */  /* Variant of for-loop */
1491  extern void foreach(environment *env) {  extern void foreach(environment *env)
1492      {  
1493    value *loop, *foo;    value *loop, *foo;
1494    stackitem *iterator;    stackitem *iterator;
1495        
# Line 1258  extern void foreach(environment *env) { Line 1506  extern void foreach(environment *env) {
1506    }    }
1507    
1508    loop= env->head->item;    loop= env->head->item;
1509    protect(env, loop);    protect(loop);
1510    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1511    
1512    foo= env->head->item;    foo= env->head->item;
1513    protect(env, foo);    protect(foo);
1514    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1515    
1516    iterator= foo->content.ptr;    iterator= foo->content.ptr;
# Line 1273  extern void foreach(environment *env) { Line 1521  extern void foreach(environment *env) {
1521      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1522      iterator= iterator->next;      iterator= iterator->next;
1523    }    }
1524    unprotect(env); unprotect(env);    unprotect(loop); unprotect(foo);
1525  }  }
1526    
1527  /* "to" */  /* "to" */
1528  extern void to(environment *env) {  extern void to(environment *env)
1529    int i, start, ending;  {
1530    stackitem *temp_head;    int ending, start, i;
1531    value *temp_val;    stackitem *iterator, *temp;
1532        value *pack;
1533    
1534    if((env->head)==NULL || env->head->next==NULL) {    if((env->head)==NULL || env->head->next==NULL) {
1535      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1536      env->err=1;      env->err=1;
# Line 1295  extern void to(environment *env) { Line 1544  extern void to(environment *env) {
1544      return;      return;
1545    }    }
1546    
1547    ending= env->head->item->content.val;    ending= env->head->item->content.i;
1548    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1549    start= env->head->item->content.val;    start= env->head->item->content.i;
1550    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1551    
1552    temp_head= env->head;    push_sym(env, "[");
   env->head= NULL;  
1553    
1554    if(ending>=start) {    if(ending>=start) {
1555      for(i= ending; i>=start; i--)      for(i= ending; i>=start; i--)
# Line 1311  extern void to(environment *env) { Line 1559  extern void to(environment *env) {
1559        push_int(env, i);        push_int(env, i);
1560    }    }
1561    
1562    temp_val= new_val(env);    iterator= env->head;
1563    temp_val->content.ptr= env->head;    pack= new_val(env);
1564    temp_val->type= list;    protect(pack);
1565    env->head= temp_head;  
1566    push_val(env, temp_val);    if(iterator==NULL
1567         || (iterator->item->type==symb
1568         && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {
1569        temp= NULL;
1570        toss(env);
1571      } else {
1572        /* Search for first delimiter */
1573        while(iterator->next!=NULL
1574              && (iterator->next->item->type!=symb
1575              || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))
1576          iterator= iterator->next;
1577        
1578        /* Extract list */
1579        temp= env->head;
1580        env->head= iterator->next;
1581        iterator->next= NULL;
1582    
1583        pack->type= list;
1584        pack->content.ptr= temp;
1585        
1586        if(env->head!=NULL)
1587          toss(env);
1588      }
1589    
1590      /* Push list */
1591    
1592      push_val(env, pack);
1593    
1594      unprotect(pack);
1595  }  }
1596    
1597  /* Read a string */  /* Read a string */
1598  extern void readline(environment *env) {  extern void readline(environment *env)
1599    {
1600    char in_string[101];    char in_string[101];
1601    
1602    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, env->inputstream)==NULL)
# Line 1329  extern void readline(environment *env) { Line 1606  extern void readline(environment *env) {
1606  }  }
1607    
1608  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1609  extern void sx_72656164(environment *env) {  extern void sx_72656164(environment *env)
1610    {
1611    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1612    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1613    const char intform[]= "%i%n";    const char intform[]= "%i%n";
1614      const char fltform[]= "%f%n";
1615    const char blankform[]= "%*[ \t]%n";    const char blankform[]= "%*[ \t]%n";
1616    const char ebrackform[]= "]%n";    const char ebrackform[]= "]%n";
1617    const char semicform[]= ";%n";    const char semicform[]= ";%n";
1618    const char bbrackform[]= "[%n";    const char bbrackform[]= "[%n";
1619    
1620    int itemp, readlength= -1;    int itemp, readlength= -1;
1621      int count= -1;
1622      float ftemp;
1623    static int depth= 0;    static int depth= 0;
1624    char *match;    char *match, *ctemp;
1625    size_t inlength;    size_t inlength;
1626    
1627    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1363  extern void sx_72656164(environment *env Line 1644  extern void sx_72656164(environment *env
1644    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1645    match= malloc(inlength);    match= malloc(inlength);
1646    
1647    if(sscanf(env->in_string, blankform, &readlength)!=EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1648       && readlength != -1) {       && readlength != -1) {
1649      ;      ;
1650    } else if(sscanf(env->in_string, intform, &itemp, &readlength) != EOF    } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
1651              && readlength != -1) {              && readlength != -1) {
1652      push_int(env, itemp);      if(sscanf(env->in_string, intform, &itemp, &count) != EOF
1653           && count==readlength) {
1654          push_int(env, itemp);
1655        } else {
1656          push_float(env, ftemp);
1657        }
1658    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1659              && readlength != -1) {              && readlength != -1) {
1660      push_cstring(env, match);      push_cstring(env, match);
# Line 1390  extern void sx_72656164(environment *env Line 1676  extern void sx_72656164(environment *env
1676      free(env->free_string);      free(env->free_string);
1677      env->in_string = env->free_string = NULL;      env->in_string = env->free_string = NULL;
1678    }    }
1679    if ( env->in_string != NULL) {    if (env->in_string != NULL) {
1680      env->in_string += readlength;      env->in_string += readlength;
1681    }    }
1682    
# Line 1399  extern void sx_72656164(environment *env Line 1685  extern void sx_72656164(environment *env
1685    if(depth)    if(depth)
1686      return sx_72656164(env);      return sx_72656164(env);
1687  }  }
1688    
1689    extern void beep(environment *env)
1690    {
1691      int freq, dur, period, ticks;
1692    
1693      if((env->head)==NULL || env->head->next==NULL) {
1694        printerr("Too Few Arguments");
1695        env->err=1;
1696        return;
1697      }
1698    
1699      if(env->head->item->type!=integer
1700         || env->head->next->item->type!=integer) {
1701        printerr("Bad Argument Type");
1702        env->err=2;
1703        return;
1704      }
1705    
1706      dur=env->head->item->content.i;
1707      toss(env);
1708      freq=env->head->item->content.i;
1709      toss(env);
1710    
1711      period=1193180/freq;          /* convert freq from Hz to period
1712                                       length */
1713      ticks=dur*.001193180;         /* convert duration from µseconds to
1714                                       timer ticks */
1715    
1716    /*    ticks=dur/1000; */
1717    
1718      /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1719      switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1720      case 0:
1721        usleep(dur);
1722        return;
1723      case -1:
1724        perror("beep");
1725        env->err=5;
1726        return;
1727      default:
1728        abort();
1729      }
1730    }
1731    
1732    /* "wait" */
1733    extern void sx_77616974(environment *env)
1734    {
1735      int dur;
1736    
1737      if((env->head)==NULL) {
1738        printerr("Too Few Arguments");
1739        env->err=1;
1740        return;
1741      }
1742    
1743      if(env->head->item->type!=integer) {
1744        printerr("Bad Argument Type");
1745        env->err=2;
1746        return;
1747      }
1748    
1749      dur=env->head->item->content.i;
1750      toss(env);
1751    
1752      usleep(dur);
1753    }
1754    
1755    extern void copying(environment *env)
1756    {
1757      printf("GNU GENERAL PUBLIC LICENSE\n\
1758                           Version 2, June 1991\n\
1759    \n\
1760     Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
1761         59 Temple Place, Suite 330, Boston, MA  02111-1307  USA\n\
1762     Everyone is permitted to copy and distribute verbatim copies\n\
1763     of this license document, but changing it is not allowed.\n\
1764    \n\
1765                                Preamble\n\
1766    \n\
1767      The licenses for most software are designed to take away your\n\
1768    freedom to share and change it.  By contrast, the GNU General Public\n\
1769    License is intended to guarantee your freedom to share and change free\n\
1770    software--to make sure the software is free for all its users.  This\n\
1771    General Public License applies to most of the Free Software\n\
1772    Foundation's software and to any other program whose authors commit to\n\
1773    using it.  (Some other Free Software Foundation software is covered by\n\
1774    the GNU Library General Public License instead.)  You can apply it to\n\
1775    your programs, too.\n\
1776    \n\
1777      When we speak of free software, we are referring to freedom, not\n\
1778    price.  Our General Public Licenses are designed to make sure that you\n\
1779    have the freedom to distribute copies of free software (and charge for\n\
1780    this service if you wish), that you receive source code or can get it\n\
1781    if you want it, that you can change the software or use pieces of it\n\
1782    in new free programs; and that you know you can do these things.\n\
1783    \n\
1784      To protect your rights, we need to make restrictions that forbid\n\
1785    anyone to deny you these rights or to ask you to surrender the rights.\n\
1786    These restrictions translate to certain responsibilities for you if you\n\
1787    distribute copies of the software, or if you modify it.\n\
1788    \n\
1789      For example, if you distribute copies of such a program, whether\n\
1790    gratis or for a fee, you must give the recipients all the rights that\n\
1791    you have.  You must make sure that they, too, receive or can get the\n\
1792    source code.  And you must show them these terms so they know their\n\
1793    rights.\n\
1794    \n\
1795      We protect your rights with two steps: (1) copyright the software, and\n\
1796    (2) offer you this license which gives you legal permission to copy,\n\
1797    distribute and/or modify the software.\n\
1798    \n\
1799      Also, for each author's protection and ours, we want to make certain\n\
1800    that everyone understands that there is no warranty for this free\n\
1801    software.  If the software is modified by someone else and passed on, we\n\
1802    want its recipients to know that what they have is not the original, so\n\
1803    that any problems introduced by others will not reflect on the original\n\
1804    authors' reputations.\n\
1805    \n\
1806      Finally, any free program is threatened constantly by software\n\
1807    patents.  We wish to avoid the danger that redistributors of a free\n\
1808    program will individually obtain patent licenses, in effect making the\n\
1809    program proprietary.  To prevent this, we have made it clear that any\n\
1810    patent must be licensed for everyone's free use or not licensed at all.\n\
1811    \n\
1812      The precise terms and conditions for copying, distribution and\n\
1813    modification follow.\n\
1814    \n\
1815                        GNU GENERAL PUBLIC LICENSE\n\
1816       TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION\n\
1817    \n\
1818      0. This License applies to any program or other work which contains\n\
1819    a notice placed by the copyright holder saying it may be distributed\n\
1820    under the terms of this General Public License.  The \"Program\", below,\n\
1821    refers to any such program or work, and a \"work based on the Program\"\n\
1822    means either the Program or any derivative work under copyright law:\n\
1823    that is to say, a work containing the Program or a portion of it,\n\
1824    either verbatim or with modifications and/or translated into another\n\
1825    language.  (Hereinafter, translation is included without limitation in\n\
1826    the term \"modification\".)  Each licensee is addressed as \"you\".\n\
1827    \n\
1828    Activities other than copying, distribution and modification are not\n\
1829    covered by this License; they are outside its scope.  The act of\n\
1830    running the Program is not restricted, and the output from the Program\n\
1831    is covered only if its contents constitute a work based on the\n\
1832    Program (independent of having been made by running the Program).\n\
1833    Whether that is true depends on what the Program does.\n\
1834    \n\
1835      1. You may copy and distribute verbatim copies of the Program's\n\
1836    source code as you receive it, in any medium, provided that you\n\
1837    conspicuously and appropriately publish on each copy an appropriate\n\
1838    copyright notice and disclaimer of warranty; keep intact all the\n\
1839    notices that refer to this License and to the absence of any warranty;\n\
1840    and give any other recipients of the Program a copy of this License\n\
1841    along with the Program.\n\
1842    \n\
1843    You may charge a fee for the physical act of transferring a copy, and\n\
1844    you may at your option offer warranty protection in exchange for a fee.\n\
1845    \n\
1846      2. You may modify your copy or copies of the Program or any portion\n\
1847    of it, thus forming a work based on the Program, and copy and\n\
1848    distribute such modifications or work under the terms of Section 1\n\
1849    above, provided that you also meet all of these conditions:\n\
1850    \n\
1851        a) You must cause the modified files to carry prominent notices\n\
1852        stating that you changed the files and the date of any change.\n\
1853    \n\
1854        b) You must cause any work that you distribute or publish, that in\n\
1855        whole or in part contains or is derived from the Program or any\n\
1856        part thereof, to be licensed as a whole at no charge to all third\n\
1857        parties under the terms of this License.\n\
1858    \n\
1859        c) If the modified program normally reads commands interactively\n\
1860        when run, you must cause it, when started running for such\n\
1861        interactive use in the most ordinary way, to print or display an\n\
1862        announcement including an appropriate copyright notice and a\n\
1863        notice that there is no warranty (or else, saying that you provide\n\
1864        a warranty) and that users may redistribute the program under\n\
1865        these conditions, and telling the user how to view a copy of this\n\
1866        License.  (Exception: if the Program itself is interactive but\n\
1867        does not normally print such an announcement, your work based on\n\
1868        the Program is not required to print an announcement.)\n\
1869    \n\
1870    These requirements apply to the modified work as a whole.  If\n\
1871    identifiable sections of that work are not derived from the Program,\n\
1872    and can be reasonably considered independent and separate works in\n\
1873    themselves, then this License, and its terms, do not apply to those\n\
1874    sections when you distribute them as separate works.  But when you\n\
1875    distribute the same sections as part of a whole which is a work based\n\
1876    on the Program, the distribution of the whole must be on the terms of\n\
1877    this License, whose permissions for other licensees extend to the\n\
1878    entire whole, and thus to each and every part regardless of who wrote it.\n\
1879    \n\
1880    Thus, it is not the intent of this section to claim rights or contest\n\
1881    your rights to work written entirely by you; rather, the intent is to\n\
1882    exercise the right to control the distribution of derivative or\n\
1883    collective works based on the Program.\n\
1884    \n\
1885    In addition, mere aggregation of another work not based on the Program\n\
1886    with the Program (or with a work based on the Program) on a volume of\n\
1887    a storage or distribution medium does not bring the other work under\n\
1888    the scope of this License.\n\
1889    \n\
1890      3. You may copy and distribute the Program (or a work based on it,\n\
1891    under Section 2) in object code or executable form under the terms of\n\
1892    Sections 1 and 2 above provided that you also do one of the following:\n\
1893    \n\
1894        a) Accompany it with the complete corresponding machine-readable\n\
1895        source code, which must be distributed under the terms of Sections\n\
1896        1 and 2 above on a medium customarily used for software interchange; or,\n\
1897    \n\
1898        b) Accompany it with a written offer, valid for at least three\n\
1899        years, to give any third party, for a charge no more than your\n\
1900        cost of physically performing source distribution, a complete\n\
1901        machine-readable copy of the corresponding source code, to be\n\
1902        distributed under the terms of Sections 1 and 2 above on a medium\n\
1903        customarily used for software interchange; or,\n\
1904    \n\
1905        c) Accompany it with the information you received as to the offer\n\
1906        to distribute corresponding source code.  (This alternative is\n\
1907        allowed only for noncommercial distribution and only if you\n\
1908        received the program in object code or executable form with such\n\
1909        an offer, in accord with Subsection b above.)\n\
1910    \n\
1911    The source code for a work means the preferred form of the work for\n\
1912    making modifications to it.  For an executable work, complete source\n\
1913    code means all the source code for all modules it contains, plus any\n\
1914    associated interface definition files, plus the scripts used to\n\
1915    control compilation and installation of the executable.  However, as a\n\
1916    special exception, the source code distributed need not include\n\
1917    anything that is normally distributed (in either source or binary\n\
1918    form) with the major components (compiler, kernel, and so on) of the\n\
1919    operating system on which the executable runs, unless that component\n\
1920    itself accompanies the executable.\n\
1921    \n\
1922    If distribution of executable or object code is made by offering\n\
1923    access to copy from a designated place, then offering equivalent\n\
1924    access to copy the source code from the same place counts as\n\
1925    distribution of the source code, even though third parties are not\n\
1926    compelled to copy the source along with the object code.\n\
1927    \n\
1928      4. You may not copy, modify, sublicense, or distribute the Program\n\
1929    except as expressly provided under this License.  Any attempt\n\
1930    otherwise to copy, modify, sublicense or distribute the Program is\n\
1931    void, and will automatically terminate your rights under this License.\n\
1932    However, parties who have received copies, or rights, from you under\n\
1933    this License will not have their licenses terminated so long as such\n\
1934    parties remain in full compliance.\n\
1935    \n\
1936      5. You are not required to accept this License, since you have not\n\
1937    signed it.  However, nothing else grants you permission to modify or\n\
1938    distribute the Program or its derivative works.  These actions are\n\
1939    prohibited by law if you do not accept this License.  Therefore, by\n\
1940    modifying or distributing the Program (or any work based on the\n\
1941    Program), you indicate your acceptance of this License to do so, and\n\
1942    all its terms and conditions for copying, distributing or modifying\n\
1943    the Program or works based on it.\n\
1944    \n\
1945      6. Each time you redistribute the Program (or any work based on the\n\
1946    Program), the recipient automatically receives a license from the\n\
1947    original licensor to copy, distribute or modify the Program subject to\n\
1948    these terms and conditions.  You may not impose any further\n\
1949    restrictions on the recipients' exercise of the rights granted herein.\n\
1950    You are not responsible for enforcing compliance by third parties to\n\
1951    this License.\n\
1952    \n\
1953      7. If, as a consequence of a court judgment or allegation of patent\n\
1954    infringement or for any other reason (not limited to patent issues),\n\
1955    conditions are imposed on you (whether by court order, agreement or\n\
1956    otherwise) that contradict the conditions of this License, they do not\n\
1957    excuse you from the conditions of this License.  If you cannot\n\
1958    distribute so as to satisfy simultaneously your obligations under this\n\
1959    License and any other pertinent obligations, then as a consequence you\n\
1960    may not distribute the Program at all.  For example, if a patent\n\
1961    license would not permit royalty-free redistribution of the Program by\n\
1962    all those who receive copies directly or indirectly through you, then\n\
1963    the only way you could satisfy both it and this License would be to\n\
1964    refrain entirely from distribution of the Program.\n\
1965    \n\
1966    If any portion of this section is held invalid or unenforceable under\n\
1967    any particular circumstance, the balance of the section is intended to\n\
1968    apply and the section as a whole is intended to apply in other\n\
1969    circumstances.\n\
1970    \n\
1971    It is not the purpose of this section to induce you to infringe any\n\
1972    patents or other property right claims or to contest validity of any\n\
1973    such claims; this section has the sole purpose of protecting the\n\
1974    integrity of the free software distribution system, which is\n\
1975    implemented by public license practices.  Many people have made\n\
1976    generous contributions to the wide range of software distributed\n\
1977    through that system in reliance on consistent application of that\n\
1978    system; it is up to the author/donor to decide if he or she is willing\n\
1979    to distribute software through any other system and a licensee cannot\n\
1980    impose that choice.\n\
1981    \n\
1982    This section is intended to make thoroughly clear what is believed to\n\
1983    be a consequence of the rest of this License.\n\
1984    \n\
1985      8. If the distribution and/or use of the Program is restricted in\n\
1986    certain countries either by patents or by copyrighted interfaces, the\n\
1987    original copyright holder who places the Program under this License\n\
1988    may add an explicit geographical distribution limitation excluding\n\
1989    those countries, so that distribution is permitted only in or among\n\
1990    countries not thus excluded.  In such case, this License incorporates\n\
1991    the limitation as if written in the body of this License.\n\
1992    \n\
1993      9. The Free Software Foundation may publish revised and/or new versions\n\
1994    of the General Public License from time to time.  Such new versions will\n\
1995    be similar in spirit to the present version, but may differ in detail to\n\
1996    address new problems or concerns.\n\
1997    \n\
1998    Each version is given a distinguishing version number.  If the Program\n\
1999    specifies a version number of this License which applies to it and \"any\n\
2000    later version\", you have the option of following the terms and conditions\n\
2001    either of that version or of any later version published by the Free\n\
2002    Software Foundation.  If the Program does not specify a version number of\n\
2003    this License, you may choose any version ever published by the Free Software\n\
2004    Foundation.\n\
2005    \n\
2006      10. If you wish to incorporate parts of the Program into other free\n\
2007    programs whose distribution conditions are different, write to the author\n\
2008    to ask for permission.  For software which is copyrighted by the Free\n\
2009    Software Foundation, write to the Free Software Foundation; we sometimes\n\
2010    make exceptions for this.  Our decision will be guided by the two goals\n\
2011    of preserving the free status of all derivatives of our free software and\n\
2012    of promoting the sharing and reuse of software generally.\n");
2013    }
2014    
2015    extern void warranty(environment *env)
2016    {
2017      printf("                          NO WARRANTY\n\
2018    \n\
2019      11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\
2020    FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN\n\
2021    OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES\n\
2022    PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED\n\
2023    OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF\n\
2024    MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS\n\
2025    TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE\n\
2026    PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,\n\
2027    REPAIR OR CORRECTION.\n\
2028    \n\
2029      12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\n\
2030    WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR\n\
2031    REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,\n\
2032    INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING\n\
2033    OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED\n\
2034    TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY\n\
2035    YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER\n\
2036    PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE\n\
2037    POSSIBILITY OF SUCH DAMAGES.\n");
2038    }
2039    
2040    /* "*" */
2041    extern void sx_2a(environment *env)
2042    {
2043      int a, b;
2044      float fa, fb;
2045    
2046      if((env->head)==NULL || env->head->next==NULL) {
2047        printerr("Too Few Arguments");
2048        env->err=1;
2049        return;
2050      }
2051      
2052      if(env->head->item->type==integer
2053         && env->head->next->item->type==integer) {
2054        a=env->head->item->content.i;
2055        toss(env); if(env->err) return;
2056        b=env->head->item->content.i;
2057        toss(env); if(env->err) return;
2058        push_int(env, b*a);
2059    
2060        return;
2061      }
2062    
2063      if(env->head->item->type==tfloat
2064         && env->head->next->item->type==tfloat) {
2065        fa= env->head->item->content.f;
2066        toss(env); if(env->err) return;
2067        fb= env->head->item->content.f;
2068        toss(env); if(env->err) return;
2069        push_float(env, fb*fa);
2070        
2071        return;
2072      }
2073    
2074      if(env->head->item->type==tfloat
2075         && env->head->next->item->type==integer) {
2076        fa= env->head->item->content.f;
2077        toss(env); if(env->err) return;
2078        b= env->head->item->content.i;
2079        toss(env); if(env->err) return;
2080        push_float(env, b*fa);
2081        
2082        return;
2083      }
2084    
2085      if(env->head->item->type==integer
2086         && env->head->next->item->type==tfloat) {
2087        a= env->head->item->content.i;
2088        toss(env); if(env->err) return;
2089        fb= env->head->item->content.f;
2090        toss(env); if(env->err) return;
2091        push_float(env, fb*a);
2092    
2093        return;
2094      }
2095    
2096      printerr("Bad Argument Type");
2097      env->err=2;
2098    }
2099    
2100    /* "/" */
2101    extern void sx_2f(environment *env)
2102    {
2103      int a, b;
2104      float fa, fb;
2105    
2106      if((env->head)==NULL || env->head->next==NULL) {
2107        printerr("Too Few Arguments");
2108        env->err=1;
2109        return;
2110      }
2111      
2112      if(env->head->item->type==integer
2113         && env->head->next->item->type==integer) {
2114        a=env->head->item->content.i;
2115        toss(env); if(env->err) return;
2116        b=env->head->item->content.i;
2117        toss(env); if(env->err) return;
2118        push_float(env, b/a);
2119    
2120        return;
2121      }
2122    
2123      if(env->head->item->type==tfloat
2124         && env->head->next->item->type==tfloat) {
2125        fa= env->head->item->content.f;
2126        toss(env); if(env->err) return;
2127        fb= env->head->item->content.f;
2128        toss(env); if(env->err) return;
2129        push_float(env, fb/fa);
2130        
2131        return;
2132      }
2133    
2134      if(env->head->item->type==tfloat
2135         && env->head->next->item->type==integer) {
2136        fa= env->head->item->content.f;
2137        toss(env); if(env->err) return;
2138        b= env->head->item->content.i;
2139        toss(env); if(env->err) return;
2140        push_float(env, b/fa);
2141        
2142        return;
2143      }
2144    
2145      if(env->head->item->type==integer
2146         && env->head->next->item->type==tfloat) {
2147        a= env->head->item->content.i;
2148        toss(env); if(env->err) return;
2149        fb= env->head->item->content.f;
2150        toss(env); if(env->err) return;
2151        push_float(env, fb/a);
2152    
2153        return;
2154      }
2155    
2156      printerr("Bad Argument Type");
2157      env->err=2;
2158    }
2159    
2160    /* "mod" */
2161    extern void mod(environment *env)
2162    {
2163      int a, b;
2164    
2165      if((env->head)==NULL || env->head->next==NULL) {
2166        printerr("Too Few Arguments");
2167        env->err= 1;
2168        return;
2169      }
2170      
2171      if(env->head->item->type==integer
2172         && env->head->next->item->type==integer) {
2173        a= env->head->item->content.i;
2174        toss(env); if(env->err) return;
2175        b= env->head->item->content.i;
2176        toss(env); if(env->err) return;
2177        push_int(env, b%a);
2178    
2179        return;
2180      }
2181    
2182      printerr("Bad Argument Type");
2183      env->err=2;
2184    }
2185    
2186    /* "div" */
2187    extern void sx_646976(environment *env)
2188    {
2189      int a, b;
2190      
2191      if((env->head)==NULL || env->head->next==NULL) {
2192        printerr("Too Few Arguments");
2193        env->err= 1;
2194        return;
2195      }
2196    
2197      if(env->head->item->type==integer
2198         && env->head->next->item->type==integer) {
2199        a= env->head->item->content.i;
2200        toss(env); if(env->err) return;
2201        b= env->head->item->content.i;
2202        toss(env); if(env->err) return;
2203        push_int(env, (int)b/a);
2204    
2205        return;
2206      }
2207    
2208      printerr("Bad Argument Type");
2209      env->err= 2;
2210    }
Legend:
Removed from v.1.90  
changed lines
  Added in v.1.100
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26