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

Diff of /stack/stack.c

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

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