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

Diff of /stack/stack.c

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

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