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

Diff of /stack/stack.c

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

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