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

Diff of /stack/stack.c

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

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