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

Diff of /stack/stack.c

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

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