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

Diff of /stack/stack.c

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

revision 1.110 by teddy, Sat Mar 16 09:12:39 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  #define CAR(X) ((X)->content.c->car)
25  #define CDR(X) X->content.c->cdr  #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>
# Line 60  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 78  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    if(env->head==NULL) {    if(env->head->type==empty) {
83      printerr("Too Few Arguments");      printerr("Too Few Arguments");
84      env->err= 1;      env->err= 1;
85      return;      return;
# Line 122  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= integer;    nval->type= empty;
131    
132    nitem->item= nval;    nitem->item= nval;
133    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
# Line 164  inline void gc_maybe(environment *env) Line 168  inline void gc_maybe(environment *env)
168  extern void gc_init(environment *env)  extern void gc_init(environment *env)
169  {  {
170    stackitem *new_head= NULL, *titem;    stackitem *new_head= NULL, *titem;
   cons *iterator;  
171    symbol *tsymb;    symbol *tsymb;
172    int i;    int i;
173    
# Line 194  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        if(env->gc_ref->item->type==string) /* Remove content */        /* Remove content */
201          switch(env->gc_ref->item->type){
202          case string:
203          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
204            break;
205          case tcons:
206            free(env->gc_ref->item->content.c);
207            break;
208          case port:
209          case empty:
210          case integer:
211          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;
# Line 232  extern void gc_init(environment *env) Line 249  extern void gc_init(environment *env)
249      /* Keep values */          /* Keep values */    
250      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
251      if(env->gc_ref->item->type==string)      if(env->gc_ref->item->type==string)
252        env->gc_count += strlen(env->gc_ref->item->content.ptr);        env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
253            
254      titem= env->gc_ref->next;      titem= env->gc_ref->next;
255      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
# Line 284  void push_val(environment *env, value *v Line 301  void push_val(environment *env, value *v
301  {  {
302    value *new_value= new_val(env);    value *new_value= new_val(env);
303    
304    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(pair));
305    assert(new_value->content.c!=NULL);    assert(new_value->content.c!=NULL);
306      env->gc_count += sizeof(pair);
307    new_value->type= tcons;    new_value->type= tcons;
308    CAR(new_value)= val;    CAR(new_value)= val;
309    CDR(new_value)= env->head;    CDR(new_value)= env->head;
# Line 321  void push_cstring(environment *env, cons Line 339  void push_cstring(environment *env, cons
339    int length= strlen(in_string)+1;    int length= strlen(in_string)+1;
340    
341    new_value->content.ptr= malloc(length);    new_value->content.ptr= malloc(length);
342      assert(new_value != NULL);
343    env->gc_count += length;    env->gc_count += length;
344    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
345    new_value->type= string;    new_value->type= string;
# Line 335  char *mangle_str(const char *old_string) Line 354  char *mangle_str(const char *old_string)
354    char *new_string, *current;    char *new_string, *current;
355    
356    new_string= malloc((strlen(old_string)*2)+4);    new_string= malloc((strlen(old_string)*2)+4);
357      assert(new_string != NULL);
358    strcpy(new_string, "sx_");    /* Stack eXternal */    strcpy(new_string, "sx_");    /* Stack eXternal */
359    current= new_string+3;    current= new_string+3;
360    while(old_string[0] != '\0'){    while(old_string[0] != '\0'){
# Line 352  extern void mangle(environment *env) Line 372  extern void mangle(environment *env)
372  {  {
373    char *new_string;    char *new_string;
374    
375    if(env->head==NULL) {    if(env->head->type==empty) {
376      printerr("Too Few Arguments");      printerr("Too Few Arguments");
377      env->err= 1;      env->err= 1;
378      return;      return;
# Line 404  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 441  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    
503    typenum= CAR(env->head)->type;    switch(CAR(env->head)->type){
504    toss(env);    case empty:
505    switch(typenum){      push_sym(env, "empty");
506        break;
507    case integer:    case integer:
508      push_sym(env, "integer");      push_sym(env, "integer");
509      break;      break;
# Line 476  extern void type(environment *env) Line 520  extern void type(environment *env)
520      push_sym(env, "function");      push_sym(env, "function");
521      break;      break;
522    case tcons:    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(value *stack_head, int noquote)  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
536  {  {
537    switch(CAR(stack_head)->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", CAR(stack_head)->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", CAR(stack_head)->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*)CAR(stack_head)->content.ptr);        if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){
565      else          perror("print_val");
566        printf("\"%s\"", (char*)CAR(stack_head)->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", CAR(stack_head)->content.sym->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)(CAR(stack_head)->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;
591      case port:
592        if(fprintf(stream, "#<port %p>", (funcp)(val->content.p)) < 0){
593          perror("print_val");
594          env->err= 5;
595          return;
596        }
597      break;      break;
598    case tcons:    case tcons:
599      /* A list is just a stack, so make stack_head point to it */      if(fprintf(stream, "[ ") < 0){
600      stack_head= CAR(stack_head);        perror("print_val");
601      printf("[ ");        env->err= 5;
602      while(stack_head != NULL) {        return;
603        print_h(stack_head, noquote);      }
604        printf(" ");      tstack= stack;
605        stack_head= CDR(stack_head);      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 536  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 554  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(value *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(CDR(stack_head) != NULL)    if(CDR(stack_head)->type != empty)
785      print_st(CDR(stack_head), 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. */
# Line 580  extern void swap(environment *env) Line 804  extern void swap(environment *env)
804  {  {
805    value *temp= env->head;    value *temp= env->head;
806        
807    if(env->head==NULL || CDR(env->head)==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;
# Line 596  extern void rot(environment *env) Line 820  extern void rot(environment *env)
820  {  {
821    value *temp= env->head;    value *temp= env->head;
822        
823    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
824       || CDR(CDR(env->head))==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;
# Line 613  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;
# Line 651  extern void eval(environment *env) Line 875  extern void eval(environment *env)
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;
# Line 682  extern void eval(environment *env) Line 906  extern void eval(environment *env)
906      toss(env); if(env->err) return;      toss(env); if(env->err) return;
907      iterator= temp_val;      iterator= temp_val;
908            
909      while(iterator!=NULL) {      while(iterator->type != empty) {
910        push_val(env, CAR(iterator));        push_val(env, CAR(iterator));
911                
912        if(CAR(env->head)->type==symb        if(CAR(env->head)->type==symb
# Line 690  extern void eval(environment *env) Line 914  extern void eval(environment *env)
914          toss(env);          toss(env);
915          if(env->err) return;          if(env->err) return;
916                    
917          if(CDR(iterator)==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        if (CDR(iterator)==NULL || CDR(iterator)->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
924          iterator= CDR(iterator);          iterator= CDR(iterator);
925        else {        else {
926          printerr("Bad Argument Type"); /* Improper list */          printerr("Bad Argument Type"); /* Improper list */
# Line 707  extern void eval(environment *env) Line 931  extern void eval(environment *env)
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 717  extern void rev(environment *env) Line 946  extern void rev(environment *env)
946  {  {
947    value *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(CAR(env->head)->type==empty)
956        return;                     /* Don't reverse an empty list */
957    
958    if(CAR(env->head)->type!=tcons) {    if(CAR(env->head)->type!=tcons) {
959      printerr("Bad Argument Type");      printerr("Bad Argument Type");
960      env->err= 2;      env->err= 2;
# Line 730  extern void rev(environment *env) Line 962  extern void rev(environment *env)
962    }    }
963    
964    old_head= CAR(env->head);    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= CDR(old_head);      old_head= CDR(old_head);
969      CDR(item)= new_head;      CDR(item)= new_head;
# Line 743  extern void rev(environment *env) Line 975  extern void rev(environment *env)
975  /* Make a list. */  /* Make a list. */
976  extern void pack(environment *env)  extern void pack(environment *env)
977  {  {
978    value *iterator, *temp;    value *iterator, *temp, *ending;
979    
980      ending=new_val(env);
981    
982    iterator= env->head;    iterator= env->head;
983    if(iterator==NULL    if(iterator->type == empty
984       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
985       && CAR(iterator)->content.sym->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
986      temp= NULL;      temp= ending;
987      toss(env);      toss(env);
988    } else {    } else {
989      /* Search for first delimiter */      /* Search for first delimiter */
990      while(CDR(iterator)!=NULL      while(CDR(iterator)->type != empty
991            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
992             || CAR(CDR(iterator))->content.sym->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
993        iterator= CDR(iterator);        iterator= CDR(iterator);
# Line 761  extern void pack(environment *env) Line 995  extern void pack(environment *env)
995      /* Extract list */      /* Extract list */
996      temp= env->head;      temp= env->head;
997      env->head= CDR(iterator);      env->head= CDR(iterator);
998      CDR(iterator)= NULL;      CDR(iterator)= ending;
999    
1000      if(env->head!=NULL)      if(env->head->type != empty)
1001        toss(env);        toss(env);
1002    }    }
1003    
# Line 779  extern void expand(environment *env) Line 1013  extern void expand(environment *env)
1013    value *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;
# Line 802  extern void expand(environment *env) Line 1036  extern void expand(environment *env)
1036    toss(env);    toss(env);
1037    
1038    /* Find the end of the list */    /* Find the end of the list */
1039    while(CDR(temp)->content.ptr != NULL) {    while(CDR(temp)->type != empty) {
1040      if (CDR(temp)->type == tcons)      if (CDR(temp)->type == tcons)
1041        temp= CDR(temp);        temp= CDR(temp);
1042      else {      else {
# Line 823  extern void eq(environment *env) Line 1057  extern void eq(environment *env)
1057  {  {
1058    void *left, *right;    void *left, *right;
1059    
1060    if(env->head==NULL || CDR(env->head)==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;
# Line 841  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;
# Line 872  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 || CDR(env->head)==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;
# Line 926  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 965  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;
   value *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(CAR(stack_head)->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= CAR(stack_head)->content.sym->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 1042  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);        /* "read" */      sx_72656164(&myenv);        /* "read" */
1287      if (myenv.err==4) {         /* EOF */      if (myenv.err) {            /* EOF or other error */
1288        myenv.err=0;        myenv.err=0;
1289        quit(&myenv);        quit(&myenv);
1290      } else if(myenv.head!=NULL      } else if(myenv.head->type!=empty
1291                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
1292                && CAR(myenv.head)->content.sym->id[0]                && CAR(myenv.head)->content.sym->id[0] == ';') {
1293                ==';') {        toss(&myenv); if(myenv.err) continue;
       toss(&myenv);             /* No error check in main */  
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 1075  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 || CDR(env->head)==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;
# Line 1090  extern void sx_2b(environment *env) Line 1324  extern void sx_2b(environment *env)
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 1153  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 || CDR(env->head)==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;
# Line 1213  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 || CDR(env->head)==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;
# Line 1296  value *copy_val(environment *env, value Line 1531  value *copy_val(environment *env, value
1531    if(old_value==NULL)    if(old_value==NULL)
1532      return NULL;      return NULL;
1533    
   protect(old_value);  
1534    new_value= new_val(env);    new_value= new_val(env);
1535    new_value->type= old_value->type;    new_value->type= old_value->type;
1536    
# Line 1305  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:
# Line 1313  value *copy_val(environment *env, value Line 1549  value *copy_val(environment *env, value
1549      break;      break;
1550    case tcons:    case tcons:
1551    
1552      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(pair));
1553      assert(new_value->content.c!=NULL);      assert(new_value->content.c!=NULL);
1554        env->gc_count += sizeof(pair);
1555    
1556      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1557      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
1558      break;      break;
1559    }    }
1560    
   unprotect(old_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;
# Line 1342  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 || CDR(env->head)==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;
# Line 1373  extern void ifelse(environment *env) Line 1608  extern void ifelse(environment *env)
1608  {  {
1609    int truth;    int truth;
1610    
1611    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1612       || CDR(CDR(env->head))==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;
# Line 1404  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)  extern void sx_656c7365(environment *env)
1644  {  {
1645    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1646       || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL       || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1647       || CDR(CDR(CDR(CDR(env->head))))==NULL) {       || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1648      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1649      env->err= 1;      env->err= 1;
1650      return;      return;
# Line 1429  extern void sx_656c7365(environment *env Line 1665  extern void sx_656c7365(environment *env
1665    
1666  extern void then(environment *env)  extern void then(environment *env)
1667  {  {
1668    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1669       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type==empty) {
1670      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1671      env->err= 1;      env->err= 1;
1672      return;      return;
# Line 1453  extern void sx_7768696c65(environment *e Line 1689  extern void sx_7768696c65(environment *e
1689    int truth;    int truth;
1690    value *loop, *test;    value *loop, *test;
1691    
1692    if(env->head==NULL || CDR(env->head)==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;
# Line 1499  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 || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1739       || CDR(CDR(env->head))==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;
# Line 1547  extern void foreach(environment *env) Line 1783  extern void foreach(environment *env)
1783    value *loop, *foo;    value *loop, *foo;
1784    value *iterator;    value *iterator;
1785        
1786    if(env->head==NULL || CDR(env->head)==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;
# Line 1569  extern void foreach(environment *env) Line 1805  extern void foreach(environment *env)
1805    
1806    iterator= foo;    iterator= foo;
1807    
1808    while(iterator!=NULL) {    while(iterator->type!=empty) {
1809      push_val(env, CAR(iterator));      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;
# Line 1588  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    value *iterator, *temp;    value *iterator, *temp, *end;
1828    
1829    if(env->head==NULL || CDR(env->head)==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;
# Line 1620  extern void to(environment *env) Line 1858  extern void to(environment *env)
1858    
1859    iterator= env->head;    iterator= env->head;
1860    
1861    if(iterator==NULL    if(iterator->type==empty
1862       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
1863           && CAR(iterator)->content.sym->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(CDR(iterator)!=NULL      while(CDR(iterator)->type!=empty
1869            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
1870                || CAR(CDR(iterator))->content.sym->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1871        iterator= CDR(iterator);        iterator= CDR(iterator);
# Line 1635  extern void to(environment *env) Line 1873  extern void to(environment *env)
1873      /* Extract list */      /* Extract list */
1874      temp= env->head;      temp= env->head;
1875      env->head= CDR(iterator);      env->head= CDR(iterator);
1876      CDR(iterator)= NULL;      CDR(iterator)= end;
1877    
1878      if(env->head!=NULL)      if(env->head->type!=empty)
1879        toss(env);        toss(env);
1880    }    }
1881    
# Line 1648  extern void to(environment *env) Line 1886  extern void to(environment *env)
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 1672  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 1687  extern void sx_72656164(environment *env Line 1990  extern void sx_72656164(environment *env
1990      }      }
1991            
1992      env->in_string= malloc(strlen(CAR(env->head)->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, CAR(env->head)->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1996      toss(env); if(env->err) return;      toss(env); if(env->err) return;
# Line 1694  extern void sx_72656164(environment *env Line 1998  extern void sx_72656164(environment *env
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 1706  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 1742  extern void beep(environment *env) Line 2050  extern void beep(environment *env)
2050  {  {
2051    int freq, dur, period, ticks;    int freq, dur, period, ticks;
2052    
2053    if(env->head==NULL || CDR(env->head)==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;
# Line 1787  extern void sx_77616974(environment *env Line 2095  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;
# Line 1807  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 2096  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 || CDR(env->head)==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;
# Line 2156  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 || CDR(env->head)==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;
# Line 2215  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 || CDR(env->head)==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;
# Line 2241  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 || CDR(env->head)==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;
# Line 2261  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.110  
changed lines
  Added in v.1.125
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26