/[cvs]/stack/stack.c

Diff of /stack/stack.c

Parent Directory | 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
- /* printf */
+ /*
+     stack - an interactive interpreter for a stack-based language
+     Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
+     This program is free software; you can redistribute it and/or modify
+     it under the terms of the GNU General Public License as published by
+     the Free Software Foundation; either version 2 of the License, or
+     (at your option) any later version.
+     This program is distributed in the hope that it will be useful,
+     but WITHOUT ANY WARRANTY; without even the implied warranty of
+     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+     GNU General Public License for more details.
+     You should have received a copy of the GNU General Public License
+     along with this program; if not, write to the Free Software
+     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+     Authors: Mats Alritzson <masse@fukt.bth.se>
+              Teddy Hogeborn <teddy@fukt.bth.se>
+ */
+ /* printf, sscanf, fgets, fprintf, fopen, perror */
  #include <stdio.h>
- /* EXIT_SUCCESS */
+ /* exit, EXIT_SUCCESS, malloc, free */
  #include <stdlib.h>
  /* NULL */
  #include <stddef.h>
  /* dlopen, dlsym, dlerror */
  #include <dlfcn.h>
+ /* strcmp, strcpy, strlen, strcat, strdup */
+ #include <string.h>
+ /* getopt, STDIN_FILENO, STDOUT_FILENO, usleep */
+ #include <unistd.h>
+ /* EX_NOINPUT, EX_USAGE */
+ #include <sysexits.h>
+ /* mtrace, muntrace */
+ #include <mcheck.h>
+ /* ioctl */
+ #include <sys/ioctl.h>
+ /* KDMKTONE */
+ #include <linux/kd.h>
+ #include "stack.h"
+ /* Initialize a newly created environment */
+ void init_env(environment *env)
+ {
+   int i;
+   env->gc_limit= 400000;
+   env->gc_count= 0;
+   env->gc_ref= NULL;
- #define HASHTBLSIZE 65536
+   env->head= NULL;
+   for(i= 0; i<HASHTBLSIZE; i++)
+     env->symbols[i]= NULL;
+   env->err= 0;
+   env->in_string= NULL;
+   env->free_string= NULL;
+   env->inputstream= stdin;
+   env->interactive= 1;
+ }
- typedef struct stack_item
+ void printerr(const char* in_string)
  {
-   enum {value, string, ref, func, symbol, list} type;
+   fprintf(stderr, "Err: %s\n", in_string);
-   union {
+ }
-     void* ptr;
-     int val;
-   } content;
-   char* id;
-   struct stack_item* next;
- } stackitem;
- typedef stackitem* hashtbl[HASHTBLSIZE];
- typedef void (*funcp)(stackitem**);
- void init_hashtbl(hashtbl out_hash)
+ /* Discard the top element of the stack. */
+ extern void toss(environment *env)
  {
-   long i;
+   stackitem *temp= env->head;
-   for(i= 0; i<HASHTBLSIZE; i++)
+   if((env->head)==NULL) {
-     out_hash[i]= NULL;
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   env->head= env->head->next;   /* Remove the top stack item */
+   free(temp);                   /* Free the old top stack item */
  }
- stackitem** hash(hashtbl in_hashtbl, const char* in_string)
+ /* Returns a pointer to a pointer to an element in the hash table. */
+ symbol **hash(hashtbl in_hashtbl, const char *in_string)
  {
-   long i= 0;
+   int i= 0;
-   unsigned long out_hash= 0;
+   unsigned int out_hash= 0;
-   char key= 0;
+   char key= '\0';
-   stackitem** position;
+   symbol **position;
-   while(1){
+   while(1){                     /* Hash in_string */
      key= in_string[i++];
      if(key=='\0')
        break;
-Line 51 
 stackitem** hash(hashtbl in_hashtbl, con
+Line 101 
 stackitem** hash(hashtbl in_hashtbl, con
    position= &(in_hashtbl[out_hash]);
    while(1){
-     if(*position==NULL)
+     if(*position==NULL)         /* If empty */
        return position;
-     if(strcmp(in_string, (*position)->id)==0)
+     if(strcmp(in_string, (*position)->id)==0) /* If match */
        return position;
-     position= &((*position)->next);
+     position= &((*position)->next); /* Try next */
    }
  }
+ /* Create new value */
- int push(stackitem** stack_head, stackitem* in_item)
+ value* new_val(environment *env)
  {
-   in_item->next= *stack_head;
+   value *nval= malloc(sizeof(value));
-   *stack_head= in_item;
+   stackitem *nitem= malloc(sizeof(stackitem));
-   return 1;
+   nval->content.ptr= NULL;
+   nitem->item= nval;
+   nitem->next= env->gc_ref;
+   env->gc_ref= nitem;
+   env->gc_count += sizeof(value);
+   nval->gc.flag.mark= 0;
+   nval->gc.flag.protect= 0;
+   return nval;
  }
- int push_val(stackitem** stack_head, int in_val)
+ /* Mark values recursively.
+    Marked values are not collected by the GC. */
+ inline void gc_mark(value *val)
  {
-   stackitem* new_item= malloc(sizeof(stackitem));
+   stackitem *iterator;
-   new_item->content.val= in_val;
-   new_item->type= value;
-   push(stack_head, new_item);
+   if(val->gc.flag.mark)
-   return 1;
+     return;
+   val->gc.flag.mark= 1;
+   if(val->type==list) {
+     iterator= val->content.ptr;
+     while(iterator!=NULL) {
+       gc_mark(iterator->item);
+       iterator= iterator->next;
+     }
+   }
+ }
+ inline void gc_maybe(environment *env)
+ {
+   if(env->gc_count < env->gc_limit)
+     return;
+   else
+     return gc_init(env);
  }
- int push_cstring(stackitem** stack_head, const char* in_string)
+ /* Start GC */
+ extern void gc_init(environment *env)
  {
-   stackitem* new_item= malloc(sizeof(stackitem));
+   stackitem *new_head= NULL, *titem, *iterator;
-   new_item->content.ptr= malloc(strlen(in_string)+1);
+   symbol *tsymb;
-   strcpy(new_item->content.ptr, in_string);
+   int i;
-   new_item->type= string;
+   if(env->interactive){
+     printf("Garbage collecting.");
+   }
+   /* Mark values on stack */
+   iterator= env->head;
+   while(iterator!=NULL) {
+     gc_mark(iterator->item);
+     iterator= iterator->next;
+   }
+   if(env->interactive){
+     printf(".");
+   }
+   /* Mark values in hashtable */
+   for(i= 0; i<HASHTBLSIZE; i++) {
+     tsymb= env->symbols[i];
+     while(tsymb!=NULL) {
+       if (tsymb->val != NULL)
+         gc_mark(tsymb->val);
+       tsymb= tsymb->next;
+     }
+   }
+   if(env->interactive){
+     printf(".");
+   }
+   env->gc_count= 0;
+   while(env->gc_ref!=NULL) {    /* Sweep unused values */
+     if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
+       switch(env->gc_ref->item->type) { /* Remove content */
+       case string:
+         free(env->gc_ref->item->content.ptr);
+         break;
+       case list:
+         while(env->gc_ref->item->content.ptr!=NULL) {
+           titem= env->gc_ref->item->content.ptr;
+           env->gc_ref->item->content.ptr= titem->next;
+           free(titem);
+         }
+       default:
+       }
+       free(env->gc_ref->item);  /* Remove from gc_ref */
+       titem= env->gc_ref->next;
+       free(env->gc_ref);        /* Remove value */
+       env->gc_ref= titem;
+       continue;
+     } else {
+       env->gc_count += sizeof(value);
+       if(env->gc_ref->item->type == string)
+         env->gc_count += strlen(env->gc_ref->item->content.ptr);
+     }
+     /* Keep values */
+     titem= env->gc_ref->next;
+     env->gc_ref->next= new_head;
+     new_head= env->gc_ref;
+     new_head->item->gc.flag.mark= 0;
+     env->gc_ref= titem;
+   }
+   if (env->gc_limit < env->gc_count*2)
+     env->gc_limit= env->gc_count*2;
+   env->gc_ref= new_head;
+   if(env->interactive){
+     printf("done\n");
+   }
-   push(stack_head, new_item);
-   return 1;
  }
- int mk_hashentry(hashtbl in_hashtbl, stackitem* in_item, const char* id)
+ /* Protect values from GC */
+ void protect(value *val)
  {
-   in_item->id= malloc(strlen(id)+1);
+   stackitem *iterator;
+   if(val->gc.flag.protect)
+     return;
-   strcpy(in_item->id, id);
+   val->gc.flag.protect= 1;
-   push(hash(in_hashtbl, id), in_item);
-   return 1;
+   if(val->type==list) {
+     iterator= val->content.ptr;
+     while(iterator!=NULL) {
+       protect(iterator->item);
+       iterator= iterator->next;
+     }
+   }
  }
- void def_func(hashtbl in_hashtbl, funcp in_func, const char* id)
+ /* Unprotect values from GC */
+ void unprotect(value *val)
  {
-   stackitem* temp= malloc(sizeof(stackitem));
+   stackitem *iterator;
+   if(!(val->gc.flag.protect))
+     return;
-   temp->type= func;
+   val->gc.flag.protect= 0;
-   temp->content.ptr= in_func;
+   if(val->type==list) {
+     iterator= val->content.ptr;
+     while(iterator!=NULL) {
+       unprotect(iterator->item);
+       iterator= iterator->next;
+     }
+   }
+ }
-   mk_hashentry(in_hashtbl, temp, id);
+ /* Push a value onto the stack */
+ void push_val(environment *env, value *val)
+ {
+   stackitem *new_item= malloc(sizeof(stackitem));
+   new_item->item= val;
+   new_item->next= env->head;
+   env->head= new_item;
  }
- void def_sym(hashtbl in_hashtbl, const char* id)
+ /* Push an integer onto the stack */
+ void push_int(environment *env, int in_val)
  {
-   stackitem* temp= malloc(sizeof(stackitem));
+   value *new_value= new_val(env);
-   temp->type= symbol;
+   new_value->content.i= in_val;
+   new_value->type= integer;
-   mk_hashentry(in_hashtbl, temp, id);
+   push_val(env, new_value);
  }
- int push_ref(stackitem** stack_head, hashtbl in_hash, const char* in_string)
+ /* Push a floating point number onto the stack */
+ void push_float(environment *env, float in_val)
  {
-   static void* handle= NULL;
+   value *new_value= new_val(env);
-   void* symbol;
-   stackitem* new_item= malloc(sizeof(stackitem));
+   new_value->content.f= in_val;
-   new_item->content.ptr= *hash(in_hash, in_string);
+   new_value->type= tfloat;
-   new_item->type= ref;
-   if(new_item->content.ptr==NULL) {
+   push_val(env, new_value);
-     if(handle==NULL)
+ }
-       handle= dlopen(NULL, RTLD_LAZY);
-     symbol= dlsym(handle, in_string);
+ /* Copy a string onto the stack. */
-     if(dlerror()==NULL)
+ void push_cstring(environment *env, const char *in_string)
-       def_func(in_hash, symbol, in_string);
+ {
-     else
+   value *new_value= new_val(env);
-       def_sym(in_hash, in_string);
+   int length= strlen(in_string)+1;
-     new_item->content.ptr= *hash(in_hash, in_string);
+   new_value->content.ptr= malloc(length);
-     new_item->type= ref;
+   env->gc_count += length;
+   strcpy(new_value->content.ptr, in_string);
+   new_value->type= string;
+   push_val(env, new_value);
+ }
+ /* Mangle a symbol name to a valid C identifier name */
+ char *mangle_str(const char *old_string)
+ {
+   char validchars[]= "0123456789abcdef";
+   char *new_string, *current;
+   new_string= malloc((strlen(old_string)*2)+4);
+   strcpy(new_string, "sx_");    /* Stack eXternal */
+   current= new_string+3;
+   while(old_string[0] != '\0'){
+     current[0]= validchars[(unsigned char)(old_string[0])/16];
+     current[1]= validchars[(unsigned char)(old_string[0])%16];
+     current+= 2;
+     old_string++;
    }
+   current[0]= '\0';
-   push(stack_head, new_item);
+   return new_string;            /* The caller must free() it */
-   return 1;
  }
- extern void toss(stackitem** stack_head)
+ extern void mangle(environment *env)
  {
-   stackitem* temp= *stack_head;
+   char *new_string;
-   if((*stack_head)==NULL)
+   if((env->head)==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
      return;
+   }
-   if((*stack_head)->type==string)
-     free((*stack_head)->content.ptr);
-   *stack_head= (*stack_head)->next;
+   if(env->head->item->type!=string) {
-   free(temp);
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   new_string= mangle_str((const char *)(env->head->item->content.ptr));
+   toss(env);
+   if(env->err) return;
+   push_cstring(env, new_string);
+ }
+ /* Push a symbol onto the stack. */
+ void push_sym(environment *env, const char *in_string)
+ {
+   value *new_value;             /* A new symbol value */
+   /* ...which might point to... */
+   symbol **new_symbol;          /* (if needed) A new actual symbol */
+   /* ...which, if possible, will be bound to... */
+   value *new_fvalue;            /* (if needed) A new function value */
+   /* ...which will point to... */
+   void *funcptr;                /* A function pointer */
+   static void *handle= NULL;    /* Dynamic linker handle */
+   const char *dlerr;            /* Dynamic linker error */
+   char *mangled;                /* Mangled function name */
+   new_value= new_val(env);
+   protect(new_value);
+   new_fvalue= new_val(env);
+   protect(new_fvalue);
+   /* The new value is a symbol */
+   new_value->type= symb;
+   /* Look up the symbol name in the hash table */
+   new_symbol= hash(env->symbols, in_string);
+   new_value->content.ptr= *new_symbol;
+   if(*new_symbol==NULL) { /* If symbol was undefined */
+     /* Create a new symbol */
+     (*new_symbol)= malloc(sizeof(symbol));
+     (*new_symbol)->val= NULL;   /* undefined value */
+     (*new_symbol)->next= NULL;
+     (*new_symbol)->id= malloc(strlen(in_string)+1);
+     strcpy((*new_symbol)->id, in_string);
+     /* Intern the new symbol in the hash table */
+     new_value->content.ptr= *new_symbol;
+     /* Try to load the symbol name as an external function, to see if
+        we should bind the symbol to a new function pointer value */
+     if(handle==NULL)            /* If no handle */
+       handle= dlopen(NULL, RTLD_LAZY);
+     mangled= mangle_str(in_string); /* mangle the name */
+     funcptr= dlsym(handle, mangled); /* and try to find it */
+     dlerr= dlerror();
+     if(dlerr != NULL) {         /* If no function was found */
+       funcptr= dlsym(handle, in_string); /* Get function pointer */
+       dlerr= dlerror();
+     }
+     if(dlerr==NULL) {           /* If a function was found */
+       new_fvalue->type= func;   /* The new value is a function pointer */
+       new_fvalue->content.ptr= funcptr; /* Store function pointer */
+       (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
+                                          function value */
+     }
+     free(mangled);
+   }
+   push_val(env, new_value);
+   unprotect(new_value); unprotect(new_fvalue);
  }
+ /* Print newline. */
  extern void nl()
  {
    printf("\n");
  }
- void print_(stackitem** stack_head)
+ /* Gets the type of a value */
+ extern void type(environment *env)
  {
-   if((*stack_head)==NULL)
+   int typenum;
+   if((env->head)==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
      return;
+   }
+   typenum=env->head->item->type;
+   toss(env);
+   switch(typenum){
+   case integer:
+     push_sym(env, "integer");
+     break;
+   case tfloat:
+     push_sym(env, "float");
+     break;
+   case string:
+     push_sym(env, "string");
+     break;
+   case symb:
+     push_sym(env, "symbol");
+     break;
+   case func:
+     push_sym(env, "function");
+     break;
+   case list:
+     push_sym(env, "list");
+     break;
+   }
+ }
-   switch((*stack_head)->type) {
+ /* Prints the top element of the stack. */
-   case value:
+ void print_h(stackitem *stack_head, int noquote)
-     printf("%d", (*stack_head)->content.val);
+ {
+   switch(stack_head->item->type) {
+   case integer:
+     printf("%d", stack_head->item->content.i);
+     break;
+   case tfloat:
+     printf("%f", stack_head->item->content.f);
      break;
    case string:
-     printf("%s", (char*)(*stack_head)->content.ptr);
+     if(noquote)
+       printf("%s", (char*)stack_head->item->content.ptr);
+     else
+       printf("\"%s\"", (char*)stack_head->item->content.ptr);
      break;
-   case ref:
+   case symb:
-     printf("%s", ((stackitem*)(*stack_head)->content.ptr)->id);
+     printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);
      break;
-   case symbol:
+   case func:
-   default:
+     printf("#<function %p>", (funcp)(stack_head->item->content.ptr));
-     printf("%p", (*stack_head)->content.ptr);
      break;
+   case list:
+     /* A list is just a stack, so make stack_head point to it */
+     stack_head=(stackitem *)(stack_head->item->content.ptr);
+     printf("[ ");
+     while(stack_head != NULL) {
+       print_h(stack_head, noquote);
+       printf(" ");
+       stack_head=stack_head->next;
+     }
+     printf("]");
+     break;
+   }
+ }
+ extern void print_(environment *env)
+ {
+   if(env->head==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   print_h(env->head, 0);
+   nl();
+ }
+ /* Prints the top element of the stack and then discards it. */
+ extern void print(environment *env)
+ {
+   print_(env);
+   if(env->err) return;
+   toss(env);
+ }
+ extern void princ_(environment *env)
+ {
+   if(env->head==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
    }
+   print_h(env->head, 1);
  }
- extern void print(stackitem** stack_head)
+ /* Prints the top element of the stack and then discards it. */
+ extern void princ(environment *env)
  {
-   print_(stack_head);
+   princ_(env);
-   toss(stack_head);
+   if(env->err) return;
+   toss(env);
  }
- /* print_stack(stack); */
+ /* Only to be called by function printstack. */
- void print_st(stackitem* stack_head, long counter)
+ void print_st(stackitem *stack_head, long counter)
  {
    if(stack_head->next != NULL)
      print_st(stack_head->next, counter+1);
    printf("%ld: ", counter);
-   print_(&stack_head);
+   print_h(stack_head, 0);
    nl();
  }
- extern void printstack(stackitem** stack_head)
+ /* Prints the stack. */
+ extern void printstack(environment *env)
  {
-   if(*stack_head != NULL) {
+   if(env->head == NULL) {
-     print_st(*stack_head, 1);
+     printf("Stack Empty\n");
-     printf("\n");
+     return;
    }
+   print_st(env->head, 1);
  }
+ /* Swap the two top elements on the stack. */
+ extern void swap(environment *env)
+ {
+   stackitem *temp= env->head;
+   if(env->head==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
- extern void eval(stackitem** stack_head)
+   env->head= env->head->next;
+   temp->next= env->head->next;
+   env->head->next= temp;
+ }
+ /* Rotate the first three elements on the stack. */
+ extern void rot(environment *env)
  {
-   funcp in_func;
+   stackitem *temp= env->head;
+   if(env->head==NULL || env->head->next==NULL
+       || env->head->next->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   env->head= env->head->next->next;
+   temp->next->next= env->head->next;
+   env->head->next= temp;
+ }
-   if((*stack_head)==NULL || (*stack_head)->type!=ref)
+ /* Recall a value from a symbol, if bound */
+ extern void rcl(environment *env)
+ {
+   value *val;
+   if(env->head == NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
      return;
+   }
-   if(((stackitem*)(*stack_head)->content.ptr)->type==func) {
+   if(env->head->item->type!=symb) {
-     in_func= (funcp)((stackitem*)(*stack_head)->content.ptr)->content.ptr;
+     printerr("Bad Argument Type");
-     toss(stack_head);
+     env->err=2;
-     (*in_func)(stack_head);
      return;
    }
+   val=((symbol *)(env->head->item->content.ptr))->val;
+   if(val == NULL){
+     printerr("Unbound Variable");
+     env->err=3;
+     return;
+   }
+   protect(val);
+   toss(env);            /* toss the symbol */
+   if(env->err) return;
+   push_val(env, val); /* Return its bound value */
+   unprotect(val);
  }
- 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
+    function value, and if it is, toss the symbol and execute the
+    function. */
+ extern void eval(environment *env)
  {
-   char *temp, *rest;
+   funcp in_func;
-   int itemp;
+   value* temp_val;
-   size_t inlength= strlen(in_line)+1;
+   stackitem* iterator;
-   int convert= 0;
-   temp= malloc(inlength);
+  eval_start:
-   rest= malloc(inlength);
-   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);
-   free(temp);
+   if(env->head==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   switch(env->head->item->type) {
+     /* if it's a symbol */
+   case symb:
+     rcl(env);                   /* get its contents */
+     if(env->err) return;
+     if(env->head->item->type!=symb){ /* don't recurse symbols */
+       goto eval_start;
+     }
+     return;
-   if(convert<2) {
+     /* If it's a lone function value, run it */
-     free(rest);
+   case func:
-     return 0;
+     in_func= (funcp)(env->head->item->content.ptr);
+     toss(env);
+     if(env->err) return;
+     return in_func(env);
+     /* If it's a list */
+   case list:
+     temp_val= env->head->item;
+     protect(temp_val);
+     toss(env); if(env->err) return;
+     iterator= (stackitem*)temp_val->content.ptr;
+     while(iterator!=NULL) {
+       push_val(env, iterator->item);
+       if(env->head->item->type==symb
+          && (((symbol*)(env->head->item->content.ptr))->id[0] == ';')) {
+         toss(env);
+         if(env->err) return;
+         if(iterator->next == NULL){
+           goto eval_start;
+         }
+         eval(env);
+         if(env->err) return;
+       }
+       iterator= iterator->next;
+     }
+     unprotect(temp_val);
+     return;
+   default:
+     return;
    }
-   stack_read(stack_head, in_hash, rest);
-   free(rest);
-   return 1;
  }
- extern void pack(stackitem** stack_head)
+ /* Reverse (flip) a list */
+ extern void rev(environment *env)
  {
-   void* delimiter;
+   stackitem *old_head, *new_head, *item;
-   stackitem *iterator, *temp, *pack;
-   if((*stack_head)==NULL)
+   if((env->head)==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
      return;
+   }
-   delimiter= (*stack_head)->content.ptr;
+   if(env->head->item->type!=list) {
-   toss(stack_head);
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
-   iterator= *stack_head;
+   old_head= (stackitem *)(env->head->item->content.ptr);
+   new_head= NULL;
+   while(old_head != NULL){
+     item= old_head;
+     old_head= old_head->next;
+     item->next= new_head;
+     new_head= item;
+   }
+   env->head->item->content.ptr= new_head;
+ }
-   while(iterator->next!=NULL && iterator->next->content.ptr!=delimiter)
+ /* Make a list. */
-     iterator= iterator->next;
+ extern void pack(environment *env)
+ {
+   stackitem *iterator, *temp;
+   value *pack;
-   temp= *stack_head;
+   iterator= env->head;
-   *stack_head= iterator->next;
+   pack= new_val(env);
-   iterator->next= NULL;
+   protect(pack);
-   if(*stack_head!=NULL && (*stack_head)->content.ptr==delimiter)
+   if(iterator==NULL
-     toss(stack_head);
+      || (iterator->item->type==symb
+      && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {
+     temp= NULL;
+     toss(env);
+   } else {
+     /* Search for first delimiter */
+     while(iterator->next!=NULL
+           && (iterator->next->item->type!=symb
+           || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))
+       iterator= iterator->next;
+     /* Extract list */
+     temp= env->head;
+     env->head= iterator->next;
+     iterator->next= NULL;
+     pack->type= list;
+     pack->content.ptr= temp;
+     if(env->head!=NULL)
+       toss(env);
+   }
-   pack= malloc(sizeof(stackitem));
+   /* Push list */
-   pack->type= list;
-   pack->content.ptr= temp;
-   push(stack_head, pack);
+   push_val(env, pack);
+   rev(env);
+   unprotect(pack);
  }
- extern void expand(stackitem** stack_head)
+ /* Relocate elements of the list on the stack. */
+ extern void expand(environment *env)
  {
    stackitem *temp, *new_head;
-   if((*stack_head)==NULL || (*stack_head)->type!=list)
+   /* Is top element a list? */
+   if(env->head==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(env->head->item->type!=list) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   rev(env);
+   if(env->err)
      return;
-   new_head= temp= (*stack_head)->content.ptr;
+   /* The first list element is the new stack head */
-   toss(stack_head);
+   new_head= temp= env->head->item->content.ptr;
+   toss(env);
+   /* Find the end of the list */
    while(temp->next!=NULL)
      temp= temp->next;
-   temp->next= *stack_head;
+   /* Connect the tail of the list with the old stack head */
-   *stack_head= new_head;
+   temp->next= env->head;
+   env->head= new_head;          /* ...and voila! */
  }
- extern void swap(stackitem** stack_head)
+ /* Compares two elements by reference. */
+ extern void eq(environment *env)
  {
-   stackitem* temp= (*stack_head);
+   void *left, *right;
+   int result;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   left= env->head->item->content.ptr;
+   swap(env);
+   right= env->head->item->content.ptr;
+   result= (left==right);
-   if((*stack_head)==NULL || (*stack_head)->next==NULL)
+   toss(env); toss(env);
+   push_int(env, result);
+ }
+ /* Negates the top element on the stack. */
+ extern void not(environment *env)
+ {
+   int val;
+   if((env->head)==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(env->head->item->type!=integer) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   val= env->head->item->content.i;
+   toss(env);
+   push_int(env, !val);
+ }
+ /* Compares the two top elements on the stack and return 0 if they're the
+    same. */
+ extern void neq(environment *env)
+ {
+   eq(env);
+   not(env);
+ }
+ /* Give a symbol some content. */
+ extern void def(environment *env)
+ {
+   symbol *sym;
+   /* Needs two values on the stack, the top one must be a symbol */
+   if(env->head==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(env->head->item->type!=symb) {
+     printerr("Bad Argument Type");
+     env->err= 2;
      return;
+   }
+   /* long names are a pain */
+   sym= env->head->item->content.ptr;
-   *stack_head= (*stack_head)->next;
+   /* Bind the symbol to the value */
-   temp->next= (*stack_head)->next;
+   sym->val= env->head->next->item;
-   (*stack_head)->next= temp;
+   toss(env); toss(env);
  }
- extern void eq(stackitem** stack_head)
+ /* Quit stack. */
+ extern void quit(environment *env)
  {
-   void *left, *right;
+   int i;
-   int result;
+   clear(env);
+   if (env->err) return;
+   for(i= 0; i<HASHTBLSIZE; i++) {
+     while(env->symbols[i]!= NULL) {
+       forget_sym(&(env->symbols[i]));
+     }
+     env->symbols[i]= NULL;
+   }
+   env->gc_limit= 0;
+   gc_maybe(env);
+   if(env->free_string!=NULL)
+     free(env->free_string);
+   muntrace();
+   exit(EXIT_SUCCESS);
+ }
+ /* Clear stack */
+ extern void clear(environment *env)
+ {
+   while(env->head!=NULL)
+     toss(env);
+ }
+ /* List all defined words */
+ extern void words(environment *env)
+ {
+   symbol *temp;
+   int i;
+   for(i= 0; i<HASHTBLSIZE; i++) {
+     temp= env->symbols[i];
+     while(temp!=NULL) {
+       printf("%s\n", temp->id);
+       temp= temp->next;
+     }
+   }
+ }
+ /* Internal forget function */
+ void forget_sym(symbol **hash_entry)
+ {
+   symbol *temp;
-   if((*stack_head)==NULL || (*stack_head)->next==NULL)
+   temp= *hash_entry;
+   *hash_entry= (*hash_entry)->next;
+   free(temp->id);
+   free(temp);
+ }
+ /* Forgets a symbol (remove it from the hash table) */
+ extern void forget(environment *env)
+ {
+   char* sym_id;
+   stackitem *stack_head= env->head;
+   if(stack_head==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   if(stack_head->item->type!=symb) {
+     printerr("Bad Argument Type");
+     env->err=2;
      return;
+   }
-   left= (*stack_head)->content.ptr;
+   sym_id= ((symbol*)(stack_head->item->content.ptr))->id;
-   swap(stack_head);
+   toss(env);
-   right= (*stack_head)->content.ptr;
-   result= (left==right);
+   return forget_sym(hash(env->symbols, sym_id));
+ }
+ /* Returns the current error number to the stack */
+ extern void errn(environment *env)
+ {
+   push_int(env, env->err);
+ }
+ int main(int argc, char **argv)
+ {
+   environment myenv;
+   int c;                        /* getopt option character */
+   mtrace();
+   init_env(&myenv);
+   myenv.interactive = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO);
+   while ((c = getopt (argc, argv, "i")) != -1)
+     switch (c)
+       {
+       case 'i':
+         myenv.interactive = 1;
+         break;
+       case '?':
+         fprintf (stderr,
+                  "Unknown option character `\\x%x'.\n",
+                  optopt);
+         return EX_USAGE;
+       default:
+         abort ();
+       }
-   toss(stack_head); toss(stack_head);
+   if (optind < argc) {
-   push_val(stack_head, (left==right));
+     myenv.interactive = 0;
+     myenv.inputstream= fopen(argv[optind], "r");
+     if(myenv.inputstream== NULL) {
+       perror(argv[0]);
+       exit (EX_NOINPUT);
+     }
+   }
+   if(myenv.interactive) {
+     printf("Stack version $Revision$\n\
+ Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
+ Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\
+ This is free software, and you are welcome to redistribute it\n\
+ under certain conditions; type `copying;' for details.\n");
+   }
+   while(1) {
+     if(myenv.in_string==NULL) {
+       if (myenv.interactive) {
+         if(myenv.err) {
+           printf("(error %d)\n", myenv.err);
+         }
+         nl();
+         printstack(&myenv);
+         printf("> ");
+       }
+       myenv.err=0;
+     }
+     sx_72656164(&myenv);
+     if (myenv.err==4) {
+       return EXIT_SUCCESS;      /* EOF */
+     } else if(myenv.head!=NULL
+               && myenv.head->item->type==symb
+               && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {
+       toss(&myenv);             /* No error check in main */
+       eval(&myenv);
+     }
+     gc_maybe(&myenv);
+   }
+   quit(&myenv);
+   return EXIT_FAILURE;
  }
- extern void not(stackitem** stack_head)
+ /* "+" */
+ extern void sx_2b(environment *env)
  {
-   int value;
+   int a, b;
+   float fa, fb;
+   size_t len;
+   char* new_string;
+   value *a_val, *b_val;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(env->head->item->type==string
+      && env->head->next->item->type==string) {
+     a_val= env->head->item;
+     b_val= env->head->next->item;
+     protect(a_val); protect(b_val);
+     toss(env); if(env->err) return;
+     toss(env); if(env->err) return;
+     len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
+     new_string= malloc(len);
+     strcpy(new_string, b_val->content.ptr);
+     strcat(new_string, a_val->content.ptr);
+     push_cstring(env, new_string);
+     unprotect(a_val); unprotect(b_val);
+     free(new_string);
+     return;
+   }
+   if(env->head->item->type==integer
+      && env->head->next->item->type==integer) {
+     a=env->head->item->content.i;
+     toss(env); if(env->err) return;
+     b=env->head->item->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, b+a);
+     return;
+   }
-   if((*stack_head)==NULL)
+   if(env->head->item->type==tfloat
+      && env->head->next->item->type==tfloat) {
+     fa= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     fb= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb+fa);
      return;
+   }
-   value= (*stack_head)->content.val;
+   if(env->head->item->type==tfloat
-   toss(stack_head);
+      && env->head->next->item->type==integer) {
-   push_val(stack_head, !value);
+     fa= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     b= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     push_float(env, b+fa);
+     return;
+   }
+   if(env->head->item->type==integer
+      && env->head->next->item->type==tfloat) {
+     a= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     fb= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb+a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err=2;
  }
- extern void neq(stackitem** stack_head)
+ /* "-" */
+ extern void sx_2d(environment *env)
  {
-   eq(stack_head);
+   int a, b;
-   not(stack_head);
+   float fa, fb;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   if(env->head->item->type==integer
+      && env->head->next->item->type==integer) {
+     a=env->head->item->content.i;
+     toss(env); if(env->err) return;
+     b=env->head->item->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, b-a);
+     return;
+   }
+   if(env->head->item->type==tfloat
+      && env->head->next->item->type==tfloat) {
+     fa= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     fb= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb-fa);
+     return;
+   }
+   if(env->head->item->type==tfloat
+      && env->head->next->item->type==integer) {
+     fa= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     b= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     push_float(env, b-fa);
+     return;
+   }
+   if(env->head->item->type==integer
+      && env->head->next->item->type==tfloat) {
+     a= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     fb= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb-a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err=2;
  }
- extern void def(stackitem** stack_head)
+ /* ">" */
+ extern void sx_3e(environment *env)
  {
-   stackitem *temp, *value;
+   int a, b;
+   float fa, fb;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   if(env->head->item->type==integer
+      && env->head->next->item->type==integer) {
+     a=env->head->item->content.i;
+     toss(env); if(env->err) return;
+     b=env->head->item->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, b>a);
-   if(*stack_head==NULL || (*stack_head)->next==NULL
-      || (*stack_head)->type!=ref)
      return;
+   }
-   temp= (*stack_head)->content.ptr;
+   if(env->head->item->type==tfloat
-   value= (*stack_head)->next;
+      && env->head->next->item->type==tfloat) {
-   temp->content= value->content;
+     fa= env->head->item->content.f;
-   value->content.ptr=NULL;
+     toss(env); if(env->err) return;
-   temp->type= value->type;
+     fb= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     push_int(env, fb>fa);
+     return;
+   }
-   toss(stack_head); toss(stack_head);
+   if(env->head->item->type==tfloat
- }
+      && env->head->next->item->type==integer) {
+     fa= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     b= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, b>fa);
+     return;
+   }
- extern void quit()
+   if(env->head->item->type==integer
+      && env->head->next->item->type==tfloat) {
+     a= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     fb= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     push_int(env, fb>a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err=2;
+ }
+ /* "<" */
+ extern void sx_3c(environment *env)
  {
-   exit(EXIT_SUCCESS);
+   swap(env); if(env->err) return;
+   sx_3e(env);
+ }
+ /* "<=" */
+ extern void sx_3c3d(environment *env)
+ {
+   sx_3e(env); if(env->err) return;
+   not(env);
+ }
+ /* ">=" */
+ extern void sx_3e3d(environment *env)
+ {
+   sx_3c(env); if(env->err) return;
+   not(env);
  }
- int main()
+ /* Return copy of a value */
+ value *copy_val(environment *env, value *old_value)
  {
-   stackitem* s= NULL;
+   stackitem *old_item, *new_item, *prev_item;
-   hashtbl myhash;
+   value *new_value;
-   char in_string[100];
+   protect(old_value);
+   new_value= new_val(env);
+   protect(new_value);
+   new_value->type= old_value->type;
-   init_hashtbl(myhash);
+   switch(old_value->type){
+   case tfloat:
+   case integer:
+   case func:
+   case symb:
+     new_value->content= old_value->content;
+     break;
+   case string:
+     (char *)(new_value->content.ptr)=
+       strdup((char *)(old_value->content.ptr));
+     break;
+   case list:
+     new_value->content.ptr= NULL;
-   printf("okidok\n ");
+     prev_item= NULL;
+     old_item= (stackitem*)(old_value->content.ptr);
-   while(fgets(in_string, 100, stdin) != NULL) {
+     while(old_item != NULL) {   /* While list is not empty */
-     stack_read(&s, myhash, in_string);
+       new_item= malloc(sizeof(stackitem));
-     printf("okidok\n ");
+       new_item->item= copy_val(env, old_item->item); /* recurse */
+       new_item->next= NULL;
+       if(prev_item != NULL)     /* If this wasn't the first item */
+         prev_item->next= new_item; /* point the previous item to the
+                                      new item */
+       else
+         new_value->content.ptr= new_item;
+       old_item= old_item->next;
+       prev_item= new_item;
+     }
+     break;
    }
-   exit(EXIT_SUCCESS);
+   unprotect(old_value); unprotect(new_value);
+   return new_value;
+ }
+ /* "dup"; duplicates an item on the stack */
+ extern void sx_647570(environment *env)
+ {
+   if((env->head)==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   push_val(env, copy_val(env, env->head->item));
+ }
+ /* "if", If-Then */
+ extern void sx_6966(environment *env)
+ {
+   int truth;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(env->head->next->item->type != integer) {
+     printerr("Bad Argument Type");
+     env->err=2;
+     return;
+   }
+   swap(env);
+   if(env->err) return;
+   truth=env->head->item->content.i;
+   toss(env);
+   if(env->err) return;
+   if(truth)
+     eval(env);
+   else
+     toss(env);
+ }
+ /* If-Then-Else */
+ extern void ifelse(environment *env)
+ {
+   int truth;
+   if((env->head)==NULL || env->head->next==NULL
+      || env->head->next->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   if(env->head->next->next->item->type != integer) {
+     printerr("Bad Argument Type");
+     env->err=2;
+     return;
+   }
+   rot(env);
+   if(env->err) return;
+   truth=env->head->item->content.i;
+   toss(env);
+   if(env->err) return;
+   if(!truth)
+     swap(env);
+   if(env->err) return;
+   toss(env);
+   if(env->err) return;
+   eval(env);
+ }
+ /* "while" */
+ extern void sx_7768696c65(environment *env)
+ {
+   int truth;
+   value *loop, *test;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   loop= env->head->item;
+   protect(loop);
+   toss(env); if(env->err) return;
+   test= env->head->item;
+   protect(test);
+   toss(env); if(env->err) return;
+   do {
+     push_val(env, test);
+     eval(env);
+     if(env->head->item->type != integer) {
+       printerr("Bad Argument Type");
+       env->err= 2;
+       return;
+     }
+     truth= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     if(truth) {
+       push_val(env, loop);
+       eval(env);
+     } else {
+       toss(env);
+     }
+   } while(truth);
+   unprotect(loop); unprotect(test);
+ }
+ /* "for"; for-loop */
+ extern void sx_666f72(environment *env)
+ {
+   value *loop;
+   int foo1, foo2;
+   if(env->head==NULL || env->head->next==NULL
+      || env->head->next->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(env->head->next->item->type!=integer
+      || env->head->next->next->item->type!=integer) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   loop= env->head->item;
+   protect(loop);
+   toss(env); if(env->err) return;
+   foo2= env->head->item->content.i;
+   toss(env); if(env->err) return;
+   foo1= env->head->item->content.i;
+   toss(env); if(env->err) return;
+   if(foo1<=foo2) {
+     while(foo1<=foo2) {
+       push_int(env, foo1);
+       push_val(env, loop);
+       eval(env); if(env->err) return;
+       foo1++;
+     }
+   } else {
+     while(foo1>=foo2) {
+       push_int(env, foo1);
+       push_val(env, loop);
+       eval(env); if(env->err) return;
+       foo1--;
+     }
+   }
+   unprotect(loop);
+ }
+ /* Variant of for-loop */
+ extern void foreach(environment *env)
+ {
+   value *loop, *foo;
+   stackitem *iterator;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(env->head->next->item->type != list) {
+     printerr("Bad Argument Type");
+     env->err= 2;
+     return;
+   }
+   loop= env->head->item;
+   protect(loop);
+   toss(env); if(env->err) return;
+   foo= env->head->item;
+   protect(foo);
+   toss(env); if(env->err) return;
+   iterator= foo->content.ptr;
+   while(iterator!=NULL) {
+     push_val(env, iterator->item);
+     push_val(env, loop);
+     eval(env); if(env->err) return;
+     iterator= iterator->next;
+   }
+   unprotect(loop); unprotect(foo);
  }
- /* Local Variables: */
+ /* "to" */
- /* compile-command:"make CFLAGS=\"-Wall -g -rdynamic -ldl\" stack" */
+ extern void to(environment *env)
- /* End: */
+ {
+   int ending, start, i;
+   stackitem *iterator, *temp;
+   value *pack;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   if(env->head->item->type!=integer
+      || env->head->next->item->type!=integer) {
+     printerr("Bad Argument Type");
+     env->err=2;
+     return;
+   }
+   ending= env->head->item->content.i;
+   toss(env); if(env->err) return;
+   start= env->head->item->content.i;
+   toss(env); if(env->err) return;
+   push_sym(env, "[");
+   if(ending>=start) {
+     for(i= ending; i>=start; i--)
+       push_int(env, i);
+   } else {
+     for(i= ending; i<=start; i++)
+       push_int(env, i);
+   }
+   iterator= env->head;
+   pack= new_val(env);
+   protect(pack);
+   if(iterator==NULL
+      || (iterator->item->type==symb
+      && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {
+     temp= NULL;
+     toss(env);
+   } else {
+     /* Search for first delimiter */
+     while(iterator->next!=NULL
+           && (iterator->next->item->type!=symb
+           || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))
+       iterator= iterator->next;
+     /* Extract list */
+     temp= env->head;
+     env->head= iterator->next;
+     iterator->next= NULL;
+     pack->type= list;
+     pack->content.ptr= temp;
+     if(env->head!=NULL)
+       toss(env);
+   }
+   /* Push list */
+   push_val(env, pack);
+   unprotect(pack);
+ }
+ /* Read a string */
+ extern void readline(environment *env)
+ {
+   char in_string[101];
+   if(fgets(in_string, 100, env->inputstream)==NULL)
+     push_cstring(env, "");
+   else
+     push_cstring(env, in_string);
+ }
+ /* "read"; Read a value and place on stack */
+ extern void sx_72656164(environment *env)
+ {
+   const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
+   const char strform[]= "\"%[^\"]\"%n";
+   const char intform[]= "%i%n";
+   const char fltform[]= "%f%n";
+   const char blankform[]= "%*[ \t]%n";
+   const char ebrackform[]= "]%n";
+   const char semicform[]= ";%n";
+   const char bbrackform[]= "[%n";
+   int itemp, readlength= -1;
+   int count= -1;
+   float ftemp;
+   static int depth= 0;
+   char *match, *ctemp;
+   size_t inlength;
+   if(env->in_string==NULL) {
+     if(depth > 0 && env->interactive) {
+       printf("]> ");
+     }
+     readline(env); if(env->err) return;
+     if(((char *)(env->head->item->content.ptr))[0]=='\0'){
+       env->err= 4;              /* "" means EOF */
+       return;
+     }
+     env->in_string= malloc(strlen(env->head->item->content.ptr)+1);
+     env->free_string= env->in_string; /* Save the original pointer */
+     strcpy(env->in_string, env->head->item->content.ptr);
+     toss(env); if(env->err) return;
+   }
+   inlength= strlen(env->in_string)+1;
+   match= malloc(inlength);
+   if(sscanf(env->in_string, blankform, &readlength) != EOF
+      && readlength != -1) {
+     ;
+   } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
+             && readlength != -1) {
+     if(sscanf(env->in_string, intform, &itemp, &count) != EOF
+        && count==readlength) {
+       push_int(env, itemp);
+     } else {
+       push_float(env, ftemp);
+     }
+   } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
+             && readlength != -1) {
+     push_cstring(env, match);
+   } else if(sscanf(env->in_string, symbform, match, &readlength) != EOF
+             && readlength != -1) {
+     push_sym(env, match);
+   } else if(sscanf(env->in_string, ebrackform, &readlength) != EOF
+             && readlength != -1) {
+     pack(env); if(env->err) return;
+     if(depth != 0) depth--;
+   } else if(sscanf(env->in_string, semicform, &readlength) != EOF
+             && readlength != -1) {
+     push_sym(env, ";");
+   } else if(sscanf(env->in_string, bbrackform, &readlength) != EOF
+             && readlength != -1) {
+     push_sym(env, "[");
+     depth++;
+   } else {
+     free(env->free_string);
+     env->in_string = env->free_string = NULL;
+   }
+   if (env->in_string != NULL) {
+     env->in_string += readlength;
+   }
+   free(match);
+   if(depth)
+     return sx_72656164(env);
+ }
+ extern void beep(environment *env)
+ {
+   int freq, dur, period, ticks;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   if(env->head->item->type!=integer
+      || env->head->next->item->type!=integer) {
+     printerr("Bad Argument Type");
+     env->err=2;
+     return;
+   }
+   dur=env->head->item->content.i;
+   toss(env);
+   freq=env->head->item->content.i;
+   toss(env);
+   period=1193180/freq;          /* convert freq from Hz to period
+                                    length */
+   ticks=dur*.001193180;         /* convert duration from µseconds to
+                                    timer ticks */
+ /*    ticks=dur/1000; */
+   /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
+   switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
+   case 0:
+     usleep(dur);
+     return;
+   case -1:
+     perror("beep");
+     env->err=5;
+     return;
+   default:
+     abort();
+   }
+ }
+ /* "wait" */
+ extern void sx_77616974(environment *env)
+ {
+   int dur;
+   if((env->head)==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   if(env->head->item->type!=integer) {
+     printerr("Bad Argument Type");
+     env->err=2;
+     return;
+   }
+   dur=env->head->item->content.i;
+   toss(env);
+   usleep(dur);
+ }
+ extern void copying(environment *env)
+ {
+   printf("GNU GENERAL PUBLIC LICENSE\n\
+                        Version 2, June 1991\n\
+ \n\
+  Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
+Temple Place, Suite 330, Boston, MA  02111-1307  USA\n\
+  Everyone is permitted to copy and distribute verbatim copies\n\
+  of this license document, but changing it is not allowed.\n\
+ \n\
+                             Preamble\n\
+ \n\
+   The licenses for most software are designed to take away your\n\
+ freedom to share and change it.  By contrast, the GNU General Public\n\
+ License is intended to guarantee your freedom to share and change free\n\
+ software--to make sure the software is free for all its users.  This\n\
+ General Public License applies to most of the Free Software\n\
+ Foundation's software and to any other program whose authors commit to\n\
+ using it.  (Some other Free Software Foundation software is covered by\n\
+ the GNU Library General Public License instead.)  You can apply it to\n\
+ your programs, too.\n\
+ \n\
+   When we speak of free software, we are referring to freedom, not\n\
+ price.  Our General Public Licenses are designed to make sure that you\n\
+ have the freedom to distribute copies of free software (and charge for\n\
+ this service if you wish), that you receive source code or can get it\n\
+ if you want it, that you can change the software or use pieces of it\n\
+ in new free programs; and that you know you can do these things.\n\
+ \n\
+   To protect your rights, we need to make restrictions that forbid\n\
+ anyone to deny you these rights or to ask you to surrender the rights.\n\
+ These restrictions translate to certain responsibilities for you if you\n\
+ distribute copies of the software, or if you modify it.\n\
+ \n\
+   For example, if you distribute copies of such a program, whether\n\
+ gratis or for a fee, you must give the recipients all the rights that\n\
+ you have.  You must make sure that they, too, receive or can get the\n\
+ source code.  And you must show them these terms so they know their\n\
+ rights.\n\
+ \n\
+   We protect your rights with two steps: (1) copyright the software, and\n\
+ (2) offer you this license which gives you legal permission to copy,\n\
+ distribute and/or modify the software.\n\
+ \n\
+   Also, for each author's protection and ours, we want to make certain\n\
+ that everyone understands that there is no warranty for this free\n\
+ software.  If the software is modified by someone else and passed on, we\n\
+ want its recipients to know that what they have is not the original, so\n\
+ that any problems introduced by others will not reflect on the original\n\
+ authors' reputations.\n\
+ \n\
+   Finally, any free program is threatened constantly by software\n\
+ patents.  We wish to avoid the danger that redistributors of a free\n\
+ program will individually obtain patent licenses, in effect making the\n\
+ program proprietary.  To prevent this, we have made it clear that any\n\
+ patent must be licensed for everyone's free use or not licensed at all.\n\
+ \n\
+   The precise terms and conditions for copying, distribution and\n\
+ modification follow.\n\
+ \n\
+                     GNU GENERAL PUBLIC LICENSE\n\
+    TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION\n\
+ \n\
+. This License applies to any program or other work which contains\n\
+ a notice placed by the copyright holder saying it may be distributed\n\
+ under the terms of this General Public License.  The \"Program\", below,\n\
+ refers to any such program or work, and a \"work based on the Program\"\n\
+ means either the Program or any derivative work under copyright law:\n\
+ that is to say, a work containing the Program or a portion of it,\n\
+ either verbatim or with modifications and/or translated into another\n\
+ language.  (Hereinafter, translation is included without limitation in\n\
+ the term \"modification\".)  Each licensee is addressed as \"you\".\n\
+ \n\
+ Activities other than copying, distribution and modification are not\n\
+ covered by this License; they are outside its scope.  The act of\n\
+ running the Program is not restricted, and the output from the Program\n\
+ is covered only if its contents constitute a work based on the\n\
+ Program (independent of having been made by running the Program).\n\
+ Whether that is true depends on what the Program does.\n\
+ \n\
+. You may copy and distribute verbatim copies of the Program's\n\
+ source code as you receive it, in any medium, provided that you\n\
+ conspicuously and appropriately publish on each copy an appropriate\n\
+ copyright notice and disclaimer of warranty; keep intact all the\n\
+ notices that refer to this License and to the absence of any warranty;\n\
+ and give any other recipients of the Program a copy of this License\n\
+ along with the Program.\n\
+ \n\
+ You may charge a fee for the physical act of transferring a copy, and\n\
+ you may at your option offer warranty protection in exchange for a fee.\n\
+ \n\
+. You may modify your copy or copies of the Program or any portion\n\
+ of it, thus forming a work based on the Program, and copy and\n\
+ distribute such modifications or work under the terms of Section 1\n\
+ above, provided that you also meet all of these conditions:\n\
+ \n\
+     a) You must cause the modified files to carry prominent notices\n\
+     stating that you changed the files and the date of any change.\n\
+ \n\
+     b) You must cause any work that you distribute or publish, that in\n\
+     whole or in part contains or is derived from the Program or any\n\
+     part thereof, to be licensed as a whole at no charge to all third\n\
+     parties under the terms of this License.\n\
+ \n\
+     c) If the modified program normally reads commands interactively\n\
+     when run, you must cause it, when started running for such\n\
+     interactive use in the most ordinary way, to print or display an\n\
+     announcement including an appropriate copyright notice and a\n\
+     notice that there is no warranty (or else, saying that you provide\n\
+     a warranty) and that users may redistribute the program under\n\
+     these conditions, and telling the user how to view a copy of this\n\
+     License.  (Exception: if the Program itself is interactive but\n\
+     does not normally print such an announcement, your work based on\n\
+     the Program is not required to print an announcement.)\n\
+ \n\
+ These requirements apply to the modified work as a whole.  If\n\
+ identifiable sections of that work are not derived from the Program,\n\
+ and can be reasonably considered independent and separate works in\n\
+ themselves, then this License, and its terms, do not apply to those\n\
+ sections when you distribute them as separate works.  But when you\n\
+ distribute the same sections as part of a whole which is a work based\n\
+ on the Program, the distribution of the whole must be on the terms of\n\
+ this License, whose permissions for other licensees extend to the\n\
+ entire whole, and thus to each and every part regardless of who wrote it.\n\
+ \n\
+ Thus, it is not the intent of this section to claim rights or contest\n\
+ your rights to work written entirely by you; rather, the intent is to\n\
+ exercise the right to control the distribution of derivative or\n\
+ collective works based on the Program.\n\
+ \n\
+ In addition, mere aggregation of another work not based on the Program\n\
+ with the Program (or with a work based on the Program) on a volume of\n\
+ a storage or distribution medium does not bring the other work under\n\
+ the scope of this License.\n\
+ \n\
+. You may copy and distribute the Program (or a work based on it,\n\
+ under Section 2) in object code or executable form under the terms of\n\
+ Sections 1 and 2 above provided that you also do one of the following:\n\
+ \n\
+     a) Accompany it with the complete corresponding machine-readable\n\
+     source code, which must be distributed under the terms of Sections\n\
+and 2 above on a medium customarily used for software interchange; or,\n\
+ \n\
+     b) Accompany it with a written offer, valid for at least three\n\
+     years, to give any third party, for a charge no more than your\n\
+     cost of physically performing source distribution, a complete\n\
+     machine-readable copy of the corresponding source code, to be\n\
+     distributed under the terms of Sections 1 and 2 above on a medium\n\
+     customarily used for software interchange; or,\n\
+ \n\
+     c) Accompany it with the information you received as to the offer\n\
+     to distribute corresponding source code.  (This alternative is\n\
+     allowed only for noncommercial distribution and only if you\n\
+     received the program in object code or executable form with such\n\
+     an offer, in accord with Subsection b above.)\n\
+ \n\
+ The source code for a work means the preferred form of the work for\n\
+ making modifications to it.  For an executable work, complete source\n\
+ code means all the source code for all modules it contains, plus any\n\
+ associated interface definition files, plus the scripts used to\n\
+ control compilation and installation of the executable.  However, as a\n\
+ special exception, the source code distributed need not include\n\
+ anything that is normally distributed (in either source or binary\n\
+ form) with the major components (compiler, kernel, and so on) of the\n\
+ operating system on which the executable runs, unless that component\n\
+ itself accompanies the executable.\n\
+ \n\
+ If distribution of executable or object code is made by offering\n\
+ access to copy from a designated place, then offering equivalent\n\
+ access to copy the source code from the same place counts as\n\
+ distribution of the source code, even though third parties are not\n\
+ compelled to copy the source along with the object code.\n\
+ \n\
+. You may not copy, modify, sublicense, or distribute the Program\n\
+ except as expressly provided under this License.  Any attempt\n\
+ otherwise to copy, modify, sublicense or distribute the Program is\n\
+ void, and will automatically terminate your rights under this License.\n\
+ However, parties who have received copies, or rights, from you under\n\
+ this License will not have their licenses terminated so long as such\n\
+ parties remain in full compliance.\n\
+ \n\
+. You are not required to accept this License, since you have not\n\
+ signed it.  However, nothing else grants you permission to modify or\n\
+ distribute the Program or its derivative works.  These actions are\n\
+ prohibited by law if you do not accept this License.  Therefore, by\n\
+ modifying or distributing the Program (or any work based on the\n\
+ Program), you indicate your acceptance of this License to do so, and\n\
+ all its terms and conditions for copying, distributing or modifying\n\
+ the Program or works based on it.\n\
+ \n\
+. Each time you redistribute the Program (or any work based on the\n\
+ Program), the recipient automatically receives a license from the\n\
+ original licensor to copy, distribute or modify the Program subject to\n\
+ these terms and conditions.  You may not impose any further\n\
+ restrictions on the recipients' exercise of the rights granted herein.\n\
+ You are not responsible for enforcing compliance by third parties to\n\
+ this License.\n\
+ \n\
+. If, as a consequence of a court judgment or allegation of patent\n\
+ infringement or for any other reason (not limited to patent issues),\n\
+ conditions are imposed on you (whether by court order, agreement or\n\
+ otherwise) that contradict the conditions of this License, they do not\n\
+ excuse you from the conditions of this License.  If you cannot\n\
+ distribute so as to satisfy simultaneously your obligations under this\n\
+ License and any other pertinent obligations, then as a consequence you\n\
+ may not distribute the Program at all.  For example, if a patent\n\
+ license would not permit royalty-free redistribution of the Program by\n\
+ all those who receive copies directly or indirectly through you, then\n\
+ the only way you could satisfy both it and this License would be to\n\
+ refrain entirely from distribution of the Program.\n\
+ \n\
+ If any portion of this section is held invalid or unenforceable under\n\
+ any particular circumstance, the balance of the section is intended to\n\
+ apply and the section as a whole is intended to apply in other\n\
+ circumstances.\n\
+ \n\
+ It is not the purpose of this section to induce you to infringe any\n\
+ patents or other property right claims or to contest validity of any\n\
+ such claims; this section has the sole purpose of protecting the\n\
+ integrity of the free software distribution system, which is\n\
+ implemented by public license practices.  Many people have made\n\
+ generous contributions to the wide range of software distributed\n\
+ through that system in reliance on consistent application of that\n\
+ system; it is up to the author/donor to decide if he or she is willing\n\
+ to distribute software through any other system and a licensee cannot\n\
+ impose that choice.\n\
+ \n\
+ This section is intended to make thoroughly clear what is believed to\n\
+ be a consequence of the rest of this License.\n\
+ \n\
+. If the distribution and/or use of the Program is restricted in\n\
+ certain countries either by patents or by copyrighted interfaces, the\n\
+ original copyright holder who places the Program under this License\n\
+ may add an explicit geographical distribution limitation excluding\n\
+ those countries, so that distribution is permitted only in or among\n\
+ countries not thus excluded.  In such case, this License incorporates\n\
+ the limitation as if written in the body of this License.\n\
+ \n\
+. The Free Software Foundation may publish revised and/or new versions\n\
+ of the General Public License from time to time.  Such new versions will\n\
+ be similar in spirit to the present version, but may differ in detail to\n\
+ address new problems or concerns.\n\
+ \n\
+ Each version is given a distinguishing version number.  If the Program\n\
+ specifies a version number of this License which applies to it and \"any\n\
+ later version\", you have the option of following the terms and conditions\n\
+ either of that version or of any later version published by the Free\n\
+ Software Foundation.  If the Program does not specify a version number of\n\
+ this License, you may choose any version ever published by the Free Software\n\
+ Foundation.\n\
+ \n\
+. If you wish to incorporate parts of the Program into other free\n\
+ programs whose distribution conditions are different, write to the author\n\
+ to ask for permission.  For software which is copyrighted by the Free\n\
+ Software Foundation, write to the Free Software Foundation; we sometimes\n\
+ make exceptions for this.  Our decision will be guided by the two goals\n\
+ of preserving the free status of all derivatives of our free software and\n\
+ of promoting the sharing and reuse of software generally.\n");
+ }
+ extern void warranty(environment *env)
+ {
+   printf("                          NO WARRANTY\n\
+ \n\
+. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\n\
+ FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN\n\
+ OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES\n\
+ PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED\n\
+ OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF\n\
+ MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS\n\
+ TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE\n\
+ PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,\n\
+ REPAIR OR CORRECTION.\n\
+ \n\
+. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\n\
+ WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR\n\
+ REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,\n\
+ INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING\n\
+ OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED\n\
+ TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY\n\
+ YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER\n\
+ PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE\n\
+ POSSIBILITY OF SUCH DAMAGES.\n");
+ }
+ /* "*" */
+ extern void sx_2a(environment *env)
+ {
+   int a, b;
+   float fa, fb;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   if(env->head->item->type==integer
+      && env->head->next->item->type==integer) {
+     a=env->head->item->content.i;
+     toss(env); if(env->err) return;
+     b=env->head->item->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, b*a);
+     return;
+   }
+   if(env->head->item->type==tfloat
+      && env->head->next->item->type==tfloat) {
+     fa= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     fb= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb*fa);
+     return;
+   }
+   if(env->head->item->type==tfloat
+      && env->head->next->item->type==integer) {
+     fa= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     b= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     push_float(env, b*fa);
+     return;
+   }
+   if(env->head->item->type==integer
+      && env->head->next->item->type==tfloat) {
+     a= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     fb= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb*a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err=2;
+ }
+ /* "/" */
+ extern void sx_2f(environment *env)
+ {
+   int a, b;
+   float fa, fb;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err=1;
+     return;
+   }
+   if(env->head->item->type==integer
+      && env->head->next->item->type==integer) {
+     a=env->head->item->content.i;
+     toss(env); if(env->err) return;
+     b=env->head->item->content.i;
+     toss(env); if(env->err) return;
+     push_float(env, b/a);
+     return;
+   }
+   if(env->head->item->type==tfloat
+      && env->head->next->item->type==tfloat) {
+     fa= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     fb= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb/fa);
+     return;
+   }
+   if(env->head->item->type==tfloat
+      && env->head->next->item->type==integer) {
+     fa= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     b= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     push_float(env, b/fa);
+     return;
+   }
+   if(env->head->item->type==integer
+      && env->head->next->item->type==tfloat) {
+     a= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     fb= env->head->item->content.f;
+     toss(env); if(env->err) return;
+     push_float(env, fb/a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err=2;
+ }
+ /* "mod" */
+ extern void mod(environment *env)
+ {
+   int a, b;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(env->head->item->type==integer
+      && env->head->next->item->type==integer) {
+     a= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     b= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, b%a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err=2;
+ }
+ /* "div" */
+ extern void sx_646976(environment *env)
+ {
+   int a, b;
+   if((env->head)==NULL || env->head->next==NULL) {
+     printerr("Too Few Arguments");
+     env->err= 1;
+     return;
+   }
+   if(env->head->item->type==integer
+      && env->head->next->item->type==integer) {
+     a= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     b= env->head->item->content.i;
+     toss(env); if(env->err) return;
+     push_int(env, (int)b/a);
+     return;
+   }
+   printerr("Bad Argument Type");
+   env->err= 2;
+ }

 Legend:



Removed from v.1.13
 


changed lines


 
Added in v.1.101
 Legend:



Removed from v.1.13
 


changed lines


 
Added in v.1.101
-Removed from v.1.13
+Added in v.1.101

root@recompile.se	ViewVC Help
Powered by ViewVC 1.1.26