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

Diff of /stack/stack.c

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

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