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

Diff of /stack/stack.c

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

revision 1.100 by teddy, Sun Mar 10 12:05:20 2002 UTC revision 1.125 by teddy, Sun Mar 31 02:19:54 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);
138    nval->gc.flag.mark= 0;    nval->gc.flag.mark= 0;
139    nval->gc.flag.protect= 0;    nval->gc.flag.protect= 0;
140    
# 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.", env->gc_count, env->gc_limit);      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);  
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 232  extern void gc_init(environment *env) Line 260  extern void gc_init(environment *env)
260    
261    if (env->gc_limit < env->gc_count*2)    if (env->gc_limit < env->gc_count*2)
262      env->gc_limit= env->gc_count*2;      env->gc_limit= env->gc_count*2;
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 315  void push_float(environment *env, float Line 336  void push_float(environment *env, float
336  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
337  {  {
338    value *new_value= new_val(env);    value *new_value= new_val(env);
339      int length= strlen(in_string)+1;
340    
341    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
342      assert(new_value != NULL);
343      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;
346    
# Line 330  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 347  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 398  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 435  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 468  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 529  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 547  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 606  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 638  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 702  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 792  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 810  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 832  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 863  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 902  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 913  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 926  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 948  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 980  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 994  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 1013  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 1023  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) {            /* EOF or other error */
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        toss(&myenv);             /* No error check in main */                && CAR(myenv.head)->content.sym->id[0] == ';') {
1293          toss(&myenv); if(myenv.err) continue;
1294        eval(&myenv);        eval(&myenv);
1295        } else {
1296          gc_maybe(&myenv);
1297      }      }
     gc_maybe(&myenv);  
1298    }    }
1299    quit(&myenv);    quit(&myenv);
1300    return EXIT_FAILURE;    return EXIT_FAILURE;
# Line 1054  extern void sx_2b(environment *env) Line 1309  extern void sx_2b(environment *env)
1309    char* new_string;    char* new_string;
1310    value *a_val, *b_val;    value *a_val, *b_val;
1311    
1312    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1313      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1314      env->err= 1;      env->err= 1;
1315      return;      return;
1316    }    }
1317    
1318    if(env->head->item->type==string    if(CAR(env->head)->type==string
1319       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1320      a_val= env->head->item;      a_val= CAR(env->head);
1321      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1322      protect(a_val); protect(b_val);      protect(a_val); protect(b_val);
1323      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1324      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1325      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
1326      new_string= malloc(len);      new_string= malloc(len);
1327        assert(new_string != NULL);
1328      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1329      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1330      push_cstring(env, new_string);      push_cstring(env, new_string);
# Line 1078  extern void sx_2b(environment *env) Line 1334  extern void sx_2b(environment *env)
1334      return;      return;
1335    }    }
1336        
1337    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1338       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1339      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1340      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1341      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1342      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1343      push_int(env, b+a);      push_int(env, b+a);
1344    
1345      return;      return;
1346    }    }
1347    
1348    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1349       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1350      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1351      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1352      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1353      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1354      push_float(env, fb+fa);      push_float(env, fb+fa);
1355            
1356      return;      return;
1357    }    }
1358    
1359    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1360       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1361      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1362      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1363      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1364      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1365      push_float(env, b+fa);      push_float(env, b+fa);
1366            
1367      return;      return;
1368    }    }
1369    
1370    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1371       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1372      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1373      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1374      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1375      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1376      push_float(env, fb+a);      push_float(env, fb+a);
1377    
# Line 1132  extern void sx_2d(environment *env) Line 1388  extern void sx_2d(environment *env)
1388    int a, b;    int a, b;
1389    float fa, fb;    float fa, fb;
1390    
1391    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1392      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1393      env->err=1;      env->err=1;
1394      return;      return;
1395    }    }
1396        
1397    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1398       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1399      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1400      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1401      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1402      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1403      push_int(env, b-a);      push_int(env, b-a);
1404    
1405      return;      return;
1406    }    }
1407    
1408    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1409       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1410      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1411      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1412      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1413      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1414      push_float(env, fb-fa);      push_float(env, fb-fa);
1415            
1416      return;      return;
1417    }    }
1418    
1419    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1420       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1421      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1422      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1423      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1424      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1425      push_float(env, b-fa);      push_float(env, b-fa);
1426            
1427      return;      return;
1428    }    }
1429    
1430    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1431       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1432      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1433      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1434      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1435      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1436      push_float(env, fb-a);      push_float(env, fb-a);
1437    
# Line 1192  extern void sx_3e(environment *env) Line 1448  extern void sx_3e(environment *env)
1448    int a, b;    int a, b;
1449    float fa, fb;    float fa, fb;
1450    
1451    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1452      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1453      env->err=1;      env->err= 1;
1454      return;      return;
1455    }    }
1456        
1457    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1458       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1459      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1460      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1461      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1462      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1463      push_int(env, b>a);      push_int(env, b>a);
1464    
1465      return;      return;
1466    }    }
1467    
1468    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1469       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1470      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1471      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1472      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1473      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1474      push_int(env, fb>fa);      push_int(env, fb>fa);
1475            
1476      return;      return;
1477    }    }
1478    
1479    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1480       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1481      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1482      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1483      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1484      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1485      push_int(env, b>fa);      push_int(env, b>fa);
1486            
1487      return;      return;
1488    }    }
1489    
1490    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1491       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1492      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1493      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1494      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1495      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1496      push_int(env, fb>a);      push_int(env, fb>a);
1497    
# Line 1243  extern void sx_3e(environment *env) Line 1499  extern void sx_3e(environment *env)
1499    }    }
1500    
1501    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1502    env->err=2;    env->err= 2;
1503  }  }
1504    
1505  /* "<" */  /* "<" */
# Line 1270  extern void sx_3e3d(environment *env) Line 1526  extern void sx_3e3d(environment *env)
1526  /* Return copy of a value */  /* Return copy of a value */
1527  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
1528  {  {
   stackitem *old_item, *new_item, *prev_item;  
1529    value *new_value;    value *new_value;
1530    
1531    protect(old_value);    if(old_value==NULL)
1532        return NULL;
1533    
1534    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
1535    new_value->type= old_value->type;    new_value->type= old_value->type;
1536    
1537    switch(old_value->type){    switch(old_value->type){
# Line 1283  value *copy_val(environment *env, value Line 1539  value *copy_val(environment *env, value
1539    case integer:    case integer:
1540    case func:    case func:
1541    case symb:    case symb:
1542      case empty:
1543      case port:
1544      new_value->content= old_value->content;      new_value->content= old_value->content;
1545      break;      break;
1546    case string:    case string:
1547      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1548        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1549      break;      break;
1550    case list:    case tcons:
     new_value->content.ptr= NULL;  
1551    
1552      prev_item= NULL;      new_value->content.c= malloc(sizeof(pair));
1553      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
1554        env->gc_count += sizeof(pair);
1555    
1556      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1557        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;  
     }      
1558      break;      break;
1559    }    }
1560    
   unprotect(old_value); unprotect(new_value);  
   
1561    return new_value;    return new_value;
1562  }  }
1563    
1564  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1565  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1566  {  {
1567    if((env->head)==NULL) {    if(env->head->type==empty) {
1568      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1569      env->err= 1;      env->err= 1;
1570      return;      return;
1571    }    }
1572    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1573  }  }
1574    
1575  /* "if", If-Then */  /* "if", If-Then */
# Line 1331  extern void sx_6966(environment *env) Line 1577  extern void sx_6966(environment *env)
1577  {  {
1578    int truth;    int truth;
1579    
1580    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1581      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1582      env->err= 1;      env->err= 1;
1583      return;      return;
1584    }    }
1585    
1586    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1587      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1588      env->err=2;      env->err= 2;
1589      return;      return;
1590    }    }
1591        
1592    swap(env);    swap(env);
1593    if(env->err) return;    if(env->err) return;
1594        
1595    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1596    
1597    toss(env);    toss(env);
1598    if(env->err) return;    if(env->err) return;
# Line 1362  extern void ifelse(environment *env) Line 1608  extern void ifelse(environment *env)
1608  {  {
1609    int truth;    int truth;
1610    
1611    if((env->head)==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1612       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1613      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1614      env->err=1;      env->err= 1;
1615      return;      return;
1616    }    }
1617    
1618    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1619      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1620      env->err=2;      env->err= 2;
1621      return;      return;
1622    }    }
1623        
1624    rot(env);    rot(env);
1625    if(env->err) return;    if(env->err) return;
1626        
1627    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1628    
1629    toss(env);    toss(env);
1630    if(env->err) return;    if(env->err) return;
# Line 1393  extern void ifelse(environment *env) Line 1639  extern void ifelse(environment *env)
1639    eval(env);    eval(env);
1640  }  }
1641    
1642    /* "else" */
1643    extern void sx_656c7365(environment *env)
1644    {
1645      if(env->head->type==empty || CDR(env->head)->type==empty
1646         || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1647         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1648        printerr("Too Few Arguments");
1649        env->err= 1;
1650        return;
1651      }
1652    
1653      if(CAR(CDR(env->head))->type!=symb
1654         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1655         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1656         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1657        printerr("Bad Argument Type");
1658        env->err= 2;
1659        return;
1660      }
1661    
1662      swap(env); toss(env); rot(env); toss(env);
1663      ifelse(env);
1664    }
1665    
1666    extern void then(environment *env)
1667    {
1668      if(env->head->type==empty || CDR(env->head)->type==empty
1669         || CDR(CDR(env->head))->type==empty) {
1670        printerr("Too Few Arguments");
1671        env->err= 1;
1672        return;
1673      }
1674    
1675      if(CAR(CDR(env->head))->type!=symb
1676         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1677        printerr("Bad Argument Type");
1678        env->err= 2;
1679        return;
1680      }
1681    
1682      swap(env); toss(env);
1683      sx_6966(env);
1684    }
1685    
1686  /* "while" */  /* "while" */
1687  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1688  {  {
1689    int truth;    int truth;
1690    value *loop, *test;    value *loop, *test;
1691    
1692    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1693      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1694      env->err=1;      env->err= 1;
1695      return;      return;
1696    }    }
1697    
1698    loop= env->head->item;    loop= CAR(env->head);
1699    protect(loop);    protect(loop);
1700    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1701    
1702    test= env->head->item;    test= CAR(env->head);
1703    protect(test);    protect(test);
1704    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1705    
# Line 1417  extern void sx_7768696c65(environment *e Line 1707  extern void sx_7768696c65(environment *e
1707      push_val(env, test);      push_val(env, test);
1708      eval(env);      eval(env);
1709            
1710      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1711        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1712        env->err= 2;        env->err= 2;
1713        return;        return;
1714      }      }
1715            
1716      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1717      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1718            
1719      if(truth) {      if(truth) {
# Line 1445  extern void sx_666f72(environment *env) Line 1735  extern void sx_666f72(environment *env)
1735    value *loop;    value *loop;
1736    int foo1, foo2;    int foo1, foo2;
1737    
1738    if(env->head==NULL || env->head->next==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1739       || env->head->next->next==NULL) {       || CDR(CDR(env->head))->type==empty) {
1740      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1741      env->err= 1;      env->err= 1;
1742      return;      return;
1743    }    }
1744    
1745    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1746       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1747      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1748      env->err= 2;      env->err= 2;
1749      return;      return;
1750    }    }
1751    
1752    loop= env->head->item;    loop= CAR(env->head);
1753    protect(loop);    protect(loop);
1754    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1755    
1756    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1757    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1758    
1759    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1760    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1761    
1762    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1491  extern void sx_666f72(environment *env) Line 1781  extern void sx_666f72(environment *env)
1781  extern void foreach(environment *env)  extern void foreach(environment *env)
1782  {    {  
1783    value *loop, *foo;    value *loop, *foo;
1784    stackitem *iterator;    value *iterator;
1785        
1786    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1787      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1788      env->err= 1;      env->err= 1;
1789      return;      return;
1790    }    }
1791    
1792    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1793      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1794      env->err= 2;      env->err= 2;
1795      return;      return;
1796    }    }
1797    
1798    loop= env->head->item;    loop= CAR(env->head);
1799    protect(loop);    protect(loop);
1800    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1801    
1802    foo= env->head->item;    foo= CAR(env->head);
1803    protect(foo);    protect(foo);
1804    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1805    
1806    iterator= foo->content.ptr;    iterator= foo;
1807    
1808    while(iterator!=NULL) {    while(iterator->type!=empty) {
1809      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1810      push_val(env, loop);      push_val(env, loop);
1811      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1812      iterator= iterator->next;      if (iterator->type == tcons){
1813          iterator= CDR(iterator);
1814        } else {
1815          printerr("Bad Argument Type"); /* Improper list */
1816          env->err= 2;
1817          break;
1818        }
1819    }    }
1820    unprotect(loop); unprotect(foo);    unprotect(loop); unprotect(foo);
1821  }  }
# Line 1528  extern void foreach(environment *env) Line 1824  extern void foreach(environment *env)
1824  extern void to(environment *env)  extern void to(environment *env)
1825  {  {
1826    int ending, start, i;    int ending, start, i;
1827    stackitem *iterator, *temp;    value *iterator, *temp, *end;
   value *pack;  
1828    
1829    if((env->head)==NULL || env->head->next==NULL) {    end= new_val(env);
1830    
1831      if(env->head->type==empty || CDR(env->head)->type==empty) {
1832      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1833      env->err=1;      env->err= 1;
1834      return;      return;
1835    }    }
1836    
1837    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1838       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1839      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1840      env->err=2;      env->err= 2;
1841      return;      return;
1842    }    }
1843    
1844    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1845    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1846    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1847    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1848    
1849    push_sym(env, "[");    push_sym(env, "[");
# Line 1560  extern void to(environment *env) Line 1857  extern void to(environment *env)
1857    }    }
1858    
1859    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(pack);  
1860    
1861    if(iterator==NULL    if(iterator->type==empty
1862       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
1863       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1864      temp= NULL;      temp= end;
1865      toss(env);      toss(env);
1866    } else {    } else {
1867      /* Search for first delimiter */      /* Search for first delimiter */
1868      while(iterator->next!=NULL      while(CDR(iterator)->type!=empty
1869            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
1870            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1871        iterator= iterator->next;        iterator= CDR(iterator);
1872            
1873      /* Extract list */      /* Extract list */
1874      temp= env->head;      temp= env->head;
1875      env->head= iterator->next;      env->head= CDR(iterator);
1876      iterator->next= NULL;      CDR(iterator)= end;
1877    
1878      pack->type= list;      if(env->head->type!=empty)
     pack->content.ptr= temp;  
       
     if(env->head!=NULL)  
1879        toss(env);        toss(env);
1880    }    }
1881    
1882    /* Push list */    /* Push list */
1883      push_val(env, temp);
   push_val(env, pack);  
   
   unprotect(pack);  
1884  }  }
1885    
1886  /* Read a string */  /* Read a string */
1887  extern void readline(environment *env)  extern void readline(environment *env)
1888  {  {
1889      readlinestream(env, env->inputstream);
1890    }
1891    
1892    /* Read a string from a port */
1893    extern void readlineport(environment *env)
1894    {
1895      FILE *stream;
1896    
1897      if(env->head->type==empty) {
1898        printerr("Too Few Arguments");
1899        env->err= 1;
1900        return;
1901      }
1902    
1903      if(CAR(env->head)->type!=port) {
1904        printerr("Bad Argument Type");
1905        env->err= 2;
1906        return;
1907      }
1908    
1909      stream=CAR(env->head)->content.p;
1910      readlinestream(env, stream); if(env->err) return;
1911    
1912      swap(env); if(env->err) return;
1913      toss(env);
1914    }
1915    
1916    /* read a line from a stream; used by readline */
1917    void readlinestream(environment *env, FILE *stream)
1918    {
1919    char in_string[101];    char in_string[101];
1920    
1921    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, stream)==NULL) {
1922      push_cstring(env, "");      push_cstring(env, "");
1923    else      if (! feof(stream)){
1924          perror("readline");
1925          env->err= 5;
1926        }
1927      } else {
1928      push_cstring(env, in_string);      push_cstring(env, in_string);
1929      }
1930  }  }
1931    
1932  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1933  extern void sx_72656164(environment *env)  extern void sx_72656164(environment *env)
1934  {  {
1935      readstream(env, env->inputstream);
1936    }
1937    
1938    /* "readport"; Read a value from a port and place on stack */
1939    extern void readport(environment *env)
1940    {
1941      FILE *stream;
1942    
1943      if(env->head->type==empty) {
1944        printerr("Too Few Arguments");
1945        env->err= 1;
1946        return;
1947      }
1948    
1949      if(CAR(env->head)->type!=port) {
1950        printerr("Bad Argument Type");
1951        env->err= 2;
1952        return;
1953      }
1954    
1955      stream=CAR(env->head)->content.p;
1956      readstream(env, stream); if(env->err) return;
1957    
1958      swap(env); if(env->err) return;
1959      toss(env);
1960    }
1961    
1962    /* read from a stream; used by "read" and "readport" */
1963    void readstream(environment *env, FILE *stream)
1964    {
1965    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1966    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1967    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1621  extern void sx_72656164(environment *env Line 1975  extern void sx_72656164(environment *env
1975    int count= -1;    int count= -1;
1976    float ftemp;    float ftemp;
1977    static int depth= 0;    static int depth= 0;
1978    char *match, *ctemp;    char *match;
1979    size_t inlength;    size_t inlength;
1980    
1981    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1630  extern void sx_72656164(environment *env Line 1984  extern void sx_72656164(environment *env
1984      }      }
1985      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1986    
1987      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1988        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1989        return;        return;
1990      }      }
1991            
1992      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1993        assert(env->in_string != NULL);
1994      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1995      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1996      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1997    }    }
1998        
1999    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
2000    match= malloc(inlength);    match= malloc(inlength);
2001      assert(match != NULL);
2002    
2003    if(sscanf(env->in_string, blankform, &readlength) != EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
2004       && readlength != -1) {       && readlength != -1) {
# Line 1655  extern void sx_72656164(environment *env Line 2011  extern void sx_72656164(environment *env
2011      } else {      } else {
2012        push_float(env, ftemp);        push_float(env, ftemp);
2013      }      }
2014      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
2015                && readlength != -1) {
2016        push_cstring(env, "");
2017    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
2018              && readlength != -1) {              && readlength != -1) {
2019      push_cstring(env, match);      push_cstring(env, match);
# Line 1686  extern void sx_72656164(environment *env Line 2045  extern void sx_72656164(environment *env
2045      return sx_72656164(env);      return sx_72656164(env);
2046  }  }
2047    
2048    #ifdef __linux__
2049  extern void beep(environment *env)  extern void beep(environment *env)
2050  {  {
2051    int freq, dur, period, ticks;    int freq, dur, period, ticks;
2052    
2053    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2054      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2055      env->err=1;      env->err= 1;
2056      return;      return;
2057    }    }
2058    
2059    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
2060       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
2061      printerr("Bad Argument Type");      printerr("Bad Argument Type");
2062      env->err=2;      env->err= 2;
2063      return;      return;
2064    }    }
2065    
2066    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
2067    toss(env);    toss(env);
2068    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
2069    toss(env);    toss(env);
2070    
2071    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
2072                                     length */                                     length */
2073    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
2074                                     timer ticks */                                     timer ticks */
2075    
2076  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
2077    
2078    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
2079    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
2080    case 0:    case 0:
2081      usleep(dur);      usleep(dur);
2082      return;      return;
2083    case -1:    case -1:
2084      perror("beep");      perror("beep");
2085      env->err=5;      env->err= 5;
2086      return;      return;
2087    default:    default:
2088      abort();      abort();
2089    }    }
2090  }  }
2091    #endif /* __linux__ */
2092    
2093  /* "wait" */  /* "wait" */
2094  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
2095  {  {
2096    int dur;    int dur;
2097    
2098    if((env->head)==NULL) {    if(env->head->type==empty) {
2099      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2100      env->err=1;      env->err= 1;
2101      return;      return;
2102    }    }
2103    
2104    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
2105      printerr("Bad Argument Type");      printerr("Bad Argument Type");
2106      env->err=2;      env->err= 2;
2107      return;      return;
2108    }    }
2109    
2110    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
2111    toss(env);    toss(env);
2112    
2113    usleep(dur);    usleep(dur);
# Line 1754  extern void sx_77616974(environment *env Line 2115  extern void sx_77616974(environment *env
2115    
2116  extern void copying(environment *env)  extern void copying(environment *env)
2117  {  {
2118    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
2119                         Version 2, June 1991\n\                         Version 2, June 1991\n\
2120  \n\  \n\
2121   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2043  extern void sx_2a(environment *env) Line 2404  extern void sx_2a(environment *env)
2404    int a, b;    int a, b;
2405    float fa, fb;    float fa, fb;
2406    
2407    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2408      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2409      env->err=1;      env->err= 1;
2410      return;      return;
2411    }    }
2412        
2413    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2414       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2415      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2416      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2417      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2418      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2419      push_int(env, b*a);      push_int(env, b*a);
2420    
2421      return;      return;
2422    }    }
2423    
2424    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2425       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2426      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2427      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2428      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2429      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2430      push_float(env, fb*fa);      push_float(env, fb*fa);
2431            
2432      return;      return;
2433    }    }
2434    
2435    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2436       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2437      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2438      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2439      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2440      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2441      push_float(env, b*fa);      push_float(env, b*fa);
2442            
2443      return;      return;
2444    }    }
2445    
2446    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2447       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2448      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2449      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2450      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2451      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2452      push_float(env, fb*a);      push_float(env, fb*a);
2453    
# Line 2094  extern void sx_2a(environment *env) Line 2455  extern void sx_2a(environment *env)
2455    }    }
2456    
2457    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2458    env->err=2;    env->err= 2;
2459  }  }
2460    
2461  /* "/" */  /* "/" */
# Line 2103  extern void sx_2f(environment *env) Line 2464  extern void sx_2f(environment *env)
2464    int a, b;    int a, b;
2465    float fa, fb;    float fa, fb;
2466    
2467    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2468      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2469      env->err=1;      env->err= 1;
2470      return;      return;
2471    }    }
2472        
2473    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2474       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2475      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2476      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2477      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2478      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2479      push_float(env, b/a);      push_float(env, b/a);
2480    
2481      return;      return;
2482    }    }
2483    
2484    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2485       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2486      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2487      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2488      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2489      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2490      push_float(env, fb/fa);      push_float(env, fb/fa);
2491            
2492      return;      return;
2493    }    }
2494    
2495    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2496       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2497      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2498      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2499      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2500      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2501      push_float(env, b/fa);      push_float(env, b/fa);
2502            
2503      return;      return;
2504    }    }
2505    
2506    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2507       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2508      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2509      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2510      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2511      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2512      push_float(env, fb/a);      push_float(env, fb/a);
2513    
# Line 2154  extern void sx_2f(environment *env) Line 2515  extern void sx_2f(environment *env)
2515    }    }
2516    
2517    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2518    env->err=2;    env->err= 2;
2519  }  }
2520    
2521  /* "mod" */  /* "mod" */
# Line 2162  extern void mod(environment *env) Line 2523  extern void mod(environment *env)
2523  {  {
2524    int a, b;    int a, b;
2525    
2526    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2527      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2528      env->err= 1;      env->err= 1;
2529      return;      return;
2530    }    }
2531        
2532    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2533       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2534      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2535      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2536      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2537      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2538      push_int(env, b%a);      push_int(env, b%a);
2539    
# Line 2180  extern void mod(environment *env) Line 2541  extern void mod(environment *env)
2541    }    }
2542    
2543    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2544    env->err=2;    env->err= 2;
2545  }  }
2546    
2547  /* "div" */  /* "div" */
# Line 2188  extern void sx_646976(environment *env) Line 2549  extern void sx_646976(environment *env)
2549  {  {
2550    int a, b;    int a, b;
2551        
2552    if((env->head)==NULL || env->head->next==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2553      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2554      env->err= 1;      env->err= 1;
2555      return;      return;
2556    }    }
2557    
2558    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2559       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2560      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2561      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2562      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2563      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2564      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2565    
# Line 2208  extern void sx_646976(environment *env) Line 2569  extern void sx_646976(environment *env)
2569    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2570    env->err= 2;    env->err= 2;
2571  }  }
2572    
2573    extern void setcar(environment *env)
2574    {
2575      if(env->head->type==empty || CDR(env->head)->type==empty) {
2576        printerr("Too Few Arguments");
2577        env->err= 1;
2578        return;
2579      }
2580    
2581      if(CDR(env->head)->type!=tcons) {
2582        printerr("Bad Argument Type");
2583        env->err= 2;
2584        return;
2585      }
2586    
2587      CAR(CAR(CDR(env->head)))=CAR(env->head);
2588      toss(env);
2589    }
2590    
2591    extern void setcdr(environment *env)
2592    {
2593      if(env->head->type==empty || CDR(env->head)->type==empty) {
2594        printerr("Too Few Arguments");
2595        env->err= 1;
2596        return;
2597      }
2598    
2599      if(CDR(env->head)->type!=tcons) {
2600        printerr("Bad Argument Type");
2601        env->err= 2;
2602        return;
2603      }
2604    
2605      CDR(CAR(CDR(env->head)))=CAR(env->head);
2606      toss(env);
2607    }
2608    
2609    extern void car(environment *env)
2610    {
2611      if(env->head->type==empty) {
2612        printerr("Too Few Arguments");
2613        env->err= 1;
2614        return;
2615      }
2616    
2617      if(CAR(env->head)->type!=tcons) {
2618        printerr("Bad Argument Type");
2619        env->err= 2;
2620        return;
2621      }
2622    
2623      CAR(env->head)=CAR(CAR(env->head));
2624    }
2625    
2626    extern void cdr(environment *env)
2627    {
2628      if(env->head->type==empty) {
2629        printerr("Too Few Arguments");
2630        env->err= 1;
2631        return;
2632      }
2633    
2634      if(CAR(env->head)->type!=tcons) {
2635        printerr("Bad Argument Type");
2636        env->err= 2;
2637        return;
2638      }
2639    
2640      CAR(env->head)=CDR(CAR(env->head));
2641    }
2642    
2643    extern void cons(environment *env)
2644    {
2645      value *val;
2646    
2647      if(env->head->type==empty || CDR(env->head)->type==empty) {
2648        printerr("Too Few Arguments");
2649        env->err= 1;
2650        return;
2651      }
2652    
2653      val=new_val(env);
2654      val->content.c= malloc(sizeof(pair));
2655      assert(val->content.c!=NULL);
2656    
2657      env->gc_count += sizeof(pair);
2658      val->type=tcons;
2659    
2660      CAR(val)= CAR(CDR(env->head));
2661      CDR(val)= CAR(env->head);
2662    
2663      push_val(env, val);
2664    
2665      swap(env); if(env->err) return;
2666      toss(env); if(env->err) return;
2667      swap(env); if(env->err) return;
2668      toss(env); if(env->err) return;
2669    }
2670    
2671    /*  2: 3                        =>                */
2672    /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
2673    extern void assq(environment *env)
2674    {
2675      assocgen(env, eq);
2676    }
2677    
2678    
2679    /* General assoc function */
2680    void assocgen(environment *env, funcp eqfunc)
2681    {
2682      value *key, *item;
2683    
2684      /* Needs two values on the stack, the top one must be an association
2685         list */
2686      if(env->head->type==empty || CDR(env->head)->type==empty) {
2687        printerr("Too Few Arguments");
2688        env->err= 1;
2689        return;
2690      }
2691    
2692      if(CAR(env->head)->type!=tcons) {
2693        printerr("Bad Argument Type");
2694        env->err= 2;
2695        return;
2696      }
2697    
2698      key=CAR(CDR(env->head));
2699      item=CAR(env->head);
2700    
2701      while(item->type == tcons){
2702        if(CAR(item)->type != tcons){
2703          printerr("Bad Argument Type");
2704          env->err= 2;
2705          return;
2706        }
2707        push_val(env, key);
2708        push_val(env, CAR(CAR(item)));
2709        eqfunc(env); if(env->err) return;
2710    
2711        /* Check the result of 'eqfunc' */
2712        if(env->head->type==empty) {
2713          printerr("Too Few Arguments");
2714          env->err= 1;
2715        return;
2716        }
2717        if(CAR(env->head)->type!=integer) {
2718          printerr("Bad Argument Type");
2719          env->err= 2;
2720          return;
2721        }
2722    
2723        if(CAR(env->head)->content.i){
2724          toss(env); if(env->err) return;
2725          break;
2726        }
2727        toss(env); if(env->err) return;
2728    
2729        if(item->type!=tcons) {
2730          printerr("Bad Argument Type");
2731          env->err= 2;
2732          return;
2733        }
2734    
2735        item=CDR(item);
2736      }
2737    
2738      if(item->type == tcons){      /* A match was found */
2739        push_val(env, CAR(item));
2740      } else {
2741        push_int(env, 0);
2742      }
2743      swap(env); if(env->err) return;
2744      toss(env); if(env->err) return;
2745      swap(env); if(env->err) return;
2746      toss(env);
2747    }
2748    
2749    /* "do" */
2750    extern void sx_646f(environment *env)
2751    {
2752      swap(env); if(env->err) return;
2753      eval(env);
2754    }
2755    
2756    /* "open" */
2757    /* 2: "file"                                    */
2758    /* 1: "r"       =>      1: #<port 0x47114711>   */
2759    extern void sx_6f70656e(environment *env)
2760    {
2761      value *new_port;
2762      FILE *stream;
2763    
2764      if(env->head->type == empty || CDR(env->head)->type == empty) {
2765        printerr("Too Few Arguments");
2766        env->err=1;
2767        return;
2768      }
2769    
2770      if(CAR(env->head)->type != string
2771         || CAR(CDR(env->head))->type != string) {
2772        printerr("Bad Argument Type");
2773        env->err= 2;
2774        return;
2775      }
2776    
2777      stream=fopen(CAR(CDR(env->head))->content.ptr,
2778                   CAR(env->head)->content.ptr);
2779    
2780      if(stream == NULL) {
2781        perror("open");
2782        env->err= 5;
2783        return;
2784      }
2785    
2786      new_port=new_val(env);
2787      new_port->type=port;
2788      new_port->content.p=stream;
2789    
2790      push_val(env, new_port);
2791    
2792      swap(env); if(env->err) return;
2793      toss(env); if(env->err) return;
2794      swap(env); if(env->err) return;
2795      toss(env);
2796    }
2797    
2798    
2799    /* "close" */
2800    extern void sx_636c6f7365(environment *env)
2801    {
2802      int ret;
2803    
2804      if(env->head->type == empty) {
2805        printerr("Too Few Arguments");
2806        env->err=1;
2807        return;
2808      }
2809    
2810      if(CAR(env->head)->type != port) {
2811        printerr("Bad Argument Type");
2812        env->err= 2;
2813        return;
2814      }
2815    
2816      ret= fclose(CAR(env->head)->content.p);
2817    
2818      if(ret != 0){
2819        perror("close");
2820        env->err= 5;
2821        return;
2822      }
2823    
2824      toss(env);
2825    }
Legend:
Removed from v.1.100  
changed lines
  Added in v.1.125
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26