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

Diff of /stack/stack.c

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

revision 1.10 by masse, Tue Jan 8 17:31:27 2002 UTC revision 1.87 by masse, Fri Feb 15 18:27:18 2002 UTC
# Line 1  Line 1 
1  /* printf */  /* printf, sscanf, fgets, fprintf, fopen, perror */
2  #include <stdio.h>  #include <stdio.h>
3  /* EXIT_SUCCESS */  /* exit, EXIT_SUCCESS, malloc, free */
4  #include <stdlib.h>  #include <stdlib.h>
5  /* NULL */  /* NULL */
6  #include <stddef.h>  #include <stddef.h>
7  /* dlopen, dlsym, dlerror */  /* dlopen, dlsym, dlerror */
8  #include <dlfcn.h>  #include <dlfcn.h>
9    /* strcmp, strcpy, strlen, strcat, strdup */
10    #include <string.h>
11    /* getopt, STDIN_FILENO, STDOUT_FILENO */
12    #include <unistd.h>
13    /* EX_NOINPUT, EX_USAGE */
14    #include <sysexits.h>
15    /* mtrace, muntrace */
16    #include <mcheck.h>
17    
18    #define HASHTBLSIZE 2048
19    
20    /* First, define some types. */
21    
22    /* A value of some type */
23    typedef struct {
24      enum {
25        integer,
26        string,
27        func,                       /* Function pointer */
28        symb,
29        list
30      } type;                       /* Type of stack element */
31    
32  #define HASHTBLSIZE 65536    union {
33        void *ptr;                  /* Pointer to the content */
34        int val;                    /* ...or an integer */
35      } content;                    /* Stores a pointer or an integer */
36    
37      int gc_garb;
38    
39    } value;
40    
41    /* A symbol with a name and possible value */
42    /* (These do not need reference counters, they are kept unique by
43       hashing.) */
44    typedef struct symbol_struct {
45      char *id;                     /* Symbol name */
46      value *val;                   /* The value (if any) bound to it */
47      struct symbol_struct *next;   /* In case of hashing conflicts, a */
48    } symbol;                       /* symbol is a kind of stack item. */
49    
50    /* A type for a hash table for symbols */
51    typedef symbol *hashtbl[HASHTBLSIZE]; /* Hash table declaration */
52    
53    /* An item (value) on a stack */
54    typedef struct stackitem_struct
55    {
56      value *item;                  /* The value on the stack */
57                                    /* (This is never NULL) */
58      struct stackitem_struct *next; /* Next item */
59    } stackitem;
60    
61  typedef struct stack_item  /* An environment; gives access to the stack and a hash table of
62       defined symbols */
63    typedef struct {
64      stackitem *gc_ref;
65      int gc_limit, gc_count;
66    
67      stackitem *head;              /* Head of the stack */
68      hashtbl symbols;              /* Hash table of all variable bindings */
69      int err;                      /* Error flag */
70      char *in_string;              /* Input pending to be read */
71      char *free_string;            /* Free this string when all input is
72                                       read from in_string */
73      FILE *inputstream;            /* stdin or a file, most likely */
74      int interactive;              /* print prompts, stack, etc */
75    } environment;
76    
77    /* A type for pointers to external functions */
78    typedef void (*funcp)(environment *); /* funcp is a pointer to a void
79                                             function (environment *) */
80    
81    /* Initialize a newly created environment */
82    void init_env(environment *env)
83  {  {
84    enum {value, string, ref, func, symbol, list} type;    int i;
   union {  
     void* ptr;  
     int val;  
   } content;  
85    
86    char* id;    env->gc_limit= 20;
87    struct stack_item* next;    env->gc_count= 0;
 } stackitem;  
88    
89      env->head= NULL;
90      for(i= 0; i<HASHTBLSIZE; i++)
91        env->symbols[i]= NULL;
92      env->err= 0;
93      env->in_string= NULL;
94      env->free_string= NULL;
95      env->inputstream= stdin;
96      env->interactive= 1;
97    }
98    
99  typedef stackitem* hashtbl[HASHTBLSIZE];  void printerr(const char* in_string) {
100  typedef void (*funcp)(stackitem**);    fprintf(stderr, "Err: %s\n", in_string);
101    }
102    
103  void init_hashtbl(hashtbl out_hash)  /* Discard the top element of the stack. */
104    extern void toss(environment *env)
105  {  {
106    long i;    stackitem *temp= env->head;
107    
108    for(i= 0; i<HASHTBLSIZE; i++)    if((env->head)==NULL) {
109      out_hash[i]= NULL;      printerr("Too Few Arguments");
110        env->err=1;
111        return;
112      }
113      
114      env->head= env->head->next;   /* Remove the top stack item */
115      free(temp);                   /* Free the old top stack item */
116  }  }
117    
118  stackitem** hash(hashtbl in_hashtbl, const char* in_string)  /* Returns a pointer to a pointer to an element in the hash table. */
119    symbol **hash(hashtbl in_hashtbl, const char *in_string)
120  {  {
121    long i= 0;    int i= 0;
122    unsigned long out_hash= 0;    unsigned int out_hash= 0;
123    char key= 0;    char key= '\0';
124    stackitem** position;    symbol **position;
125        
126    while(1){    while(1){                     /* Hash in_string */
127      key= in_string[i++];      key= in_string[i++];
128      if(key=='\0')      if(key=='\0')
129        break;        break;
# Line 51  stackitem** hash(hashtbl in_hashtbl, con Line 134  stackitem** hash(hashtbl in_hashtbl, con
134    position= &(in_hashtbl[out_hash]);    position= &(in_hashtbl[out_hash]);
135    
136    while(1){    while(1){
137      if(*position==NULL)      if(*position==NULL)         /* If empty */
138        return position;        return position;
139            
140      if(strcmp(in_string, (*position)->id)==0)      if(strcmp(in_string, (*position)->id)==0) /* If match */
141        return position;        return position;
142    
143      position= &((*position)->next);      position= &((*position)->next); /* Try next */
144    }    }
145  }  }
146    
147    extern void gc_init(environment*);
148    
149  int push(stackitem** stack_head, stackitem* in_item)  value* new_val(environment *env) {
150  {    value *nval= malloc(sizeof(value));
151    in_item->next= *stack_head;    stackitem *nitem= malloc(sizeof(stackitem));
   *stack_head= in_item;  
   return 1;  
 }  
152    
153  int push_val(stackitem** stack_head, int in_val)    if(env->gc_count >= env->gc_limit)
154  {      gc_init(env);
   stackitem* new_item= malloc(sizeof(stackitem));  
   new_item->content.val= in_val;  
   new_item->type= value;  
155    
156    push(stack_head, new_item);    nval->content.ptr= NULL;
   return 1;  
 }  
157    
158  int push_cstring(stackitem** stack_head, const char* in_string)    nitem->item= nval;
159  {    nitem->next= env->gc_ref;
160    stackitem* new_item= malloc(sizeof(stackitem));    env->gc_ref= nitem;
   new_item->content.ptr= malloc(strlen(in_string)+1);  
   strcpy(new_item->content.ptr, in_string);  
   new_item->type= string;  
161    
162    push(stack_head, new_item);    env->gc_count++;
163    return 1;  
164      return nval;
165  }  }
166    
167  int mk_hashentry(hashtbl in_hashtbl, stackitem* in_item, const char* id)  void gc_mark(value *val) {
168  {    stackitem *iterator;
   in_item->id= malloc(strlen(id)+1);  
169    
170    strcpy(in_item->id, id);    if(val==NULL || val->gc_garb==0)
171    push(hash(in_hashtbl, id), in_item);      return;
172    
173      val->gc_garb= 0;
174    
175      if(val->type==list) {
176        iterator= val->content.ptr;
177    
178    return 1;      while(iterator!=NULL) {
179          gc_mark(iterator->item);
180          iterator= iterator->next;
181        }
182      }
183  }  }
184    
185  void def_func(hashtbl in_hashtbl, funcp in_func, const char* id)  extern void gc_init(environment *env) {
186  {    stackitem *new_head= NULL, *titem, *iterator= env->gc_ref;
187    stackitem* temp= malloc(sizeof(stackitem));    symbol *tsymb;
188      int i;
189    
190      while(iterator!=NULL) {
191        iterator->item->gc_garb= 1;
192        iterator= iterator->next;
193      }
194    
195      /* Mark */
196      iterator= env->head;
197      while(iterator!=NULL) {
198        gc_mark(iterator->item);
199        iterator= iterator->next;
200      }
201    
202      for(i= 0; i<HASHTBLSIZE; i++) {
203        tsymb= env->symbols[i];
204        while(tsymb!=NULL) {
205          gc_mark(tsymb->val);
206          tsymb= tsymb->next;
207        }
208      }
209    
210      env->gc_count= 0;
211    
212      /* Sweep */
213      while(env->gc_ref!=NULL) {
214        if(env->gc_ref->item->gc_garb) {
215          switch(env->gc_ref->item->type) {
216          case string:
217            free(env->gc_ref->item->content.ptr);
218            break;
219          case integer:
220            break;
221          case list:
222            while(env->gc_ref->item->content.ptr!=NULL) {
223              titem= env->gc_ref->item->content.ptr;
224              env->gc_ref->item->content.ptr= titem->next;
225              free(titem);
226            }
227            break;
228          default:
229            break;
230          }
231          free(env->gc_ref->item);
232          titem= env->gc_ref->next;
233          free(env->gc_ref);
234          env->gc_ref= titem;
235        } else {
236          titem= env->gc_ref->next;
237          env->gc_ref->next= new_head;
238          new_head= env->gc_ref;
239          env->gc_ref= titem;
240          env->gc_count++;
241        }
242      }
243    
244    temp->type= func;    env->gc_limit= env->gc_count+20;
245    temp->content.ptr= in_func;    env->gc_ref= new_head;
246    }
247    
248    mk_hashentry(in_hashtbl, temp, id);  /* Push a value onto the stack */
249    void push_val(environment *env, value *val)
250    {
251      stackitem *new_item= malloc(sizeof(stackitem));
252      new_item->item= val;
253      new_item->next= env->head;
254      env->head= new_item;
255  }  }
256    
257  void def_sym(hashtbl in_hashtbl, const char* id)  /* Push an integer onto the stack. */
258    void push_int(environment *env, int in_val)
259  {  {
260    stackitem* temp= malloc(sizeof(stackitem));    value *new_value= new_val(env);
261        
262    temp->type= symbol;    new_value->content.val= in_val;
263      new_value->type= integer;
264    
265    mk_hashentry(in_hashtbl, temp, id);    push_val(env, new_value);
266  }  }
267    
268  int push_ref(stackitem** stack_head, hashtbl in_hash, const char* in_string)  /* Copy a string onto the stack. */
269    void push_cstring(environment *env, const char *in_string)
270  {  {
271    static void* handle= NULL;    value *new_value= new_val(env);
   void* symbol;  
272    
273    stackitem* new_item= malloc(sizeof(stackitem));    new_value->content.ptr= malloc(strlen(in_string)+1);
274    new_item->content.ptr= *hash(in_hash, in_string);    strcpy(new_value->content.ptr, in_string);
275    new_item->type= ref;    new_value->type= string;
276    
277    if(new_item->content.ptr==NULL) {    push_val(env, new_value);
278      if(handle==NULL)  }
       handle= dlopen(NULL, RTLD_LAZY);      
279    
280      symbol= dlsym(handle, in_string);  /* Mangle a symbol name to a valid C identifier name */
281      if(dlerror()==NULL)  char *mangle_str(const char *old_string){
282        def_func(in_hash, symbol, in_string);    char validchars[]
283      else      ="0123456789abcdef";
284        def_sym(in_hash, in_string);    char *new_string, *current;
285          
286      new_item->content.ptr= *hash(in_hash, in_string);    new_string=malloc((strlen(old_string)*2)+4);
287      new_item->type= ref;    strcpy(new_string, "sx_");    /* Stack eXternal */
288      current=new_string+3;
289      while(old_string[0] != '\0'){
290        current[0]=validchars[(unsigned char)(old_string[0])/16];
291        current[1]=validchars[(unsigned char)(old_string[0])%16];
292        current+=2;
293        old_string++;
294    }    }
295      current[0]='\0';
296    
297    push(stack_head, new_item);    return new_string;            /* The caller must free() it */
   return 1;  
298  }  }
299    
300  extern void toss(stackitem** stack_head)  extern void mangle(environment *env){
301  {    char *new_string;
   stackitem* temp= *stack_head;  
302    
303    if((*stack_head)==NULL)    if((env->head)==NULL) {
304        printerr("Too Few Arguments");
305        env->err=1;
306      return;      return;
307        }
   if((*stack_head)->type==string)  
     free((*stack_head)->content.ptr);  
308    
309    *stack_head= (*stack_head)->next;    if(env->head->item->type!=string) {
310    free(temp);      printerr("Bad Argument Type");
311        env->err=2;
312        return;
313      }
314    
315      new_string= mangle_str((const char *)(env->head->item->content.ptr));
316    
317      toss(env);
318      if(env->err) return;
319    
320      push_cstring(env, new_string);
321  }  }
322    
323    /* Push a symbol onto the stack. */
324    void push_sym(environment *env, const char *in_string)
325    {
326      value *new_value;             /* A new symbol value */
327      /* ...which might point to... */
328      symbol **new_symbol;          /* (if needed) A new actual symbol */
329      /* ...which, if possible, will be bound to... */
330      value *new_fvalue;            /* (if needed) A new function value */
331      /* ...which will point to... */
332      void *funcptr;                /* A function pointer */
333    
334      static void *handle= NULL;    /* Dynamic linker handle */
335      const char *dlerr;            /* Dynamic linker error */
336      char *mangled;                /* Mangled function name */
337    
338      new_value= new_val(env);
339    
340      /* The new value is a symbol */
341      new_value->type= symb;
342    
343      /* Look up the symbol name in the hash table */
344      new_symbol= hash(env->symbols, in_string);
345      new_value->content.ptr= *new_symbol;
346    
347      if(*new_symbol==NULL) { /* If symbol was undefined */
348    
349        /* Create a new symbol */
350        (*new_symbol)= malloc(sizeof(symbol));
351        (*new_symbol)->val= NULL;   /* undefined value */
352        (*new_symbol)->next= NULL;
353        (*new_symbol)->id= malloc(strlen(in_string)+1);
354        strcpy((*new_symbol)->id, in_string);
355    
356        /* Intern the new symbol in the hash table */
357        new_value->content.ptr= *new_symbol;
358    
359        /* Try to load the symbol name as an external function, to see if
360           we should bind the symbol to a new function pointer value */
361        if(handle==NULL)            /* If no handle */
362          handle= dlopen(NULL, RTLD_LAZY);
363    
364        mangled=mangle_str(in_string); /* mangle the name */
365        funcptr= dlsym(handle, mangled); /* and try to find it */
366        free(mangled);
367        dlerr=dlerror();
368        if(dlerr != NULL) {         /* If no function was found */
369          funcptr= dlsym(handle, in_string); /* Get function pointer */
370          dlerr=dlerror();
371        }
372        if(dlerr==NULL) {           /* If a function was found */
373          new_fvalue= new_val(env); /* Create a new value */
374          new_fvalue->type=func;    /* The new value is a function pointer */
375          new_fvalue->content.ptr=funcptr; /* Store function pointer */
376          (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
377                                             function value */
378        }
379      }
380      push_val(env, new_value);
381    }
382    
383    /* Print newline. */
384  extern void nl()  extern void nl()
385  {  {
386    printf("\n");    printf("\n");
387  }  }
388    
389  void prin(stackitem** stack_head)  /* Gets the type of a value */
390  {  extern void type(environment *env){
391    if((*stack_head)==NULL)    int typenum;
392    
393      if((env->head)==NULL) {
394        printerr("Too Few Arguments");
395        env->err=1;
396      return;      return;
397      }
398      typenum=env->head->item->type;
399      toss(env);
400      switch(typenum){
401      case integer:
402        push_sym(env, "integer");
403        break;
404      case string:
405        push_sym(env, "string");
406        break;
407      case symb:
408        push_sym(env, "symbol");
409        break;
410      case func:
411        push_sym(env, "function");
412        break;
413      case list:
414        push_sym(env, "list");
415        break;
416      }
417    }    
418    
419    switch((*stack_head)->type) {  /* Prints the top element of the stack. */
420    case value:  void print_h(stackitem *stack_head, int noquote)
421      printf("%d", (*stack_head)->content.val);  {
422      switch(stack_head->item->type) {
423      case integer:
424        printf("%d", stack_head->item->content.val);
425      break;      break;
426    case string:    case string:
427      printf("%s", (char*)(*stack_head)->content.ptr);      if(noquote)
428          printf("%s", (char*)stack_head->item->content.ptr);
429        else
430          printf("\"%s\"", (char*)stack_head->item->content.ptr);
431      break;      break;
432    case ref:    case symb:
433      printf("%s", ((stackitem*)(*stack_head)->content.ptr)->id);      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);
434      break;      break;
435    case symbol:    case func:
436    default:      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));
437      printf("%p", (*stack_head)->content.ptr);      break;
438      case list:
439        /* A list is just a stack, so make stack_head point to it */
440        stack_head=(stackitem *)(stack_head->item->content.ptr);
441        printf("[ ");
442        while(stack_head != NULL) {
443          print_h(stack_head, noquote);
444          printf(" ");
445          stack_head=stack_head->next;
446        }
447        printf("]");
448      break;      break;
449    }    }
450  }  }
451    
452  extern void print(stackitem** stack_head)  extern void print_(environment *env) {
453      if(env->head==NULL) {
454        printerr("Too Few Arguments");
455        env->err=1;
456        return;
457      }
458      print_h(env->head, 0);
459      nl();
460    }
461    
462    /* Prints the top element of the stack and then discards it. */
463    extern void print(environment *env)
464  {  {
465    prin(stack_head);    print_(env);
466    toss(stack_head);    if(env->err) return;
467      toss(env);
468    }
469    
470    extern void princ_(environment *env) {
471      if(env->head==NULL) {
472        printerr("Too Few Arguments");
473        env->err=1;
474        return;
475      }
476      print_h(env->head, 1);
477  }  }
478    
479  /* print_stack(stack); */  /* Prints the top element of the stack and then discards it. */
480  void print_st(stackitem* stack_head, long counter)  extern void princ(environment *env)
481    {
482      princ_(env);
483      if(env->err) return;
484      toss(env);
485    }
486    
487    /* Only to be called by function printstack. */
488    void print_st(stackitem *stack_head, long counter)
489  {  {
490    if(stack_head->next != NULL)    if(stack_head->next != NULL)
491      print_st(stack_head->next, counter+1);      print_st(stack_head->next, counter+1);
   
492    printf("%ld: ", counter);    printf("%ld: ", counter);
493    prin(&stack_head);    print_h(stack_head, 0);
494    nl();    nl();
495  }  }
496    
497  extern void printstack(stackitem** stack_head)  /* Prints the stack. */
498    extern void printstack(environment *env)
499  {  {
500    if(*stack_head != NULL) {    if(env->head == NULL) {
501      print_st(*stack_head, 1);      printf("Stack Empty\n");
502      printf("\n");      return;
503    }    }
504      print_st(env->head, 1);
505  }  }
506    
507    /* Swap the two top elements on the stack. */
508    extern void swap(environment *env)
509    {
510      stackitem *temp= env->head;
511      
512      if(env->head==NULL || env->head->next==NULL) {
513        printerr("Too Few Arguments");
514        env->err=1;
515        return;
516      }
517    
518      env->head= env->head->next;
519      temp->next= env->head->next;
520      env->head->next= temp;
521    }
522    
523  extern void eval(stackitem** stack_head)  /* Rotate the first three elements on the stack. */
524    extern void rot(environment *env)
525  {  {
526    funcp in_func;    stackitem *temp= env->head;
527      
528      if(env->head==NULL || env->head->next==NULL
529          || env->head->next->next==NULL) {
530        printerr("Too Few Arguments");
531        env->err=1;
532        return;
533      }
534    
535      env->head= env->head->next->next;
536      temp->next->next= env->head->next;
537      env->head->next= temp;
538    }
539    
540    /* Recall a value from a symbol, if bound */
541    extern void rcl(environment *env)
542    {
543      value *val;
544    
545    if((*stack_head)==NULL || (*stack_head)->type!=ref)    if(env->head == NULL) {
546        printerr("Too Few Arguments");
547        env->err=1;
548      return;      return;
549      }
550    
551    if(((stackitem*)(*stack_head)->content.ptr)->type==func) {    if(env->head->item->type!=symb) {
552      in_func= (funcp)((stackitem*)(*stack_head)->content.ptr)->content.ptr;      printerr("Bad Argument Type");
553      toss(stack_head);      env->err=2;
     (*in_func)(stack_head);  
554      return;      return;
555    }    }
556    
557      val=((symbol *)(env->head->item->content.ptr))->val;
558      if(val == NULL){
559        printerr("Unbound Variable");
560        env->err=3;
561        return;
562      }
563      toss(env);            /* toss the symbol */
564      if(env->err) return;
565      push_val(env, val); /* Return its bound value */
566  }  }
567    
568  int stack_read(stackitem** stack_head, hashtbl in_hash, char* in_line)  /* If the top element is a symbol, determine if it's bound to a
569       function value, and if it is, toss the symbol and execute the
570       function. */
571    extern void eval(environment *env)
572  {  {
573    char *temp, *rest;    funcp in_func;
574    int itemp;    value* temp_val;
575    size_t inlength= strlen(in_line)+1;    stackitem* iterator;
   int convert= 0;  
576    
577    temp= malloc(inlength);   eval_start:
   rest= malloc(inlength);  
578    
579    if((convert= sscanf(in_line, "\"%[^\"\n\r]\" %[^\n\r]", temp, rest)) >= 1)    if(env->head==NULL) {
580      push_cstring(stack_head, temp);      printerr("Too Few Arguments");
581    else if((convert= sscanf(in_line, "%d %[^\n\r]", &itemp, rest)) >= 1)      env->err=1;
582      push_val(stack_head, itemp);      return;
583    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);  
584    
585    free(temp);    switch(env->head->item->type) {
586        /* if it's a symbol */
587      case symb:
588        rcl(env);                   /* get its contents */
589        if(env->err) return;
590        if(env->head->item->type!=symb){ /* don't recurse symbols */
591          goto eval_start;
592        }
593        return;
594    
595        /* If it's a lone function value, run it */
596      case func:
597        in_func= (funcp)(env->head->item->content.ptr);
598        toss(env);
599        if(env->err) return;
600        return (*in_func)(env);
601    
602        /* If it's a list */
603      case list:
604        temp_val= env->head->item;
605        toss(env);
606        if(env->err) return;
607        iterator= (stackitem*)temp_val->content.ptr;
608        while(iterator!=NULL) {
609          push_val(env, iterator->item);
610          if(env->head->item->type==symb
611            && strcmp(";", ((symbol*)(env->head->item->content.ptr))->id)==0) {
612            toss(env);
613            if(env->err) return;
614            if(iterator->next == NULL){
615              goto eval_start;
616            }
617            eval(env);
618            if(env->err) return;
619          }
620          iterator= iterator->next;
621        }
622        return;
623    
624    if(convert<2) {    default:
625      free(rest);      return;
     return 0;  
626    }    }
     
   stack_read(stack_head, in_hash, rest);  
     
   free(rest);  
   return 1;  
627  }  }
628    
629  extern void pack(stackitem** stack_head)  /* Reverse (flip) a list */
630  {  extern void rev(environment *env){
631    void* delimiter;    stackitem *old_head, *new_head, *item;
632    stackitem *iterator, *temp, *pack;  
633      if((env->head)==NULL) {
634    if((*stack_head)==NULL)      printerr("Too Few Arguments");
635        env->err=1;
636      return;      return;
637      }
638    
639    delimiter= (*stack_head)->content.ptr;    if(env->head->item->type!=list) {
640    toss(stack_head);      printerr("Bad Argument Type");
641        env->err=2;
642        return;
643      }
644    
645    iterator= *stack_head;    old_head=(stackitem *)(env->head->item->content.ptr);
646      new_head=NULL;
647      while(old_head != NULL){
648        item=old_head;
649        old_head=old_head->next;
650        item->next=new_head;
651        new_head=item;
652      }
653      env->head->item->content.ptr=new_head;
654    }
655    
656    while(iterator->next!=NULL && iterator->next->content.ptr!=delimiter)  /* Make a list. */
657      iterator= iterator->next;  extern void pack(environment *env)
658    {
659      stackitem *iterator, *temp;
660      value *pack;
661    
662    temp= *stack_head;    iterator= env->head;
663    *stack_head= iterator->next;  
664    iterator->next= NULL;    if(iterator==NULL
665           || (iterator->item->type==symb
666    if(*stack_head!=NULL && (*stack_head)->content.ptr==delimiter)       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {
667      toss(stack_head);      temp= NULL;
668        toss(env);
669      } else {
670        /* Search for first delimiter */
671        while(iterator->next!=NULL
672              && (iterator->next->item->type!=symb
673              || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))
674          iterator= iterator->next;
675        
676        /* Extract list */
677        temp= env->head;
678        env->head= iterator->next;
679        iterator->next= NULL;
680        
681        if(env->head!=NULL)
682          toss(env);
683      }
684    
685    pack= malloc(sizeof(stackitem));    /* Push list */
686      pack= new_val(env);
687    pack->type= list;    pack->type= list;
688    pack->content.ptr= temp;    pack->content.ptr= temp;
689    
690    push(stack_head, pack);    push_val(env, pack);
691      rev(env);
692  }  }
693    
694  extern void expand(stackitem** stack_head)  /* Relocate elements of the list on the stack. */
695    extern void expand(environment *env)
696  {  {
697    stackitem *temp, *new_head;    stackitem *temp, *new_head;
698    
699    if((*stack_head)==NULL || (*stack_head)->type!=list)    /* Is top element a list? */
700      if(env->head==NULL) {
701        printerr("Too Few Arguments");
702        env->err=1;
703        return;
704      }
705      if(env->head->item->type!=list) {
706        printerr("Bad Argument Type");
707        env->err=2;
708        return;
709      }
710    
711      rev(env);
712    
713      if(env->err)
714      return;      return;
715    
716    new_head= temp= (*stack_head)->content.ptr;    /* The first list element is the new stack head */
717    toss(stack_head);    new_head= temp= env->head->item->content.ptr;
718    
719      toss(env);
720    
721      /* Find the end of the list */
722    while(temp->next!=NULL)    while(temp->next!=NULL)
723      temp= temp->next;      temp= temp->next;
724    
725    temp->next= *stack_head;    /* Connect the tail of the list with the old stack head */
726    *stack_head= new_head;    temp->next= env->head;
727      env->head= new_head;          /* ...and voila! */
728    
729  }  }
730    
731  extern void swap(stackitem** stack_head)  /* Compares two elements by reference. */
732    extern void eq(environment *env)
733  {  {
734    stackitem* temp= (*stack_head);    void *left, *right;
735      int result;
736    
737      if((env->head)==NULL || env->head->next==NULL) {
738        printerr("Too Few Arguments");
739        env->err=1;
740        return;
741      }
742    
743      left= env->head->item->content.ptr;
744      swap(env);
745      right= env->head->item->content.ptr;
746      result= (left==right);
747        
748    if((*stack_head)==NULL || (*stack_head)->next==NULL)    toss(env); toss(env);
749      push_int(env, result);
750    }
751    
752    /* Negates the top element on the stack. */
753    extern void not(environment *env)
754    {
755      int val;
756    
757      if((env->head)==NULL) {
758        printerr("Too Few Arguments");
759        env->err=1;
760      return;      return;
761      }
762    
763      if(env->head->item->type!=integer) {
764        printerr("Bad Argument Type");
765        env->err=2;
766        return;
767      }
768    
769      val= env->head->item->content.val;
770      toss(env);
771      push_int(env, !val);
772    }
773    
774    /* Compares the two top elements on the stack and return 0 if they're the
775       same. */
776    extern void neq(environment *env)
777    {
778      eq(env);
779      not(env);
780    }
781    
782    /* Give a symbol some content. */
783    extern void def(environment *env)
784    {
785      symbol *sym;
786    
787      /* Needs two values on the stack, the top one must be a symbol */
788      if(env->head==NULL || env->head->next==NULL) {
789        printerr("Too Few Arguments");
790        env->err=1;
791        return;
792      }
793    
794      if(env->head->item->type!=symb) {
795        printerr("Bad Argument Type");
796        env->err=2;
797        return;
798      }
799    
800      /* long names are a pain */
801      sym=env->head->item->content.ptr;
802    
803      /* if the symbol was bound to something else, throw it away */
804    
805      /* Bind the symbol to the value */
806      sym->val= env->head->next->item;
807    
808    *stack_head= (*stack_head)->next;    toss(env); toss(env);
   temp->next= (*stack_head)->next;  
   (*stack_head)->next= temp;  
809  }  }
810    
811  extern void quit()  extern void clear(environment *);
812    void forget_sym(symbol **);
813    
814    /* Quit stack. */
815    extern void quit(environment *env)
816  {  {
817      long i;
818    
819      clear(env);
820    
821      if (env->err) return;
822      for(i= 0; i<HASHTBLSIZE; i++) {
823        while(env->symbols[i]!= NULL) {
824          forget_sym(&(env->symbols[i]));
825        }
826        env->symbols[i]= NULL;
827      }
828    
829      gc_init(env);
830    
831      if(env->free_string!=NULL)
832        free(env->free_string);
833      
834      muntrace();
835    
836    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
837  }  }
838    
839  int main()  /* Clear stack */
840    extern void clear(environment *env)
841    {
842      while(env->head!=NULL)
843        toss(env);
844    }
845    
846    /* List all defined words */
847    extern void words(environment *env)
848    {
849      symbol *temp;
850      int i;
851      
852      for(i= 0; i<HASHTBLSIZE; i++) {
853        temp= env->symbols[i];
854        while(temp!=NULL) {
855          printf("%s\n", temp->id);
856          temp= temp->next;
857        }
858      }
859    }
860    
861    /* Internal forget function */
862    void forget_sym(symbol **hash_entry) {
863      symbol *temp;
864    
865      temp= *hash_entry;
866      *hash_entry= (*hash_entry)->next;
867      
868      free(temp->id);
869      free(temp);
870    }
871    
872    /* Forgets a symbol (remove it from the hash table) */
873    extern void forget(environment *env)
874    {
875      char* sym_id;
876      stackitem *stack_head= env->head;
877    
878      if(stack_head==NULL) {
879        printerr("Too Few Arguments");
880        env->err=1;
881        return;
882      }
883      
884      if(stack_head->item->type!=symb) {
885        printerr("Bad Argument Type");
886        env->err=2;
887        return;
888      }
889    
890      sym_id= ((symbol*)(stack_head->item->content.ptr))->id;
891      toss(env);
892    
893      return forget_sym(hash(env->symbols, sym_id));
894    }
895    
896    /* Returns the current error number to the stack */
897    extern void errn(environment *env){
898      push_int(env, env->err);
899    }
900    
901    extern void sx_72656164(environment*);
902    
903    int main(int argc, char **argv)
904  {  {
905    stackitem* s= NULL;    environment myenv;
906    hashtbl myhash;  
907    char in_string[100];    int c;                        /* getopt option character */
908    
909      mtrace();
910    
911    init_hashtbl(myhash);    init_env(&myenv);
912    
913    printf("okidok\n ");    myenv.interactive = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO);
914    
915    while(fgets(in_string, 100, stdin) != NULL) {    while ((c = getopt (argc, argv, "i")) != -1)
916      stack_read(&s, myhash, in_string);      switch (c)
917      printf("okidok\n ");        {
918          case 'i':
919            myenv.interactive = 1;
920            break;
921          case '?':
922            fprintf (stderr,
923                     "Unknown option character `\\x%x'.\n",
924                     optopt);
925            return EX_USAGE;
926          default:
927            abort ();
928          }
929      
930      if (optind < argc) {
931        myenv.interactive = 0;
932        myenv.inputstream= fopen(argv[optind], "r");
933        if(myenv.inputstream== NULL) {
934          perror(argv[0]);
935          exit (EX_NOINPUT);
936        }
937    }    }
938    
939    exit(EXIT_SUCCESS);    while(1) {
940        if(myenv.in_string==NULL) {
941          if (myenv.interactive) {
942            if(myenv.err) {
943              printf("(error %d)\n", myenv.err);
944            }
945            nl();
946            printstack(&myenv);
947            printf("> ");
948          }
949          myenv.err=0;
950        }
951        sx_72656164(&myenv);
952        if (myenv.err==4) {
953          return EX_NOINPUT;
954        } else if(myenv.head!=NULL
955                  && myenv.head->item->type==symb
956                  && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {
957          toss(&myenv);             /* No error check in main */
958          eval(&myenv);
959        }
960      }
961      quit(&myenv);
962      return EXIT_FAILURE;
963    }
964    
965    /* "+" */
966    extern void sx_2b(environment *env) {
967      int a, b;
968      size_t len;
969      char* new_string;
970      value *a_val, *b_val;
971    
972      if((env->head)==NULL || env->head->next==NULL) {
973        printerr("Too Few Arguments");
974        env->err=1;
975        return;
976      }
977    
978      if(env->head->item->type==string
979         && env->head->next->item->type==string) {
980        a_val= env->head->item;
981        b_val= env->head->next->item;
982        toss(env); if(env->err) return;
983        toss(env); if(env->err) return;
984        len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
985        new_string= malloc(len);
986        strcpy(new_string, b_val->content.ptr);
987        strcat(new_string, a_val->content.ptr);
988        push_cstring(env, new_string);
989        free(new_string);
990        return;
991      }
992      
993      if(env->head->item->type!=integer
994         || env->head->next->item->type!=integer) {
995        printerr("Bad Argument Type");
996        env->err=2;
997        return;
998      }
999      a=env->head->item->content.val;
1000      toss(env); if(env->err) return;
1001      
1002      b=env->head->item->content.val;
1003      toss(env); if(env->err) return;
1004      push_int(env, a+b);
1005    }
1006    
1007    /* "-" */
1008    extern void sx_2d(environment *env) {
1009      int a, b;
1010    
1011      if((env->head)==NULL || env->head->next==NULL) {
1012        printerr("Too Few Arguments");
1013        env->err=1;
1014        return;
1015      }
1016      
1017      if(env->head->item->type!=integer
1018         || env->head->next->item->type!=integer) {
1019        printerr("Bad Argument Type");
1020        env->err=2;
1021        return;
1022      }
1023      a=env->head->item->content.val;
1024      toss(env); if(env->err) return;
1025      b=env->head->item->content.val;
1026      toss(env); if(env->err) return;
1027      push_int(env, b-a);
1028    }
1029    
1030    /* ">" */
1031    extern void sx_3e(environment *env) {
1032      int a, b;
1033    
1034      if((env->head)==NULL || env->head->next==NULL) {
1035        printerr("Too Few Arguments");
1036        env->err=1;
1037        return;
1038      }
1039      
1040      if(env->head->item->type!=integer
1041         || env->head->next->item->type!=integer) {
1042        printerr("Bad Argument Type");
1043        env->err=2;
1044        return;
1045      }
1046      a=env->head->item->content.val;
1047      toss(env); if(env->err) return;
1048      b=env->head->item->content.val;
1049      toss(env); if(env->err) return;
1050      push_int(env, b>a);
1051    }
1052    
1053    /* Return copy of a value */
1054    value *copy_val(environment *env, value *old_value){
1055      stackitem *old_item, *new_item, *prev_item;
1056    
1057      value *new_value=new_val(env);
1058    
1059      new_value->type=old_value->type;
1060    
1061      switch(old_value->type){
1062      case integer:
1063        new_value->content.val=old_value->content.val;
1064        break;
1065      case string:
1066        (char *)(new_value->content.ptr)
1067          = strdup((char *)(old_value->content.ptr));
1068        break;
1069      case func:
1070      case symb:
1071        new_value->content.ptr=old_value->content.ptr;
1072        break;
1073      case list:
1074        new_value->content.ptr=NULL;
1075    
1076        prev_item=NULL;
1077        old_item=(stackitem *)(old_value->content.ptr);
1078    
1079        while(old_item != NULL) {   /* While list is not empty */
1080          new_item= malloc(sizeof(stackitem));
1081          new_item->item=copy_val(env, old_item->item); /* recurse */
1082          new_item->next=NULL;
1083          if(prev_item != NULL)     /* If this wasn't the first item */
1084            prev_item->next=new_item; /* point the previous item to the
1085                                         new item */
1086          else
1087            new_value->content.ptr=new_item;
1088          old_item=old_item->next;
1089          prev_item=new_item;
1090        }    
1091        break;
1092      }
1093      return new_value;
1094  }  }
1095    
1096  /* Local Variables: */  /* "dup"; duplicates an item on the stack */
1097  /* compile-command:"make CFLAGS=\"-Wall -g -rdynamic -ldl\" stack" */  extern void sx_647570(environment *env) {
1098  /* End: */    if((env->head)==NULL) {
1099        printerr("Too Few Arguments");
1100        env->err=1;
1101        return;
1102      }
1103      push_val(env, copy_val(env, env->head->item));
1104    }
1105    
1106    /* "if", If-Then */
1107    extern void sx_6966(environment *env) {
1108    
1109      int truth;
1110    
1111      if((env->head)==NULL || env->head->next==NULL) {
1112        printerr("Too Few Arguments");
1113        env->err=1;
1114        return;
1115      }
1116    
1117      if(env->head->next->item->type != integer) {
1118        printerr("Bad Argument Type");
1119        env->err=2;
1120        return;
1121      }
1122      
1123      swap(env);
1124      if(env->err) return;
1125      
1126      truth=env->head->item->content.val;
1127    
1128      toss(env);
1129      if(env->err) return;
1130    
1131      if(truth)
1132        eval(env);
1133      else
1134        toss(env);
1135    }
1136    
1137    /* If-Then-Else */
1138    extern void ifelse(environment *env) {
1139    
1140      int truth;
1141    
1142      if((env->head)==NULL || env->head->next==NULL
1143         || env->head->next->next==NULL) {
1144        printerr("Too Few Arguments");
1145        env->err=1;
1146        return;
1147      }
1148    
1149      if(env->head->next->next->item->type != integer) {
1150        printerr("Bad Argument Type");
1151        env->err=2;
1152        return;
1153      }
1154      
1155      rot(env);
1156      if(env->err) return;
1157      
1158      truth=env->head->item->content.val;
1159    
1160      toss(env);
1161      if(env->err) return;
1162    
1163      if(!truth)
1164        swap(env);
1165      if(env->err) return;
1166    
1167      toss(env);
1168      if(env->err) return;
1169    
1170      eval(env);
1171    }
1172    
1173    /* "while" */
1174    extern void sx_7768696c65(environment *env) {
1175    
1176      int truth;
1177      value *loop, *test;
1178    
1179      if((env->head)==NULL || env->head->next==NULL) {
1180        printerr("Too Few Arguments");
1181        env->err=1;
1182        return;
1183      }
1184    
1185      loop= env->head->item;
1186      toss(env); if(env->err) return;
1187    
1188      test= env->head->item;
1189      toss(env); if(env->err) return;
1190    
1191      do {
1192        push_val(env, test);
1193        eval(env);
1194        
1195        if(env->head->item->type != integer) {
1196          printerr("Bad Argument Type");
1197          env->err=2;
1198          return;
1199        }
1200        
1201        truth= env->head->item->content.val;
1202        toss(env); if(env->err) return;
1203        
1204        if(truth) {
1205          push_val(env, loop);
1206          eval(env);
1207        } else {
1208          toss(env);
1209        }
1210      
1211      } while(truth);
1212    }
1213    
1214    /* "for"; For-loop */
1215    extern void sx_666f72(environment *env) {
1216      
1217      value *loop, *foo;
1218      stackitem *iterator;
1219      
1220      if((env->head)==NULL || env->head->next==NULL) {
1221        printerr("Too Few Arguments");
1222        env->err=1;
1223        return;
1224      }
1225    
1226      if(env->head->next->item->type != list) {
1227        printerr("Bad Argument Type");
1228        env->err=2;
1229        return;
1230      }
1231    
1232      loop= env->head->item;
1233      toss(env); if(env->err) return;
1234    
1235      foo= env->head->item;
1236      toss(env); if(env->err) return;
1237    
1238      iterator= foo->content.ptr;
1239    
1240      while(iterator!=NULL) {
1241        push_val(env, iterator->item);
1242        push_val(env, loop);
1243        eval(env); if(env->err) return;
1244        iterator= iterator->next;
1245      }
1246    }
1247    
1248    /* "to" */
1249    extern void to(environment *env) {
1250      int i, start, ending;
1251      stackitem *temp_head;
1252      value *temp_val;
1253      
1254      if((env->head)==NULL || env->head->next==NULL) {
1255        printerr("Too Few Arguments");
1256        env->err=1;
1257        return;
1258      }
1259    
1260      if(env->head->item->type!=integer
1261         || env->head->next->item->type!=integer) {
1262        printerr("Bad Argument Type");
1263        env->err=2;
1264        return;
1265      }
1266    
1267      ending= env->head->item->content.val;
1268      toss(env); if(env->err) return;
1269      start= env->head->item->content.val;
1270      toss(env); if(env->err) return;
1271    
1272      temp_head= env->head;
1273      env->head= NULL;
1274    
1275      if(ending>=start) {
1276        for(i= ending; i>=start; i--)
1277          push_int(env, i);
1278      } else {
1279        for(i= ending; i<=start; i++)
1280          push_int(env, i);
1281      }
1282    
1283      temp_val= new_val(env);
1284      temp_val->content.ptr= env->head;
1285      temp_val->type= list;
1286      env->head= temp_head;
1287      push_val(env, temp_val);
1288    }
1289    
1290    /* Read a string */
1291    extern void readline(environment *env) {
1292      char in_string[101];
1293    
1294      if(fgets(in_string, 100, env->inputstream)==NULL)
1295        push_cstring(env, "");
1296      else
1297        push_cstring(env, in_string);
1298    }
1299    
1300    /* "read"; Read a value and place on stack */
1301    extern void sx_72656164(environment *env) {
1302      const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1303      const char strform[]= "\"%[^\"]\"%n";
1304      const char intform[]= "%i%n";
1305      const char blankform[]= "%*[ \t]%n";
1306      const char ebrackform[]= "%*1[]]%n";
1307      const char semicform[]= "%*1[;]%n";
1308      const char bbrackform[]= "%*1[[]%n";
1309    
1310      int itemp, readlength= -1;
1311      static int depth= 0;
1312      char *match;
1313      size_t inlength;
1314    
1315      if(env->in_string==NULL) {
1316        if(depth > 0 && env->interactive) {
1317          printf("]> ");
1318        }
1319        readline(env); if(env->err) return;
1320    
1321        if(((char *)(env->head->item->content.ptr))[0]=='\0'){
1322          env->err= 4;              /* "" means EOF */
1323          return;
1324        }
1325        
1326        env->in_string= malloc(strlen(env->head->item->content.ptr)+1);
1327        env->free_string= env->in_string; /* Save the original pointer */
1328        strcpy(env->in_string, env->head->item->content.ptr);
1329        toss(env); if(env->err) return;
1330      }
1331      
1332      inlength= strlen(env->in_string)+1;
1333      match= malloc(inlength);
1334    
1335      if(sscanf(env->in_string, blankform, &readlength)!=EOF
1336         && readlength != -1) {
1337        ;
1338      } else if(sscanf(env->in_string, intform, &itemp, &readlength) != EOF
1339                && readlength != -1) {
1340        push_int(env, itemp);
1341      } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1342                && readlength != -1) {
1343        push_cstring(env, match);
1344      } else if(sscanf(env->in_string, symbform, match, &readlength) != EOF
1345                && readlength != -1) {
1346        push_sym(env, match);
1347      } else if(sscanf(env->in_string, ebrackform, &readlength) != EOF
1348                && readlength != -1) {
1349        pack(env); if(env->err) return;
1350        if(depth != 0) depth--;
1351      } else if(sscanf(env->in_string, semicform, &readlength) != EOF
1352                && readlength != -1) {
1353        push_sym(env, ";");
1354      } else if(sscanf(env->in_string, bbrackform, &readlength) != EOF
1355                && readlength != -1) {
1356        push_sym(env, "[");
1357        depth++;
1358      } else {
1359        free(env->free_string);
1360        env->in_string = env->free_string = NULL;
1361      }
1362      if ( env->in_string != NULL) {
1363        env->in_string += readlength;
1364      }
1365    
1366      free(match);
1367    
1368      if(depth)
1369        return sx_72656164(env);
1370    }
Legend:
Removed from v.1.10  
changed lines
  Added in v.1.87
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26