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

Diff of /stack/stack.c

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

revision 1.101 by teddy, Sun Mar 10 13:00:01 2002 UTC revision 1.124 by teddy, Sat Mar 30 02:31:24 2002 UTC
# Line 1  Line 1 
1    /* -*- coding: utf-8; -*- */
2  /*  /*
3      stack - an interactive interpreter for a stack-based language      stack - an interactive interpreter for a stack-based language
4      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
# Line 20  Line 21 
21               Teddy Hogeborn <teddy@fukt.bth.se>               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 34  Line 38 
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 */  /* ioctl */
48  #include <sys/ioctl.h>  #include <sys/ioctl.h>
49  /* KDMKTONE */  /* KDMKTONE */
50  #include <linux/kd.h>  #include <linux/kd.h>
51    #endif /* __linux__ */
52    
53  #include "stack.h"  #include "stack.h"
54    
# Line 52  void init_env(environment *env) Line 61  void init_env(environment *env)
61    env->gc_count= 0;    env->gc_count= 0;
62    env->gc_ref= NULL;    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 70  void printerr(const char* in_string) Line 79  void printerr(const char* in_string)
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 117  value* new_val(environment *env) Line 123  value* new_val(environment *env)
123    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
124    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
125    
126      assert(nval != NULL);
127      assert(nitem != NULL);
128    
129    nval->content.ptr= NULL;    nval->content.ptr= NULL;
130      nval->type= empty;
131    
132    nitem->item= nval;    nitem->item= nval;
133    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
134    
135    env->gc_ref= nitem;    env->gc_ref= nitem;
136    
137    env->gc_count += sizeof(value);    env->gc_count += sizeof(value);
# Line 134  value* new_val(environment *env) Line 145  value* new_val(environment *env)
145     Marked values are not collected by the GC. */     Marked values are not collected by the GC. */
146  inline void gc_mark(value *val)  inline void gc_mark(value *val)
147  {  {
148    stackitem *iterator;    if(val==NULL || val->gc.flag.mark)
   
   if(val->gc.flag.mark)  
149      return;      return;
150    
151    val->gc.flag.mark= 1;    val->gc.flag.mark= 1;
152    
153    if(val->type==list) {    if(val->type==tcons) {
154      iterator= val->content.ptr;      gc_mark(CAR(val));
155        gc_mark(CDR(val));
     while(iterator!=NULL) {  
       gc_mark(iterator->item);  
       iterator= iterator->next;  
     }  
156    }    }
157  }  }
158    
# Line 162  inline void gc_maybe(environment *env) Line 167  inline void gc_maybe(environment *env)
167  /* Start GC */  /* Start GC */
168  extern void gc_init(environment *env)  extern void gc_init(environment *env)
169  {  {
170    stackitem *new_head= NULL, *titem, *iterator;    stackitem *new_head= NULL, *titem;
171    symbol *tsymb;    symbol *tsymb;
172    int i;    int i;
173    
174    if(env->interactive){    if(env->interactive)
175      printf("Garbage collecting.");      printf("Garbage collecting.");
   }  
176    
177    /* Mark values on stack */    /* Mark values on stack */
178    iterator= env->head;    gc_mark(env->head);
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
179    
180    if(env->interactive){    if(env->interactive)
181      printf(".");      printf(".");
182    }  
183    
184    /* Mark values in hashtable */    /* Mark values in hashtable */
185    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++)
186      tsymb= env->symbols[i];      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
     while(tsymb!=NULL) {  
187        if (tsymb->val != NULL)        if (tsymb->val != NULL)
188          gc_mark(tsymb->val);          gc_mark(tsymb->val);
       tsymb= tsymb->next;  
     }  
   }  
189    
190    if(env->interactive){  
191      if(env->interactive)
192      printf(".");      printf(".");
   }  
193    
194    env->gc_count= 0;    env->gc_count= 0;
195    
# Line 201  extern void gc_init(environment *env) Line 197  extern void gc_init(environment *env)
197    
198      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
199    
200        switch(env->gc_ref->item->type) { /* Remove content */        /* Remove content */
201          switch(env->gc_ref->item->type){
202        case string:        case string:
203          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
204          break;          break;
205        case list:        case tcons:
206          while(env->gc_ref->item->content.ptr!=NULL) {          free(env->gc_ref->item->content.c);
207            titem= env->gc_ref->item->content.ptr;          break;
208            env->gc_ref->item->content.ptr= titem->next;        case port:
209            free(titem);        case empty:
210          }        case integer:
211        default:        case tfloat:
212          case func:
213          case symb:
214            /* Symbol strings are freed when walking the hash table */
215        }        }
216    
217        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
218        titem= env->gc_ref->next;        titem= env->gc_ref->next;
219        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
220        env->gc_ref= titem;        env->gc_ref= titem;
221        continue;        continue;
     } else {  
       env->gc_count += sizeof(value);  
       if(env->gc_ref->item->type == string)  
         env->gc_count += strlen(env->gc_ref->item->content.ptr);  
222      }      }
223    #ifdef DEBUG
224        printf("Kept value (%p)", env->gc_ref->item);
225        if(env->gc_ref->item->gc.flag.mark)
226          printf(" (marked)");
227        if(env->gc_ref->item->gc.flag.protect)
228          printf(" (protected)");
229        switch(env->gc_ref->item->type){
230        case integer:
231          printf(" integer: %d", env->gc_ref->item->content.i);
232          break;
233        case func:
234          printf(" func: %p", env->gc_ref->item->content.ptr);
235          break;
236        case symb:
237          printf(" symb: %s", env->gc_ref->item->content.sym->id);
238          break;
239        case tcons:
240          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
241                 env->gc_ref->item->content.c->cdr);
242          break;
243        default:
244          printf(" <unknown %d>", (env->gc_ref->item->type));
245        }
246        printf("\n");
247    #endif /* DEBUG */
248    
249        /* Keep values */    
250        env->gc_count += sizeof(value);
251        if(env->gc_ref->item->type==string)
252          env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
253            
     /* Keep values */  
254      titem= env->gc_ref->next;      titem= env->gc_ref->next;
255      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
256      new_head= env->gc_ref;      new_head= env->gc_ref;
# Line 237  extern void gc_init(environment *env) Line 263  extern void gc_init(environment *env)
263    
264    env->gc_ref= new_head;    env->gc_ref= new_head;
265    
266    if(env->interactive){    if(env->interactive)
267      printf("done\n");      printf("done (%d bytes still allocated)\n", env->gc_count);
   }  
