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

Diff of /stack/stack.c

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

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