/[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.112 by teddy, Sat Mar 16 20:09:51 2002 UTC
# Line 37  Line 37 
37  #include <unistd.h>  #include <unistd.h>
38  /* EX_NOINPUT, EX_USAGE */  /* EX_NOINPUT, EX_USAGE */
39  #include <sysexits.h>  #include <sysexits.h>
40    /* assert */
41    #include <assert.h>
42    
43    #ifdef __linux__
44  /* mtrace, muntrace */  /* mtrace, muntrace */
45  #include <mcheck.h>  #include <mcheck.h>
46  /* ioctl */  /* ioctl */
47  #include <sys/ioctl.h>  #include <sys/ioctl.h>
48  /* KDMKTONE */  /* KDMKTONE */
49  #include <linux/kd.h>  #include <linux/kd.h>
50    #endif /* __linux__ */
51    
52  #include "stack.h"  #include "stack.h"
53    
# Line 55  void init_env(environment *env) Line 60  void init_env(environment *env)
60    env->gc_count= 0;    env->gc_count= 0;
61    env->gc_ref= NULL;    env->gc_ref= NULL;
62    
63    env->head= NULL;    env->head= new_val(env);
64      env->head->type= empty;
65    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
66      env->symbols[i]= NULL;      env->symbols[i]= NULL;
67    env->err= 0;    env->err= 0;
# Line 73  void printerr(const char* in_string) Line 79  void printerr(const char* in_string)
79  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
80  extern void toss(environment *env)  extern void toss(environment *env)
81  {  {
82    if(env->head==NULL) {    if(env->head->type==empty) {
83      printerr("Too Few Arguments");      printerr("Too Few Arguments");
84      env->err= 1;      env->err= 1;
85      return;      return;
# Line 118  value* new_val(environment *env) Line 124  value* new_val(environment *env)
124    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
125    
126    nval->content.ptr= NULL;    nval->content.ptr= NULL;
127      nval->type= integer;
128    
129    nitem->item= nval;    nitem->item= nval;
130    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
# 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 */
# Line 197  extern void gc_init(environment *env) Line 203  extern void gc_init(environment *env)
203        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
204        env->gc_ref= titem;        env->gc_ref= titem;
205        continue;        continue;
206      }      }
207    #ifdef DEBUG
208        printf("Kept value (%p)", env->gc_ref->item);
209        if(env->gc_ref->item->gc.flag.mark)
210          printf(" (marked)");
211        if(env->gc_ref->item->gc.flag.protect)
212          printf(" (protected)");
213        switch(env->gc_ref->item->type){
214        case integer:
215          printf(" integer: %d", env->gc_ref->item->content.i);
216          break;
217        case func:
218          printf(" func: %p", env->gc_ref->item->content.ptr);
219          break;
220        case symb:
221          printf(" symb: %s", env->gc_ref->item->content.sym->id);
222          break;
223        case tcons:
224          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
225                 env->gc_ref->item->content.c->cdr);
226          break;
227        default:
228          printf(" <unknown %d>", (env->gc_ref->item->type));
229        }
230        printf("\n");
231    #endif /* DEBUG */
232    
233      /* Keep values */          /* Keep values */    
234      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
# Line 217  extern void gc_init(environment *env) Line 248  extern void gc_init(environment *env)
248    env->gc_ref= new_head;    env->gc_ref= new_head;
249    
250    if(env->interactive)    if(env->interactive)
251      printf("done\n");      printf("done (%d bytes still allocated)\n", env->gc_count);
252    
253  }  }
254    
# Line 255  void push_val(environment *env, value *v Line 286  void push_val(environment *env, value *v
286    value *new_value= new_val(env);    value *new_value= new_val(env);
287    
288    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(cons));
289      assert(new_value->content.c!=NULL);
290    new_value->type= tcons;    new_value->type= tcons;
291    CAR(new_value)= val;    CAR(new_value)= val;
292    CDR(new_value)= env->head;    CDR(new_value)= env->head;
# Line 321  extern void mangle(environment *env) Line 353  extern void mangle(environment *env)
353  {  {
354    char *new_string;    char *new_string;
355    
356    if(env->head==NULL) {    if(env->head->type==empty) {
357      printerr("Too Few Arguments");      printerr("Too Few Arguments");
358      env->err= 1;      env->err= 1;
359      return;      return;
# Line 418  extern void nl() Line 450  extern void nl()
450  /* Gets the type of a value */  /* Gets the type of a value */
451  extern void type(environment *env)  extern void type(environment *env)
452  {  {
453    int typenum;    if(env->head->type==empty) {
   
   if(env->head==NULL) {  
454      printerr("Too Few Arguments");      printerr("Too Few Arguments");
455      env->err= 1;      env->err= 1;
456      return;      return;
457    }    }
458    
459    typenum= CAR(env->head)->type;    switch(CAR(env->head)->type){
460    toss(env);    case empty:
461    switch(typenum){      push_sym(env, "empty");
462        break;
463    case integer:    case integer:
464      push_sym(env, "integer");      push_sym(env, "integer");
465      break;      break;
# Line 448  extern void type(environment *env) Line 479  extern void type(environment *env)
479      push_sym(env, "list");      push_sym(env, "list");
480      break;      break;
481    }    }
482      swap(env);
483      if (env->err) return;
484      toss(env);
485  }      }    
486    
487  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
488  void print_h(value *stack_head, int noquote)  void print_h(value *stack_head, int noquote)
489  {  {
490    switch(CAR(stack_head)->type) {    switch(CAR(stack_head)->type) {
491      case empty:
492        printf("[]");
493        break;
494    case integer:    case integer:
495      printf("%d", CAR(stack_head)->content.i);      printf("%d", CAR(stack_head)->content.i);
496      break;      break;
# Line 462  void print_h(value *stack_head, int noqu Line 499  void print_h(value *stack_head, int noqu
499      break;      break;
500    case string:    case string:
501      if(noquote)      if(noquote)
502        printf("%s", (char*)CAR(stack_head)->content.ptr);        printf("%s", (char*)(CAR(stack_head)->content.ptr));
503      else      else
504        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);        printf("\"%s\"", (char*)(CAR(stack_head)->content.ptr));
505      break;      break;
506    case symb:    case symb:
507      printf("%s", CAR(stack_head)->content.sym->id);      printf("%s", CAR(stack_head)->content.sym->id);
# Line 476  void print_h(value *stack_head, int noqu Line 513  void print_h(value *stack_head, int noqu
513      /* A list is just a stack, so make stack_head point to it */      /* A list is just a stack, so make stack_head point to it */
514      stack_head= CAR(stack_head);      stack_head= CAR(stack_head);
515      printf("[ ");      printf("[ ");
516      while(stack_head != NULL) {      while(stack_head->type != empty) {
517        print_h(stack_head, noquote);        print_h(stack_head, noquote);
518        printf(" ");        switch(CDR(stack_head)->type){
519          case empty:
520            break;
521          case tcons:
522            printf(" ");
523            break;
524          default:
525            printf(" . ");          /* Improper list */
526          }
527        stack_head= CDR(stack_head);        stack_head= CDR(stack_head);
528      }      }
529      printf("]");      printf(" ]");
530      break;      break;
531    }    }
532  }  }
533    
534  extern void print_(environment *env)  extern void print_(environment *env)
535  {  {
536    if(env->head==NULL) {    if(env->head->type==empty) {
537      printerr("Too Few Arguments");      printerr("Too Few Arguments");
538      env->err= 1;      env->err= 1;
539      return;      return;
# Line 507  extern void print(environment *env) Line 552  extern void print(environment *env)
552    
553  extern void princ_(environment *env)  extern void princ_(environment *env)
554  {  {
555    if(env->head==NULL) {    if(env->head->type==empty) {
556      printerr("Too Few Arguments");      printerr("Too Few Arguments");
557      env->err= 1;      env->err= 1;
558      return;      return;
# Line 526  extern void princ(environment *env) Line 571  extern void princ(environment *env)
571  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
572  void print_st(value *stack_head, long counter)  void print_st(value *stack_head, long counter)
573  {  {
574    if(CDR(stack_head) != NULL)    if(CDR(stack_head)->type != empty)
575      print_st(CDR(stack_head), counter+1);      print_st(CDR(stack_head), counter+1);
576    printf("%ld: ", counter);    printf("%ld: ", counter);
577    print_h(stack_head, 0);    print_h(stack_head, 0);
# Line 536  void print_st(value *stack_head, long co Line 581  void print_st(value *stack_head, long co
581  /* Prints the stack. */  /* Prints the stack. */
582  extern void printstack(environment *env)  extern void printstack(environment *env)
583  {  {
584    if(env->head == NULL) {    if(env->head->type == empty) {
585      printf("Stack Empty\n");      printf("Stack Empty\n");
586      return;      return;
587    }    }
# Line 549  extern void swap(environment *env) Line 594  extern void swap(environment *env)
594  {  {
595    value *temp= env->head;    value *temp= env->head;
596        
597    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
598      printerr("Too Few Arguments");      printerr("Too Few Arguments");
599      env->err=1;      env->err=1;
600      return;      return;
# Line 565  extern void rot(environment *env) Line 610  extern void rot(environment *env)
610  {  {
611    value *temp= env->head;    value *temp= env->head;
612        
613    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
614       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type == empty) {
615      printerr("Too Few Arguments");      printerr("Too Few Arguments");
616      env->err= 1;      env->err= 1;
617      return;      return;
# Line 582  extern void rcl(environment *env) Line 627  extern void rcl(environment *env)
627  {  {
628    value *val;    value *val;
629    
630    if(env->head==NULL) {    if(env->head->type==empty) {
631      printerr("Too Few Arguments");      printerr("Too Few Arguments");
632      env->err= 1;      env->err= 1;
633      return;      return;
# Line 600  extern void rcl(environment *env) Line 645  extern void rcl(environment *env)
645      env->err= 3;      env->err= 3;
646      return;      return;
647    }    }
648    protect(val);    push_val(env, val);           /* Return the symbol's bound value */
649    toss(env);            /* toss the symbol */    swap(env);
650      if(env->err) return;
651      toss(env);                    /* toss the symbol */
652    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(val);  
653  }  }
654    
655  /* 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 665  extern void eval(environment *env)
665    
666    gc_maybe(env);    gc_maybe(env);
667    
668    if(env->head==NULL) {    if(env->head->type==empty) {
669      printerr("Too Few Arguments");      printerr("Too Few Arguments");
670      env->err= 1;      env->err= 1;
671      return;      return;
# Line 651  extern void eval(environment *env) Line 696  extern void eval(environment *env)
696      toss(env); if(env->err) return;      toss(env); if(env->err) return;
697      iterator= temp_val;      iterator= temp_val;
698            
699      while(iterator!=NULL) {      while(iterator->type != empty) {
700        push_val(env, CAR(iterator));        push_val(env, CAR(iterator));
701                
702        if(CAR(env->head)->type==symb        if(CAR(env->head)->type==symb
# Line 659  extern void eval(environment *env) Line 704  extern void eval(environment *env)
704          toss(env);          toss(env);
705          if(env->err) return;          if(env->err) return;
706                    
707          if(CDR(iterator)==NULL){          if(CDR(iterator)->type == empty){
708            goto eval_start;            goto eval_start;
709          }          }
710          eval(env);          eval(env);
711          if(env->err) return;          if(env->err) return;
712        }        }
713        if (CDR(iterator)->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
714          iterator= CDR(iterator);          iterator= CDR(iterator);
715        else {        else {
716          printerr("Bad Argument Type"); /* Improper list */          printerr("Bad Argument Type"); /* Improper list */
# Line 686  extern void rev(environment *env) Line 731  extern void rev(environment *env)
731  {  {
732    value *old_head, *new_head, *item;    value *old_head, *new_head, *item;
733    
734    if(env->head==NULL) {    if(env->head->type==empty) {
735      printerr("Too Few Arguments");      printerr("Too Few Arguments");
736      env->err= 1;      env->err= 1;
737      return;      return;
738    }    }
739    
740      if(CAR(env->head)->type==empty)
741        return;                     /* Don't reverse an empty list */
742    
743    if(CAR(env->head)->type!=tcons) {    if(CAR(env->head)->type!=tcons) {
744      printerr("Bad Argument Type");      printerr("Bad Argument Type");
745      env->err= 2;      env->err= 2;
# Line 699  extern void rev(environment *env) Line 747  extern void rev(environment *env)
747    }    }
748    
749    old_head= CAR(env->head);    old_head= CAR(env->head);
750    new_head= NULL;    new_head= new_val(env);
751    while(old_head!=NULL) {    new_head->type= empty;
752      while(old_head->type != empty) {
753      item= old_head;      item= old_head;
754      old_head= CDR(old_head);      old_head= CDR(old_head);
755      CDR(item)= new_head;      CDR(item)= new_head;
# Line 712  extern void rev(environment *env) Line 761  extern void rev(environment *env)
761  /* Make a list. */  /* Make a list. */
762  extern void pack(environment *env)  extern void pack(environment *env)
763  {  {
764    value *iterator, *temp;    value *iterator, *temp, *ending;
765    
766      ending=new_val(env);
767      ending->type=empty;
768    
769    iterator= env->head;    iterator= env->head;
770    if(iterator==NULL    if(iterator->type == empty
771       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
772       && CAR(iterator)->content.sym->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
773      temp= NULL;      temp= ending;
774      toss(env);      toss(env);
775    } else {    } else {
776      /* Search for first delimiter */      /* Search for first delimiter */
777      while(CDR(iterator)!=NULL      while(CDR(iterator)->type != empty
778            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
779             || CAR(CDR(iterator))->content.sym->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
780        iterator= CDR(iterator);        iterator= CDR(iterator);
# Line 730  extern void pack(environment *env) Line 782  extern void pack(environment *env)
782      /* Extract list */      /* Extract list */
783      temp= env->head;      temp= env->head;
784      env->head= CDR(iterator);      env->head= CDR(iterator);
785      CDR(iterator)= NULL;      CDR(iterator)= ending;
786    
787      if(env->head!=NULL)      if(env->head->type != empty)
788        toss(env);        toss(env);
789    }    }
790    
# Line 748  extern void expand(environment *env) Line 800  extern void expand(environment *env)
800    value *temp, *new_head;    value *temp, *new_head;
801    
802    /* Is top element a list? */    /* Is top element a list? */
803    if(env->head==NULL) {    if(env->head->type==empty) {
804      printerr("Too Few Arguments");      printerr("Too Few Arguments");
805      env->err= 1;      env->err= 1;
806      return;      return;
# Line 771  extern void expand(environment *env) Line 823  extern void expand(environment *env)
823    toss(env);    toss(env);
824    
825    /* Find the end of the list */    /* Find the end of the list */
826    while(CDR(temp)->content.ptr != NULL) {    while(CDR(temp)->type != empty) {
827      if (CDR(temp)->type == tcons)      if (CDR(temp)->type == tcons)
828        temp= CDR(temp);        temp= CDR(temp);
829      else {      else {
# Line 792  extern void eq(environment *env) Line 844  extern void eq(environment *env)
844  {  {
845    void *left, *right;    void *left, *right;
846    
847    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
848      printerr("Too Few Arguments");      printerr("Too Few Arguments");
849      env->err= 1;      env->err= 1;
850      return;      return;
# Line 810  extern void not(environment *env) Line 862  extern void not(environment *env)
862  {  {
863    int val;    int val;
864    
865    if(env->head==NULL) {    if(env->head->type==empty) {
866      printerr("Too Few Arguments");      printerr("Too Few Arguments");
867      env->err= 1;      env->err= 1;
868      return;      return;
# Line 841  extern void def(environment *env) Line 893  extern void def(environment *env)
893    symbol *sym;    symbol *sym;
894    
895    /* 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 */
896    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
897      printerr("Too Few Arguments");      printerr("Too Few Arguments");
898      env->err= 1;      env->err= 1;
899      return;      return;
# Line 880  extern void quit(environment *env) Line 932  extern void quit(environment *env)
932    env->gc_limit= 0;    env->gc_limit= 0;
933    gc_maybe(env);    gc_maybe(env);
934    
935      words(env);
936    
937    if(env->free_string!=NULL)    if(env->free_string!=NULL)
938      free(env->free_string);      free(env->free_string);
939        
940    #ifdef __linux__
941    muntrace();    muntrace();
942    #endif
943    
944    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
945  }  }
# Line 891  extern void quit(environment *env) Line 947  extern void quit(environment *env)
947  /* Clear stack */  /* Clear stack */
948  extern void clear(environment *env)  extern void clear(environment *env)
949  {  {
950    while(env->head!=NULL)    while(env->head->type != empty)
951      toss(env);      toss(env);
952  }  }
953    
# Line 904  extern void words(environment *env) Line 960  extern void words(environment *env)
960    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
961      temp= env->symbols[i];      temp= env->symbols[i];
962      while(temp!=NULL) {      while(temp!=NULL) {
963    #ifdef DEBUG
964          if (temp->val != NULL && temp->val->gc.flag.protect)
965            printf("(protected) ");
966    #endif /* DEBUG */
967        printf("%s\n", temp->id);        printf("%s\n", temp->id);
968        temp= temp->next;        temp= temp->next;
969      }      }
# Line 926  void forget_sym(symbol **hash_entry) Line 986  void forget_sym(symbol **hash_entry)
986  extern void forget(environment *env)  extern void forget(environment *env)
987  {  {
988    char* sym_id;    char* sym_id;
   value *stack_head= env->head;  
989    
990    if(stack_head==NULL) {    if(env->head->type==empty) {
991      printerr("Too Few Arguments");      printerr("Too Few Arguments");
992      env->err= 1;      env->err= 1;
993      return;      return;
994    }    }
995        
996    if(CAR(stack_head)->type!=symb) {    if(CAR(env->head)->type!=symb) {
997      printerr("Bad Argument Type");      printerr("Bad Argument Type");
998      env->err= 2;      env->err= 2;
999      return;      return;
1000    }    }
1001    
1002    sym_id= CAR(stack_head)->content.sym->id;    sym_id= CAR(env->head)->content.sym->id;
1003    toss(env);    toss(env);
1004    
1005    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 1017  int main(int argc, char **argv)
1017    
1018    int c;                        /* getopt option character */    int c;                        /* getopt option character */
1019    
1020    #ifdef __linux__
1021    mtrace();    mtrace();
1022    #endif
1023    
1024    init_env(&myenv);    init_env(&myenv);
1025    
# Line 972  int main(int argc, char **argv) Line 1033  int main(int argc, char **argv)
1033          break;          break;
1034        case '?':        case '?':
1035          fprintf (stderr,          fprintf (stderr,
1036                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1037                   optopt);                   optopt);
1038          return EX_USAGE;          return EX_USAGE;
1039        default:        default:
# Line 991  int main(int argc, char **argv) Line 1052  int main(int argc, char **argv)
1052    if(myenv.interactive) {    if(myenv.interactive) {
1053      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1054  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1055  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1056  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1057  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1058    }    }
1059    
1060    while(1) {    while(1) {
# Line 1008  under certain conditions; type `copying; Line 1069  under certain conditions; type `copying;
1069        }        }
1070        myenv.err=0;        myenv.err=0;
1071      }      }
1072      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1073      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1074        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1075      } else if(myenv.head!=NULL        quit(&myenv);
1076        } else if(myenv.head->type!=empty
1077                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
1078                && CAR(myenv.head)->content.sym->id[0]                && CAR(myenv.head)->content.sym->id[0]
1079                ==';') {                ==';') {
# Line 1033  extern void sx_2b(environment *env) Line 1095  extern void sx_2b(environment *env)
1095    char* new_string;    char* new_string;
1096    value *a_val, *b_val;    value *a_val, *b_val;
1097    
1098    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1099      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1100      env->err= 1;      env->err= 1;
1101      return;      return;
# Line 1111  extern void sx_2d(environment *env) Line 1173  extern void sx_2d(environment *env)
1173    int a, b;    int a, b;
1174    float fa, fb;    float fa, fb;
1175    
1176    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1177      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1178      env->err=1;      env->err=1;
1179      return;      return;
# Line 1171  extern void sx_3e(environment *env) Line 1233  extern void sx_3e(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 1256  value *copy_val(environment *env, value Line 1318  value *copy_val(environment *env, value
1318    
1319    protect(old_value);    protect(old_value);
1320    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
1321    new_value->type= old_value->type;    new_value->type= old_value->type;
1322    
1323    switch(old_value->type){    switch(old_value->type){
# Line 1271  value *copy_val(environment *env, value Line 1332  value *copy_val(environment *env, value
1332        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1333      break;      break;
1334    case tcons:    case tcons:
     new_value= NULL;  
1335    
1336      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(cons));
1337        assert(new_value->content.c!=NULL);
1338    
1339      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1340      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
1341      break;      break;
1342    }    }
1343    
1344    unprotect(old_value); unprotect(new_value);    unprotect(old_value);
1345    
1346    return new_value;    return new_value;
1347  }  }
# Line 1287  value *copy_val(environment *env, value Line 1349  value *copy_val(environment *env, value
1349  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1350  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1351  {  {
1352    if(env->head==NULL) {    if(env->head->type==empty) {
1353      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1354      env->err= 1;      env->err= 1;
1355      return;      return;
# Line 1300  extern void sx_6966(environment *env) Line 1362  extern void sx_6966(environment *env)
1362  {  {
1363    int truth;    int truth;
1364    
1365    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1366      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1367      env->err= 1;      env->err= 1;
1368      return;      return;
# Line 1331  extern void ifelse(environment *env) Line 1393  extern void ifelse(environment *env)
1393  {  {
1394    int truth;    int truth;
1395    
1396    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1397       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type==empty) {
1398      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1399      env->err= 1;      env->err= 1;
1400      return;      return;
# Line 1364  extern void ifelse(environment *env) Line 1426  extern void ifelse(environment *env)
1426    
1427  extern void sx_656c7365(environment *env)  extern void sx_656c7365(environment *env)
1428  {  {
1429    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1430       || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL) {       || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1431         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1432        printerr("Too Few Arguments");
1433        env->err= 1;
1434        return;
1435      }
1436    
1437      if(CAR(CDR(env->head))->type!=symb
1438         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1439         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1440         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1441        printerr("Bad Argument Type");
1442        env->err= 2;
1443        return;
1444      }
1445    
1446      swap(env); toss(env); rot(env); toss(env);
1447      ifelse(env);
1448    }
1449    
1450    extern void then(environment *env)
1451    {
1452      if(env->head->type==empty || CDR(env->head)->type==empty
1453         || CDR(CDR(env->head))->type==empty) {
1454      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1455      env->err= 1;      env->err= 1;
1456      return;      return;
# Line 1379  extern void sx_656c7365(environment *env Line 1464  extern void sx_656c7365(environment *env
1464    }    }
1465    
1466    swap(env); toss(env);    swap(env); toss(env);
1467    ifelse(env);    sx_6966(env);
1468  }  }
1469    
1470  /* "while" */  /* "while" */
# Line 1388  extern void sx_7768696c65(environment *e Line 1473  extern void sx_7768696c65(environment *e
1473    int truth;    int truth;
1474    value *loop, *test;    value *loop, *test;
1475    
1476    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1477      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1478      env->err= 1;      env->err= 1;
1479      return;      return;
# Line 1434  extern void sx_666f72(environment *env) Line 1519  extern void sx_666f72(environment *env)
1519    value *loop;    value *loop;
1520    int foo1, foo2;    int foo1, foo2;
1521    
1522    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1523       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type==empty) {
1524      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1525      env->err= 1;      env->err= 1;
1526      return;      return;
# Line 1482  extern void foreach(environment *env) Line 1567  extern void foreach(environment *env)
1567    value *loop, *foo;    value *loop, *foo;
1568    value *iterator;    value *iterator;
1569        
1570    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1571      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1572      env->err= 1;      env->err= 1;
1573      return;      return;
# Line 1525  extern void to(environment *env) Line 1610  extern void to(environment *env)
1610    int ending, start, i;    int ending, start, i;
1611    value *iterator, *temp;    value *iterator, *temp;
1612    
1613    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1614      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1615      env->err= 1;      env->err= 1;
1616      return;      return;
# Line 1555  extern void to(environment *env) Line 1640  extern void to(environment *env)
1640    
1641    iterator= env->head;    iterator= env->head;
1642    
1643    if(iterator==NULL    if(iterator->type==empty
1644       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
1645           && CAR(iterator)->content.sym->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1646      temp= NULL;      temp= NULL;
# Line 1672  extern void sx_72656164(environment *env Line 1757  extern void sx_72656164(environment *env
1757      return sx_72656164(env);      return sx_72656164(env);
1758  }  }
1759    
1760    #ifdef __linux__
1761  extern void beep(environment *env)  extern void beep(environment *env)
1762  {  {
1763    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1764    
1765    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1766      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1767      env->err= 1;      env->err= 1;
1768      return;      return;
# Line 1714  extern void beep(environment *env) Line 1800  extern void beep(environment *env)
1800      abort();      abort();
1801    }    }
1802  }  }
1803    #endif /* __linux__ */
1804    
1805  /* "wait" */  /* "wait" */
1806  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
1807  {  {
1808    int dur;    int dur;
1809    
1810    if(env->head==NULL) {    if(env->head->type==empty) {
1811      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1812      env->err= 1;      env->err= 1;
1813      return;      return;
# Line 1740  extern void sx_77616974(environment *env Line 1827  extern void sx_77616974(environment *env
1827    
1828  extern void copying(environment *env)  extern void copying(environment *env)
1829  {  {
1830    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1831                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1832  \n\  \n\
1833   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 2116  extern void sx_2a(environment *env)
2116    int a, b;    int a, b;
2117    float fa, fb;    float fa, fb;
2118    
2119    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2120      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2121      env->err= 1;      env->err= 1;
2122      return;      return;
# Line 2089  extern void sx_2f(environment *env) Line 2176  extern void sx_2f(environment *env)
2176    int a, b;    int a, b;
2177    float fa, fb;    float fa, fb;
2178    
2179    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2180      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2181      env->err= 1;      env->err= 1;
2182      return;      return;
# Line 2148  extern void mod(environment *env) Line 2235  extern void mod(environment *env)
2235  {  {
2236    int a, b;    int a, b;
2237    
2238    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2239      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2240      env->err= 1;      env->err= 1;
2241      return;      return;
# Line 2174  extern void sx_646976(environment *env) Line 2261  extern void sx_646976(environment *env)
2261  {  {
2262    int a, b;    int a, b;
2263        
2264    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2265      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2266      env->err= 1;      env->err= 1;
2267      return;      return;
Legend:
Removed from v.1.106  
changed lines
  Added in v.1.112
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26