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

Diff of /stack/stack.c

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

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