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

Diff of /stack/stack.c

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

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