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

Diff of /stack/stack.c

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

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