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

Diff of /stack/stack.c

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

revision 1.107 by masse, Tue Mar 12 21:05:11 2002 UTC revision 1.116 by teddy, Sun Mar 17 12:49:27 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 37  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__  #ifdef __linux__
45  /* mtrace, muntrace */  /* mtrace, muntrace */
# Line 58  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      env->head->type= empty;
66    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
67      env->symbols[i]= NULL;      env->symbols[i]= NULL;
68    env->err= 0;    env->err= 0;
# Line 76  void printerr(const char* in_string) Line 80  void printerr(const char* in_string)
80  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
81  extern void toss(environment *env)  extern void toss(environment *env)
82  {  {
83    if(env->head==NULL) {    if(env->head->type==empty) {
84      printerr("Too Few Arguments");      printerr("Too Few Arguments");
85      env->err= 1;      env->err= 1;
86      return;      return;
# Line 121  value* new_val(environment *env) Line 125  value* new_val(environment *env)
125    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
126    
127    nval->content.ptr= NULL;    nval->content.ptr= NULL;
128      nval->type= integer;
129    
130    nitem->item= nval;    nitem->item= nval;
131    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
# Line 161  inline void gc_maybe(environment *env) Line 166  inline void gc_maybe(environment *env)
166  extern void gc_init(environment *env)  extern void gc_init(environment *env)
167  {  {
168    stackitem *new_head= NULL, *titem;    stackitem *new_head= NULL, *titem;
   cons *iterator;  
169    symbol *tsymb;    symbol *tsymb;
170    int i;    int i;
171    
# Line 185  extern void gc_init(environment *env) Line 189  extern void gc_init(environment *env)
189    if(env->interactive)    if(env->interactive)
190      printf(".");      printf(".");
191    
   
192    env->gc_count= 0;    env->gc_count= 0;
193    
194    while(env->gc_ref!=NULL) {    /* Sweep unused values */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
195    
196      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
197    
198        if(env->gc_ref->item->type==string) /* Remove content */        /* Remove content */
199          switch(env->gc_ref->item->type){
200          case string:
201          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
202            break;
203          case tcons:
204            free(env->gc_ref->item->content.c);
205            break;
206          case empty:
207          case integer:
208          case tfloat:
209          case func:
210          case symb:
211            /* Symbol strings are freed when walking the hash table */
212          }
213    
214        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
215        titem= env->gc_ref->next;        titem= env->gc_ref->next;
216        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
217        env->gc_ref= titem;        env->gc_ref= titem;
218        continue;        continue;
219      }      }
220    #ifdef DEBUG
221        printf("Kept value (%p)", env->gc_ref->item);
222        if(env->gc_ref->item->gc.flag.mark)
223          printf(" (marked)");
224        if(env->gc_ref->item->gc.flag.protect)
225          printf(" (protected)");
226        switch(env->gc_ref->item->type){
227        case integer:
228          printf(" integer: %d", env->gc_ref->item->content.i);
229          break;
230        case func:
231          printf(" func: %p", env->gc_ref->item->content.ptr);
232          break;
233        case symb:
234          printf(" symb: %s", env->gc_ref->item->content.sym->id);
235          break;
236        case tcons:
237          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
238                 env->gc_ref->item->content.c->cdr);
239          break;
240        default:
241          printf(" <unknown %d>", (env->gc_ref->item->type));
242        }
243        printf("\n");
244    #endif /* DEBUG */
245    
246      /* Keep values */          /* Keep values */    
247      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
248      if(env->gc_ref->item->type==string)      if(env->gc_ref->item->type==string)
249        env->gc_count += strlen(env->gc_ref->item->content.ptr);        env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
250            
251      titem= env->gc_ref->next;      titem= env->gc_ref->next;
252      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
# Line 220  extern void gc_init(environment *env) Line 261  extern void gc_init(environment *env)
261    env->gc_ref= new_head;    env->gc_ref= new_head;
262    
263    if(env->interactive)    if(env->interactive)
264      printf("done\n");      printf("done (%d bytes still allocated)\n", env->gc_count);
265    
266  }  }
267    
# Line 257  void push_val(environment *env, value *v Line 298  void push_val(environment *env, value *v
298  {  {
299    value *new_value= new_val(env);    value *new_value= new_val(env);
300    
301    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(pair));
302      assert(new_value->content.c!=NULL);
303      env->gc_count += sizeof(pair);
304    new_value->type= tcons;    new_value->type= tcons;
305    CAR(new_value)= val;    CAR(new_value)= val;
306    CDR(new_value)= env->head;    CDR(new_value)= env->head;
# Line 324  extern void mangle(environment *env) Line 367  extern void mangle(environment *env)
367  {  {
368    char *new_string;    char *new_string;
369    
370    if(env->head==NULL) {    if(env->head->type==empty) {
371      printerr("Too Few Arguments");      printerr("Too Few Arguments");
372      env->err= 1;      env->err= 1;
373      return;      return;
# Line 421  extern void nl() Line 464  extern void nl()
464  /* Gets the type of a value */  /* Gets the type of a value */
465  extern void type(environment *env)  extern void type(environment *env)
466  {  {
467    int typenum;    if(env->head->type==empty) {
   
   if(env->head==NULL) {  
468      printerr("Too Few Arguments");      printerr("Too Few Arguments");
469      env->err= 1;      env->err= 1;
470      return;      return;
471    }    }
472    
473    typenum= CAR(env->head)->type;    switch(CAR(env->head)->type){
474    toss(env);    case empty:
475    switch(typenum){      push_sym(env, "empty");
476        break;
477    case integer:    case integer:
478      push_sym(env, "integer");      push_sym(env, "integer");
479      break;      break;
# Line 448  extern void type(environment *env) Line 490  extern void type(environment *env)
490      push_sym(env, "function");      push_sym(env, "function");
491      break;      break;
492    case tcons:    case tcons:
493      push_sym(env, "list");      push_sym(env, "pair");
494      break;      break;
495    }    }
496      swap(env);
497      if (env->err) return;
498      toss(env);
499  }      }    
500    
501  /* Prints the top element of the stack. */  /* Print a value */
502  void print_h(value *stack_head, int noquote)  void print_val(value *val, int noquote)
503  {  {
504    switch(CAR(stack_head)->type) {    switch(val->type) {
505      case empty:
506        printf("[]");
507        break;
508    case integer:    case integer:
509      printf("%d", CAR(stack_head)->content.i);      printf("%d", val->content.i);
510      break;      break;
511    case tfloat:    case tfloat:
512      printf("%f", CAR(stack_head)->content.f);      printf("%f", val->content.f);
513      break;      break;
514    case string:    case string:
515      if(noquote)      if(noquote)
516        printf("%s", (char*)CAR(stack_head)->content.ptr);        printf("%s", (char*)(val->content.ptr));
517      else      else
518        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);        printf("\"%s\"", (char*)(val->content.ptr));
519      break;      break;
520    case symb:    case symb:
521      printf("%s", CAR(stack_head)->content.sym->id);      printf("%s", val->content.sym->id);
522      break;      break;
523    case func:    case func:
524      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));      printf("#<function %p>", (funcp)(val->content.ptr));
525      break;      break;
526    case tcons:    case tcons:
     /* A list is just a stack, so make stack_head point to it */  
     stack_head= CAR(stack_head);  
527      printf("[ ");      printf("[ ");
528      while(stack_head != NULL) {      do {
529        print_h(stack_head, noquote);        print_val(CAR(val), noquote);
530        printf(" ");        val= CDR(val);
531        stack_head= CDR(stack_head);        switch(val->type){
532      }        case empty:
533      printf("]");          break;
534          case tcons:
535            printf(" ");
536            break;
537          default:
538            printf(" . ");          /* Improper list */
539            print_val(val, noquote);
540          }
541        } while(val->type == tcons);
542        printf(" ]");
543      break;      break;
544    }    }
545  }  }
546    
547  extern void print_(environment *env)  extern void print_(environment *env)
548  {  {
549    if(env->head==NULL) {    if(env->head->type==empty) {
550      printerr("Too Few Arguments");      printerr("Too Few Arguments");
551      env->err= 1;      env->err= 1;
552      return;      return;
553    }    }
554    print_h(env->head, 0);    print_val(CAR(env->head), 0);
555    nl();    nl();
556  }  }
557    
# Line 510  extern void print(environment *env) Line 565  extern void print(environment *env)
565    
566  extern void princ_(environment *env)  extern void princ_(environment *env)
567  {  {
568    if(env->head==NULL) {    if(env->head->type==empty) {
569      printerr("Too Few Arguments");      printerr("Too Few Arguments");
570      env->err= 1;      env->err= 1;
571      return;      return;
572    }    }
573    print_h(env->head, 1);    print_val(CAR(env->head), 1);
574  }  }
575    
576  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack and then discards it. */
# Line 529  extern void princ(environment *env) Line 584  extern void princ(environment *env)
584  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
585  void print_st(value *stack_head, long counter)  void print_st(value *stack_head, long counter)
586  {  {
587    if(CDR(stack_head) != NULL)    if(CDR(stack_head)->type != empty)
588      print_st(CDR(stack_head), counter+1);      print_st(CDR(stack_head), counter+1);
589    printf("%ld: ", counter);    printf("%ld: ", counter);
590    print_h(stack_head, 0);    print_val(CAR(stack_head), 0);
591    nl();    nl();
592  }  }
593    
594  /* Prints the stack. */  /* Prints the stack. */
595  extern void printstack(environment *env)  extern void printstack(environment *env)
596  {  {
597    if(env->head == NULL) {    if(env->head->type == empty) {
598      printf("Stack Empty\n");      printf("Stack Empty\n");
599      return;      return;
600    }    }
# Line 552  extern void swap(environment *env) Line 607  extern void swap(environment *env)
607  {  {
608    value *temp= env->head;    value *temp= env->head;
609        
610    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
611      printerr("Too Few Arguments");      printerr("Too Few Arguments");
612      env->err=1;      env->err=1;
613      return;      return;
# Line 568  extern void rot(environment *env) Line 623  extern void rot(environment *env)
623  {  {
624    value *temp= env->head;    value *temp= env->head;
625        
626    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
627       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type == empty) {
628      printerr("Too Few Arguments");      printerr("Too Few Arguments");
629      env->err= 1;      env->err= 1;
630      return;      return;
# Line 585  extern void rcl(environment *env) Line 640  extern void rcl(environment *env)
640  {  {
641    value *val;    value *val;
642    
643    if(env->head==NULL) {    if(env->head->type==empty) {
644      printerr("Too Few Arguments");      printerr("Too Few Arguments");
645      env->err= 1;      env->err= 1;
646      return;      return;
# Line 603  extern void rcl(environment *env) Line 658  extern void rcl(environment *env)
658      env->err= 3;      env->err= 3;
659      return;      return;
660    }    }
661    protect(val);    push_val(env, val);           /* Return the symbol's bound value */
662    toss(env);            /* toss the symbol */    swap(env);
663      if(env->err) return;
664      toss(env);                    /* toss the symbol */
665    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(val);  
666  }  }
667    
668  /* 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 623  extern void eval(environment *env) Line 678  extern void eval(environment *env)
678    
679    gc_maybe(env);    gc_maybe(env);
680    
681    if(env->head==NULL) {    if(env->head->type==empty) {
682      printerr("Too Few Arguments");      printerr("Too Few Arguments");
683      env->err= 1;      env->err= 1;
684      return;      return;
# Line 654  extern void eval(environment *env) Line 709  extern void eval(environment *env)
709      toss(env); if(env->err) return;      toss(env); if(env->err) return;
710      iterator= temp_val;      iterator= temp_val;
711            
712      while(iterator!=NULL) {      while(iterator->type != empty) {
713        push_val(env, CAR(iterator));        push_val(env, CAR(iterator));
714                
715        if(CAR(env->head)->type==symb        if(CAR(env->head)->type==symb
# Line 662  extern void eval(environment *env) Line 717  extern void eval(environment *env)
717          toss(env);          toss(env);
718          if(env->err) return;          if(env->err) return;
719                    
720          if(CDR(iterator)==NULL){          if(CDR(iterator)->type == empty){
721            goto eval_start;            goto eval_start;
722          }          }
723          eval(env);          eval(env);
724          if(env->err) return;          if(env->err) return;
725        }        }
726        if (CDR(iterator)->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
727          iterator= CDR(iterator);          iterator= CDR(iterator);
728        else {        else {
729          printerr("Bad Argument Type"); /* Improper list */          printerr("Bad Argument Type"); /* Improper list */
# Line 679  extern void eval(environment *env) Line 734  extern void eval(environment *env)
734      unprotect(temp_val);      unprotect(temp_val);
735      return;      return;
736    
737    default:    case empty:
738      case integer:
739      case tfloat:
740      case string:
741      return;      return;
742    }    }
743  }  }
# Line 689  extern void rev(environment *env) Line 747  extern void rev(environment *env)
747  {  {
748    value *old_head, *new_head, *item;    value *old_head, *new_head, *item;
749    
750    if(env->head==NULL) {    if(env->head->type==empty) {
751      printerr("Too Few Arguments");      printerr("Too Few Arguments");
752      env->err= 1;      env->err= 1;
753      return;      return;
754    }    }
755    
756      if(CAR(env->head)->type==empty)
757        return;                     /* Don't reverse an empty list */
758    
759    if(CAR(env->head)->type!=tcons) {    if(CAR(env->head)->type!=tcons) {
760      printerr("Bad Argument Type");      printerr("Bad Argument Type");
761      env->err= 2;      env->err= 2;
# Line 702  extern void rev(environment *env) Line 763  extern void rev(environment *env)
763    }    }
764    
765    old_head= CAR(env->head);    old_head= CAR(env->head);
766    new_head= NULL;    new_head= new_val(env);
767    while(old_head!=NULL) {    new_head->type= empty;
768      while(old_head->type != empty) {
769      item= old_head;      item= old_head;
770      old_head= CDR(old_head);      old_head= CDR(old_head);
771      CDR(item)= new_head;      CDR(item)= new_head;
# Line 715  extern void rev(environment *env) Line 777  extern void rev(environment *env)
777  /* Make a list. */  /* Make a list. */
778  extern void pack(environment *env)  extern void pack(environment *env)
779  {  {
780    value *iterator, *temp;    value *iterator, *temp, *ending;
781    
782      ending=new_val(env);
783      ending->type=empty;
784    
785    iterator= env->head;    iterator= env->head;
786    if(iterator==NULL    if(iterator->type == empty
787       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
788       && CAR(iterator)->content.sym->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
789      temp= NULL;      temp= ending;
790      toss(env);      toss(env);
791    } else {    } else {
792      /* Search for first delimiter */      /* Search for first delimiter */
793      while(CDR(iterator)!=NULL      while(CDR(iterator)->type != empty
794            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
795             || CAR(CDR(iterator))->content.sym->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
796        iterator= CDR(iterator);        iterator= CDR(iterator);
# Line 733  extern void pack(environment *env) Line 798  extern void pack(environment *env)
798      /* Extract list */      /* Extract list */
799      temp= env->head;      temp= env->head;
800      env->head= CDR(iterator);      env->head= CDR(iterator);
801      CDR(iterator)= NULL;      CDR(iterator)= ending;
802    
803      if(env->head!=NULL)      if(env->head->type != empty)
804        toss(env);        toss(env);
805    }    }
806    
# Line 751  extern void expand(environment *env) Line 816  extern void expand(environment *env)
816    value *temp, *new_head;    value *temp, *new_head;
817    
818    /* Is top element a list? */    /* Is top element a list? */
819    if(env->head==NULL) {    if(env->head->type==empty) {
820      printerr("Too Few Arguments");      printerr("Too Few Arguments");
821      env->err= 1;      env->err= 1;
822      return;      return;
# Line 774  extern void expand(environment *env) Line 839  extern void expand(environment *env)
839    toss(env);    toss(env);
840    
841    /* Find the end of the list */    /* Find the end of the list */
842    while(CDR(temp)->content.ptr != NULL) {    while(CDR(temp)->type != empty) {
843      if (CDR(temp)->type == tcons)      if (CDR(temp)->type == tcons)
844        temp= CDR(temp);        temp= CDR(temp);
845      else {      else {
# Line 795  extern void eq(environment *env) Line 860  extern void eq(environment *env)
860  {  {
861    void *left, *right;    void *left, *right;
862    
863    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
864      printerr("Too Few Arguments");      printerr("Too Few Arguments");
865      env->err= 1;      env->err= 1;
866      return;      return;
# Line 813  extern void not(environment *env) Line 878  extern void not(environment *env)
878  {  {
879    int val;    int val;
880    
881    if(env->head==NULL) {    if(env->head->type==empty) {
882      printerr("Too Few Arguments");      printerr("Too Few Arguments");
883      env->err= 1;      env->err= 1;
884      return;      return;
# Line 844  extern void def(environment *env) Line 909  extern void def(environment *env)
909    symbol *sym;    symbol *sym;
910    
911    /* 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 */
912    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
913      printerr("Too Few Arguments");      printerr("Too Few Arguments");
914      env->err= 1;      env->err= 1;
915      return;      return;
# Line 883  extern void quit(environment *env) Line 948  extern void quit(environment *env)
948    env->gc_limit= 0;    env->gc_limit= 0;
949    gc_maybe(env);    gc_maybe(env);
950    
951      words(env);
952    
953    if(env->free_string!=NULL)    if(env->free_string!=NULL)
954      free(env->free_string);      free(env->free_string);
955        
# Line 896  extern void quit(environment *env) Line 963  extern void quit(environment *env)
963  /* Clear stack */  /* Clear stack */
964  extern void clear(environment *env)  extern void clear(environment *env)
965  {  {
966    while(env->head!=NULL)    while(env->head->type != empty)
967      toss(env);      toss(env);
968  }  }
969    
# Line 909  extern void words(environment *env) Line 976  extern void words(environment *env)
976    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
977      temp= env->symbols[i];      temp= env->symbols[i];
978      while(temp!=NULL) {      while(temp!=NULL) {
979    #ifdef DEBUG
980          if (temp->val != NULL && temp->val->gc.flag.protect)
981            printf("(protected) ");
982    #endif /* DEBUG */
983        printf("%s\n", temp->id);        printf("%s\n", temp->id);
984        temp= temp->next;        temp= temp->next;
985      }      }
# Line 931  void forget_sym(symbol **hash_entry) Line 1002  void forget_sym(symbol **hash_entry)
1002  extern void forget(environment *env)  extern void forget(environment *env)
1003  {  {
1004    char* sym_id;    char* sym_id;
   value *stack_head= env->head;  
1005    
1006    if(stack_head==NULL) {    if(env->head->type==empty) {
1007      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1008      env->err= 1;      env->err= 1;
1009      return;      return;
1010    }    }
1011        
1012    if(CAR(stack_head)->type!=symb) {    if(CAR(env->head)->type!=symb) {
1013      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1014      env->err= 2;      env->err= 2;
1015      return;      return;
1016    }    }
1017    
1018    sym_id= CAR(stack_head)->content.sym->id;    sym_id= CAR(env->head)->content.sym->id;
1019    toss(env);    toss(env);
1020    
1021    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 979  int main(int argc, char **argv) Line 1049  int main(int argc, char **argv)
1049          break;          break;
1050        case '?':        case '?':
1051          fprintf (stderr,          fprintf (stderr,
1052                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1053                   optopt);                   optopt);
1054          return EX_USAGE;          return EX_USAGE;
1055        default:        default:
# Line 998  int main(int argc, char **argv) Line 1068  int main(int argc, char **argv)
1068    if(myenv.interactive) {    if(myenv.interactive) {
1069      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1070  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1071  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1072  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1073  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1074    }    }
1075    
1076    while(1) {    while(1) {
# Line 1015  under certain conditions; type `copying; Line 1085  under certain conditions; type `copying;
1085        }        }
1086        myenv.err=0;        myenv.err=0;
1087      }      }
1088      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1089      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1090        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1091      } else if(myenv.head!=NULL        quit(&myenv);
1092        } else if(myenv.head->type!=empty
1093                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
1094                && CAR(myenv.head)->content.sym->id[0]                && CAR(myenv.head)->content.sym->id[0]
1095                ==';') {                ==';') {
# Line 1040  extern void sx_2b(environment *env) Line 1111  extern void sx_2b(environment *env)
1111    char* new_string;    char* new_string;
1112    value *a_val, *b_val;    value *a_val, *b_val;
1113    
1114    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1115      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1116      env->err= 1;      env->err= 1;
1117      return;      return;
# Line 1118  extern void sx_2d(environment *env) Line 1189  extern void sx_2d(environment *env)
1189    int a, b;    int a, b;
1190    float fa, fb;    float fa, fb;
1191    
1192    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1193      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1194      env->err=1;      env->err=1;
1195      return;      return;
# Line 1178  extern void sx_3e(environment *env) Line 1249  extern void sx_3e(environment *env)
1249    int a, b;    int a, b;
1250    float fa, fb;    float fa, fb;
1251    
1252    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1253      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1254      env->err= 1;      env->err= 1;
1255      return;      return;
# Line 1263  value *copy_val(environment *env, value Line 1334  value *copy_val(environment *env, value
1334    
1335    protect(old_value);    protect(old_value);
1336    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
1337    new_value->type= old_value->type;    new_value->type= old_value->type;
1338    
1339    switch(old_value->type){    switch(old_value->type){
# Line 1271  value *copy_val(environment *env, value Line 1341  value *copy_val(environment *env, value
1341    case integer:    case integer:
1342    case func:    case func:
1343    case symb:    case symb:
1344      case empty:
1345      new_value->content= old_value->content;      new_value->content= old_value->content;
1346      break;      break;
1347    case string:    case string:
# Line 1278  value *copy_val(environment *env, value Line 1349  value *copy_val(environment *env, value
1349        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1350      break;      break;
1351    case tcons:    case tcons:
     new_value= NULL;  
1352    
1353      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(pair));
1354        assert(new_value->content.c!=NULL);
1355        env->gc_count += sizeof(pair);
1356    
1357      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1358      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
1359      break;      break;
1360    }    }
1361    
1362    unprotect(old_value); unprotect(new_value);    unprotect(old_value);
1363    
1364    return new_value;    return new_value;
1365  }  }
# Line 1294  value *copy_val(environment *env, value Line 1367  value *copy_val(environment *env, value
1367  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1368  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1369  {  {
1370    if(env->head==NULL) {    if(env->head->type==empty) {
1371      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1372      env->err= 1;      env->err= 1;
1373      return;      return;
# Line 1307  extern void sx_6966(environment *env) Line 1380  extern void sx_6966(environment *env)
1380  {  {
1381    int truth;    int truth;
1382    
1383    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1384      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1385      env->err= 1;      env->err= 1;
1386      return;      return;
# Line 1338  extern void ifelse(environment *env) Line 1411  extern void ifelse(environment *env)
1411  {  {
1412    int truth;    int truth;
1413    
1414    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1415       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type==empty) {
1416      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1417      env->err= 1;      env->err= 1;
1418      return;      return;
# Line 1371  extern void ifelse(environment *env) Line 1444  extern void ifelse(environment *env)
1444    
1445  extern void sx_656c7365(environment *env)  extern void sx_656c7365(environment *env)
1446  {  {
1447    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1448       || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL) {       || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1449         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1450        printerr("Too Few Arguments");
1451        env->err= 1;
1452        return;
1453      }
1454    
1455      if(CAR(CDR(env->head))->type!=symb
1456         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1457         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1458         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1459        printerr("Bad Argument Type");
1460        env->err= 2;
1461        return;
1462      }
1463    
1464      swap(env); toss(env); rot(env); toss(env);
1465      ifelse(env);
1466    }
1467    
1468    extern void then(environment *env)
1469    {
1470      if(env->head->type==empty || CDR(env->head)->type==empty
1471         || CDR(CDR(env->head))->type==empty) {
1472      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1473      env->err= 1;      env->err= 1;
1474      return;      return;
# Line 1386  extern void sx_656c7365(environment *env Line 1482  extern void sx_656c7365(environment *env
1482    }    }
1483    
1484    swap(env); toss(env);    swap(env); toss(env);
1485    ifelse(env);    sx_6966(env);
1486  }  }
1487    
1488  /* "while" */  /* "while" */
# Line 1395  extern void sx_7768696c65(environment *e Line 1491  extern void sx_7768696c65(environment *e
1491    int truth;    int truth;
1492    value *loop, *test;    value *loop, *test;
1493    
1494    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1495      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1496      env->err= 1;      env->err= 1;
1497      return;      return;
# Line 1441  extern void sx_666f72(environment *env) Line 1537  extern void sx_666f72(environment *env)
1537    value *loop;    value *loop;
1538    int foo1, foo2;    int foo1, foo2;
1539    
1540    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1541       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type==empty) {
1542      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1543      env->err= 1;      env->err= 1;
1544      return;      return;
# Line 1489  extern void foreach(environment *env) Line 1585  extern void foreach(environment *env)
1585    value *loop, *foo;    value *loop, *foo;
1586    value *iterator;    value *iterator;
1587        
1588    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1589      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1590      env->err= 1;      env->err= 1;
1591      return;      return;
# Line 1532  extern void to(environment *env) Line 1628  extern void to(environment *env)
1628    int ending, start, i;    int ending, start, i;
1629    value *iterator, *temp;    value *iterator, *temp;
1630    
1631    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1632      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1633      env->err= 1;      env->err= 1;
1634      return;      return;
# Line 1562  extern void to(environment *env) Line 1658  extern void to(environment *env)
1658    
1659    iterator= env->head;    iterator= env->head;
1660    
1661    if(iterator==NULL    if(iterator->type==empty
1662       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
1663           && CAR(iterator)->content.sym->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1664      temp= NULL;      temp= NULL;
# Line 1614  extern void sx_72656164(environment *env Line 1710  extern void sx_72656164(environment *env
1710    int count= -1;    int count= -1;
1711    float ftemp;    float ftemp;
1712    static int depth= 0;    static int depth= 0;
1713    char *match, *ctemp;    char *match;
1714    size_t inlength;    size_t inlength;
1715    
1716    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1648  extern void sx_72656164(environment *env Line 1744  extern void sx_72656164(environment *env
1744      } else {      } else {
1745        push_float(env, ftemp);        push_float(env, ftemp);
1746      }      }
1747      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1748                && readlength != -1) {
1749        push_cstring(env, "");
1750    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1751              && readlength != -1) {              && readlength != -1) {
1752      push_cstring(env, match);      push_cstring(env, match);
# Line 1684  extern void beep(environment *env) Line 1783  extern void beep(environment *env)
1783  {  {
1784    int freq, dur, period, ticks;    int freq, dur, period, ticks;
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 1729  extern void sx_77616974(environment *env Line 1828  extern void sx_77616974(environment *env
1828  {  {
1829    int dur;    int dur;
1830    
1831    if(env->head==NULL) {    if(env->head->type==empty) {
1832      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1833      env->err= 1;      env->err= 1;
1834      return;      return;
# Line 1749  extern void sx_77616974(environment *env Line 1848  extern void sx_77616974(environment *env
1848    
1849  extern void copying(environment *env)  extern void copying(environment *env)
1850  {  {
1851    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1852                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1853  \n\  \n\
1854   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2038  extern void sx_2a(environment *env) Line 2137  extern void sx_2a(environment *env)
2137    int a, b;    int a, b;
2138    float fa, fb;    float fa, fb;
2139    
2140    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2141      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2142      env->err= 1;      env->err= 1;
2143      return;      return;
# Line 2098  extern void sx_2f(environment *env) Line 2197  extern void sx_2f(environment *env)
2197    int a, b;    int a, b;
2198    float fa, fb;    float fa, fb;
2199    
2200    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2201      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2202      env->err= 1;      env->err= 1;
2203      return;      return;
# Line 2157  extern void mod(environment *env) Line 2256  extern void mod(environment *env)
2256  {  {
2257    int a, b;    int a, b;
2258    
2259    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2260      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2261      env->err= 1;      env->err= 1;
2262      return;      return;
# Line 2183  extern void sx_646976(environment *env) Line 2282  extern void sx_646976(environment *env)
2282  {  {
2283    int a, b;    int a, b;
2284        
2285    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2286      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2287      env->err= 1;      env->err= 1;
2288      return;      return;
# Line 2203  extern void sx_646976(environment *env) Line 2302  extern void sx_646976(environment *env)
2302    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2303    env->err= 2;    env->err= 2;
2304  }  }
2305    
2306    extern void setcar(environment *env)
2307    {
2308      if(env->head->type==empty || CDR(env->head)->type==empty) {
2309        printerr("Too Few Arguments");
2310        env->err= 1;
2311        return;
2312      }
2313    
2314      if(CDR(env->head)->type!=tcons) {
2315        printerr("Bad Argument Type");
2316        env->err= 2;
2317        return;
2318      }
2319    
2320      CAR(CAR(CDR(env->head)))=CAR(env->head);
2321      toss(env);
2322    }
2323    
2324    extern void setcdr(environment *env)
2325    {
2326      if(env->head->type==empty || CDR(env->head)->type==empty) {
2327        printerr("Too Few Arguments");
2328        env->err= 1;
2329        return;
2330      }
2331    
2332      if(CDR(env->head)->type!=tcons) {
2333        printerr("Bad Argument Type");
2334        env->err= 2;
2335        return;
2336      }
2337    
2338      CDR(CAR(CDR(env->head)))=CAR(env->head);
2339      toss(env);
2340    }
2341    
2342    extern void car(environment *env)
2343    {
2344      if(env->head->type==empty) {
2345        printerr("Too Few Arguments");
2346        env->err= 1;
2347        return;
2348      }
2349    
2350      if(CAR(env->head)->type!=tcons) {
2351        printerr("Bad Argument Type");
2352        env->err= 2;
2353        return;
2354      }
2355    
2356      CAR(env->head)=CAR(CAR(env->head));
2357    }
2358    
2359    extern void cdr(environment *env)
2360    {
2361      if(env->head->type==empty) {
2362        printerr("Too Few Arguments");
2363        env->err= 1;
2364        return;
2365      }
2366    
2367      if(CAR(env->head)->type!=tcons) {
2368        printerr("Bad Argument Type");
2369        env->err= 2;
2370        return;
2371      }
2372    
2373      CAR(env->head)=CDR(CAR(env->head));
2374    }
2375    
2376    extern void cons(environment *env)
2377    {
2378      value *val;
2379    
2380      if(env->head->type==empty || CDR(env->head)->type==empty) {
2381        printerr("Too Few Arguments");
2382        env->err= 1;
2383        return;
2384      }
2385    
2386      val=new_val(env);
2387      val->content.c= malloc(sizeof(pair));
2388      assert(val->content.c!=NULL);
2389    
2390      env->gc_count += sizeof(pair);
2391      val->type=tcons;
2392    
2393      CAR(val)= CAR(CDR(env->head));
2394      CDR(val)= CAR(env->head);
2395    
2396      push_val(env, val);
2397    
2398      swap(env); if(env->err) return;
2399      toss(env); if(env->err) return;
2400      swap(env); if(env->err) return;
2401      toss(env); if(env->err) return;
2402    }
Legend:
Removed from v.1.107  
changed lines
  Added in v.1.116
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26