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

Diff of /stack/stack.c

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

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