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

Diff of /stack/stack.c

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

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