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

Diff of /stack/stack.c

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

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