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

Diff of /stack/stack.c

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

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