268    
269  }  }
270    
271  /* Protect values from GC */  /* Protect values from GC */
272  void protect(value *val)  void protect(value *val)
273  {  {
274    stackitem *iterator;    if(val==NULL || val->gc.flag.protect)
   
   if(val->gc.flag.protect)  
275      return;      return;
276    
277    val->gc.flag.protect= 1;    val->gc.flag.protect= 1;
278    
279    if(val->type==list) {    if(val->type==tcons) {
280      iterator= val->content.ptr;      protect(CAR(val));
281        protect(CDR(val));
     while(iterator!=NULL) {  
       protect(iterator->item);  
       iterator= iterator->next;  
     }  
282    }    }
283  }  }
284    
285  /* Unprotect values from GC */  /* Unprotect values from GC */
286  void unprotect(value *val)  void unprotect(value *val)
287  {  {
288    stackitem *iterator;    if(val==NULL || !(val->gc.flag.protect))
   
   if(!(val->gc.flag.protect))  
289      return;      return;
290    
291    val->gc.flag.protect= 0;    val->gc.flag.protect= 0;
292    
293    if(val->type==list) {    if(val->type==tcons) {
294      iterator= val->content.ptr;      unprotect(CAR(val));
295        unprotect(CDR(val));
     while(iterator!=NULL) {  
       unprotect(iterator->item);  
       iterator= iterator->next;  
     }  
296    }    }
297  }  }
298    
299  /* Push a value onto the stack */  /* Push a value onto the stack */
300  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
301  {  {
302    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
303    new_item->item= val;  
304    new_item->next= env->head;    new_value->content.c= malloc(sizeof(pair));
305    env->head= new_item;    assert(new_value->content.c!=NULL);
306      env->gc_count += sizeof(pair);
307      new_value->type= tcons;
308      CAR(new_value)= val;
309      CDR(new_value)= env->head;
310      env->head= new_value;
311  }  }
312    
313  /* Push an integer onto the stack */  /* Push an integer onto the stack */
# Line 321  void push_cstring(environment *env, cons Line 339  void push_cstring(environment *env, cons
339    int length= strlen(in_string)+1;    int length= strlen(in_string)+1;
340    
341    new_value->content.ptr= malloc(length);    new_value->content.ptr= malloc(length);
342      assert(new_value != NULL);
343    env->gc_count += length;    env->gc_count += length;
344    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
345    new_value->type= string;    new_value->type= string;
# Line 335  char *mangle_str(const char *old_string) Line 354  char *mangle_str(const char *old_string)
354    char *new_string, *current;    char *new_string, *current;
355    
356    new_string= malloc((strlen(old_string)*2)+4);    new_string= malloc((strlen(old_string)*2)+4);
357      assert(new_string != NULL);
358    strcpy(new_string, "sx_");    /* Stack eXternal */    strcpy(new_string, "sx_");    /* Stack eXternal */
359    current= new_string+3;    current= new_string+3;
360    while(old_string[0] != '\0'){    while(old_string[0] != '\0'){
# Line 352  extern void mangle(environment *env) Line 372  extern void mangle(environment *env)
372  {  {
373    char *new_string;    char *new_string;
374    
375    if((env->head)==NULL) {    if(env->head->type==empty) {
376      printerr("Too Few Arguments");      printerr("Too Few Arguments");
377      env->err= 1;      env->err= 1;
378      return;      return;
379    }    }
380    
381    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
382      printerr("Bad Argument Type");      printerr("Bad Argument Type");
383      env->err= 2;      env->err= 2;
384      return;      return;
385    }    }
386    
387    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
388        mangle_str((const char *)(CAR(env->head)->content.ptr));
389    
390    toss(env);    toss(env);
391    if(env->err) return;    if(env->err) return;
# Line 403  void push_sym(environment *env, const ch Line 424  void push_sym(environment *env, const ch
424    
425      /* Create a new symbol */      /* Create a new symbol */
426      (*new_symbol)= malloc(sizeof(symbol));      (*new_symbol)= malloc(sizeof(symbol));
427        assert((*new_symbol) != NULL);
428      (*new_symbol)->val= NULL;   /* undefined value */      (*new_symbol)->val= NULL;   /* undefined value */
429      (*new_symbol)->next= NULL;      (*new_symbol)->next= NULL;
430      (*new_symbol)->id= malloc(strlen(in_string)+1);      (*new_symbol)->id= malloc(strlen(in_string)+1);
431        assert((*new_symbol)->id != NULL);
432      strcpy((*new_symbol)->id, in_string);      strcpy((*new_symbol)->id, in_string);
433    
434      /* Intern the new symbol in the hash table */      /* Intern the new symbol in the hash table */
# Line 440  void push_sym(environment *env, const ch Line 463  void push_sym(environment *env, const ch
463  }  }
464    
465  /* Print newline. */  /* Print newline. */
466  extern void nl()  extern void nl(environment *env)
467  {  {
468    printf("\n");    printf("\n");
469  }  }
470    
471    /* Print a newline to a port */
472    extern void nlport(environment *env)
473    {
474      if(env->head->type==empty) {
475        printerr("Too Few Arguments");
476        env->err= 1;
477        return;
478      }
479    
480      if(CAR(env->head)->type!=port) {
481        printerr("Bad Argument Type");
482        env->err= 2;
483        return;
484      }
485    
486      if(fprintf(CAR(env->head)->content.p, "\n") < 0){
487        perror("nl");
488        env->err= 5;
489        return;
490      }
491      toss(env);
492    }
493    
494  /* Gets the type of a value */  /* Gets the type of a value */
495  extern void type(environment *env)  extern void type(environment *env)
496  {  {
497    int typenum;    if(env->head->type==empty) {
   
   if((env->head)==NULL) {  
498      printerr("Too Few Arguments");      printerr("Too Few Arguments");
499      env->err=1;      env->err= 1;
500      return;      return;
501    }    }
502    typenum=env->head->item->type;  
503    toss(env);    switch(CAR(env->head)->type){
504    switch(typenum){    case empty:
505        push_sym(env, "empty");
506        break;
507    case integer:    case integer:
508      push_sym(env, "integer");      push_sym(env, "integer");
509      break;      break;
# Line 473  extern void type(environment *env) Line 519  extern void type(environment *env)
519    case func:    case func:
520      push_sym(env, "function");      push_sym(env, "function");
521      break;      break;
522    case list:    case tcons:
523      push_sym(env, "list");      push_sym(env, "pair");
524        break;
525      case port:
526        push_sym(env, "port");
527      break;      break;
528    }    }
529  }        swap(env);
530      if (env->err) return;
531      toss(env);
532    }
533    
534  /* Prints the top element of the stack. */  /* Print a value */
535  void print_h(stackitem *stack_head, int noquote)  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
536  {  {
537    switch(stack_head->item->type) {    stackitem *titem, *tstack;
538      int depth;
539    
540      switch(val->type) {
541      case empty:
542        if(fprintf(stream, "[]") < 0){
543          perror("print_val");
544          env->err= 5;
545          return;
546        }
547        break;
548    case integer:    case integer:
549      printf("%d", stack_head->item->content.i);      if(fprintf(stream, "%d", val->content.i) < 0){
550          perror("print_val");
551          env->err= 5;
552          return;
553        }
554      break;      break;
555    case tfloat:    case tfloat:
556      printf("%f", stack_head->item->content.f);      if(fprintf(stream, "%f", val->content.f) < 0){
557          perror("print_val");
558          env->err= 5;
559          return;
560        }
561      break;      break;
562    case string:    case string:
563      if(noquote)      if(noquote){
564        printf("%s", (char*)stack_head->item->content.ptr);        if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){
565      else          perror("print_val");
566        printf("\"%s\"", (char*)stack_head->item->content.ptr);          env->err= 5;
567            return;
568          }
569        } else {                    /* quote */
570          if(fprintf(stream, "\"%s\"", (char*)(val->content.ptr)) < 0){
571            perror("print_val");
572            env->err= 5;
573            return;
574          }
575        }
576      break;      break;
577    case symb:    case symb:
578      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      if(fprintf(stream, "%s", val->content.sym->id) < 0){
579          perror("print_val");
580          env->err= 5;
581          return;
582        }
583      break;      break;
584    case func:    case func:
585      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      if(fprintf(stream, "#<function %p>", (funcp)(val->content.ptr)) < 0){
586          perror("print_val");
587          env->err= 5;
588          return;
589        }
590      break;      break;
591    case list:    case port:
592      /* A list is just a stack, so make stack_head point to it */      if(fprintf(stream, "#<port %p>", (funcp)(val->content.p)) < 0){
593      stack_head=(stackitem *)(stack_head->item->content.ptr);        perror("print_val");
594      printf("[ ");        env->err= 5;
595      while(stack_head != NULL) {        return;
596        print_h(stack_head, noquote);      }
597        printf(" ");      break;
598        stack_head=stack_head->next;    case tcons:
599        if(fprintf(stream, "[ ") < 0){
600          perror("print_val");
601          env->err= 5;
602          return;
603        }
604        tstack= stack;
605        do {
606          titem=malloc(sizeof(stackitem));
607          assert(titem != NULL);
608          titem->item=val;
609          titem->next=tstack;
610          tstack=titem;             /* Put it on the stack */
611          /* Search a stack of values being printed to see if we are already
612             printing this value */
613          titem=tstack;
614          depth=0;
615          while(titem != NULL && titem->item != CAR(val)){
616            titem=titem->next;
617            depth++;
618          }
619          if(titem != NULL){        /* If we found it on the stack, */
620            if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
621              perror("print_val");
622              env->err= 5;
623              free(titem);
624              return;
625            }
626          } else {
627            print_val(env, CAR(val), noquote, tstack, stream);
628          }
629          val= CDR(val);
630          switch(val->type){
631          case empty:
632            break;
633          case tcons:
634            /* Search a stack of values being printed to see if we are already
635               printing this value */
636            titem=tstack;
637            depth=0;
638            while(titem != NULL && titem->item != val){
639              titem=titem->next;
640              depth++;
641            }
642            if(titem != NULL){      /* If we found it on the stack, */
643              if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
644                perror("print_val");
645                env->err= 5;
646                goto printval_end;
647              }
648            } else {
649              if(fprintf(stream, " ") < 0){
650                perror("print_val");
651                env->err= 5;
652                goto printval_end;
653              }
654            }
655            break;
656          default:
657            if(fprintf(stream, " . ") < 0){ /* Improper list */
658              perror("print_val");
659              env->err= 5;
660              goto printval_end;
661            }
662            print_val(env, val, noquote, tstack, stream);
663          }
664        } while(val->type == tcons && titem == NULL);
665    
666      printval_end:
667    
668        titem=tstack;
669        while(titem != stack){
670          tstack=titem->next;
671          free(titem);
672          titem=tstack;
673        }
674    
675        if(! (env->err)){
676          if(fprintf(stream, " ]") < 0){
677            perror("print_val");
678            env->err= 5;
679          }
680      }      }
     printf("]");  
681      break;      break;
682    }    }
683  }  }
684    
685    /* Print the top element of the stack but don't discard it */
686  extern void print_(environment *env)  extern void print_(environment *env)
687  {  {
688    if(env->head==NULL) {    if(env->head->type==empty) {
689      printerr("Too Few Arguments");      printerr("Too Few Arguments");
690      env->err=1;      env->err= 1;
691      return;      return;
692    }    }
693    print_h(env->head, 0);    print_val(env, CAR(env->head), 0, NULL, stdout);
694    nl();    if(env->err) return;
695      nl(env);
696  }  }
697    
698  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack */
699  extern void print(environment *env)  extern void print(environment *env)
700  {  {
701    print_(env);    print_(env);
# Line 534  extern void print(environment *env) Line 703  extern void print(environment *env)
703    toss(env);    toss(env);
704  }  }
705    
706    /* Print the top element of the stack without quotes, but don't
707       discard it. */
708  extern void princ_(environment *env)  extern void princ_(environment *env)
709  {  {
710    if(env->head==NULL) {    if(env->head->type==empty) {
711      printerr("Too Few Arguments");      printerr("Too Few Arguments");
712      env->err=1;      env->err= 1;
713      return;      return;
714    }    }
715    print_h(env->head, 1);    print_val(env, CAR(env->head), 1, NULL, stdout);
716  }  }
717    
718  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack without quotes. */
719  extern void princ(environment *env)  extern void princ(environment *env)
720  {  {
721    princ_(env);    princ_(env);
# Line 552  extern void princ(environment *env) Line 723  extern void princ(environment *env)
723    toss(env);    toss(env);
724  }  }
725    
726  /* Only to be called by function printstack. */  /* Print a value to a port, but don't discard it */
727  void print_st(stackitem *stack_head, long counter)  extern void printport_(environment *env)
728    {
729      if(env->head->type==empty ||  CDR(env->head)->type == empty) {
730        printerr("Too Few Arguments");
731        env->err= 1;
732        return;
733      }
734    
735      if(CAR(env->head)->type!=port) {
736        printerr("Bad Argument Type");
737        env->err= 2;
738        return;
739      }
740    
741      print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p);
742      if(env->err) return;
743      nlport(env);
744    }
745    
746    /* Print a value to a port */
747    extern void printport(environment *env)
748    {
749      printport_(env);
750      if(env->err) return;
751      toss(env);
752    }
753    
754    /* Print, without quotes, to a port, a value, but don't discard it. */
755    extern void princport_(environment *env)
756    {
757      if(env->head->type==empty ||  CDR(env->head)->type == empty) {
758        printerr("Too Few Arguments");
759        env->err= 1;
760        return;
761      }
762    
763      if(CAR(env->head)->type!=port) {
764        printerr("Bad Argument Type");
765        env->err= 2;
766        return;
767      }
768    
769      print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p);
770      toss(env); if(env->err) return;
771    }
772    
773    /* Print, without quotes, to a port, the top element. */
774    extern void princport(environment *env)
775    {
776      princport_(env);
777      if(env->err) return;
778      toss(env);
779    }
780    
781    /* Only to be called by itself function printstack. */
782    void print_st(environment *env, value *stack_head, long counter)
783  {  {
784    if(stack_head->next != NULL)    if(CDR(stack_head)->type != empty)
785      print_st(stack_head->next, counter+1);      print_st(env, CDR(stack_head), counter+1);
786    printf("%ld: ", counter);    printf("%ld: ", counter);
787    print_h(stack_head, 0);    print_val(env, CAR(stack_head), 0, NULL, stdout);
788    nl();    nl(env);
789  }  }
790    
791  /* Prints the stack. */  /* Prints the stack. */
792  extern void printstack(environment *env)  extern void printstack(environment *env)
793  {  {
794    if(env->head == NULL) {    if(env->head->type == empty) {
795      printf("Stack Empty\n");      printf("Stack Empty\n");
796      return;      return;
797    }    }
798    
799    print_st(env->head, 1);    print_st(env, env->head, 1);
800  }  }
801    
802  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
803  extern void swap(environment *env)  extern void swap(environment *env)
804  {  {
805    stackitem *temp= env->head;    value *temp= env->head;
806        
807    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
808      printerr("Too Few Arguments");      printerr("Too Few Arguments");
809      env->err=1;      env->err=1;
810      return;      return;
811    }    }
812    
813    env->head= env->head->next;    env->head= CDR(env->head);
814    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
815    env->head->next= temp;    CDR(env->head)= temp;
816  }  }
817    
818  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
819  extern void rot(environment *env)  extern void rot(environment *env)
820  {  {
821    stackitem *temp= env->head;    value *temp= env->head;
822        
823    if(env->head==NULL || env->head->next==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
824        || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type == empty) {
825      printerr("Too Few Arguments");      printerr("Too Few Arguments");
826      env->err=1;      env->err= 1;
827      return;      return;
828    }    }
829      
830    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
831    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
832    env->head->next= temp;    CDR(env->head)= temp;
833  }  }
834    
835  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 611  extern void rcl(environment *env) Line 837  extern void rcl(environment *env)
837  {  {
838    value *val;    value *val;
839    
840    if(env->head == NULL) {    if(env->head->type==empty) {
841      printerr("Too Few Arguments");      printerr("Too Few Arguments");
842      env->err=1;      env->err= 1;
843      return;      return;
844    }    }
845    
846    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
847      printerr("Bad Argument Type");      printerr("Bad Argument Type");
848      env->err=2;      env->err= 2;
849      return;      return;
850    }    }
851    
852    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
853    if(val == NULL){    if(val == NULL){
854      printerr("Unbound Variable");      printerr("Unbound Variable");
855      env->err=3;      env->err= 3;
856      return;      return;
857    }    }
858    protect(val);    push_val(env, val);           /* Return the symbol's bound value */
859    toss(env);            /* toss the symbol */    swap(env);
860      if(env->err) return;
861      toss(env);                    /* toss the symbol */
862    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(val);  
863  }  }
864    
865  /* 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 643  extern void eval(environment *env) Line 869  extern void eval(environment *env)
869  {  {
870    funcp in_func;    funcp in_func;
871    value* temp_val;    value* temp_val;
872    stackitem* iterator;    value* iterator;
873    
874   eval_start:   eval_start:
875    
876    gc_maybe(env);    gc_maybe(env);
877    
878    if(env->head==NULL) {    if(env->head->type==empty) {
879      printerr("Too Few Arguments");      printerr("Too Few Arguments");
880      env->err=1;      env->err= 1;
881      return;      return;
882    }    }
883    
884    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
885      /* if it's a symbol */      /* if it's a symbol */
886    case symb:    case symb:
887      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
888      if(env->err) return;      if(env->err) return;
889      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
890        goto eval_start;        goto eval_start;
891      }      }
892      return;      return;
893    
894      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
895    case func:    case func:
896      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
897      toss(env);      toss(env);
898      if(env->err) return;      if(env->err) return;
899      return in_func(env);      return in_func(env);
900    
901      /* If it's a list */      /* If it's a list */
902    case list:    case tcons:
903      temp_val= env->head->item;      temp_val= CAR(env->head);
904      protect(temp_val);      protect(temp_val);
905    
906      toss(env); if(env->err) return;      toss(env); if(env->err) return;
907      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
908            
909      while(iterator!=NULL) {      while(iterator->type != empty) {
910        push_val(env, iterator->item);        push_val(env, CAR(iterator));
911                
912        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
913           && (((symbol*)(env->head->item->content.ptr))->id[0] == ';')) {           && CAR(env->head)->content.sym->id[0]==';') {
914          toss(env);          toss(env);
915          if(env->err) return;          if(env->err) return;
916                    
917          if(iterator->next == NULL){          if(CDR(iterator)->type == empty){
918            goto eval_start;            goto eval_start;
919          }          }
920          eval(env);          eval(env);
921          if(env->err) return;          if(env->err) return;
922        }        }
923        iterator= iterator->next;        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
924            iterator= CDR(iterator);
925          else {
926            printerr("Bad Argument Type"); /* Improper list */
927            env->err= 2;
928            return;
929          }
930      }      }
931      unprotect(temp_val);      unprotect(temp_val);
932      return;      return;
933    
934    default:    case empty:
935        toss(env);
936      case integer:
937      case tfloat:
938      case string:
939      case port:
940      return;      return;
941    }    }
942  }  }
# Line 707  extern void eval(environment *env) Line 944  extern void eval(environment *env)
944  /* Reverse (flip) a list */  /* Reverse (flip) a list */
945  extern void rev(environment *env)  extern void rev(environment *env)
946  {  {
947    stackitem *old_head, *new_head, *item;    value *old_head, *new_head, *item;
948    
949    if((env->head)==NULL) {    if(env->head->type==empty) {
950      printerr("Too Few Arguments");      printerr("Too Few Arguments");
951      env->err= 1;      env->err= 1;
952      return;      return;
953    }    }
954    
955    if(env->head->item->type!=list) {    if(CAR(env->head)->type==empty)
956        return;                     /* Don't reverse an empty list */
957    
958      if(CAR(env->head)->type!=tcons) {
959      printerr("Bad Argument Type");      printerr("Bad Argument Type");
960      env->err= 2;      env->err= 2;
961      return;      return;
962    }    }
963    
964    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
965    new_head= NULL;    new_head= new_val(env);
966    while(old_head != NULL){    while(old_head->type != empty) {
967      item= old_head;      item= old_head;
968      old_head= old_head->next;      old_head= CDR(old_head);
969      item->next= new_head;      CDR(item)= new_head;
970      new_head= item;      new_head= item;
971    }    }
972    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
973  }  }
974    
975  /* Make a list. */  /* Make a list. */
976  extern void pack(environment *env)  extern void pack(environment *env)
977  {  {
978    stackitem *iterator, *temp;    value *iterator, *temp, *ending;
   value *pack;  
979    
980    iterator= env->head;    ending=new_val(env);
   pack= new_val(env);  
   protect(pack);  
981    
982    if(iterator==NULL    iterator= env->head;
983       || (iterator->item->type==symb    if(iterator->type == empty
984       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       || (CAR(iterator)->type==symb
985      temp= NULL;       && CAR(iterator)->content.sym->id[0]=='[')) {
986        temp= ending;
987      toss(env);      toss(env);
988    } else {    } else {
989      /* Search for first delimiter */      /* Search for first delimiter */
990      while(iterator->next!=NULL      while(CDR(iterator)->type != empty
991            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
992            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
993        iterator= iterator->next;        iterator= CDR(iterator);
994            
995      /* Extract list */      /* Extract list */
996      temp= env->head;      temp= env->head;
997      env->head= iterator->next;      env->head= CDR(iterator);
998      iterator->next= NULL;      CDR(iterator)= ending;
999    
1000      pack->type= list;      if(env->head->type != empty)
     pack->content.ptr= temp;  
       
     if(env->head!=NULL)  
1001        toss(env);        toss(env);
1002    }    }
1003    
1004    /* Push list */    /* Push list */
1005    
1006    push_val(env, pack);    push_val(env, temp);
1007    rev(env);    rev(env);
   
   unprotect(pack);  
1008  }  }
1009    
1010  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
1011  extern void expand(environment *env)  extern void expand(environment *env)
1012  {  {
1013    stackitem *temp, *new_head;    value *temp, *new_head;
1014    
1015    /* Is top element a list? */    /* Is top element a list? */
1016    if(env->head==NULL) {    if(env->head->type==empty) {
1017      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1018      env->err= 1;      env->err= 1;
1019      return;      return;
1020    }    }
1021    if(env->head->item->type!=list) {  
1022      if(CAR(env->head)->type!=tcons) {
1023      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1024      env->err= 2;      env->err= 2;
1025      return;      return;
# Line 797  extern void expand(environment *env) Line 1031  extern void expand(environment *env)
1031      return;      return;
1032    
1033    /* The first list element is the new stack head */    /* The first list element is the new stack head */
1034    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
1035    
1036    toss(env);    toss(env);
1037    
1038    /* Find the end of the list */    /* Find the end of the list */
1039    while(temp->next!=NULL)    while(CDR(temp)->type != empty) {
1040      temp= temp->next;      if (CDR(temp)->type == tcons)
1041          temp= CDR(temp);
1042        else {
1043          printerr("Bad Argument Type"); /* Improper list */
1044          env->err= 2;
1045          return;
1046        }
1047      }
1048    
1049    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
1050    temp->next= env->head;    CDR(temp)= env->head;
1051    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
1052    
1053  }  }
# Line 815  extern void expand(environment *env) Line 1056  extern void expand(environment *env)
1056  extern void eq(environment *env)  extern void eq(environment *env)
1057  {  {
1058    void *left, *right;    void *left, *right;
   int result;  
1059    
1060    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1061      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1062      env->err= 1;      env->err= 1;
1063      return;      return;
1064    }    }
1065    
1066    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
1067    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
1068    toss(env); toss(env);    toss(env); toss(env);
1069    push_int(env, result);  
1070      push_int(env, left==right);
1071  }  }
1072    
1073  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 837  extern void not(environment *env) Line 1075  extern void not(environment *env)
1075  {  {
1076    int val;    int val;
1077    
1078    if((env->head)==NULL) {    if(env->head->type==empty) {
1079      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1080      env->err= 1;      env->err= 1;
1081      return;      return;
1082    }    }
1083    
1084    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1085      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1086      env->err= 2;      env->err= 2;
1087      return;      return;
1088    }    }
1089    
1090    val= env->head->item->content.i;    val= CAR(env->head)->content.i;
1091    toss(env);    toss(env);
1092    push_int(env, !val);    push_int(env, !val);
1093  }  }
# Line 868  extern void def(environment *env) Line 1106  extern void def(environment *env)
1106    symbol *sym;    symbol *sym;
1107    
1108    /* 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 */
1109    if(env->head==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1110      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1111      env->err= 1;      env->err= 1;
1112      return;      return;
1113    }    }
1114    
1115    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
1116      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1117      env->err= 2;      env->err= 2;
1118      return;      return;
1119    }    }
1120    
1121    /* long names are a pain */    /* long names are a pain */
1122    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
1123    
1124    /* Bind the symbol to the value */    /* Bind the symbol to the value */
1125    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
1126    
1127    toss(env); toss(env);    toss(env); toss(env);
1128  }  }
# Line 907  extern void quit(environment *env) Line 1145  extern void quit(environment *env)
1145    env->gc_limit= 0;    env->gc_limit= 0;
1146    gc_maybe(env);    gc_maybe(env);
1147    
1148      words(env);
1149    
1150    if(env->free_string!=NULL)    if(env->free_string!=NULL)
1151      free(env->free_string);      free(env->free_string);
1152        
1153    #ifdef __linux__
1154    muntrace();    muntrace();
1155    #endif
1156    
1157    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
1158  }  }
# Line 918  extern void quit(environment *env) Line 1160  extern void quit(environment *env)
1160  /* Clear stack */  /* Clear stack */
1161  extern void clear(environment *env)  extern void clear(environment *env)
1162  {  {
1163    while(env->head!=NULL)    while(env->head->type != empty)
1164      toss(env);      toss(env);
1165  }  }
1166    
# Line 931  extern void words(environment *env) Line 1173  extern void words(environment *env)
1173    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
1174      temp= env->symbols[i];      temp= env->symbols[i];
1175      while(temp!=NULL) {      while(temp!=NULL) {
1176    #ifdef DEBUG
1177          if (temp->val != NULL && temp->val->gc.flag.protect)
1178            printf("(protected) ");
1179    #endif /* DEBUG */
1180        printf("%s\n", temp->id);        printf("%s\n", temp->id);
1181        temp= temp->next;        temp= temp->next;
1182      }      }
# Line 953  void forget_sym(symbol **hash_entry) Line 1199  void forget_sym(symbol **hash_entry)
1199  extern void forget(environment *env)  extern void forget(environment *env)
1200  {  {
1201    char* sym_id;    char* sym_id;
   stackitem *stack_head= env->head;  
1202    
1203    if(stack_head==NULL) {    if(env->head->type==empty) {
1204      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1205      env->err=1;      env->err= 1;
1206      return;      return;
1207    }    }
1208        
1209    if(stack_head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
1210      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1211      env->err=2;      env->err= 2;
1212      return;      return;
1213    }    }
1214    
1215    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(env->head)->content.sym->id;
1216    toss(env);    toss(env);
1217    
1218    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 985  int main(int argc, char **argv) Line 1230  int main(int argc, char **argv)
1230    
1231    int c;                        /* getopt option character */    int c;                        /* getopt option character */
1232    
1233    #ifdef __linux__
1234    mtrace();    mtrace();
1235    #endif
1236    
1237    init_env(&myenv);    init_env(&myenv);
1238    
# Line 999  int main(int argc, char **argv) Line 1246  int main(int argc, char **argv)
1246          break;          break;
1247        case '?':        case '?':
1248          fprintf (stderr,          fprintf (stderr,
1249                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1250                   optopt);                   optopt);
1251          return EX_USAGE;          return EX_USAGE;
1252        default:        default:
# Line 1018  int main(int argc, char **argv) Line 1265  int main(int argc, char **argv)
1265    if(myenv.interactive) {    if(myenv.interactive) {
1266      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1267  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1268  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1269  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1270  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1271    }    }
1272    
1273    while(1) {    while(1) {
# Line 1028  under certain conditions; type `copying; Line 1275  under certain conditions; type `copying;
1275        if (myenv.interactive) {        if (myenv.interactive) {
1276          if(myenv.err) {          if(myenv.err) {
1277            printf("(error %d)\n", myenv.err);            printf("(error %d)\n", myenv.err);
1278              myenv.err= 0;
1279          }          }
1280          nl();          nl(&myenv);
1281          printstack(&myenv);          printstack(&myenv);
1282          printf("> ");          printf("> ");
1283        }        }
1284        myenv.err=0;        myenv.err=0;
1285      }      }
1286      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1287      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1288        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1289      } else if(myenv.head!=NULL        quit(&myenv);
1290                && myenv.head->item->type==symb      } else if(myenv.head->type!=empty
1291                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->type==symb
1292                  && CAR(myenv.head)->content.sym->id[0] == ';') {
1293        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1294        eval(&myenv);        eval(&myenv);
1295      }      }
# Line 1059  extern void sx_2b(environment *env) Line 1308  extern void sx_2b(environment *env)
1308    char* new_string;    char* new_string;
1309    value *a_val, *b_val;    value *a_val, *b_val;
1310    
1311    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1312      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1313      env->err= 1;      env->err= 1;
1314      return;      return;
1315    }    }
1316    
1317    if(env->head->item->type==string    if(CAR(env->head)->type==string
1318       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1319      a_val= env->head->item;      a_val= CAR(env->head);
1320      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1321      protect(a_val); protect(b_val);      protect(a_val); protect(b_val);
1322      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1323      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1324      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
1325      new_string= malloc(len);      new_string= malloc(len);
1326        assert(new_string != NULL);
1327      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1328      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1329      push_cstring(env, new_string);      push_cstring(env, new_string);
# Line 1083  extern void sx_2b(environment *env) Line 1333  extern void sx_2b(environment *env)
1333      return;      return;
1334    }    }
1335        
1336    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1337       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1338      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1339      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1340      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1341      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1342      push_int(env, b+a);      push_int(env, b+a);
1343    
1344      return;      return;
1345    }    }
1346    
1347    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1348       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1349      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1350      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1351      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1352      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1353      push_float(env, fb+fa);      push_float(env, fb+fa);
1354            
1355      return;      return;
1356    }    }
1357    
1358    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1359       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1360      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1361      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1362      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1363      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1364      push_float(env, b+fa);      push_float(env, b+fa);
1365            
1366      return;      return;
1367    }    }
1368    
1369    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1370       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1371      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1372      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1373      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1374      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1375      push_float(env, fb+a);      push_float(env, fb+a);
1376    
# Line 1137  extern void sx_2d(environment *env) Line 1387  extern void sx_2d(environment *env)
1387    int a, b;    int a, b;
1388    float fa, fb;    float fa, fb;
1389    
1390    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1391      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1392      env->err=1;      env->err=1;
1393      return;      return;
1394    }    }
1395        
1396    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1397       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1398      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1399      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1400      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1401      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1402      push_int(env, b-a);      push_int(env, b-a);
1403    
1404      return;      return;
1405    }    }
1406    
1407    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1408       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1409      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1410      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1411      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1412      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1413      push_float(env, fb-fa);      push_float(env, fb-fa);
1414            
1415      return;      return;
1416    }    }
1417    
1418    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1419       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1420      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1421      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1422      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1423      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1424      push_float(env, b-fa);      push_float(env, b-fa);
1425            
1426      return;      return;
1427    }    }
1428    
1429    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1430       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1431      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1432      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1433      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1434      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1435      push_float(env, fb-a);      push_float(env, fb-a);
1436    
# Line 1197  extern void sx_3e(environment *env) Line 1447  extern void sx_3e(environment *env)
1447    int a, b;    int a, b;
1448    float fa, fb;    float fa, fb;
1449    
1450    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || 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->item->type==integer    if(CAR(env->head)->type==integer
1457       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1458      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1459      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1460      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1461      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1462      push_int(env, b>a);      push_int(env, b>a);
1463    
1464      return;      return;
1465    }    }
1466    
1467    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1468       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1469      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1470      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1471      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1472      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1473      push_int(env, fb>fa);      push_int(env, fb>fa);
1474            
1475      return;      return;
1476    }    }
1477    
1478    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1479       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1480      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1481      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1482      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1483      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1484      push_int(env, b>fa);      push_int(env, b>fa);
1485            
1486      return;      return;
1487    }    }
1488    
1489    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1490       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1491      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1492      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1493      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1494      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1495      push_int(env, fb>a);      push_int(env, fb>a);
1496    
# Line 1248  extern void sx_3e(environment *env) Line 1498  extern void sx_3e(environment *env)
1498    }    }
1499    
1500    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1501    env->err=2;    env->err= 2;
1502  }  }
1503    
1504  /* "<" */  /* "<" */
# Line 1275  extern void sx_3e3d(environment *env) Line 1525  extern void sx_3e3d(environment *env)
1525  /* Return copy of a value */  /* Return copy of a value */
1526  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
1527  {  {
   stackitem *old_item, *new_item, *prev_item;  
1528    value *new_value;    value *new_value;
1529    
1530    protect(old_value);    if(old_value==NULL)
1531        return NULL;
1532    
1533    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
1534    new_value->type= old_value->type;    new_value->type= old_value->type;
1535    
1536    switch(old_value->type){    switch(old_value->type){
# Line 1288  value *copy_val(environment *env, value Line 1538  value *copy_val(environment *env, value
1538    case integer:    case integer:
1539    case func:    case func:
1540    case symb:    case symb:
1541      case empty:
1542      case port:
1543      new_value->content= old_value->content;      new_value->content= old_value->content;
1544      break;      break;
1545    case string:    case string:
1546      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1547        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1548      break;      break;
1549    case list:    case tcons:
     new_value->content.ptr= NULL;  
1550    
1551      prev_item= NULL;      new_value->content.c= malloc(sizeof(pair));
1552      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
1553        env->gc_count += sizeof(pair);
1554    
1555      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1556        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;  
     }      
1557      break;      break;
1558    }    }
1559    
   unprotect(old_value); unprotect(new_value);  
   
1560    return new_value;    return new_value;
1561  }  }
1562    
1563  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1564  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1565  {  {
1566    if((env->head)==NULL) {    if(env->head->type==empty) {
1567      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1568      env->err= 1;      env->err= 1;
1569      return;      return;
1570    }    }
1571    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1572  }  }
1573    
1574  /* "if", If-Then */  /* "if", If-Then */
# Line 1336  extern void sx_6966(environment *env) Line 1576  extern void sx_6966(environment *env)
1576  {  {
1577    int truth;    int truth;
1578    
1579    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1580      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1581      env->err= 1;      env->err= 1;
1582      return;      return;
1583    }    }
1584    
1585    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1586      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1587      env->err=2;      env->err= 2;
1588      return;      return;
1589    }    }
1590        
1591    swap(env);    swap(env);
1592    if(env->err) return;    if(env->err) return;
1593        
1594    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1595    
1596    toss(env);    toss(env);
1597    if(env->err) return;    if(env->err) return;
# Line 1367  extern void ifelse(environment *env) Line 1607  extern void ifelse(environment *env)
1607  {  {
1608    int truth;    int truth;
1609    
1610    if((env->head)==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1611       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1612      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1613      env->err=1;      env->err= 1;
1614      return;      return;
1615    }    }
1616    
1617    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1618      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1619      env->err=2;      env->err= 2;
1620      return;      return;
1621    }    }
1622        
1623    rot(env);    rot(env);
1624    if(env->err) return;    if(env->err) return;
1625        
1626    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1627    
1628    toss(env);    toss(env);
1629    if(env->err) return;    if(env->err) return;
# Line 1398  extern void ifelse(environment *env) Line 1638  extern void ifelse(environment *env)
1638    eval(env);    eval(env);
1639  }  }
1640    
1641    /* "else" */
1642    extern void sx_656c7365(environment *env)
1643    {
1644      if(env->head->type==empty || CDR(env->head)->type==empty
1645         || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1646         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1647        printerr("Too Few Arguments");
1648        env->err= 1;
1649        return;
1650      }
1651    
1652      if(CAR(CDR(env->head))->type!=symb
1653         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1654         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1655         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1656        printerr("Bad Argument Type");
1657        env->err= 2;
1658        return;
1659      }
1660    
1661      swap(env); toss(env); rot(env); toss(env);
1662      ifelse(env);
1663    }
1664    
1665    extern void then(environment *env)
1666    {
1667      if(env->head->type==empty || CDR(env->head)->type==empty
1668         || CDR(CDR(env->head))->type==empty) {
1669        printerr("Too Few Arguments");
1670        env->err= 1;
1671        return;
1672      }
1673    
1674      if(CAR(CDR(env->head))->type!=symb
1675         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1676        printerr("Bad Argument Type");
1677        env->err= 2;
1678        return;
1679      }
1680    
1681      swap(env); toss(env);
1682      sx_6966(env);
1683    }
1684    
1685  /* "while" */  /* "while" */
1686  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1687  {  {
1688    int truth;    int truth;
1689    value *loop, *test;    value *loop, *test;
1690    
1691    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1692      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1693      env->err=1;      env->err= 1;
1694      return;      return;
1695    }    }
1696    
1697    loop= env->head->item;    loop= CAR(env->head);
1698    protect(loop);    protect(loop);
1699    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1700    
1701    test= env->head->item;    test= CAR(env->head);
1702    protect(test);    protect(test);
1703    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1704    
# Line 1422  extern void sx_7768696c65(environment *e Line 1706  extern void sx_7768696c65(environment *e
1706      push_val(env, test);      push_val(env, test);
1707      eval(env);      eval(env);
1708            
1709      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1710        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1711        env->err= 2;        env->err= 2;
1712        return;        return;
1713      }      }
1714            
1715      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1716      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1717            
1718      if(truth) {      if(truth) {
# Line 1450  extern void sx_666f72(environment *env) Line 1734  extern void sx_666f72(environment *env)
1734    value *loop;    value *loop;
1735    int foo1, foo2;    int foo1, foo2;
1736    
1737    if(env->head==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1738       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1739      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1740      env->err= 1;      env->err= 1;
1741      return;      return;
1742    }    }
1743    
1744    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1745       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1746      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1747      env->err= 2;      env->err= 2;
1748      return;      return;
1749    }    }
1750    
1751    loop= env->head->item;    loop= CAR(env->head);
1752    protect(loop);    protect(loop);
1753    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1754    
1755    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1756    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1757    
1758    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1759    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1760    
1761    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1496  extern void sx_666f72(environment *env) Line 1780  extern void sx_666f72(environment *env)
1780  extern void foreach(environment *env)  extern void foreach(environment *env)
1781  {    {  
1782    value *loop, *foo;    value *loop, *foo;
1783    stackitem *iterator;    value *iterator;
1784        
1785    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1786      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1787      env->err= 1;      env->err= 1;
1788      return;      return;
1789    }    }
1790    
1791    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1792      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1793      env->err= 2;      env->err= 2;
1794      return;      return;
1795    }    }
1796    
1797    loop= env->head->item;    loop= CAR(env->head);
1798    protect(loop);    protect(loop);
1799    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1800    
1801    foo= env->head->item;    foo= CAR(env->head);
1802    protect(foo);    protect(foo);
1803    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1804    
1805    iterator= foo->content.ptr;    iterator= foo;
1806    
1807    while(iterator!=NULL) {    while(iterator->type!=empty) {
1808      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1809      push_val(env, loop);      push_val(env, loop);
1810      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1811      iterator= iterator->next;      if (iterator->type == tcons){
1812          iterator= CDR(iterator);
1813        } else {
1814          printerr("Bad Argument Type"); /* Improper list */
1815          env->err= 2;
1816          break;
1817        }
1818    }    }
1819    unprotect(loop); unprotect(foo);    unprotect(loop); unprotect(foo);
1820  }  }
# Line 1533  extern void foreach(environment *env) Line 1823  extern void foreach(environment *env)
1823  extern void to(environment *env)  extern void to(environment *env)
1824  {  {
1825    int ending, start, i;    int ending, start, i;
1826    stackitem *iterator, *temp;    value *iterator, *temp, *end;
1827    value *pack;  
1828      end= new_val(env);
1829    
1830    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1831      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1832      env->err=1;      env->err= 1;
1833      return;      return;
1834    }    }
1835    
1836    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1837       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1838      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1839      env->err=2;      env->err= 2;
1840      return;      return;
1841    }    }
1842    
1843    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1844    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1845    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1846    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1847    
1848    push_sym(env, "[");    push_sym(env, "[");
# Line 1565  extern void to(environment *env) Line 1856  extern void to(environment *env)
1856    }    }
1857    
1858    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(pack);  
1859    
1860    if(iterator==NULL    if(iterator->type==empty
1861       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
1862       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1863      temp= NULL;      temp= end;
1864      toss(env);      toss(env);
1865    } else {    } else {
1866      /* Search for first delimiter */      /* Search for first delimiter */
1867      while(iterator->next!=NULL      while(CDR(iterator)->type!=empty
1868            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
1869            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1870        iterator= iterator->next;        iterator= CDR(iterator);
1871            
1872      /* Extract list */      /* Extract list */
1873      temp= env->head;      temp= env->head;
1874      env->head= iterator->next;      env->head= CDR(iterator);
1875      iterator->next= NULL;      CDR(iterator)= end;
1876    
1877      pack->type= list;      if(env->head->type!=empty)
     pack->content.ptr= temp;  
       
     if(env->head!=NULL)  
1878        toss(env);        toss(env);
1879    }    }
1880    
1881    /* Push list */    /* Push list */
1882      push_val(env, temp);
   push_val(env, pack);  
   
   unprotect(pack);  
1883  }  }
1884    
1885  /* Read a string */  /* Read a string */
1886  extern void readline(environment *env)  extern void readline(environment *env)
1887  {  {
1888      readlinestream(env, env->inputstream);
1889    }
1890    
1891    /* Read a string from a port */
1892    extern void readlineport(environment *env)
1893    {
1894      FILE *stream;
1895    
1896      if(env->head->type==empty) {
1897        printerr("Too Few Arguments");
1898        env->err= 1;
1899        return;
1900      }
1901    
1902      if(CAR(env->head)->type!=port) {
1903        printerr("Bad Argument Type");
1904        env->err= 2;
1905        return;
1906      }
1907    
1908      stream=CAR(env->head)->content.p;
1909      readlinestream(env, stream); if(env->err) return;
1910    
1911      swap(env); if(env->err) return;
1912      toss(env);
1913    }
1914    
1915    /* read a line from a stream; used by readline */
1916    void readlinestream(environment *env, FILE *stream)
1917    {
1918    char in_string[101];    char in_string[101];
1919    
1920    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, stream)==NULL) {
1921      push_cstring(env, "");      push_cstring(env, "");
1922    else      if (! feof(stream)){
1923          perror("readline");
1924          env->err= 5;
1925        }
1926      } else {
1927      push_cstring(env, in_string);      push_cstring(env, in_string);
1928      }
1929  }  }
1930    
1931  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1932  extern void sx_72656164(environment *env)  extern void sx_72656164(environment *env)
1933  {  {
1934      readstream(env, env->inputstream);
1935    }
1936    
1937    /* "readport"; Read a value from a port and place on stack */
1938    extern void readport(environment *env)
1939    {
1940      FILE *stream;
1941    
1942      if(env->head->type==empty) {
1943        printerr("Too Few Arguments");
1944        env->err= 1;
1945        return;
1946      }
1947    
1948      if(CAR(env->head)->type!=port) {
1949        printerr("Bad Argument Type");
1950        env->err= 2;
1951        return;
1952      }
1953    
1954      stream=CAR(env->head)->content.p;
1955      readstream(env, stream); if(env->err) return;
1956    
1957      swap(env); if(env->err) return;
1958      toss(env);
1959    }
1960    
1961    /* read from a stream; used by "read" and "readport" */
1962    void readstream(environment *env, FILE *stream)
1963    {
1964    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1965    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1966    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1626  extern void sx_72656164(environment *env Line 1974  extern void sx_72656164(environment *env
1974    int count= -1;    int count= -1;
1975    float ftemp;    float ftemp;
1976    static int depth= 0;    static int depth= 0;
1977    char *match, *ctemp;    char *match;
1978    size_t inlength;    size_t inlength;
1979    
1980    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1635  extern void sx_72656164(environment *env Line 1983  extern void sx_72656164(environment *env
1983      }      }
1984      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1985    
1986      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1987        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1988        return;        return;
1989      }      }
1990            
1991      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1992        assert(env->in_string != NULL);
1993      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1994      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1995      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1996    }    }
1997        
1998    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1999    match= malloc(inlength);    match= malloc(inlength);
2000      assert(match != NULL);
2001    
2002    if(sscanf(env->in_string, blankform, &readlength) != EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
2003       && readlength != -1) {       && readlength != -1) {
# Line 1660  extern void sx_72656164(environment *env Line 2010  extern void sx_72656164(environment *env
2010      } else {      } else {
2011        push_float(env, ftemp);        push_float(env, ftemp);
2012      }      }
2013      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
2014                && readlength != -1) {
2015        push_cstring(env, "");
2016    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
2017              && readlength != -1) {              && readlength != -1) {
2018      push_cstring(env, match);      push_cstring(env, match);
# Line 1691  extern void sx_72656164(environment *env Line 2044  extern void sx_72656164(environment *env
2044      return sx_72656164(env);      return sx_72656164(env);
2045  }  }
2046    
2047    #ifdef __linux__
2048  extern void beep(environment *env)  extern void beep(environment *env)
2049  {  {
2050    int freq, dur, period, ticks;    int freq, dur, period, ticks;
2051    
2052    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2053      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2054      env->err=1;      env->err= 1;
2055      return;      return;
2056    }    }
2057    
2058    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
2059       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
2060      printerr("Bad Argument Type");      printerr("Bad Argument Type");
2061      env->err=2;      env->err= 2;
2062      return;      return;
2063    }    }
2064    
2065    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
2066    toss(env);    toss(env);
2067    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
2068    toss(env);    toss(env);
2069    
2070    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
2071                                     length */                                     length */
2072    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
2073                                     timer ticks */                                     timer ticks */
2074    
2075  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
2076    
2077    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
2078    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
2079    case 0:    case 0:
2080      usleep(dur);      usleep(dur);
2081      return;      return;
2082    case -1:    case -1:
2083      perror("beep");      perror("beep");
2084      env->err=5;      env->err= 5;
2085      return;      return;
2086    default:    default:
2087      abort();      abort();
2088    }    }
2089  }  }
2090    #endif /* __linux__ */
2091    
2092  /* "wait" */  /* "wait" */
2093  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
2094  {  {
2095    int dur;    int dur;
2096    
2097    if((env->head)==NULL) {    if(env->head->type==empty) {
2098      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2099      env->err=1;      env->err= 1;
2100      return;      return;
2101    }    }
2102    
2103    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
2104      printerr("Bad Argument Type");      printerr("Bad Argument Type");
2105      env->err=2;      env->err= 2;
2106      return;      return;
2107    }    }
2108    
2109    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
2110    toss(env);    toss(env);
2111    
2112    usleep(dur);    usleep(dur);
# Line 1759  extern void sx_77616974(environment *env Line 2114  extern void sx_77616974(environment *env
2114    
2115  extern void copying(environment *env)  extern void copying(environment *env)
2116  {  {
2117    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
2118                         Version 2, June 1991\n\                         Version 2, June 1991\n\
2119  \n\  \n\
2120   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2048  extern void sx_2a(environment *env) Line 2403  extern void sx_2a(environment *env)
2403    int a, b;    int a, b;
2404    float fa, fb;    float fa, fb;
2405    
2406    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2407      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2408      env->err=1;      env->err= 1;
2409      return;      return;
2410    }    }
2411        
2412    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2413       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2414      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2415      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2416      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2417      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2418      push_int(env, b*a);      push_int(env, b*a);
2419    
2420      return;      return;
2421    }    }
2422    
2423    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2424       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2425      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2426      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2427      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2428      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2429      push_float(env, fb*fa);      push_float(env, fb*fa);
2430            
2431      return;      return;
2432    }    }
2433    
2434    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2435       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2436      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2437      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2438      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2439      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2440      push_float(env, b*fa);      push_float(env, b*fa);
2441            
2442      return;      return;
2443    }    }
2444    
2445    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2446       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2447      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2448      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2449      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2450      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2451      push_float(env, fb*a);      push_float(env, fb*a);
2452    
# Line 2099  extern void sx_2a(environment *env) Line 2454  extern void sx_2a(environment *env)
2454    }    }
2455    
2456    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2457    env->err=2;    env->err= 2;
2458  }  }
2459    
2460  /* "/" */  /* "/" */
# Line 2108  extern void sx_2f(environment *env) Line 2463  extern void sx_2f(environment *env)
2463    int a, b;    int a, b;
2464    float fa, fb;    float fa, fb;
2465    
2466    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2467      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2468      env->err=1;      env->err= 1;
2469      return;      return;
2470    }    }
2471        
2472    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2473       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2474      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2475      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2476      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2477      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2478      push_float(env, b/a);      push_float(env, b/a);
2479    
2480      return;      return;
2481    }    }
2482    
2483    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2484       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2485      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2486      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2487      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2488      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2489      push_float(env, fb/fa);      push_float(env, fb/fa);
2490            
2491      return;      return;
2492    }    }
2493    
2494    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2495       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2496      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2497      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2498      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2499      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2500      push_float(env, b/fa);      push_float(env, b/fa);
2501            
2502      return;      return;
2503    }    }
2504    
2505    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2506       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2507      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2508      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2509      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2510      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2511      push_float(env, fb/a);      push_float(env, fb/a);
2512    
# Line 2159  extern void sx_2f(environment *env) Line 2514  extern void sx_2f(environment *env)
2514    }    }
2515    
2516    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2517    env->err=2;    env->err= 2;
2518  }  }
2519    
2520  /* "mod" */  /* "mod" */
# Line 2167  extern void mod(environment *env) Line 2522  extern void mod(environment *env)
2522  {  {
2523    int a, b;    int a, b;
2524    
2525    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2526      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2527      env->err= 1;      env->err= 1;
2528      return;      return;
2529    }    }
2530        
2531    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2532       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2533      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2534      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2535      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2536      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2537      push_int(env, b%a);      push_int(env, b%a);
2538    
# Line 2185  extern void mod(environment *env) Line 2540  extern void mod(environment *env)
2540    }    }
2541    
2542    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2543    env->err=2;    env->err= 2;
2544  }  }
2545    
2546  /* "div" */  /* "div" */
# Line 2193  extern void sx_646976(environment *env) Line 2548  extern void sx_646976(environment *env)
2548  {  {
2549    int a, b;    int a, b;
2550        
2551    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2552      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2553      env->err= 1;      env->err= 1;
2554      return;      return;
2555    }    }
2556    
2557    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2558       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2559      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2560      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2561      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2562      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2563      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2564    
# Line 2213  extern void sx_646976(environment *env) Line 2568  extern void sx_646976(environment *env)
2568    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2569    env->err= 2;    env->err= 2;
2570  }  }
2571    
2572    extern void setcar(environment *env)
2573    {
2574      if(env->head->type==empty || CDR(env->head)->type==empty) {
2575        printerr("Too Few Arguments");
2576        env->err= 1;
2577        return;
2578      }
2579    
2580      if(CDR(env->head)->type!=tcons) {
2581        printerr("Bad Argument Type");
2582        env->err= 2;
2583        return;
2584      }
2585    
2586      CAR(CAR(CDR(env->head)))=CAR(env->head);
2587      toss(env);
2588    }
2589    
2590    extern void setcdr(environment *env)
2591    {
2592      if(env->head->type==empty || CDR(env->head)->type==empty) {
2593        printerr("Too Few Arguments");
2594        env->err= 1;
2595        return;
2596      }
2597    
2598      if(CDR(env->head)->type!=tcons) {
2599        printerr("Bad Argument Type");
2600        env->err= 2;
2601        return;
2602      }
2603    
2604      CDR(CAR(CDR(env->head)))=CAR(env->head);
2605      toss(env);
2606    }
2607    
2608    extern void car(environment *env)
2609    {
2610      if(env->head->type==empty) {
2611        printerr("Too Few Arguments");
2612        env->err= 1;
2613        return;
2614      }
2615    
2616      if(CAR(env->head)->type!=tcons) {
2617        printerr("Bad Argument Type");
2618        env->err= 2;
2619        return;
2620      }
2621    
2622      CAR(env->head)=CAR(CAR(env->head));
2623    }
2624    
2625    extern void cdr(environment *env)
2626    {
2627      if(env->head->type==empty) {
2628        printerr("Too Few Arguments");
2629        env->err= 1;
2630        return;
2631      }
2632    
2633      if(CAR(env->head)->type!=tcons) {
2634        printerr("Bad Argument Type");
2635        env->err= 2;
2636        return;
2637      }
2638    
2639      CAR(env->head)=CDR(CAR(env->head));
2640    }
2641    
2642    extern void cons(environment *env)
2643    {
2644      value *val;
2645    
2646      if(env->head->type==empty || CDR(env->head)->type==empty) {
2647        printerr("Too Few Arguments");
2648        env->err= 1;
2649        return;
2650      }
2651    
2652      val=new_val(env);
2653      val->content.c= malloc(sizeof(pair));
2654      assert(val->content.c!=NULL);
2655    
2656      env->gc_count += sizeof(pair);
2657      val->type=tcons;
2658    
2659      CAR(val)= CAR(CDR(env->head));
2660      CDR(val)= CAR(env->head);
2661    
2662      push_val(env, val);
2663    
2664      swap(env); if(env->err) return;
2665      toss(env); if(env->err) return;
2666      swap(env); if(env->err) return;
2667      toss(env); if(env->err) return;
2668    }
2669    
2670    /*  2: 3                        =>                */
2671    /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
2672    extern void assq(environment *env)
2673    {
2674      assocgen(env, eq);
2675    }
2676    
2677    
2678    /* General assoc function */
2679    void assocgen(environment *env, funcp eqfunc)
2680    {
2681      value *key, *item;
2682    
2683      /* Needs two values on the stack, the top one must be an association
2684         list */
2685      if(env->head->type==empty || CDR(env->head)->type==empty) {
2686        printerr("Too Few Arguments");
2687        env->err= 1;
2688        return;
2689      }
2690    
2691      if(CAR(env->head)->type!=tcons) {
2692        printerr("Bad Argument Type");
2693        env->err= 2;
2694        return;
2695      }
2696    
2697      key=CAR(CDR(env->head));
2698      item=CAR(env->head);
2699    
2700      while(item->type == tcons){
2701        if(CAR(item)->type != tcons){
2702          printerr("Bad Argument Type");
2703          env->err= 2;
2704          return;
2705        }
2706        push_val(env, key);
2707        push_val(env, CAR(CAR(item)));
2708        eqfunc(env); if(env->err) return;
2709    
2710        /* Check the result of 'eqfunc' */
2711        if(env->head->type==empty) {
2712          printerr("Too Few Arguments");
2713          env->err= 1;
2714        return;
2715        }
2716        if(CAR(env->head)->type!=integer) {
2717          printerr("Bad Argument Type");
2718          env->err= 2;
2719          return;
2720        }
2721    
2722        if(CAR(env->head)->content.i){
2723          toss(env); if(env->err) return;
2724          break;
2725        }
2726        toss(env); if(env->err) return;
2727    
2728        if(item->type!=tcons) {
2729          printerr("Bad Argument Type");
2730          env->err= 2;
2731          return;
2732        }
2733    
2734        item=CDR(item);
2735      }
2736    
2737      if(item->type == tcons){      /* A match was found */
2738        push_val(env, CAR(item));
2739      } else {
2740        push_int(env, 0);
2741      }
2742      swap(env); if(env->err) return;
2743      toss(env); if(env->err) return;
2744      swap(env); if(env->err) return;
2745      toss(env);
2746    }
2747    
2748    /* "do" */
2749    extern void sx_646f(environment *env)
2750    {
2751      swap(env); if(env->err) return;
2752      eval(env);
2753    }
2754    
2755    /* "open" */
2756    /* 2: "file"                                    */
2757    /* 1: "r"       =>      1: #<port 0x47114711>   */
2758    extern void sx_6f70656e(environment *env)
2759    {
2760      value *new_port;
2761      FILE *stream;
2762    
2763      if(env->head->type == empty || CDR(env->head)->type == empty) {
2764        printerr("Too Few Arguments");
2765        env->err=1;
2766        return;
2767      }
2768    
2769      if(CAR(env->head)->type != string
2770         || CAR(CDR(env->head))->type != string) {
2771        printerr("Bad Argument Type");
2772        env->err= 2;
2773        return;
2774      }
2775    
2776      stream=fopen(CAR(CDR(env->head))->content.ptr,
2777                   CAR(env->head)->content.ptr);
2778    
2779      if(stream == NULL) {
2780        perror("open");
2781        env->err= 5;
2782        return;
2783      }
2784    
2785      new_port=new_val(env);
2786      new_port->type=port;
2787      new_port->content.p=stream;
2788    
2789      push_val(env, new_port);
2790    
2791      swap(env); if(env->err) return;
2792      toss(env); if(env->err) return;
2793      swap(env); if(env->err) return;
2794      toss(env);
2795    }
2796    
2797    
2798    /* "close" */
2799    extern void sx_636c6f7365(environment *env)
2800    {
2801      int ret;
2802    
2803      if(env->head->type == empty) {
2804        printerr("Too Few Arguments");
2805        env->err=1;
2806        return;
2807      }
2808    
2809      if(CAR(env->head)->type != port) {
2810        printerr("Bad Argument Type");
2811        env->err= 2;
2812        return;
2813      }
2814    
2815      ret= fclose(CAR(env->head)->content.p);
2816    
2817      if(ret != 0){
2818        perror("close");
2819        env->err= 5;
2820        return;
2821      }
2822    
2823      toss(env);
2824    }
Legend:
Removed from v.1.101  
changed lines
  Added in v.1.124
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26