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

Diff of /stack/stack.c

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

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