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

Diff of /stack/stack.c

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

revision 1.104 by masse, Tue Mar 12 14:06:05 2002 UTC revision 1.117 by teddy, Wed Mar 20 05:29:29 2002 UTC
# Line 1  Line 1 
1    /* -*- coding: utf-8; -*- */
2  /*  /*
3      stack - an interactive interpreter for a stack-based language      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__
45  /* mtrace, muntrace */  /* mtrace, muntrace */
46  #include <mcheck.h>  #include <mcheck.h>
47  /* ioctl */  /* ioctl */
48  #include <sys/ioctl.h>  #include <sys/ioctl.h>
49  /* KDMKTONE */  /* KDMKTONE */
50  #include <linux/kd.h>  #include <linux/kd.h>
51    #endif /* __linux__ */
52    
53  #include "stack.h"  #include "stack.h"
54    
# Line 55  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 73  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 118  value* new_val(environment *env) Line 124  value* new_val(environment *env)
124    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
125    
126    nval->content.ptr= NULL;    nval->content.ptr= NULL;
127      nval->type= empty;
128    
129    nitem->item= nval;    nitem->item= nval;
130    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
# Line 158  inline void gc_maybe(environment *env) Line 165  inline void gc_maybe(environment *env)
165  extern void gc_init(environment *env)  extern void gc_init(environment *env)
166  {  {
167    stackitem *new_head= NULL, *titem;    stackitem *new_head= NULL, *titem;
   cons *iterator;  
168    symbol *tsymb;    symbol *tsymb;
169    int i;    int i;
170    
# Line 182  extern void gc_init(environment *env) Line 188  extern void gc_init(environment *env)
188    if(env->interactive)    if(env->interactive)
189      printf(".");      printf(".");
190    
   
191    env->gc_count= 0;    env->gc_count= 0;
192    
193    while(env->gc_ref!=NULL) {    /* Sweep unused values */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
194    
195      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
196    
197        if(env->gc_ref->item->type==string) /* Remove content */        /* Remove content */
198          switch(env->gc_ref->item->type){
199          case string:
200          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
201            break;
202          case tcons:
203            free(env->gc_ref->item->content.c);
204            break;
205          case empty:
206          case integer:
207          case tfloat:
208          case func:
209          case symb:
210            /* Symbol strings are freed when walking the hash table */
211          }
212    
213        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
214        titem= env->gc_ref->next;        titem= env->gc_ref->next;
215        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
216        env->gc_ref= titem;        env->gc_ref= titem;
217        continue;        continue;
218      }      }
219    #ifdef DEBUG
220        printf("Kept value (%p)", env->gc_ref->item);
221        if(env->gc_ref->item->gc.flag.mark)
222          printf(" (marked)");
223        if(env->gc_ref->item->gc.flag.protect)
224          printf(" (protected)");
225        switch(env->gc_ref->item->type){
226        case integer:
227          printf(" integer: %d", env->gc_ref->item->content.i);
228          break;
229        case func:
230          printf(" func: %p", env->gc_ref->item->content.ptr);
231          break;
232        case symb:
233          printf(" symb: %s", env->gc_ref->item->content.sym->id);
234          break;
235        case tcons:
236          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
237                 env->gc_ref->item->content.c->cdr);
238          break;
239        default:
240          printf(" <unknown %d>", (env->gc_ref->item->type));
241        }
242        printf("\n");
243    #endif /* DEBUG */
244    
245      /* Keep values */          /* Keep values */    
246      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
247      if(env->gc_ref->item->type==string)      if(env->gc_ref->item->type==string)
248        env->gc_count += strlen(env->gc_ref->item->content.ptr);        env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
249            
250      titem= env->gc_ref->next;      titem= env->gc_ref->next;
251      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
# Line 217  extern void gc_init(environment *env) Line 260  extern void gc_init(environment *env)
260    env->gc_ref= new_head;    env->gc_ref= new_head;
261    
262    if(env->interactive)    if(env->interactive)
263      printf("done\n");      printf("done (%d bytes still allocated)\n", env->gc_count);
264    
265  }  }
266    
# Line 254  void push_val(environment *env, value *v Line 297  void push_val(environment *env, value *v
297  {  {
298    value *new_value= new_val(env);    value *new_value= new_val(env);
299    
300    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(pair));
301      assert(new_value->content.c!=NULL);
302      env->gc_count += sizeof(pair);
303    new_value->type= tcons;    new_value->type= tcons;
304    CAR(new_value)= val;    CAR(new_value)= val;
305    CDR(new_value)= env->head;    CDR(new_value)= env->head;
# Line 321  extern void mangle(environment *env) Line 366  extern void mangle(environment *env)
366  {  {
367    char *new_string;    char *new_string;
368    
369    if(env->head==NULL) {    if(env->head->type==empty) {
370      printerr("Too Few Arguments");      printerr("Too Few Arguments");
371      env->err= 1;      env->err= 1;
372      return;      return;
# Line 418  extern void nl() Line 463  extern void nl()
463  /* Gets the type of a value */  /* Gets the type of a value */
464  extern void type(environment *env)  extern void type(environment *env)
465  {  {
466    int typenum;    if(env->head->type==empty) {
   
   if(env->head==NULL) {  
467      printerr("Too Few Arguments");      printerr("Too Few Arguments");
468      env->err= 1;      env->err= 1;
469      return;      return;
470    }    }
471    
472    typenum= CAR(env->head)->type;    switch(CAR(env->head)->type){
473    toss(env);    case empty:
474    switch(typenum){      push_sym(env, "empty");
475        break;
476    case integer:    case integer:
477      push_sym(env, "integer");      push_sym(env, "integer");
478      break;      break;
# Line 445  extern void type(environment *env) Line 489  extern void type(environment *env)
489      push_sym(env, "function");      push_sym(env, "function");
490      break;      break;
491    case tcons:    case tcons:
492      push_sym(env, "list");      push_sym(env, "pair");
493      break;      break;
494    }    }
495      swap(env);
496      if (env->err) return;
497      toss(env);
498  }      }    
499    
500  /* Prints the top element of the stack. */  /* Print a value */
501  void print_h(value *stack_head, int noquote)  void print_val(value *val, int noquote, stackitem *stack)
502  {  {
503    switch(CAR(stack_head)->type) {    stackitem *titem, *tstack;
504      int depth;
505    
506      switch(val->type) {
507      case empty:
508        printf("[]");
509        break;
510    case integer:    case integer:
511      printf("%d", CAR(stack_head)->content.i);      printf("%d", val->content.i);
512      break;      break;
513    case tfloat:    case tfloat:
514      printf("%f", CAR(stack_head)->content.f);      printf("%f", val->content.f);
515      break;      break;
516    case string:    case string:
517      if(noquote)      if(noquote)
518        printf("%s", (char*)CAR(stack_head)->content.ptr);        printf("%s", (char*)(val->content.ptr));
519      else      else
520        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);        printf("\"%s\"", (char*)(val->content.ptr));
521      break;      break;
522    case symb:    case symb:
523      printf("%s", ((symbol *)(CAR(stack_head)->content.ptr))->id);      printf("%s", val->content.sym->id);
524      break;      break;
525    case func:    case func:
526      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));      printf("#<function %p>", (funcp)(val->content.ptr));
527      break;      break;
528    case tcons:    case tcons:
     /* A list is just a stack, so make stack_head point to it */  
     stack_head= CAR(stack_head);  
529      printf("[ ");      printf("[ ");
530      while(stack_head != NULL) {      tstack= stack;
531        print_h(stack_head, noquote);      do {
532        printf(" ");        titem=malloc(sizeof(stackitem));
533        stack_head= CDR(stack_head);        titem->item=val;
534          titem->next=tstack;
535          tstack=titem;             /* Put it on the stack */
536          /* Search a stack of values being printed to see if we are already
537             printing this value */
538          titem=tstack;
539          depth=0;
540          while(titem != NULL && titem->item != CAR(val)){
541            titem=titem->next;
542            depth++;
543          }
544          if(titem != NULL){        /* If we found it on the stack, */
545            printf("#%d#", depth);  /* print a depth reference */
546          } else {
547            print_val(CAR(val), noquote, tstack);
548          }
549          val= CDR(val);
550          switch(val->type){
551          case empty:
552            break;
553          case tcons:
554            /* Search a stack of values being printed to see if we are already
555               printing this value */
556            titem=tstack;
557            depth=0;
558            while(titem != NULL && titem->item != val){
559              titem=titem->next;
560              depth++;
561            }
562            if(titem != NULL){      /* If we found it on the stack, */
563              printf(" . #%d#", depth); /* print a depth reference */
564            } else {
565              printf(" ");
566            }
567            break;
568          default:
569            printf(" . ");          /* Improper list */
570            print_val(val, noquote, tstack);
571          }
572        } while(val->type == tcons && titem == NULL);
573        titem=tstack;
574        while(titem != stack){
575          tstack=titem->next;
576          free(titem);
577          titem=tstack;
578      }      }
579      printf("]");      printf(" ]");
580      break;      break;
581    }    }
582  }  }
583    
584  extern void print_(environment *env)  extern void print_(environment *env)
585  {  {
586    if(env->head==NULL) {    if(env->head->type==empty) {
587      printerr("Too Few Arguments");      printerr("Too Few Arguments");
588      env->err= 1;      env->err= 1;
589      return;      return;
590    }    }
591    print_h(env->head, 0);    print_val(CAR(env->head), 0, NULL);
592    nl();    nl();
593  }  }
594    
# Line 507  extern void print(environment *env) Line 602  extern void print(environment *env)
602    
603  extern void princ_(environment *env)  extern void princ_(environment *env)
604  {  {
605    if(env->head==NULL) {    if(env->head->type==empty) {
606      printerr("Too Few Arguments");      printerr("Too Few Arguments");
607      env->err= 1;      env->err= 1;
608      return;      return;
609    }    }
610    print_h(env->head, 1);    print_val(CAR(env->head), 1, NULL);
611  }  }
612    
613  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack and then discards it. */
# Line 526  extern void princ(environment *env) Line 621  extern void princ(environment *env)
621  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
622  void print_st(value *stack_head, long counter)  void print_st(value *stack_head, long counter)
623  {  {
624    if(CDR(stack_head) != NULL)    if(CDR(stack_head)->type != empty)
625      print_st(CDR(stack_head), counter+1);      print_st(CDR(stack_head), counter+1);
626    printf("%ld: ", counter);    printf("%ld: ", counter);
627    print_h(stack_head, 0);    print_val(CAR(stack_head), 0, NULL);
628    nl();    nl();
629  }  }
630    
631  /* Prints the stack. */  /* Prints the stack. */
632  extern void printstack(environment *env)  extern void printstack(environment *env)
633  {  {
634    if(env->head == NULL) {    if(env->head->type == empty) {
635      printf("Stack Empty\n");      printf("Stack Empty\n");
636      return;      return;
637    }    }
# Line 549  extern void swap(environment *env) Line 644  extern void swap(environment *env)
644  {  {
645    value *temp= env->head;    value *temp= env->head;
646        
647    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
648      printerr("Too Few Arguments");      printerr("Too Few Arguments");
649      env->err=1;      env->err=1;
650      return;      return;
# Line 565  extern void rot(environment *env) Line 660  extern void rot(environment *env)
660  {  {
661    value *temp= env->head;    value *temp= env->head;
662        
663    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
664       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type == empty) {
665      printerr("Too Few Arguments");      printerr("Too Few Arguments");
666      env->err= 1;      env->err= 1;
667      return;      return;
# Line 582  extern void rcl(environment *env) Line 677  extern void rcl(environment *env)
677  {  {
678    value *val;    value *val;
679    
680    if(env->head==NULL) {    if(env->head->type==empty) {
681      printerr("Too Few Arguments");      printerr("Too Few Arguments");
682      env->err= 1;      env->err= 1;
683      return;      return;
# Line 594  extern void rcl(environment *env) Line 689  extern void rcl(environment *env)
689      return;      return;
690    }    }
691    
692    val= ((symbol *)(CAR(env->head)->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
693    if(val == NULL){    if(val == NULL){
694      printerr("Unbound Variable");      printerr("Unbound Variable");
695      env->err= 3;      env->err= 3;
696      return;      return;
697    }    }
698    protect(val);    push_val(env, val);           /* Return the symbol's bound value */
699    toss(env);            /* toss the symbol */    swap(env);
700      if(env->err) return;
701      toss(env);                    /* toss the symbol */
702    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(val);  
703  }  }
704    
705  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
# Line 620  extern void eval(environment *env) Line 715  extern void eval(environment *env)
715    
716    gc_maybe(env);    gc_maybe(env);
717    
718    if(env->head==NULL) {    if(env->head->type==empty) {
719      printerr("Too Few Arguments");      printerr("Too Few Arguments");
720      env->err= 1;      env->err= 1;
721      return;      return;
# Line 651  extern void eval(environment *env) Line 746  extern void eval(environment *env)
746      toss(env); if(env->err) return;      toss(env); if(env->err) return;
747      iterator= temp_val;      iterator= temp_val;
748            
749      while(iterator!=NULL) {      while(iterator->type != empty) {
750        push_val(env, CAR(iterator));        push_val(env, CAR(iterator));
751                
752        if(CAR(env->head)->type==symb        if(CAR(env->head)->type==symb
753           && (((symbol*)(CAR(env->head)->content.ptr))->id[0]==';')) {           && CAR(env->head)->content.sym->id[0]==';') {
754          toss(env);          toss(env);
755          if(env->err) return;          if(env->err) return;
756                    
757          if(CDR(iterator)==NULL){          if(CDR(iterator)->type == empty){
758            goto eval_start;            goto eval_start;
759          }          }
760          eval(env);          eval(env);
761          if(env->err) return;          if(env->err) return;
762        }        }
763        if (CDR(iterator)->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
764          iterator= CDR(iterator);          iterator= CDR(iterator);
765        else {        else {
766          printerr("Bad Argument Type"); /* Improper list */          printerr("Bad Argument Type"); /* Improper list */
# Line 676  extern void eval(environment *env) Line 771  extern void eval(environment *env)
771      unprotect(temp_val);      unprotect(temp_val);
772      return;      return;
773    
774    default:    case empty:
775      case integer:
776      case tfloat:
777      case string:
778      return;      return;
779    }    }
780  }  }
# Line 686  extern void rev(environment *env) Line 784  extern void rev(environment *env)
784  {  {
785    value *old_head, *new_head, *item;    value *old_head, *new_head, *item;
786    
787    if(env->head==NULL) {    if(env->head->type==empty) {
788      printerr("Too Few Arguments");      printerr("Too Few Arguments");
789      env->err= 1;      env->err= 1;
790      return;      return;
791    }    }
792    
793      if(CAR(env->head)->type==empty)
794        return;                     /* Don't reverse an empty list */
795    
796    if(CAR(env->head)->type!=tcons) {    if(CAR(env->head)->type!=tcons) {
797      printerr("Bad Argument Type");      printerr("Bad Argument Type");
798      env->err= 2;      env->err= 2;
# Line 699  extern void rev(environment *env) Line 800  extern void rev(environment *env)
800    }    }
801    
802    old_head= CAR(env->head);    old_head= CAR(env->head);
803    new_head= NULL;    new_head= new_val(env);
804    while(old_head!=NULL) {    while(old_head->type != empty) {
805      item= old_head;      item= old_head;
806      old_head= CDR(old_head);      old_head= CDR(old_head);
807      CDR(item)= new_head;      CDR(item)= new_head;
# Line 712  extern void rev(environment *env) Line 813  extern void rev(environment *env)
813  /* Make a list. */  /* Make a list. */
814  extern void pack(environment *env)  extern void pack(environment *env)
815  {  {
816    value *iterator, *temp;    value *iterator, *temp, *ending;
817    
818      ending=new_val(env);
819    
820    iterator= env->head;    iterator= env->head;
821    if(iterator==NULL    if(iterator->type == empty
822       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
823       && ((symbol*)(CAR(iterator)->content.ptr))->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
824      temp= NULL;      temp= ending;
825      toss(env);      toss(env);
826    } else {    } else {
827      /* Search for first delimiter */      /* Search for first delimiter */
828      while(CDR(iterator)!=NULL      while(CDR(iterator)->type != empty
829            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
830             || ((symbol*)(CAR(CDR(iterator))->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
831        iterator= CDR(iterator);        iterator= CDR(iterator);
832            
833      /* Extract list */      /* Extract list */
834      temp= env->head;      temp= env->head;
835      env->head= CDR(iterator);      env->head= CDR(iterator);
836      CDR(iterator)= NULL;      CDR(iterator)= ending;
837    
838      if(env->head!=NULL)      if(env->head->type != empty)
839        toss(env);        toss(env);
840    }    }
841    
# Line 748  extern void expand(environment *env) Line 851  extern void expand(environment *env)
851    value *temp, *new_head;    value *temp, *new_head;
852    
853    /* Is top element a list? */    /* Is top element a list? */
854    if(env->head==NULL) {    if(env->head->type==empty) {
855      printerr("Too Few Arguments");      printerr("Too Few Arguments");
856      env->err= 1;      env->err= 1;
857      return;      return;
# Line 771  extern void expand(environment *env) Line 874  extern void expand(environment *env)
874    toss(env);    toss(env);
875    
876    /* Find the end of the list */    /* Find the end of the list */
877    while(CDR(temp)->content.ptr != NULL) {    while(CDR(temp)->type != empty) {
878      if (CDR(temp)->type == tcons)      if (CDR(temp)->type == tcons)
879        temp= CDR(temp);        temp= CDR(temp);
880      else {      else {
# Line 792  extern void eq(environment *env) Line 895  extern void eq(environment *env)
895  {  {
896    void *left, *right;    void *left, *right;
897    
898    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
899      printerr("Too Few Arguments");      printerr("Too Few Arguments");
900      env->err= 1;      env->err= 1;
901      return;      return;
# Line 810  extern void not(environment *env) Line 913  extern void not(environment *env)
913  {  {
914    int val;    int val;
915    
916    if(env->head==NULL) {    if(env->head->type==empty) {
917      printerr("Too Few Arguments");      printerr("Too Few Arguments");
918      env->err= 1;      env->err= 1;
919      return;      return;
# Line 841  extern void def(environment *env) Line 944  extern void def(environment *env)
944    symbol *sym;    symbol *sym;
945    
946    /* Needs two values on the stack, the top one must be a symbol */    /* Needs two values on the stack, the top one must be a symbol */
947    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
948      printerr("Too Few Arguments");      printerr("Too Few Arguments");
949      env->err= 1;      env->err= 1;
950      return;      return;
# Line 880  extern void quit(environment *env) Line 983  extern void quit(environment *env)
983    env->gc_limit= 0;    env->gc_limit= 0;
984    gc_maybe(env);    gc_maybe(env);
985    
986      words(env);
987    
988    if(env->free_string!=NULL)    if(env->free_string!=NULL)
989      free(env->free_string);      free(env->free_string);
990        
991    #ifdef __linux__
992    muntrace();    muntrace();
993    #endif
994    
995    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
996  }  }
# Line 891  extern void quit(environment *env) Line 998  extern void quit(environment *env)
998  /* Clear stack */  /* Clear stack */
999  extern void clear(environment *env)  extern void clear(environment *env)
1000  {  {
1001    while(env->head!=NULL)    while(env->head->type != empty)
1002      toss(env);      toss(env);
1003  }  }
1004    
# Line 904  extern void words(environment *env) Line 1011  extern void words(environment *env)
1011    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
1012      temp= env->symbols[i];      temp= env->symbols[i];
1013      while(temp!=NULL) {      while(temp!=NULL) {
1014    #ifdef DEBUG
1015          if (temp->val != NULL && temp->val->gc.flag.protect)
1016            printf("(protected) ");
1017    #endif /* DEBUG */
1018        printf("%s\n", temp->id);        printf("%s\n", temp->id);
1019        temp= temp->next;        temp= temp->next;
1020      }      }
# Line 926  void forget_sym(symbol **hash_entry) Line 1037  void forget_sym(symbol **hash_entry)
1037  extern void forget(environment *env)  extern void forget(environment *env)
1038  {  {
1039    char* sym_id;    char* sym_id;
   value *stack_head= env->head;  
1040    
1041    if(stack_head==NULL) {    if(env->head->type==empty) {
1042      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1043      env->err= 1;      env->err= 1;
1044      return;      return;
1045    }    }
1046        
1047    if(CAR(stack_head)->type!=symb) {    if(CAR(env->head)->type!=symb) {
1048      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1049      env->err= 2;      env->err= 2;
1050      return;      return;
1051    }    }
1052    
1053    sym_id= ((symbol*)(CAR(stack_head)->content.ptr))->id;    sym_id= CAR(env->head)->content.sym->id;
1054    toss(env);    toss(env);
1055    
1056    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 958  int main(int argc, char **argv) Line 1068  int main(int argc, char **argv)
1068    
1069    int c;                        /* getopt option character */    int c;                        /* getopt option character */
1070    
1071    #ifdef __linux__
1072    mtrace();    mtrace();
1073    #endif
1074    
1075    init_env(&myenv);    init_env(&myenv);
1076    
# Line 972  int main(int argc, char **argv) Line 1084  int main(int argc, char **argv)
1084          break;          break;
1085        case '?':        case '?':
1086          fprintf (stderr,          fprintf (stderr,
1087                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1088                   optopt);                   optopt);
1089          return EX_USAGE;          return EX_USAGE;
1090        default:        default:
# Line 991  int main(int argc, char **argv) Line 1103  int main(int argc, char **argv)
1103    if(myenv.interactive) {    if(myenv.interactive) {
1104      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1105  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1106  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1107  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1108  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1109    }    }
1110    
1111    while(1) {    while(1) {
# Line 1008  under certain conditions; type `copying; Line 1120  under certain conditions; type `copying;
1120        }        }
1121        myenv.err=0;        myenv.err=0;
1122      }      }
1123      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1124      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1125        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1126      } else if(myenv.head!=NULL        quit(&myenv);
1127        } else if(myenv.head->type!=empty
1128                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
1129                && ((symbol*)(CAR(myenv.head)->content.ptr))->id[0]                && CAR(myenv.head)->content.sym->id[0]
1130                ==';') {                ==';') {
1131        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1132        eval(&myenv);        eval(&myenv);
# Line 1033  extern void sx_2b(environment *env) Line 1146  extern void sx_2b(environment *env)
1146    char* new_string;    char* new_string;
1147    value *a_val, *b_val;    value *a_val, *b_val;
1148    
1149    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1150      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1151      env->err= 1;      env->err= 1;
1152      return;      return;
# Line 1111  extern void sx_2d(environment *env) Line 1224  extern void sx_2d(environment *env)
1224    int a, b;    int a, b;
1225    float fa, fb;    float fa, fb;
1226    
1227    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1228      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1229      env->err=1;      env->err=1;
1230      return;      return;
# Line 1171  extern void sx_3e(environment *env) Line 1284  extern void sx_3e(environment *env)
1284    int a, b;    int a, b;
1285    float fa, fb;    float fa, fb;
1286    
1287    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1288      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1289      env->err= 1;      env->err= 1;
1290      return;      return;
# Line 1256  value *copy_val(environment *env, value Line 1369  value *copy_val(environment *env, value
1369    
1370    protect(old_value);    protect(old_value);
1371    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
1372    new_value->type= old_value->type;    new_value->type= old_value->type;
1373    
1374    switch(old_value->type){    switch(old_value->type){
# Line 1264  value *copy_val(environment *env, value Line 1376  value *copy_val(environment *env, value
1376    case integer:    case integer:
1377    case func:    case func:
1378    case symb:    case symb:
1379      case empty:
1380      new_value->content= old_value->content;      new_value->content= old_value->content;
1381      break;      break;
1382    case string:    case string:
# Line 1271  value *copy_val(environment *env, value Line 1384  value *copy_val(environment *env, value
1384        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1385      break;      break;
1386    case tcons:    case tcons:
     new_value= NULL;  
1387    
1388      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(pair));
1389        assert(new_value->content.c!=NULL);
1390        env->gc_count += sizeof(pair);
1391    
1392      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1393      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
1394      break;      break;
1395    }    }
1396    
1397    unprotect(old_value); unprotect(new_value);    unprotect(old_value);
1398    
1399    return new_value;    return new_value;
1400  }  }
# Line 1287  value *copy_val(environment *env, value Line 1402  value *copy_val(environment *env, value
1402  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1403  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1404  {  {
1405    if(env->head==NULL) {    if(env->head->type==empty) {
1406      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1407      env->err= 1;      env->err= 1;
1408      return;      return;
# Line 1300  extern void sx_6966(environment *env) Line 1415  extern void sx_6966(environment *env)
1415  {  {
1416    int truth;    int truth;
1417    
1418    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1419      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1420      env->err= 1;      env->err= 1;
1421      return;      return;
# Line 1331  extern void ifelse(environment *env) Line 1446  extern void ifelse(environment *env)
1446  {  {
1447    int truth;    int truth;
1448    
1449    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1450       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type==empty) {
1451      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1452      env->err= 1;      env->err= 1;
1453      return;      return;
# Line 1362  extern void ifelse(environment *env) Line 1477  extern void ifelse(environment *env)
1477    eval(env);    eval(env);
1478  }  }
1479    
1480    extern void sx_656c7365(environment *env)
1481    {
1482      if(env->head->type==empty || CDR(env->head)->type==empty
1483         || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1484         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1485        printerr("Too Few Arguments");
1486        env->err= 1;
1487        return;
1488      }
1489    
1490      if(CAR(CDR(env->head))->type!=symb
1491         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1492         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1493         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1494        printerr("Bad Argument Type");
1495        env->err= 2;
1496        return;
1497      }
1498    
1499      swap(env); toss(env); rot(env); toss(env);
1500      ifelse(env);
1501    }
1502    
1503    extern void then(environment *env)
1504    {
1505      if(env->head->type==empty || CDR(env->head)->type==empty
1506         || CDR(CDR(env->head))->type==empty) {
1507        printerr("Too Few Arguments");
1508        env->err= 1;
1509        return;
1510      }
1511    
1512      if(CAR(CDR(env->head))->type!=symb
1513         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1514        printerr("Bad Argument Type");
1515        env->err= 2;
1516        return;
1517      }
1518    
1519      swap(env); toss(env);
1520      sx_6966(env);
1521    }
1522    
1523  /* "while" */  /* "while" */
1524  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1525  {  {
1526    int truth;    int truth;
1527    value *loop, *test;    value *loop, *test;
1528    
1529    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1530      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1531      env->err= 1;      env->err= 1;
1532      return;      return;
# Line 1414  extern void sx_666f72(environment *env) Line 1572  extern void sx_666f72(environment *env)
1572    value *loop;    value *loop;
1573    int foo1, foo2;    int foo1, foo2;
1574    
1575    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1576       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type==empty) {
1577      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1578      env->err= 1;      env->err= 1;
1579      return;      return;
# Line 1462  extern void foreach(environment *env) Line 1620  extern void foreach(environment *env)
1620    value *loop, *foo;    value *loop, *foo;
1621    value *iterator;    value *iterator;
1622        
1623    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1624      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1625      env->err= 1;      env->err= 1;
1626      return;      return;
# Line 1488  extern void foreach(environment *env) Line 1646  extern void foreach(environment *env)
1646      push_val(env, CAR(iterator));      push_val(env, CAR(iterator));
1647      push_val(env, loop);      push_val(env, loop);
1648      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1649      if (CDR(iterator)->type == tcons){      if (iterator->type == tcons){
1650        iterator= CDR(iterator);        iterator= CDR(iterator);
1651      } else {      } else {
1652        printerr("Bad Argument Type"); /* Improper list */        printerr("Bad Argument Type"); /* Improper list */
# Line 1505  extern void to(environment *env) Line 1663  extern void to(environment *env)
1663    int ending, start, i;    int ending, start, i;
1664    value *iterator, *temp;    value *iterator, *temp;
1665    
1666    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1667      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1668      env->err= 1;      env->err= 1;
1669      return;      return;
# Line 1535  extern void to(environment *env) Line 1693  extern void to(environment *env)
1693    
1694    iterator= env->head;    iterator= env->head;
1695    
1696    if(iterator==NULL    if(iterator->type==empty
1697       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
1698           && ((symbol*)(CAR(iterator)->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1699      temp= NULL;      temp= NULL;
1700      toss(env);      toss(env);
1701    } else {    } else {
1702      /* Search for first delimiter */      /* Search for first delimiter */
1703      while(CDR(iterator)!=NULL      while(CDR(iterator)!=NULL
1704            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
1705                || ((symbol*)(CAR(CDR(iterator))->content.ptr))->id[0]                || CAR(CDR(iterator))->content.sym->id[0]!='['))
               !='['))  
1706        iterator= CDR(iterator);        iterator= CDR(iterator);
1707            
1708      /* Extract list */      /* Extract list */
# Line 1588  extern void sx_72656164(environment *env Line 1745  extern void sx_72656164(environment *env
1745    int count= -1;    int count= -1;
1746    float ftemp;    float ftemp;
1747    static int depth= 0;    static int depth= 0;
1748    char *match, *ctemp;    char *match;
1749    size_t inlength;    size_t inlength;
1750    
1751    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1622  extern void sx_72656164(environment *env Line 1779  extern void sx_72656164(environment *env
1779      } else {      } else {
1780        push_float(env, ftemp);        push_float(env, ftemp);
1781      }      }
1782      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1783                && readlength != -1) {
1784        push_cstring(env, "");
1785    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1786              && readlength != -1) {              && readlength != -1) {
1787      push_cstring(env, match);      push_cstring(env, match);
# Line 1653  extern void sx_72656164(environment *env Line 1813  extern void sx_72656164(environment *env
1813      return sx_72656164(env);      return sx_72656164(env);
1814  }  }
1815    
1816    #ifdef __linux__
1817  extern void beep(environment *env)  extern void beep(environment *env)
1818  {  {
1819    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1820    
1821    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1822      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1823      env->err= 1;      env->err= 1;
1824      return;      return;
# Line 1695  extern void beep(environment *env) Line 1856  extern void beep(environment *env)
1856      abort();      abort();
1857    }    }
1858  }  }
1859    #endif /* __linux__ */
1860    
1861  /* "wait" */  /* "wait" */
1862  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
1863  {  {
1864    int dur;    int dur;
1865    
1866    if(env->head==NULL) {    if(env->head->type==empty) {
1867      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1868      env->err= 1;      env->err= 1;
1869      return;      return;
# Line 1721  extern void sx_77616974(environment *env Line 1883  extern void sx_77616974(environment *env
1883    
1884  extern void copying(environment *env)  extern void copying(environment *env)
1885  {  {
1886    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1887                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1888  \n\  \n\
1889   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2010  extern void sx_2a(environment *env) Line 2172  extern void sx_2a(environment *env)
2172    int a, b;    int a, b;
2173    float fa, fb;    float fa, fb;
2174    
2175    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2176      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2177      env->err= 1;      env->err= 1;
2178      return;      return;
# Line 2070  extern void sx_2f(environment *env) Line 2232  extern void sx_2f(environment *env)
2232    int a, b;    int a, b;
2233    float fa, fb;    float fa, fb;
2234    
2235    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2236      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2237      env->err= 1;      env->err= 1;
2238      return;      return;
# Line 2129  extern void mod(environment *env) Line 2291  extern void mod(environment *env)
2291  {  {
2292    int a, b;    int a, b;
2293    
2294    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2295      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2296      env->err= 1;      env->err= 1;
2297      return;      return;
# Line 2155  extern void sx_646976(environment *env) Line 2317  extern void sx_646976(environment *env)
2317  {  {
2318    int a, b;    int a, b;
2319        
2320    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2321      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2322      env->err= 1;      env->err= 1;
2323      return;      return;
# Line 2175  extern void sx_646976(environment *env) Line 2337  extern void sx_646976(environment *env)
2337    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2338    env->err= 2;    env->err= 2;
2339  }  }
2340    
2341    extern void setcar(environment *env)
2342    {
2343      if(env->head->type==empty || CDR(env->head)->type==empty) {
2344        printerr("Too Few Arguments");
2345        env->err= 1;
2346        return;
2347      }
2348    
2349      if(CDR(env->head)->type!=tcons) {
2350        printerr("Bad Argument Type");
2351        env->err= 2;
2352        return;
2353      }
2354    
2355      CAR(CAR(CDR(env->head)))=CAR(env->head);
2356      toss(env);
2357    }
2358    
2359    extern void setcdr(environment *env)
2360    {
2361      if(env->head->type==empty || CDR(env->head)->type==empty) {
2362        printerr("Too Few Arguments");
2363        env->err= 1;
2364        return;
2365      }
2366    
2367      if(CDR(env->head)->type!=tcons) {
2368        printerr("Bad Argument Type");
2369        env->err= 2;
2370        return;
2371      }
2372    
2373      CDR(CAR(CDR(env->head)))=CAR(env->head);
2374      toss(env);
2375    }
2376    
2377    extern void car(environment *env)
2378    {
2379      if(env->head->type==empty) {
2380        printerr("Too Few Arguments");
2381        env->err= 1;
2382        return;
2383      }
2384    
2385      if(CAR(env->head)->type!=tcons) {
2386        printerr("Bad Argument Type");
2387        env->err= 2;
2388        return;
2389      }
2390    
2391      CAR(env->head)=CAR(CAR(env->head));
2392    }
2393    
2394    extern void cdr(environment *env)
2395    {
2396      if(env->head->type==empty) {
2397        printerr("Too Few Arguments");
2398        env->err= 1;
2399        return;
2400      }
2401    
2402      if(CAR(env->head)->type!=tcons) {
2403        printerr("Bad Argument Type");
2404        env->err= 2;
2405        return;
2406      }
2407    
2408      CAR(env->head)=CDR(CAR(env->head));
2409    }
2410    
2411    extern void cons(environment *env)
2412    {
2413      value *val;
2414    
2415      if(env->head->type==empty || CDR(env->head)->type==empty) {
2416        printerr("Too Few Arguments");
2417        env->err= 1;
2418        return;
2419      }
2420    
2421      val=new_val(env);
2422      val->content.c= malloc(sizeof(pair));
2423      assert(val->content.c!=NULL);
2424    
2425      env->gc_count += sizeof(pair);
2426      val->type=tcons;
2427    
2428      CAR(val)= CAR(CDR(env->head));
2429      CDR(val)= CAR(env->head);
2430    
2431      push_val(env, val);
2432    
2433      swap(env); if(env->err) return;
2434      toss(env); if(env->err) return;
2435      swap(env); if(env->err) return;
2436      toss(env); if(env->err) return;
2437    }
Legend:
Removed from v.1.104  
changed lines
  Added in v.1.117
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26