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

Diff of /stack/stack.c

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

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

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.110

root@recompile.se
ViewVC Help
Powered by ViewVC 1.1.26