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

Diff of /stack/stack.c

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

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

Legend:
Removed from v.1.33  
changed lines
  Added in v.1.108

root@recompile.se
ViewVC Help
Powered by ViewVC 1.1.26