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

Diff of /stack/stack.c

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

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

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.101

root@recompile.se
ViewVC Help
Powered by ViewVC 1.1.26