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

Diff of /stack/stack.c

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

revision 1.108 by masse, Tue Mar 12 22:03:21 2002 UTC revision 1.120 by teddy, Thu Mar 21 03:19:32 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))))->type==empty) {
1494        printerr("Too Few Arguments");
1495        env->err= 1;
1496        return;
1497      }
1498    
1499      if(CAR(CDR(env->head))->type!=symb
1500         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1501         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1502         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1503        printerr("Bad Argument Type");
1504        env->err= 2;
1505        return;
1506      }
1507    
1508      swap(env); toss(env); rot(env); toss(env);
1509      ifelse(env);
1510    }
1511    
1512    extern void then(environment *env)
1513    {
1514      if(env->head->type==empty || CDR(env->head)->type==empty
1515         || 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 1390  extern void sx_656c7365(environment *env Line 1526  extern void sx_656c7365(environment *env
1526    }    }
1527    
1528    swap(env); toss(env);    swap(env); toss(env);
1529    ifelse(env);    sx_6966(env);
1530  }  }
1531    
1532  /* "while" */  /* "while" */
# Line 1399  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 1445  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 1493  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 1536  extern void to(environment *env) Line 1672  extern void to(environment *env)
1672    int ending, start, i;    int ending, start, i;
1673    value *iterator, *temp;    value *iterator, *temp;
1674    
1675    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1676      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1677      env->err= 1;      env->err= 1;
1678      return;      return;
# Line 1566  extern void to(environment *env) Line 1702  extern void to(environment *env)
1702    
1703    iterator= env->head;    iterator= env->head;
1704    
1705    if(iterator==NULL    if(iterator->type==empty
1706       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
1707           && CAR(iterator)->content.sym->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1708      temp= NULL;      temp= NULL;
# Line 1618  extern void sx_72656164(environment *env Line 1754  extern void sx_72656164(environment *env
1754    int count= -1;    int count= -1;
1755    float ftemp;    float ftemp;
1756    static int depth= 0;    static int depth= 0;
1757    char *match, *ctemp;    char *match;
1758    size_t inlength;    size_t inlength;
1759    
1760    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1633  extern void sx_72656164(environment *env Line 1769  extern void sx_72656164(environment *env
1769      }      }
1770            
1771      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1772        assert(env->in_string != NULL);
1773      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1774      strcpy(env->in_string, CAR(env->head)->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1775      toss(env); if(env->err) return;      toss(env); if(env->err) return;
# Line 1640  extern void sx_72656164(environment *env Line 1777  extern void sx_72656164(environment *env
1777        
1778    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1779    match= malloc(inlength);    match= malloc(inlength);
1780      assert(match != NULL);
1781    
1782    if(sscanf(env->in_string, blankform, &readlength) != EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1783       && readlength != -1) {       && readlength != -1) {
# Line 1652  extern void sx_72656164(environment *env Line 1790  extern void sx_72656164(environment *env
1790      } else {      } else {
1791        push_float(env, ftemp);        push_float(env, ftemp);
1792      }      }
1793      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1794                && readlength != -1) {
1795        push_cstring(env, "");
1796    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1797              && readlength != -1) {              && readlength != -1) {
1798      push_cstring(env, match);      push_cstring(env, match);
# Line 1688  extern void beep(environment *env) Line 1829  extern void beep(environment *env)
1829  {  {
1830    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1831    
1832    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1833      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1834      env->err= 1;      env->err= 1;
1835      return;      return;
# Line 1733  extern void sx_77616974(environment *env Line 1874  extern void sx_77616974(environment *env
1874  {  {
1875    int dur;    int dur;
1876    
1877    if(env->head==NULL) {    if(env->head->type==empty) {
1878      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1879      env->err= 1;      env->err= 1;
1880      return;      return;
# Line 1753  extern void sx_77616974(environment *env Line 1894  extern void sx_77616974(environment *env
1894    
1895  extern void copying(environment *env)  extern void copying(environment *env)
1896  {  {
1897    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1898                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1899  \n\  \n\
1900   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2042  extern void sx_2a(environment *env) Line 2183  extern void sx_2a(environment *env)
2183    int a, b;    int a, b;
2184    float fa, fb;    float fa, fb;
2185    
2186    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2187      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2188      env->err= 1;      env->err= 1;
2189      return;      return;
# Line 2102  extern void sx_2f(environment *env) Line 2243  extern void sx_2f(environment *env)
2243    int a, b;    int a, b;
2244    float fa, fb;    float fa, fb;
2245    
2246    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2247      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2248      env->err= 1;      env->err= 1;
2249      return;      return;
# Line 2161  extern void mod(environment *env) Line 2302  extern void mod(environment *env)
2302  {  {
2303    int a, b;    int a, b;
2304    
2305    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2306      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2307      env->err= 1;      env->err= 1;
2308      return;      return;
# Line 2187  extern void sx_646976(environment *env) Line 2328  extern void sx_646976(environment *env)
2328  {  {
2329    int a, b;    int a, b;
2330        
2331    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2332      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2333      env->err= 1;      env->err= 1;
2334      return;      return;
# Line 2207  extern void sx_646976(environment *env) Line 2348  extern void sx_646976(environment *env)
2348    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2349    env->err= 2;    env->err= 2;
2350  }  }
2351    
2352    extern void setcar(environment *env)
2353    {
2354      if(env->head->type==empty || CDR(env->head)->type==empty) {
2355        printerr("Too Few Arguments");
2356        env->err= 1;
2357        return;
2358      }
2359    
2360      if(CDR(env->head)->type!=tcons) {
2361        printerr("Bad Argument Type");
2362        env->err= 2;
2363        return;
2364      }
2365    
2366      CAR(CAR(CDR(env->head)))=CAR(env->head);
2367      toss(env);
2368    }
2369    
2370    extern void setcdr(environment *env)
2371    {
2372      if(env->head->type==empty || CDR(env->head)->type==empty) {
2373        printerr("Too Few Arguments");
2374        env->err= 1;
2375        return;
2376      }
2377    
2378      if(CDR(env->head)->type!=tcons) {
2379        printerr("Bad Argument Type");
2380        env->err= 2;
2381        return;
2382      }
2383    
2384      CDR(CAR(CDR(env->head)))=CAR(env->head);
2385      toss(env);
2386    }
2387    
2388    extern void car(environment *env)
2389    {
2390      if(env->head->type==empty) {
2391        printerr("Too Few Arguments");
2392        env->err= 1;
2393        return;
2394      }
2395    
2396      if(CAR(env->head)->type!=tcons) {
2397        printerr("Bad Argument Type");
2398        env->err= 2;
2399        return;
2400      }
2401    
2402      CAR(env->head)=CAR(CAR(env->head));
2403    }
2404    
2405    extern void cdr(environment *env)
2406    {
2407      if(env->head->type==empty) {
2408        printerr("Too Few Arguments");
2409        env->err= 1;
2410        return;
2411      }
2412    
2413      if(CAR(env->head)->type!=tcons) {
2414        printerr("Bad Argument Type");
2415        env->err= 2;
2416        return;
2417      }
2418    
2419      CAR(env->head)=CDR(CAR(env->head));
2420    }
2421    
2422    extern void cons(environment *env)
2423    {
2424      value *val;
2425    
2426      if(env->head->type==empty || CDR(env->head)->type==empty) {
2427        printerr("Too Few Arguments");
2428        env->err= 1;
2429        return;
2430      }
2431    
2432      val=new_val(env);
2433      val->content.c= malloc(sizeof(pair));
2434      assert(val->content.c!=NULL);
2435    
2436      env->gc_count += sizeof(pair);
2437      val->type=tcons;
2438    
2439      CAR(val)= CAR(CDR(env->head));
2440      CDR(val)= CAR(env->head);
2441    
2442      push_val(env, val);
2443    
2444      swap(env); if(env->err) return;
2445      toss(env); if(env->err) return;
2446      swap(env); if(env->err) return;
2447      toss(env); if(env->err) return;
2448    }
2449    
2450    /*  2: 3                        =>                */
2451    /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
2452    extern void assq(environment *env)
2453    {
2454      assocgen(env, eq);
2455    }
2456    
2457    
2458    /* General assoc function */
2459    void assocgen(environment *env, funcp eqfunc)
2460    {
2461      value *key, *item;
2462    
2463      /* Needs two values on the stack, the top one must be an association
2464         list */
2465      if(env->head->type==empty || CDR(env->head)->type==empty) {
2466        printerr("Too Few Arguments");
2467        env->err= 1;
2468        return;
2469      }
2470    
2471      if(CAR(env->head)->type!=tcons) {
2472        printerr("Bad Argument Type");
2473        env->err= 2;
2474        return;
2475      }
2476    
2477      key=CAR(CDR(env->head));
2478      item=CAR(env->head);
2479    
2480      while(item->type == tcons){
2481        if(CAR(item)->type != tcons){
2482          printerr("Bad Argument Type");
2483          env->err= 2;
2484          return;
2485        }
2486        push_val(env, key);
2487        push_val(env, CAR(CAR(item)));
2488        eqfunc(env); if(env->err) return;
2489    
2490        /* Check the result of 'eqfunc' */
2491        if(env->head->type==empty) {
2492          printerr("Too Few Arguments");
2493          env->err= 1;
2494        return;
2495        }
2496        if(CAR(env->head)->type!=integer) {
2497          printerr("Bad Argument Type");
2498          env->err= 2;
2499          return;
2500        }
2501    
2502        if(CAR(env->head)->content.i){
2503          toss(env); if(env->err) return;
2504          break;
2505        }
2506        toss(env); if(env->err) return;
2507    
2508        if(item->type!=tcons) {
2509          printerr("Bad Argument Type");
2510          env->err= 2;
2511          return;
2512        }
2513    
2514        item=CDR(item);
2515      }
2516    
2517      if(item->type == tcons){      /* A match was found */
2518        push_val(env, CAR(item));
2519      } else {
2520        push_int(env, 0);
2521      }
2522      swap(env); if(env->err) return;
2523      toss(env); if(env->err) return;
2524      swap(env); if(env->err) return;
2525      toss(env);
2526    }
Legend:
Removed from v.1.108  
changed lines
  Added in v.1.120
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26