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

Diff of /stack/stack.c

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

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