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

Diff of /stack/stack.c

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

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