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

Diff of /stack/stack.c

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

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