/[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.123 by masse, Wed Mar 27 19:53:01 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;
150    new_item->type= value;  
151      val->gc.flag.mark= 1;
152    
153    push(stack_head, new_item);    if(val->type==tcons) {
154    return 1;      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    temp->type= func;    val->gc.flag.protect= 0;
   temp->content.ptr= in_func;  
291    
292    mk_hashentry(in_hashtbl, temp, id);    if(val->type==tcons) {
293        unprotect(CAR(val));
294        unprotect(CDR(val));
295      }
296  }  }
297    
298  int push_ref(stackitem** stack_head, hashtbl in_hash, const char* in_string)  /* Push a value onto the stack */
299    void push_val(environment *env, value *val)
300  {  {
301    void* handle;    value *new_value= new_val(env);
302    void* symbol;  
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    /* Push an integer onto the stack */
313    void push_int(environment *env, int in_val)
314    {
315      value *new_value= new_val(env);
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  /* print_stack(stack); */      free(mangled);
458  void print_st(stackitem* stack_head, long counter)    }
 {  
   if(stack_head->next != NULL)  
     print_st(stack_head->next, counter+1);  
459    
460    switch(stack_head->type){    push_val(env, new_value);
461    case value:    unprotect(new_value); unprotect(new_fvalue);
462      printf("%ld: %d\n", counter, (int)stack_head->content.val);  }
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      switch(CAR(env->head)->type){
480      case empty:
481        push_sym(env, "empty");
482        break;
483      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(val->type) {
514      case empty:
515        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  extern void eval(stackitem** stack_head)    if(CAR(env->head)->type!=symb) {
695        printerr("Bad Argument Type");
696        env->err= 2;
697        return;
698      }
699    
700      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      gc_maybe(env);
725    
726    if((*stack_head)==NULL || (*stack_head)->type!=ref)    if(env->head->type==empty) {
727        printerr("Too Few Arguments");
728        env->err= 1;
729      return;      return;
730      }
731    
732    if(((stackitem*)(*stack_head)->content.ptr)->type==func) {    switch(CAR(env->head)->type) {
733      in_func= (funcp)((stackitem*)(*stack_head)->content.ptr)->content.ptr;      /* if it's a symbol */
734      toss(stack_head);    case symb:
735      (*in_func)(stack_head);      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;      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;
928      }
929    
930      if(CAR(env->head)->type!=integer) {
931        printerr("Bad Argument Type");
932        env->err= 2;
933        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;  }
   int convert= 0;  
948    
949    temp= malloc(inlength);  /* Give a symbol some content. */
950    rest= malloc(inlength);  extern void def(environment *env)
951    {
952      symbol *sym;
953    
954    if((convert= sscanf(in_line, "\"%[^\"\n\r]\" %[^\n\r]", temp, rest)) >= 1)    /* Needs two values on the stack, the top one must be a symbol */
955      push_cstring(stack_head, temp);    if(env->head->type==empty || CDR(env->head)->type==empty) {
956    else if((convert= sscanf(in_line, "%d %[^\n\r]", &itemp, rest)) >= 1)      printerr("Too Few Arguments");
957      push_val(stack_head, itemp);      env->err= 1;
958    else if((convert= sscanf(in_line, "%[^ ;\n\r]%[^\n\r]", temp, rest)) >= 1)      return;
959      push_ref(stack_head, in_hash, temp);    }
   else if((convert= sscanf(in_line, "%c%[^\n\r]", temp, rest)) >= 1)  
     if(*temp==';')  
       eval(stack_head);  
960    
961      if(CAR(env->head)->type!=symb) {
962        printerr("Bad Argument Type");
963        env->err= 2;
964        return;
965      }
966    
967      /* long names are a pain */
968      sym= CAR(env->head)->content.ptr;
969    
970      /* Bind the symbol to the value */
971      sym->val= CAR(CDR(env->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    int main(int argc, char **argv)
1074    {
1075      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  extern void print(stackitem** stack_head)  /* "+" */
1149    extern void sx_2b(environment *env)
1150  {  {
1151    if((*stack_head)==NULL)    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((*stack_head)->type==value)    if(CAR(env->head)->type==string
1164      printf("%d", (*stack_head)->content.val);       && CAR(CDR(env->head))->type==string) {
1165    else if((*stack_head)->type==string)      a_val= CAR(env->head);
1166      printf("%s", (char*)(*stack_head)->content.ptr);      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        return;
1251      }
1252    
1253      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    toss(stack_head);    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(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->type!=empty) {
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, *end;
1674    
1675      end= new_val(env);
1676    
1677      if(env->head->type==empty || CDR(env->head)->type==empty) {
1678        printerr("Too Few Arguments");
1679        env->err= 1;
1680        return;
1681      }
1682    
1683      if(CAR(env->head)->type!=integer
1684         || CAR(CDR(env->head))->type!=integer) {
1685        printerr("Bad Argument Type");
1686        env->err= 2;
1687        return;
1688      }
1689    
1690      ending= CAR(env->head)->content.i;
1691      toss(env); if(env->err) return;
1692      start= CAR(env->head)->content.i;
1693      toss(env); if(env->err) return;
1694    
1695      push_sym(env, "[");
1696    
1697      if(ending>=start) {
1698        for(i= ending; i>=start; i--)
1699          push_int(env, i);
1700      } else {
1701        for(i= ending; i<=start; i++)
1702          push_int(env, i);
1703      }
1704    
1705      iterator= env->head;
1706    
1707      if(iterator->type==empty
1708         || (CAR(iterator)->type==symb
1709             && CAR(iterator)->content.sym->id[0]=='[')) {
1710        temp= end;
1711        toss(env);
1712      } else {
1713        /* Search for first delimiter */
1714        while(CDR(iterator)->type!=empty
1715              && (CAR(CDR(iterator))->type!=symb
1716                  || CAR(CDR(iterator))->content.sym->id[0]!='['))
1717          iterator= CDR(iterator);
1718        
1719        /* Extract list */
1720        temp= env->head;
1721        env->head= CDR(iterator);
1722        CDR(iterator)= end;
1723    
1724        if(env->head->type!=empty)
1725          toss(env);
1726      }
1727    
1728      /* Push list */
1729      push_val(env, temp);
1730    }
1731    
1732    /* Read a string */
1733    extern void readline(environment *env)
1734    {
1735      char in_string[101];
1736    
1737      if(fgets(in_string, 100, env->inputstream)==NULL)
1738        push_cstring(env, "");
1739      else
1740        push_cstring(env, in_string);
1741    }
1742    
1743    /* "read"; Read a value and place on stack */
1744    extern void sx_72656164(environment *env)
1745    {
1746      const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1747      const char strform[]= "\"%[^\"]\"%n";
1748      const char intform[]= "%i%n";
1749      const char fltform[]= "%f%n";
1750      const char blankform[]= "%*[ \t]%n";
1751      const char ebrackform[]= "]%n";
1752      const char semicform[]= ";%n";
1753      const char bbrackform[]= "[%n";
1754    
1755      int itemp, readlength= -1;
1756      int count= -1;
1757      float ftemp;
1758      static int depth= 0;
1759      char *match;
1760      size_t inlength;
1761    
1762      if(env->in_string==NULL) {
1763        if(depth > 0 && env->interactive) {
1764          printf("]> ");
1765        }
1766        readline(env); if(env->err) return;
1767    
1768        if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1769          env->err= 4;              /* "" means EOF */
1770          return;
1771        }
1772        
1773        env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1774        assert(env->in_string != NULL);
1775        env->free_string= env->in_string; /* Save the original pointer */
1776        strcpy(env->in_string, CAR(env->head)->content.ptr);
1777        toss(env); if(env->err) return;
1778      }
1779      
1780      inlength= strlen(env->in_string)+1;
1781      match= malloc(inlength);
1782      assert(match != NULL);
1783    
1784      if(sscanf(env->in_string, blankform, &readlength) != EOF
1785         && readlength != -1) {
1786        ;
1787      } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
1788                && readlength != -1) {
1789        if(sscanf(env->in_string, intform, &itemp, &count) != EOF
1790           && count==readlength) {
1791          push_int(env, itemp);
1792        } else {
1793          push_float(env, ftemp);
1794        }
1795      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1796                && readlength != -1) {
1797        push_cstring(env, "");
1798      } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1799                && readlength != -1) {
1800        push_cstring(env, match);
1801      } else if(sscanf(env->in_string, symbform, match, &readlength) != EOF
1802                && readlength != -1) {
1803        push_sym(env, match);
1804      } else if(sscanf(env->in_string, ebrackform, &readlength) != EOF
1805                && readlength != -1) {
1806        pack(env); if(env->err) return;
1807        if(depth != 0) depth--;
1808      } else if(sscanf(env->in_string, semicform, &readlength) != EOF
1809                && readlength != -1) {
1810        push_sym(env, ";");
1811      } else if(sscanf(env->in_string, bbrackform, &readlength) != EOF
1812                && readlength != -1) {
1813        push_sym(env, "[");
1814        depth++;
1815      } else {
1816        free(env->free_string);
1817        env->in_string = env->free_string = NULL;
1818      }
1819      if (env->in_string != NULL) {
1820        env->in_string += readlength;
1821      }
1822    
1823      free(match);
1824    
1825      if(depth)
1826        return sx_72656164(env);
1827    }
1828    
1829    #ifdef __linux__
1830    extern void beep(environment *env)
1831    {
1832      int freq, dur, period, ticks;
1833    
1834      if(env->head->type==empty || CDR(env->head)->type==empty) {
1835        printerr("Too Few Arguments");
1836        env->err= 1;
1837        return;
1838      }
1839    
1840      if(CAR(env->head)->type!=integer
1841         || CAR(CDR(env->head))->type!=integer) {
1842        printerr("Bad Argument Type");
1843        env->err= 2;
1844        return;
1845      }
1846    
1847      dur= CAR(env->head)->content.i;
1848      toss(env);
1849      freq= CAR(env->head)->content.i;
1850      toss(env);
1851    
1852      period= 1193180/freq;         /* convert freq from Hz to period
1853                                       length */
1854      ticks= dur*.001193180;        /* convert duration from µseconds to
1855                                       timer ticks */
1856    
1857    /*    ticks=dur/1000; */
1858    
1859          /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1860      switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1861      case 0:
1862        usleep(dur);
1863        return;
1864      case -1:
1865        perror("beep");
1866        env->err= 5;
1867        return;
1868      default:
1869        abort();
1870      }
1871    }
1872    #endif /* __linux__ */
1873    
1874    /* "wait" */
1875    extern void sx_77616974(environment *env)
1876    {
1877      int dur;
1878    
1879      if(env->head->type==empty) {
1880        printerr("Too Few Arguments");
1881        env->err= 1;
1882        return;
1883      }
1884    
1885      if(CAR(env->head)->type!=integer) {
1886        printerr("Bad Argument Type");
1887        env->err= 2;
1888        return;
1889      }
1890    
1891      dur= CAR(env->head)->content.i;
1892      toss(env);
1893    
1894      usleep(dur);
1895    }
1896    
1897    extern void copying(environment *env)
1898    {
1899      printf("                  GNU GENERAL PUBLIC LICENSE\n\
1900                           Version 2, June 1991\n\
1901    \n\
1902     Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
1903         59 Temple Place, Suite 330, Boston, MA  02111-1307  USA\n\
1904     Everyone is permitted to copy and distribute verbatim copies\n\
1905     of this license document, but changing it is not allowed.\n\
1906    \n\
1907                                Preamble\n\
1908    \n\
1909      The licenses for most software are designed to take away your\n\
1910    freedom to share and change it.  By contrast, the GNU General Public\n\
1911    License is intended to guarantee your freedom to share and change free\n\
1912    software--to make sure the software is free for all its users.  This\n\
1913    General Public License applies to most of the Free Software\n\
1914    Foundation's software and to any other program whose authors commit to\n\
1915    using it.  (Some other Free Software Foundation software is covered by\n\
1916    the GNU Library General Public License instead.)  You can apply it to\n\
1917    your programs, too.\n\
1918    \n\
1919      When we speak of free software, we are referring to freedom, not\n\
1920    price.  Our General Public Licenses are designed to make sure that you\n\
1921    have the freedom to distribute copies of free software (and charge for\n\
1922    this service if you wish), that you receive source code or can get it\n\
1923    if you want it, that you can change the software or use pieces of it\n\
1924    in new free programs; and that you know you can do these things.\n\
1925    \n\
1926      To protect your rights, we need to make restrictions that forbid\n\
1927    anyone to deny you these rights or to ask you to surrender the rights.\n\
1928    These restrictions translate to certain responsibilities for you if you\n\
1929    distribute copies of the software, or if you modify it.\n\
1930    \n\
1931      For example, if you distribute copies of such a program, whether\n\
1932    gratis or for a fee, you must give the recipients all the rights that\n\
1933    you have.  You must make sure that they, too, receive or can get the\n\
1934    source code.  And you must show them these terms so they know their\n\
1935    rights.\n\
1936    \n\
1937      We protect your rights with two steps: (1) copyright the software, and\n\
1938    (2) offer you this license which gives you legal permission to copy,\n\
1939    distribute and/or modify the software.\n\
1940    \n\
1941      Also, for each author's protection and ours, we want to make certain\n\
1942    that everyone understands that there is no warranty for this free\n\
1943    software.  If the software is modified by someone else and passed on, we\n\
1944    want its recipients to know that what they have is not the original, so\n\
1945    that any problems introduced by others will not reflect on the original\n\
1946    authors' reputations.\n\
1947    \n\
1948      Finally, any free program is threatened constantly by software\n\
1949    patents.  We wish to avoid the danger that redistributors of a free\n\
1950    program will individually obtain patent licenses, in effect making the\n\
1951    program proprietary.  To prevent this, we have made it clear that any\n\
1952    patent must be licensed for everyone's free use or not licensed at all.\n\
1953    \n\
1954      The precise terms and conditions for copying, distribution and\n\
1955    modification follow.\n\
1956    \n\
1957                        GNU GENERAL PUBLIC LICENSE\n\
1958       TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION\n\
1959    \n\
1960      0. This License applies to any program or other work which contains\n\
1961    a notice placed by the copyright holder saying it may be distributed\n\
1962    under the terms of this General Public License.  The \"Program\", below,\n\
1963    refers to any such program or work, and a \"work based on the Program\"\n\
1964    means either the Program or any derivative work under copyright law:\n\
1965    that is to say, a work containing the Program or a portion of it,\n\
1966    either verbatim or with modifications and/or translated into another\n\
1967    language.  (Hereinafter, translation is included without limitation in\n\
1968    the term \"modification\".)  Each licensee is addressed as \"you\".\n\
1969    \n\
1970    Activities other than copying, distribution and modification are not\n\
1971    covered by this License; they are outside its scope.  The act of\n\
1972    running the Program is not restricted, and the output from the Program\n\
1973    is covered only if its contents constitute a work based on the\n\
1974    Program (independent of having been made by running the Program).\n\
1975    Whether that is true depends on what the Program does.\n\
1976    \n\
1977      1. You may copy and distribute verbatim copies of the Program's\n\
1978    source code as you receive it, in any medium, provided that you\n\
1979    conspicuously and appropriately publish on each copy an appropriate\n\
1980    copyright notice and disclaimer of warranty; keep intact all the\n\
1981    notices that refer to this License and to the absence of any warranty;\n\
1982    and give any other recipients of the Program a copy of this License\n\
1983    along with the Program.\n\
1984    \n\
1985    You may charge a fee for the physical act of transferring a copy, and\n\
1986    you may at your option offer warranty protection in exchange for a fee.\n\
1987    \n\
1988      2. You may modify your copy or copies of the Program or any portion\n\
1989    of it, thus forming a work based on the Program, and copy and\n\
1990    distribute such modifications or work under the terms of Section 1\n\
1991    above, provided that you also meet all of these conditions:\n\
1992    \n\
1993        a) You must cause the modified files to carry prominent notices\n\
1994        stating that you changed the files and the date of any change.\n\
1995    \n\
1996        b) You must cause any work that you distribute or publish, that in\n\
1997        whole or in part contains or is derived from the Program or any\n\
1998        part thereof, to be licensed as a whole at no charge to all third\n\
1999        parties under the terms of this License.\n\
2000    \n\
2001        c) If the modified program normally reads commands interactively\n\
2002        when run, you must cause it, when started running for such\n\
2003        interactive use in the most ordinary way, to print or display an\n\
2004        announcement including an appropriate copyright notice and a\n\
2005        notice that there is no warranty (or else, saying that you provide\n\
2006        a warranty) and that users may redistribute the program under\n\
2007        these conditions, and telling the user how to view a copy of this\n\
2008        License.  (Exception: if the Program itself is interactive but\n\
2009        does not normally print such an announcement, your work based on\n\
2010        the Program is not required to print an announcement.)\n\
2011    \n\
2012    These requirements apply to the modified work as a whole.  If\n\
2013    identifiable sections of that work are not derived from the Program,\n\
2014    and can be reasonably considered independent and separate works in\n\
2015    themselves, then this License, and its terms, do not apply to those\n\
2016    sections when you distribute them as separate works.  But when you\n\
2017    distribute the same sections as part of a whole which is a work based\n\
2018    on the Program, the distribution of the whole must be on the terms of\n\
2019    this License, whose permissions for other licensees extend to the\n\
2020    entire whole, and thus to each and every part regardless of who wrote it.\n\
2021    \n\
2022    Thus, it is not the intent of this section to claim rights or contest\n\
2023    your rights to work written entirely by you; rather, the intent is to\n\
2024    exercise the right to control the distribution of derivative or\n\
2025    collective works based on the Program.\n\
2026    \n\
2027    In addition, mere aggregation of another work not based on the Program\n\
2028    with the Program (or with a work based on the Program) on a volume of\n\
2029    a storage or distribution medium does not bring the other work under\n\
2030    the scope of this License.\n\
2031    \n\
2032      3. You may copy and distribute the Program (or a work based on it,\n\
2033    under Section 2) in object code or executable form under the terms of\n\
2034    Sections 1 and 2 above provided that you also do one of the following:\n\
2035    \n\
2036        a) Accompany it with the complete corresponding machine-readable\n\
2037        source code, which must be distributed under the terms of Sections\n\
2038        1 and 2 above on a medium customarily used for software interchange; or,\n\
2039    \n\
2040        b) Accompany it with a written offer, valid for at least three\n\
2041        years, to give any third party, for a charge no more than your\n\
2042        cost of physically performing source distribution, a complete\n\
2043        machine-readable copy of the corresponding source code, to be\n\
2044        distributed under the terms of Sections 1 and 2 above on a medium\n\
2045        customarily used for software interchange; or,\n\
2046    \n\
2047        c) Accompany it with the information you received as to the offer\n\
2048        to distribute corresponding source code.  (This alternative is\n\
2049        allowed only for noncommercial distribution and only if you\n\
2050        received the program in object code or executable form with such\n\
2051        an offer, in accord with Subsection b above.)\n\
2052    \n\
2053    The source code for a work means the preferred form of the work for\n\
2054    making modifications to it.  For an executable work, complete source\n\
2055    code means all the source code for all modules it contains, plus any\n\
2056    associated interface definition files, plus the scripts used to\n\
2057    control compilation and installation of the executable.  However, as a\n\
2058    special exception, the source code distributed need not include\n\
2059    anything that is normally distributed (in either source or binary\n\
2060    form) with the major components (compiler, kernel, and so on) of the\n\
2061    operating system on which the executable runs, unless that component\n\
2062    itself accompanies the executable.\n\
2063    \n\
2064    If distribution of executable or object code is made by offering\n\
2065    access to copy from a designated place, then offering equivalent\n\
2066    access to copy the source code from the same place counts as\n\
2067    distribution of the source code, even though third parties are not\n\
2068    compelled to copy the source along with the object code.\n\
2069    \n\
2070      4. You may not copy, modify, sublicense, or distribute the Program\n\
2071    except as expressly provided under this License.  Any attempt\n\
2072    otherwise to copy, modify, sublicense or distribute the Program is\n\
2073    void, and will automatically terminate your rights under this License.\n\
2074    However, parties who have received copies, or rights, from you under\n\
2075    this License will not have their licenses terminated so long as such\n\
2076    parties remain in full compliance.\n\
2077    \n\
2078      5. You are not required to accept this License, since you have not\n\
2079    signed it.  However, nothing else grants you permission to modify or\n\
2080    distribute the Program or its derivative works.  These actions are\n\
2081    prohibited by law if you do not accept this License.  Therefore, by\n\
2082    modifying or distributing the Program (or any work based on the\n\
2083    Program), you indicate your acceptance of this License to do so, and\n\
2084    all its terms and conditions for copying, distributing or modifying\n\
2085    the Program or works based on it.\n\
2086    \n\
2087      6. Each time you redistribute the Program (or any work based on the\n\
2088    Program), the recipient automatically receives a license from the\n\
2089    original licensor to copy, distribute or modify the Program subject to\n\
2090    these terms and conditions.  You may not impose any further\n\
2091    restrictions on the recipients' exercise of the rights granted herein.\n\
2092    You are not responsible for enforcing compliance by third parties to\n\
2093    this License.\n\
2094    \n\
2095      7. If, as a consequence of a court judgment or allegation of patent\n\
2096    infringement or for any other reason (not limited to patent issues),\n\
2097    conditions are imposed on you (whether by court order, agreement or\n\
2098    otherwise) that contradict the conditions of this License, they do not\n\
2099    excuse you from the conditions of this License.  If you cannot\n\
2100    distribute so as to satisfy simultaneously your obligations under this\n\
2101    License and any other pertinent obligations, then as a consequence you\n\
2102    may not distribute the Program at all.  For example, if a patent\n\
2103    license would not permit royalty-free redistribution of the Program by\n\
2104    all those who receive copies directly or indirectly through you, then\n\
2105    the only way you could satisfy both it and this License would be to\n\
2106    refrain entirely from distribution of the Program.\n\
2107    \n\
2108    If any portion of this section is held invalid or unenforceable under\n\
2109    any particular circumstance, the balance of the section is intended to\n\
2110    apply and the section as a whole is intended to apply in other\n\
2111    circumstances.\n\
2112    \n\
2113    It is not the purpose of this section to induce you to infringe any\n\
2114    patents or other property right claims or to contest validity of any\n\
2115    such claims; this section has the sole purpose of protecting the\n\
2116    integrity of the free software distribution system, which is\n\
2117    implemented by public license practices.  Many people have made\n\
2118    generous contributions to the wide range of software distributed\n\
2119    through that system in reliance on consistent application of that\n\
2120    system; it is up to the author/donor to decide if he or she is willing\n\
2121    to distribute software through any other system and a licensee cannot\n\
2122    impose that choice.\n\
2123    \n\
2124    This section is intended to make thoroughly clear what is believed to\n\
2125    be a consequence of the rest of this License.\n\
2126    \n\
2127      8. If the distribution and/or use of the Program is restricted in\n\
2128    certain countries either by patents or by copyrighted interfaces, the\n\
2129    original copyright holder who places the Program under this License\n\
2130    may add an explicit geographical distribution limitation excluding\n\
2131    those countries, so that distribution is permitted only in or among\n\
2132    countries not thus excluded.  In such case, this License incorporates\n\
2133    the limitation as if written in the body of this License.\n\
2134    \n\
2135      9. The Free Software Foundation may publish revised and/or new versions\n\
2136    of the General Public License from time to time.  Such new versions will\n\
2137    be similar in spirit to the present version, but may differ in detail to\n\
2138    address new problems or concerns.\n\
2139    \n\
2140    Each version is given a distinguishing version number.  If the Program\n\
2141    specifies a version number of this License which applies to it and \"any\n\
2142    later version\", you have the option of following the terms and conditions\n\
2143    either of that version or of any later version published by the Free\n\
2144    Software Foundation.  If the Program does not specify a version number of\n\
2145    this License, you may choose any version ever published by the Free Software\n\
2146    Foundation.\n\
2147    \n\
2148      10. If you wish to incorporate parts of the Program into other free\n\
2149    programs whose distribution conditions are different, write to the author\n\
2150    to ask for permission.  For software which is copyrighted by the Free\n\
2151    Software Foundation, write to the Free Software Foundation; we sometimes\n\
2152    make exceptions for this.  Our decision will be guided by the two goals\n\
2153    of preserving the free status of all derivatives of our free software and\n\
2154    of promoting the sharing and reuse of software generally.\n");
2155    }
2156    
2157    extern void warranty(environment *env)
2158    {
2159      printf("                          NO WARRANTY\n\
2160    \n\
2161      11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\
2162    FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN\n\
2163    OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES\n\
2164    PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED\n\
2165    OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF\n\
2166    MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS\n\
2167    TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE\n\
2168    PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,\n\
2169    REPAIR OR CORRECTION.\n\
2170    \n\
2171      12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\n\
2172    WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR\n\
2173    REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,\n\
2174    INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING\n\
2175    OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED\n\
2176    TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY\n\
2177    YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER\n\
2178    PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE\n\
2179    POSSIBILITY OF SUCH DAMAGES.\n");
2180    }
2181    
2182    /* "*" */
2183    extern void sx_2a(environment *env)
2184    {
2185      int a, b;
2186      float fa, fb;
2187    
2188      if(env->head->type==empty || CDR(env->head)->type==empty) {
2189        printerr("Too Few Arguments");
2190        env->err= 1;
2191        return;
2192      }
2193      
2194      if(CAR(env->head)->type==integer
2195         && CAR(CDR(env->head))->type==integer) {
2196        a= CAR(env->head)->content.i;
2197        toss(env); if(env->err) return;
2198        b= CAR(env->head)->content.i;
2199        toss(env); if(env->err) return;
2200        push_int(env, b*a);
2201    
2202        return;
2203      }
2204    
2205      if(CAR(env->head)->type==tfloat
2206         && CAR(CDR(env->head))->type==tfloat) {
2207        fa= CAR(env->head)->content.f;
2208        toss(env); if(env->err) return;
2209        fb= CAR(env->head)->content.f;
2210        toss(env); if(env->err) return;
2211        push_float(env, fb*fa);
2212        
2213        return;
2214      }
2215    
2216      if(CAR(env->head)->type==tfloat
2217         && CAR(CDR(env->head))->type==integer) {
2218        fa= CAR(env->head)->content.f;
2219        toss(env); if(env->err) return;
2220        b= CAR(env->head)->content.i;
2221        toss(env); if(env->err) return;
2222        push_float(env, b*fa);
2223        
2224        return;
2225      }
2226    
2227      if(CAR(env->head)->type==integer
2228         && CAR(CDR(env->head))->type==tfloat) {
2229        a= CAR(env->head)->content.i;
2230        toss(env); if(env->err) return;
2231        fb= CAR(env->head)->content.f;
2232        toss(env); if(env->err) return;
2233        push_float(env, fb*a);
2234    
2235        return;
2236      }
2237    
2238      printerr("Bad Argument Type");
2239      env->err= 2;
2240  }  }
2241    
2242  int main()  /* "/" */
2243    extern void sx_2f(environment *env)
2244  {  {
2245    stackitem* s= NULL;    int a, b;
2246    hashtbl myhash;    float fa, fb;
2247    char in_string[100];  
2248      if(env->head->type==empty || CDR(env->head)->type==empty) {
2249        printerr("Too Few Arguments");
2250        env->err= 1;
2251        return;
2252      }
2253      
2254      if(CAR(env->head)->type==integer
2255         && CAR(CDR(env->head))->type==integer) {
2256        a= CAR(env->head)->content.i;
2257        toss(env); if(env->err) return;
2258        b= CAR(env->head)->content.i;
2259        toss(env); if(env->err) return;
2260        push_float(env, b/a);
2261    
2262        return;
2263      }
2264    
2265    init_hashtbl(myhash);    if(CAR(env->head)->type==tfloat
2266         && CAR(CDR(env->head))->type==tfloat) {
2267        fa= CAR(env->head)->content.f;
2268        toss(env); if(env->err) return;
2269        fb= CAR(env->head)->content.f;
2270        toss(env); if(env->err) return;
2271        push_float(env, fb/fa);
2272        
2273        return;
2274      }
2275    
2276    printf("okidok\n ");    if(CAR(env->head)->type==tfloat
2277         && CAR(CDR(env->head))->type==integer) {
2278        fa= CAR(env->head)->content.f;
2279        toss(env); if(env->err) return;
2280        b= CAR(env->head)->content.i;
2281        toss(env); if(env->err) return;
2282        push_float(env, b/fa);
2283        
2284        return;
2285      }
2286    
2287      if(CAR(env->head)->type==integer
2288         && CAR(CDR(env->head))->type==tfloat) {
2289        a= CAR(env->head)->content.i;
2290        toss(env); if(env->err) return;
2291        fb= CAR(env->head)->content.f;
2292        toss(env); if(env->err) return;
2293        push_float(env, fb/a);
2294    
2295    while(fgets(in_string, 100, stdin) != NULL) {      return;
     stack_read(&s, myhash, in_string);  
     printf("okidok\n ");  
2296    }    }
2297    
2298      printerr("Bad Argument Type");
2299      env->err= 2;
2300    }
2301    
2302    return EXIT_SUCCESS;  /* "mod" */
2303    extern void mod(environment *env)
2304    {
2305      int a, b;
2306    
2307      if(env->head->type==empty || CDR(env->head)->type==empty) {
2308        printerr("Too Few Arguments");
2309        env->err= 1;
2310        return;
2311      }
2312      
2313      if(CAR(env->head)->type==integer
2314         && CAR(CDR(env->head))->type==integer) {
2315        a= CAR(env->head)->content.i;
2316        toss(env); if(env->err) return;
2317        b= CAR(env->head)->content.i;
2318        toss(env); if(env->err) return;
2319        push_int(env, b%a);
2320    
2321        return;
2322      }
2323    
2324      printerr("Bad Argument Type");
2325      env->err= 2;
2326  }  }
2327    
2328  /* Local Variables: */  /* "div" */
2329  /* compile-command:"make CFLAGS=\"-Wall -g -rdynamic -ldl\" stack" */  extern void sx_646976(environment *env)
2330  /* End: */  {
2331      int a, b;
2332      
2333      if(env->head->type==empty || CDR(env->head)->type==empty) {
2334        printerr("Too Few Arguments");
2335        env->err= 1;
2336        return;
2337      }
2338    
2339      if(CAR(env->head)->type==integer
2340         && CAR(CDR(env->head))->type==integer) {
2341        a= CAR(env->head)->content.i;
2342        toss(env); if(env->err) return;
2343        b= CAR(env->head)->content.i;
2344        toss(env); if(env->err) return;
2345        push_int(env, (int)b/a);
2346    
2347        return;
2348      }
2349    
2350      printerr("Bad Argument Type");
2351      env->err= 2;
2352    }
2353    
2354    extern void setcar(environment *env)
2355    {
2356      if(env->head->type==empty || CDR(env->head)->type==empty) {
2357        printerr("Too Few Arguments");
2358        env->err= 1;
2359        return;
2360      }
2361    
2362      if(CDR(env->head)->type!=tcons) {
2363        printerr("Bad Argument Type");
2364        env->err= 2;
2365        return;
2366      }
2367    
2368      CAR(CAR(CDR(env->head)))=CAR(env->head);
2369      toss(env);
2370    }
2371    
2372    extern void setcdr(environment *env)
2373    {
2374      if(env->head->type==empty || CDR(env->head)->type==empty) {
2375        printerr("Too Few Arguments");
2376        env->err= 1;
2377        return;
2378      }
2379    
2380      if(CDR(env->head)->type!=tcons) {
2381        printerr("Bad Argument Type");
2382        env->err= 2;
2383        return;
2384      }
2385    
2386      CDR(CAR(CDR(env->head)))=CAR(env->head);
2387      toss(env);
2388    }
2389    
2390    extern void car(environment *env)
2391    {
2392      if(env->head->type==empty) {
2393        printerr("Too Few Arguments");
2394        env->err= 1;
2395        return;
2396      }
2397    
2398      if(CAR(env->head)->type!=tcons) {
2399        printerr("Bad Argument Type");
2400        env->err= 2;
2401        return;
2402      }
2403    
2404      CAR(env->head)=CAR(CAR(env->head));
2405    }
2406    
2407    extern void cdr(environment *env)
2408    {
2409      if(env->head->type==empty) {
2410        printerr("Too Few Arguments");
2411        env->err= 1;
2412        return;
2413      }
2414    
2415      if(CAR(env->head)->type!=tcons) {
2416        printerr("Bad Argument Type");
2417        env->err= 2;
2418        return;
2419      }
2420    
2421      CAR(env->head)=CDR(CAR(env->head));
2422    }
2423    
2424    extern void cons(environment *env)
2425    {
2426      value *val;
2427    
2428      if(env->head->type==empty || CDR(env->head)->type==empty) {
2429        printerr("Too Few Arguments");
2430        env->err= 1;
2431        return;
2432      }
2433    
2434      val=new_val(env);
2435      val->content.c= malloc(sizeof(pair));
2436      assert(val->content.c!=NULL);
2437    
2438      env->gc_count += sizeof(pair);
2439      val->type=tcons;
2440    
2441      CAR(val)= CAR(CDR(env->head));
2442      CDR(val)= CAR(env->head);
2443    
2444      push_val(env, val);
2445    
2446      swap(env); if(env->err) return;
2447      toss(env); if(env->err) return;
2448      swap(env); if(env->err) return;
2449      toss(env); if(env->err) return;
2450    }
2451    
2452    /*  2: 3                        =>                */
2453    /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
2454    extern void assq(environment *env)
2455    {
2456      assocgen(env, eq);
2457    }
2458    
2459    
2460    /* General assoc function */
2461    void assocgen(environment *env, funcp eqfunc)
2462    {
2463      value *key, *item;
2464    
2465      /* Needs two values on the stack, the top one must be an association
2466         list */
2467      if(env->head->type==empty || CDR(env->head)->type==empty) {
2468        printerr("Too Few Arguments");
2469        env->err= 1;
2470        return;
2471      }
2472    
2473      if(CAR(env->head)->type!=tcons) {
2474        printerr("Bad Argument Type");
2475        env->err= 2;
2476        return;
2477      }
2478    
2479      key=CAR(CDR(env->head));
2480      item=CAR(env->head);
2481    
2482      while(item->type == tcons){
2483        if(CAR(item)->type != tcons){
2484          printerr("Bad Argument Type");
2485          env->err= 2;
2486          return;
2487        }
2488        push_val(env, key);
2489        push_val(env, CAR(CAR(item)));
2490        eqfunc(env); if(env->err) return;
2491    
2492        /* Check the result of 'eqfunc' */
2493        if(env->head->type==empty) {
2494          printerr("Too Few Arguments");
2495          env->err= 1;
2496        return;
2497        }
2498        if(CAR(env->head)->type!=integer) {
2499          printerr("Bad Argument Type");
2500          env->err= 2;
2501          return;
2502        }
2503    
2504        if(CAR(env->head)->content.i){
2505          toss(env); if(env->err) return;
2506          break;
2507        }
2508        toss(env); if(env->err) return;
2509    
2510        if(item->type!=tcons) {
2511          printerr("Bad Argument Type");
2512          env->err= 2;
2513          return;
2514        }
2515    
2516        item=CDR(item);
2517      }
2518    
2519      if(item->type == tcons){      /* A match was found */
2520        push_val(env, CAR(item));
2521      } else {
2522        push_int(env, 0);
2523      }
2524      swap(env); if(env->err) return;
2525      toss(env); if(env->err) return;
2526      swap(env); if(env->err) return;
2527      toss(env);
2528    }
2529    
2530    extern void sx_646f(environment *env)
2531    {
2532      swap(env); if(env->err) return;
2533      eval(env);
2534    }
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.123
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26