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

Diff of /stack/stack.c

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

revision 1.109 by masse, Thu Mar 14 10:39:11 2002 UTC revision 1.121 by masse, Wed Mar 27 14:45:17 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 188  extern void gc_init(environment *env) Line 191  extern void gc_init(environment *env)
191    if(env->interactive)    if(env->interactive)
192      printf(".");      printf(".");
193    
   
194    env->gc_count= 0;    env->gc_count= 0;
195    
196    while(env->gc_ref!=NULL) {    /* Sweep unused values */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
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 empty:
209          case integer:
210          case tfloat:
211          case func:
212          case symb:
213            /* Symbol strings are freed when walking the hash table */
214          }
215    
216        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
217        titem= env->gc_ref->next;        titem= env->gc_ref->next;
218        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
219        env->gc_ref= titem;        env->gc_ref= titem;
220        continue;        continue;
221      }      }
222    #ifdef DEBUG
223        printf("Kept value (%p)", env->gc_ref->item);
224        if(env->gc_ref->item->gc.flag.mark)
225          printf(" (marked)");
226        if(env->gc_ref->item->gc.flag.protect)
227          printf(" (protected)");
228        switch(env->gc_ref->item->type){
229        case integer:
230          printf(" integer: %d", env->gc_ref->item->content.i);
231          break;
232        case func:
233          printf(" func: %p", env->gc_ref->item->content.ptr);
234          break;
235        case symb:
236          printf(" symb: %s", env->gc_ref->item->content.sym->id);
237          break;
238        case tcons:
239          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
240                 env->gc_ref->item->content.c->cdr);
241          break;
242        default:
243          printf(" <unknown %d>", (env->gc_ref->item->type));
244        }
245        printf("\n");
246    #endif /* DEBUG */
247    
248      /* Keep values */          /* Keep values */    
249      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
250      if(env->gc_ref->item->type==string)      if(env->gc_ref->item->type==string)
251        env->gc_count += strlen(env->gc_ref->item->content.ptr);        env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
252            
253      titem= env->gc_ref->next;      titem= env->gc_ref->next;
254      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
# Line 223  extern void gc_init(environment *env) Line 263  extern void gc_init(environment *env)
263    env->gc_ref= new_head;    env->gc_ref= new_head;
264    
265    if(env->interactive)    if(env->interactive)
266      printf("done\n");      printf("done (%d bytes still allocated)\n", env->gc_count);
267    
268  }  }
269    
# Line 260  void push_val(environment *env, value *v Line 300  void push_val(environment *env, value *v
300  {  {
301    value *new_value= new_val(env);    value *new_value= new_val(env);
302    
303    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(pair));
304    assert(new_value->content.c!=NULL);    assert(new_value->content.c!=NULL);
305      env->gc_count += sizeof(pair);
306    new_value->type= tcons;    new_value->type= tcons;
307    CAR(new_value)= val;    CAR(new_value)= val;
308    CDR(new_value)= env->head;    CDR(new_value)= env->head;
# Line 297  void push_cstring(environment *env, cons Line 338  void push_cstring(environment *env, cons
338    int length= strlen(in_string)+1;    int length= strlen(in_string)+1;
339    
340    new_value->content.ptr= malloc(length);    new_value->content.ptr= malloc(length);
341      assert(new_value != NULL);
342    env->gc_count += length;    env->gc_count += length;
343    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
344    new_value->type= string;    new_value->type= string;
# Line 311  char *mangle_str(const char *old_string) Line 353  char *mangle_str(const char *old_string)
353    char *new_string, *current;    char *new_string, *current;
354    
355    new_string= malloc((strlen(old_string)*2)+4);    new_string= malloc((strlen(old_string)*2)+4);
356      assert(new_string != NULL);
357    strcpy(new_string, "sx_");    /* Stack eXternal */    strcpy(new_string, "sx_");    /* Stack eXternal */
358    current= new_string+3;    current= new_string+3;
359    while(old_string[0] != '\0'){    while(old_string[0] != '\0'){
# Line 328  extern void mangle(environment *env) Line 371  extern void mangle(environment *env)
371  {  {
372    char *new_string;    char *new_string;
373    
374    if(env->head==NULL) {    if(env->head->type==empty) {
375      printerr("Too Few Arguments");      printerr("Too Few Arguments");
376      env->err= 1;      env->err= 1;
377      return;      return;
# Line 380  void push_sym(environment *env, const ch Line 423  void push_sym(environment *env, const ch
423    
424      /* Create a new symbol */      /* Create a new symbol */
425      (*new_symbol)= malloc(sizeof(symbol));      (*new_symbol)= malloc(sizeof(symbol));
426        assert((*new_symbol) != NULL);
427      (*new_symbol)->val= NULL;   /* undefined value */      (*new_symbol)->val= NULL;   /* undefined value */
428      (*new_symbol)->next= NULL;      (*new_symbol)->next= NULL;
429      (*new_symbol)->id= malloc(strlen(in_string)+1);      (*new_symbol)->id= malloc(strlen(in_string)+1);
430        assert((*new_symbol)->id != NULL);
431      strcpy((*new_symbol)->id, in_string);      strcpy((*new_symbol)->id, in_string);
432    
433      /* Intern the new symbol in the hash table */      /* Intern the new symbol in the hash table */
# Line 425  extern void nl() Line 470  extern void nl()
470  /* Gets the type of a value */  /* Gets the type of a value */
471  extern void type(environment *env)  extern void type(environment *env)
472  {  {
473    int typenum;    if(env->head->type==empty) {
   
   if(env->head==NULL) {  
474      printerr("Too Few Arguments");      printerr("Too Few Arguments");
475      env->err= 1;      env->err= 1;
476      return;      return;
477    }    }
478    
479    typenum= CAR(env->head)->type;    switch(CAR(env->head)->type){
480    toss(env);    case empty:
481    switch(typenum){      push_sym(env, "empty");
482        break;
483    case integer:    case integer:
484      push_sym(env, "integer");      push_sym(env, "integer");
485      break;      break;
# Line 452  extern void type(environment *env) Line 496  extern void type(environment *env)
496      push_sym(env, "function");      push_sym(env, "function");
497      break;      break;
498    case tcons:    case tcons:
499      push_sym(env, "list");      push_sym(env, "pair");
500      break;      break;
501    }    }
502      swap(env);
503      if (env->err) return;
504      toss(env);
505  }      }    
506    
507  /* Prints the top element of the stack. */  /* Print a value */
508  void print_h(value *stack_head, int noquote)  void print_val(value *val, int noquote, stackitem *stack)
509  {  {
510    switch(CAR(stack_head)->type) {    stackitem *titem, *tstack;
511      int depth;
512    
513      switch(val->type) {
514      case empty:
515        printf("[]");
516        break;
517    case integer:    case integer:
518      printf("%d", CAR(stack_head)->content.i);      printf("%d", val->content.i);
519      break;      break;
520    case tfloat:    case tfloat:
521      printf("%f", CAR(stack_head)->content.f);      printf("%f", val->content.f);
522      break;      break;
523    case string:    case string:
524      if(noquote)      if(noquote)
525        printf("%s", (char*)CAR(stack_head)->content.ptr);        printf("%s", (char*)(val->content.ptr));
526      else      else
527        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);        printf("\"%s\"", (char*)(val->content.ptr));
528      break;      break;
529    case symb:    case symb:
530      printf("%s", CAR(stack_head)->content.sym->id);      printf("%s", val->content.sym->id);
531      break;      break;
532    case func:    case func:
533      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));      printf("#<function %p>", (funcp)(val->content.ptr));
534      break;      break;
535    case tcons:    case tcons:
     /* A list is just a stack, so make stack_head point to it */  
     stack_head= CAR(stack_head);  
536      printf("[ ");      printf("[ ");
537      while(stack_head != NULL) {      tstack= stack;
538        print_h(stack_head, noquote);      do {
539        printf(" ");        titem=malloc(sizeof(stackitem));
540        stack_head= CDR(stack_head);        assert(titem != NULL);
541          titem->item=val;
542          titem->next=tstack;
543          tstack=titem;             /* Put it on the stack */
544          /* Search a stack of values being printed to see if we are already
545             printing this value */
546          titem=tstack;
547          depth=0;
548          while(titem != NULL && titem->item != CAR(val)){
549            titem=titem->next;
550            depth++;
551          }
552          if(titem != NULL){        /* If we found it on the stack, */
553            printf("#%d#", depth);  /* print a depth reference */
554          } else {
555            print_val(CAR(val), noquote, tstack);
556          }
557          val= CDR(val);
558          switch(val->type){
559          case empty:
560            break;
561          case tcons:
562            /* Search a stack of values being printed to see if we are already
563               printing this value */
564            titem=tstack;
565            depth=0;
566            while(titem != NULL && titem->item != val){
567              titem=titem->next;
568              depth++;
569            }
570            if(titem != NULL){      /* If we found it on the stack, */
571              printf(" . #%d#", depth); /* print a depth reference */
572            } else {
573              printf(" ");
574            }
575            break;
576          default:
577            printf(" . ");          /* Improper list */
578            print_val(val, noquote, tstack);
579          }
580        } while(val->type == tcons && titem == NULL);
581        titem=tstack;
582        while(titem != stack){
583          tstack=titem->next;
584          free(titem);
585          titem=tstack;
586      }      }
587      printf("]");      printf(" ]");
588      break;      break;
589    }    }
590  }  }
591    
592  extern void print_(environment *env)  extern void print_(environment *env)
593  {  {
594    if(env->head==NULL) {    if(env->head->type==empty) {
595      printerr("Too Few Arguments");      printerr("Too Few Arguments");
596      env->err= 1;      env->err= 1;
597      return;      return;
598    }    }
599    print_h(env->head, 0);    print_val(CAR(env->head), 0, NULL);
600    nl();    nl();
601  }  }
602    
# Line 514  extern void print(environment *env) Line 610  extern void print(environment *env)
610    
611  extern void princ_(environment *env)  extern void princ_(environment *env)
612  {  {
613    if(env->head==NULL) {    if(env->head->type==empty) {
614      printerr("Too Few Arguments");      printerr("Too Few Arguments");
615      env->err= 1;      env->err= 1;
616      return;      return;
617    }    }
618    print_h(env->head, 1);    print_val(CAR(env->head), 1, NULL);
619  }  }
620    
621  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack and then discards it. */
# Line 533  extern void princ(environment *env) Line 629  extern void princ(environment *env)
629  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
630  void print_st(value *stack_head, long counter)  void print_st(value *stack_head, long counter)
631  {  {
632    if(CDR(stack_head) != NULL)    if(CDR(stack_head)->type != empty)
633      print_st(CDR(stack_head), counter+1);      print_st(CDR(stack_head), counter+1);
634    printf("%ld: ", counter);    printf("%ld: ", counter);
635    print_h(stack_head, 0);    print_val(CAR(stack_head), 0, NULL);
636    nl();    nl();
637  }  }
638    
639  /* Prints the stack. */  /* Prints the stack. */
640  extern void printstack(environment *env)  extern void printstack(environment *env)
641  {  {
642    if(env->head == NULL) {    if(env->head->type == empty) {
643      printf("Stack Empty\n");      printf("Stack Empty\n");
644      return;      return;
645    }    }
# Line 556  extern void swap(environment *env) Line 652  extern void swap(environment *env)
652  {  {
653    value *temp= env->head;    value *temp= env->head;
654        
655    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
656      printerr("Too Few Arguments");      printerr("Too Few Arguments");
657      env->err=1;      env->err=1;
658      return;      return;
# Line 572  extern void rot(environment *env) Line 668  extern void rot(environment *env)
668  {  {
669    value *temp= env->head;    value *temp= env->head;
670        
671    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
672       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type == empty) {
673      printerr("Too Few Arguments");      printerr("Too Few Arguments");
674      env->err= 1;      env->err= 1;
675      return;      return;
# Line 589  extern void rcl(environment *env) Line 685  extern void rcl(environment *env)
685  {  {
686    value *val;    value *val;
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;
# Line 607  extern void rcl(environment *env) Line 703  extern void rcl(environment *env)
703      env->err= 3;      env->err= 3;
704      return;      return;
705    }    }
706    protect(val);    push_val(env, val);           /* Return the symbol's bound value */
707    toss(env);            /* toss the symbol */    swap(env);
708      if(env->err) return;
709      toss(env);                    /* toss the symbol */
710    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(val);  
711  }  }
712    
713  /* 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 627  extern void eval(environment *env) Line 723  extern void eval(environment *env)
723    
724    gc_maybe(env);    gc_maybe(env);
725    
726    if(env->head==NULL) {    if(env->head->type==empty) {
727      printerr("Too Few Arguments");      printerr("Too Few Arguments");
728      env->err= 1;      env->err= 1;
729      return;      return;
# Line 658  extern void eval(environment *env) Line 754  extern void eval(environment *env)
754      toss(env); if(env->err) return;      toss(env); if(env->err) return;
755      iterator= temp_val;      iterator= temp_val;
756            
757      while(iterator!=NULL) {      while(iterator->type != empty) {
758        push_val(env, CAR(iterator));        push_val(env, CAR(iterator));
759                
760        if(CAR(env->head)->type==symb        if(CAR(env->head)->type==symb
# Line 666  extern void eval(environment *env) Line 762  extern void eval(environment *env)
762          toss(env);          toss(env);
763          if(env->err) return;          if(env->err) return;
764                    
765          if(CDR(iterator)==NULL){          if(CDR(iterator)->type == empty){
766            goto eval_start;            goto eval_start;
767          }          }
768          eval(env);          eval(env);
769          if(env->err) return;          if(env->err) return;
770        }        }
771        if (CDR(iterator)->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
772          iterator= CDR(iterator);          iterator= CDR(iterator);
773        else {        else {
774          printerr("Bad Argument Type"); /* Improper list */          printerr("Bad Argument Type"); /* Improper list */
# Line 683  extern void eval(environment *env) Line 779  extern void eval(environment *env)
779      unprotect(temp_val);      unprotect(temp_val);
780      return;      return;
781    
782    default:    case empty:
783      case integer:
784      case tfloat:
785      case string:
786      return;      return;
787    }    }
788  }  }
# Line 693  extern void rev(environment *env) Line 792  extern void rev(environment *env)
792  {  {
793    value *old_head, *new_head, *item;    value *old_head, *new_head, *item;
794    
795    if(env->head==NULL) {    if(env->head->type==empty) {
796      printerr("Too Few Arguments");      printerr("Too Few Arguments");
797      env->err= 1;      env->err= 1;
798      return;      return;
799    }    }
800    
801      if(CAR(env->head)->type==empty)
802        return;                     /* Don't reverse an empty list */
803    
804    if(CAR(env->head)->type!=tcons) {    if(CAR(env->head)->type!=tcons) {
805      printerr("Bad Argument Type");      printerr("Bad Argument Type");
806      env->err= 2;      env->err= 2;
# Line 706  extern void rev(environment *env) Line 808  extern void rev(environment *env)
808    }    }
809    
810    old_head= CAR(env->head);    old_head= CAR(env->head);
811    new_head= NULL;    new_head= new_val(env);
812    while(old_head!=NULL) {    while(old_head->type != empty) {
813      item= old_head;      item= old_head;
814      old_head= CDR(old_head);      old_head= CDR(old_head);
815      CDR(item)= new_head;      CDR(item)= new_head;
# Line 719  extern void rev(environment *env) Line 821  extern void rev(environment *env)
821  /* Make a list. */  /* Make a list. */
822  extern void pack(environment *env)  extern void pack(environment *env)
823  {  {
824    value *iterator, *temp;    value *iterator, *temp, *ending;
825    
826      ending=new_val(env);
827    
828    iterator= env->head;    iterator= env->head;
829    if(iterator==NULL    if(iterator->type == empty
830       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
831       && CAR(iterator)->content.sym->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
832      temp= NULL;      temp= ending;
833      toss(env);      toss(env);
834    } else {    } else {
835      /* Search for first delimiter */      /* Search for first delimiter */
836      while(CDR(iterator)!=NULL      while(CDR(iterator)->type != empty
837            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
838             || CAR(CDR(iterator))->content.sym->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
839        iterator= CDR(iterator);        iterator= CDR(iterator);
# Line 737  extern void pack(environment *env) Line 841  extern void pack(environment *env)
841      /* Extract list */      /* Extract list */
842      temp= env->head;      temp= env->head;
843      env->head= CDR(iterator);      env->head= CDR(iterator);
844      CDR(iterator)= NULL;      CDR(iterator)= ending;
845    
846      if(env->head!=NULL)      if(env->head->type != empty)
847        toss(env);        toss(env);
848    }    }
849    
# Line 755  extern void expand(environment *env) Line 859  extern void expand(environment *env)
859    value *temp, *new_head;    value *temp, *new_head;
860    
861    /* Is top element a list? */    /* Is top element a list? */
862    if(env->head==NULL) {    if(env->head->type==empty) {
863      printerr("Too Few Arguments");      printerr("Too Few Arguments");
864      env->err= 1;      env->err= 1;
865      return;      return;
# Line 778  extern void expand(environment *env) Line 882  extern void expand(environment *env)
882    toss(env);    toss(env);
883    
884    /* Find the end of the list */    /* Find the end of the list */
885    while(CDR(temp)->content.ptr != NULL) {    while(CDR(temp)->type != empty) {
886      if (CDR(temp)->type == tcons)      if (CDR(temp)->type == tcons)
887        temp= CDR(temp);        temp= CDR(temp);
888      else {      else {
# Line 799  extern void eq(environment *env) Line 903  extern void eq(environment *env)
903  {  {
904    void *left, *right;    void *left, *right;
905    
906    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
907      printerr("Too Few Arguments");      printerr("Too Few Arguments");
908      env->err= 1;      env->err= 1;
909      return;      return;
# Line 817  extern void not(environment *env) Line 921  extern void not(environment *env)
921  {  {
922    int val;    int val;
923    
924    if(env->head==NULL) {    if(env->head->type==empty) {
925      printerr("Too Few Arguments");      printerr("Too Few Arguments");
926      env->err= 1;      env->err= 1;
927      return;      return;
# Line 848  extern void def(environment *env) Line 952  extern void def(environment *env)
952    symbol *sym;    symbol *sym;
953    
954    /* 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 */
955    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
956      printerr("Too Few Arguments");      printerr("Too Few Arguments");
957      env->err= 1;      env->err= 1;
958      return;      return;
# Line 887  extern void quit(environment *env) Line 991  extern void quit(environment *env)
991    env->gc_limit= 0;    env->gc_limit= 0;
992    gc_maybe(env);    gc_maybe(env);
993    
994      words(env);
995    
996    if(env->free_string!=NULL)    if(env->free_string!=NULL)
997      free(env->free_string);      free(env->free_string);
998        
# Line 900  extern void quit(environment *env) Line 1006  extern void quit(environment *env)
1006  /* Clear stack */  /* Clear stack */
1007  extern void clear(environment *env)  extern void clear(environment *env)
1008  {  {
1009    while(env->head!=NULL)    while(env->head->type != empty)
1010      toss(env);      toss(env);
1011  }  }
1012    
# Line 913  extern void words(environment *env) Line 1019  extern void words(environment *env)
1019    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
1020      temp= env->symbols[i];      temp= env->symbols[i];
1021      while(temp!=NULL) {      while(temp!=NULL) {
1022    #ifdef DEBUG
1023          if (temp->val != NULL && temp->val->gc.flag.protect)
1024            printf("(protected) ");
1025    #endif /* DEBUG */
1026        printf("%s\n", temp->id);        printf("%s\n", temp->id);
1027        temp= temp->next;        temp= temp->next;
1028      }      }
# Line 935  void forget_sym(symbol **hash_entry) Line 1045  void forget_sym(symbol **hash_entry)
1045  extern void forget(environment *env)  extern void forget(environment *env)
1046  {  {
1047    char* sym_id;    char* sym_id;
   value *stack_head= env->head;  
1048    
1049    if(stack_head==NULL) {    if(env->head->type==empty) {
1050      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1051      env->err= 1;      env->err= 1;
1052      return;      return;
1053    }    }
1054        
1055    if(CAR(stack_head)->type!=symb) {    if(CAR(env->head)->type!=symb) {
1056      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1057      env->err= 2;      env->err= 2;
1058      return;      return;
1059    }    }
1060    
1061    sym_id= CAR(stack_head)->content.sym->id;    sym_id= CAR(env->head)->content.sym->id;
1062    toss(env);    toss(env);
1063    
1064    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 983  int main(int argc, char **argv) Line 1092  int main(int argc, char **argv)
1092          break;          break;
1093        case '?':        case '?':
1094          fprintf (stderr,          fprintf (stderr,
1095                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1096                   optopt);                   optopt);
1097          return EX_USAGE;          return EX_USAGE;
1098        default:        default:
# Line 1002  int main(int argc, char **argv) Line 1111  int main(int argc, char **argv)
1111    if(myenv.interactive) {    if(myenv.interactive) {
1112      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1113  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1114  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1115  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1116  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1117    }    }
1118    
1119    while(1) {    while(1) {
# Line 1019  under certain conditions; type `copying; Line 1128  under certain conditions; type `copying;
1128        }        }
1129        myenv.err=0;        myenv.err=0;
1130      }      }
1131      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1132      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1133        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1134      } else if(myenv.head!=NULL        quit(&myenv);
1135        } else if(myenv.head->type!=empty
1136                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
1137                && CAR(myenv.head)->content.sym->id[0]                && CAR(myenv.head)->content.sym->id[0]
1138                ==';') {                ==';') {
# Line 1044  extern void sx_2b(environment *env) Line 1154  extern void sx_2b(environment *env)
1154    char* new_string;    char* new_string;
1155    value *a_val, *b_val;    value *a_val, *b_val;
1156    
1157    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1158      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1159      env->err= 1;      env->err= 1;
1160      return;      return;
# Line 1059  extern void sx_2b(environment *env) Line 1169  extern void sx_2b(environment *env)
1169      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1170      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
1171      new_string= malloc(len);      new_string= malloc(len);
1172        assert(new_string != NULL);
1173      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1174      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1175      push_cstring(env, new_string);      push_cstring(env, new_string);
# Line 1122  extern void sx_2d(environment *env) Line 1233  extern void sx_2d(environment *env)
1233    int a, b;    int a, b;
1234    float fa, fb;    float fa, fb;
1235    
1236    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1237      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1238      env->err=1;      env->err=1;
1239      return;      return;
# Line 1182  extern void sx_3e(environment *env) Line 1293  extern void sx_3e(environment *env)
1293    int a, b;    int a, b;
1294    float fa, fb;    float fa, fb;
1295    
1296    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1297      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1298      env->err= 1;      env->err= 1;
1299      return;      return;
# Line 1274  value *copy_val(environment *env, value Line 1385  value *copy_val(environment *env, value
1385    case integer:    case integer:
1386    case func:    case func:
1387    case symb:    case symb:
1388      case empty:
1389      new_value->content= old_value->content;      new_value->content= old_value->content;
1390      break;      break;
1391    case string:    case string:
# Line 1282  value *copy_val(environment *env, value Line 1394  value *copy_val(environment *env, value
1394      break;      break;
1395    case tcons:    case tcons:
1396    
1397      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(pair));
1398      assert(new_value->content.c!=NULL);      assert(new_value->content.c!=NULL);
1399        env->gc_count += sizeof(pair);
1400    
1401      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1402      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
# Line 1298  value *copy_val(environment *env, value Line 1411  value *copy_val(environment *env, value
1411  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1412  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1413  {  {
1414    if(env->head==NULL) {    if(env->head->type==empty) {
1415      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1416      env->err= 1;      env->err= 1;
1417      return;      return;
# Line 1311  extern void sx_6966(environment *env) Line 1424  extern void sx_6966(environment *env)
1424  {  {
1425    int truth;    int truth;
1426    
1427    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1428      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1429      env->err= 1;      env->err= 1;
1430      return;      return;
# Line 1342  extern void ifelse(environment *env) Line 1455  extern void ifelse(environment *env)
1455  {  {
1456    int truth;    int truth;
1457    
1458    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1459       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type==empty) {
1460      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1461      env->err= 1;      env->err= 1;
1462      return;      return;
# Line 1375  extern void ifelse(environment *env) Line 1488  extern void ifelse(environment *env)
1488    
1489  extern void sx_656c7365(environment *env)  extern void sx_656c7365(environment *env)
1490  {  {
1491    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1492       || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL       || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1493       || CDR(CDR(CDR(CDR(env->head))))==NULL) {       || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1494      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1495      env->err= 1;      env->err= 1;
1496      return;      return;
# Line 1398  extern void sx_656c7365(environment *env Line 1511  extern void sx_656c7365(environment *env
1511    
1512  extern void then(environment *env)  extern void then(environment *env)
1513  {  {
1514    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1515       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type==empty) {
1516      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1517      env->err= 1;      env->err= 1;
1518      return;      return;
# Line 1422  extern void sx_7768696c65(environment *e Line 1535  extern void sx_7768696c65(environment *e
1535    int truth;    int truth;
1536    value *loop, *test;    value *loop, *test;
1537    
1538    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1539      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1540      env->err= 1;      env->err= 1;
1541      return;      return;
# Line 1468  extern void sx_666f72(environment *env) Line 1581  extern void sx_666f72(environment *env)
1581    value *loop;    value *loop;
1582    int foo1, foo2;    int foo1, foo2;
1583    
1584    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1585       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type==empty) {
1586      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1587      env->err= 1;      env->err= 1;
1588      return;      return;
# Line 1516  extern void foreach(environment *env) Line 1629  extern void foreach(environment *env)
1629    value *loop, *foo;    value *loop, *foo;
1630    value *iterator;    value *iterator;
1631        
1632    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1633      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1634      env->err= 1;      env->err= 1;
1635      return;      return;
# Line 1557  extern void foreach(environment *env) Line 1670  extern void foreach(environment *env)
1670  extern void to(environment *env)  extern void to(environment *env)
1671  {  {
1672    int ending, start, i;    int ending, start, i;
1673    value *iterator, *temp;    value *iterator, *temp, *end;
1674    
1675      end= new_val(env);
1676    
1677    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1678      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1679      env->err= 1;      env->err= 1;
1680      return;      return;
# Line 1589  extern void to(environment *env) Line 1704  extern void to(environment *env)
1704    
1705    iterator= env->head;    iterator= env->head;
1706    
1707    if(iterator==NULL    if(iterator->type==empty
1708       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
1709           && CAR(iterator)->content.sym->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1710      temp= NULL;      temp= end;
1711      toss(env);      toss(env);
1712    } else {    } else {
1713      /* Search for first delimiter */      /* Search for first delimiter */
1714      while(CDR(iterator)!=NULL      while(CDR(iterator)->type!=empty
1715            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
1716                || CAR(CDR(iterator))->content.sym->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1717        iterator= CDR(iterator);        iterator= CDR(iterator);
# Line 1604  extern void to(environment *env) Line 1719  extern void to(environment *env)
1719      /* Extract list */      /* Extract list */
1720      temp= env->head;      temp= env->head;
1721      env->head= CDR(iterator);      env->head= CDR(iterator);
1722      CDR(iterator)= NULL;      CDR(iterator)= end;
1723    
1724      if(env->head!=NULL)      if(env->head->type!=empty)
1725        toss(env);        toss(env);
1726    }    }
1727    
# Line 1641  extern void sx_72656164(environment *env Line 1756  extern void sx_72656164(environment *env
1756    int count= -1;    int count= -1;
1757    float ftemp;    float ftemp;
1758    static int depth= 0;    static int depth= 0;
1759    char *match, *ctemp;    char *match;
1760    size_t inlength;    size_t inlength;
1761    
1762    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1656  extern void sx_72656164(environment *env Line 1771  extern void sx_72656164(environment *env
1771      }      }
1772            
1773      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1774        assert(env->in_string != NULL);
1775      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1776      strcpy(env->in_string, CAR(env->head)->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1777      toss(env); if(env->err) return;      toss(env); if(env->err) return;
# Line 1663  extern void sx_72656164(environment *env Line 1779  extern void sx_72656164(environment *env
1779        
1780    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1781    match= malloc(inlength);    match= malloc(inlength);
1782      assert(match != NULL);
1783    
1784    if(sscanf(env->in_string, blankform, &readlength) != EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1785       && readlength != -1) {       && readlength != -1) {
# Line 1675  extern void sx_72656164(environment *env Line 1792  extern void sx_72656164(environment *env
1792      } else {      } else {
1793        push_float(env, ftemp);        push_float(env, ftemp);
1794      }      }
1795      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1796                && readlength != -1) {
1797        push_cstring(env, "");
1798    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1799              && readlength != -1) {              && readlength != -1) {
1800      push_cstring(env, match);      push_cstring(env, match);
# Line 1711  extern void beep(environment *env) Line 1831  extern void beep(environment *env)
1831  {  {
1832    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1833    
1834    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1835      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1836      env->err= 1;      env->err= 1;
1837      return;      return;
# Line 1756  extern void sx_77616974(environment *env Line 1876  extern void sx_77616974(environment *env
1876  {  {
1877    int dur;    int dur;
1878    
1879    if(env->head==NULL) {    if(env->head->type==empty) {
1880      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1881      env->err= 1;      env->err= 1;
1882      return;      return;
# Line 1776  extern void sx_77616974(environment *env Line 1896  extern void sx_77616974(environment *env
1896    
1897  extern void copying(environment *env)  extern void copying(environment *env)
1898  {  {
1899    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1900                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1901  \n\  \n\
1902   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2065  extern void sx_2a(environment *env) Line 2185  extern void sx_2a(environment *env)
2185    int a, b;    int a, b;
2186    float fa, fb;    float fa, fb;
2187    
2188    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2189      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2190      env->err= 1;      env->err= 1;
2191      return;      return;
# Line 2125  extern void sx_2f(environment *env) Line 2245  extern void sx_2f(environment *env)
2245    int a, b;    int a, b;
2246    float fa, fb;    float fa, fb;
2247    
2248    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2249      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2250      env->err= 1;      env->err= 1;
2251      return;      return;
# Line 2184  extern void mod(environment *env) Line 2304  extern void mod(environment *env)
2304  {  {
2305    int a, b;    int a, b;
2306    
2307    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2308      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2309      env->err= 1;      env->err= 1;
2310      return;      return;
# Line 2210  extern void sx_646976(environment *env) Line 2330  extern void sx_646976(environment *env)
2330  {  {
2331    int a, b;    int a, b;
2332        
2333    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2334      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2335      env->err= 1;      env->err= 1;
2336      return;      return;
# Line 2230  extern void sx_646976(environment *env) Line 2350  extern void sx_646976(environment *env)
2350    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2351    env->err= 2;    env->err= 2;
2352  }  }
2353    
2354    extern void setcar(environment *env)
2355    {
2356      if(env->head->type==empty || CDR(env->head)->type==empty) {
2357        printerr("Too Few Arguments");
2358        env->err= 1;
2359        return;
2360      }
2361    
2362      if(CDR(env->head)->type!=tcons) {
2363        printerr("Bad Argument Type");
2364        env->err= 2;
2365        return;
2366      }
2367    
2368      CAR(CAR(CDR(env->head)))=CAR(env->head);
2369      toss(env);
2370    }
2371    
2372    extern void setcdr(environment *env)
2373    {
2374      if(env->head->type==empty || CDR(env->head)->type==empty) {
2375        printerr("Too Few Arguments");
2376        env->err= 1;
2377        return;
2378      }
2379    
2380      if(CDR(env->head)->type!=tcons) {
2381        printerr("Bad Argument Type");
2382        env->err= 2;
2383        return;
2384      }
2385    
2386      CDR(CAR(CDR(env->head)))=CAR(env->head);
2387      toss(env);
2388    }
2389    
2390    extern void car(environment *env)
2391    {
2392      if(env->head->type==empty) {
2393        printerr("Too Few Arguments");
2394        env->err= 1;
2395        return;
2396      }
2397    
2398      if(CAR(env->head)->type!=tcons) {
2399        printerr("Bad Argument Type");
2400        env->err= 2;
2401        return;
2402      }
2403    
2404      CAR(env->head)=CAR(CAR(env->head));
2405    }
2406    
2407    extern void cdr(environment *env)
2408    {
2409      if(env->head->type==empty) {
2410        printerr("Too Few Arguments");
2411        env->err= 1;
2412        return;
2413      }
2414    
2415      if(CAR(env->head)->type!=tcons) {
2416        printerr("Bad Argument Type");
2417        env->err= 2;
2418        return;
2419      }
2420    
2421      CAR(env->head)=CDR(CAR(env->head));
2422    }
2423    
2424    extern void cons(environment *env)
2425    {
2426      value *val;
2427    
2428      if(env->head->type==empty || CDR(env->head)->type==empty) {
2429        printerr("Too Few Arguments");
2430        env->err= 1;
2431        return;
2432      }
2433    
2434      val=new_val(env);
2435      val->content.c= malloc(sizeof(pair));
2436      assert(val->content.c!=NULL);
2437    
2438      env->gc_count += sizeof(pair);
2439      val->type=tcons;
2440    
2441      CAR(val)= CAR(CDR(env->head));
2442      CDR(val)= CAR(env->head);
2443    
2444      push_val(env, val);
2445    
2446      swap(env); if(env->err) return;
2447      toss(env); if(env->err) return;
2448      swap(env); if(env->err) return;
2449      toss(env); if(env->err) return;
2450    }
2451    
2452    /*  2: 3                        =>                */
2453    /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
2454    extern void assq(environment *env)
2455    {
2456      assocgen(env, eq);
2457    }
2458    
2459    
2460    /* General assoc function */
2461    void assocgen(environment *env, funcp eqfunc)
2462    {
2463      value *key, *item;
2464    
2465      /* Needs two values on the stack, the top one must be an association
2466         list */
2467      if(env->head->type==empty || CDR(env->head)->type==empty) {
2468        printerr("Too Few Arguments");
2469        env->err= 1;
2470        return;
2471      }
2472    
2473      if(CAR(env->head)->type!=tcons) {
2474        printerr("Bad Argument Type");
2475        env->err= 2;
2476        return;
2477      }
2478    
2479      key=CAR(CDR(env->head));
2480      item=CAR(env->head);
2481    
2482      while(item->type == tcons){
2483        if(CAR(item)->type != tcons){
2484          printerr("Bad Argument Type");
2485          env->err= 2;
2486          return;
2487        }
2488        push_val(env, key);
2489        push_val(env, CAR(CAR(item)));
2490        eqfunc(env); if(env->err) return;
2491    
2492        /* Check the result of 'eqfunc' */
2493        if(env->head->type==empty) {
2494          printerr("Too Few Arguments");
2495          env->err= 1;
2496        return;
2497        }
2498        if(CAR(env->head)->type!=integer) {
2499          printerr("Bad Argument Type");
2500          env->err= 2;
2501          return;
2502        }
2503    
2504        if(CAR(env->head)->content.i){
2505          toss(env); if(env->err) return;
2506          break;
2507        }
2508        toss(env); if(env->err) return;
2509    
2510        if(item->type!=tcons) {
2511          printerr("Bad Argument Type");
2512          env->err= 2;
2513          return;
2514        }
2515    
2516        item=CDR(item);
2517      }
2518    
2519      if(item->type == tcons){      /* A match was found */
2520        push_val(env, CAR(item));
2521      } else {
2522        push_int(env, 0);
2523      }
2524      swap(env); if(env->err) return;
2525      toss(env); if(env->err) return;
2526      swap(env); if(env->err) return;
2527      toss(env);
2528    }
Legend:
Removed from v.1.109  
changed lines
  Added in v.1.121
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26