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

Diff of /stack/stack.c

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

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