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

Diff of /stack/stack.c

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

revision 1.122 by masse, Wed Mar 27 14:49:56 2002 UTC revision 1.125 by teddy, Sun Mar 31 02:19:54 2002 UTC
# Line 205  extern void gc_init(environment *env) Line 205  extern void gc_init(environment *env)
205        case tcons:        case tcons:
206          free(env->gc_ref->item->content.c);          free(env->gc_ref->item->content.c);
207          break;          break;
208          case port:
209        case empty:        case empty:
210        case integer:        case integer:
211        case tfloat:        case tfloat:
# Line 462  void push_sym(environment *env, const ch Line 463  void push_sym(environment *env, const ch
463  }  }
464    
465  /* Print newline. */  /* Print newline. */
466  extern void nl()  extern void nl(environment *env)
467  {  {
468    printf("\n");    printf("\n");
469  }  }
470    
471    /* Print a newline to a port */
472    extern void nlport(environment *env)
473    {
474      if(env->head->type==empty) {
475        printerr("Too Few Arguments");
476        env->err= 1;
477        return;
478      }
479    
480      if(CAR(env->head)->type!=port) {
481        printerr("Bad Argument Type");
482        env->err= 2;
483        return;
484      }
485    
486      if(fprintf(CAR(env->head)->content.p, "\n") < 0){
487        perror("nl");
488        env->err= 5;
489        return;
490      }
491      toss(env);
492    }
493    
494  /* Gets the type of a value */  /* Gets the type of a value */
495  extern void type(environment *env)  extern void type(environment *env)
496  {  {
# Line 498  extern void type(environment *env) Line 522  extern void type(environment *env)
522    case tcons:    case tcons:
523      push_sym(env, "pair");      push_sym(env, "pair");
524      break;      break;
525      case port:
526        push_sym(env, "port");
527        break;
528    }    }
529    swap(env);    swap(env);
530    if (env->err) return;    if (env->err) return;
531    toss(env);    toss(env);
532  }      }
533    
534  /* Print a value */  /* Print a value */
535  void print_val(value *val, int noquote, stackitem *stack)  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
536  {  {
537    stackitem *titem, *tstack;    stackitem *titem, *tstack;
538    int depth;    int depth;
539    
540    switch(val->type) {    switch(val->type) {
541    case empty:    case empty:
542      printf("[]");      if(fprintf(stream, "[]") < 0){
543          perror("print_val");
544          env->err= 5;
545          return;
546        }
547      break;      break;
548    case integer:    case integer:
549      printf("%d", val->content.i);      if(fprintf(stream, "%d", val->content.i) < 0){
550          perror("print_val");
551          env->err= 5;
552          return;
553        }
554      break;      break;
555    case tfloat:    case tfloat:
556      printf("%f", val->content.f);      if(fprintf(stream, "%f", val->content.f) < 0){
557          perror("print_val");
558          env->err= 5;
559          return;
560        }
561      break;      break;
562    case string:    case string:
563      if(noquote)      if(noquote){
564        printf("%s", (char*)(val->content.ptr));        if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){
565      else          perror("print_val");
566        printf("\"%s\"", (char*)(val->content.ptr));          env->err= 5;
567            return;
568          }
569        } else {                    /* quote */
570          if(fprintf(stream, "\"%s\"", (char*)(val->content.ptr)) < 0){
571            perror("print_val");
572            env->err= 5;
573            return;
574          }
575        }
576      break;      break;
577    case symb:    case symb:
578      printf("%s", val->content.sym->id);      if(fprintf(stream, "%s", val->content.sym->id) < 0){
579          perror("print_val");
580          env->err= 5;
581          return;
582        }
583      break;      break;
584    case func:    case func:
585      printf("#<function %p>", (funcp)(val->content.ptr));      if(fprintf(stream, "#<function %p>", (funcp)(val->content.ptr)) < 0){
586          perror("print_val");
587          env->err= 5;
588          return;
589        }
590        break;
591      case port:
592        if(fprintf(stream, "#<port %p>", (funcp)(val->content.p)) < 0){
593          perror("print_val");
594          env->err= 5;
595          return;
596        }
597      break;      break;
598    case tcons:    case tcons:
599      printf("[ ");      if(fprintf(stream, "[ ") < 0){
600          perror("print_val");
601          env->err= 5;
602          return;
603        }
604      tstack= stack;      tstack= stack;
605      do {      do {
606        titem=malloc(sizeof(stackitem));        titem=malloc(sizeof(stackitem));
# Line 550  void print_val(value *val, int noquote, Line 617  void print_val(value *val, int noquote,
617          depth++;          depth++;
618        }        }
619        if(titem != NULL){        /* If we found it on the stack, */        if(titem != NULL){        /* If we found it on the stack, */
620          printf("#%d#", depth);  /* print a depth reference */          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
621              perror("print_val");
622              env->err= 5;
623              free(titem);
624              return;
625            }
626        } else {        } else {
627          print_val(CAR(val), noquote, tstack);          print_val(env, CAR(val), noquote, tstack, stream);
628        }        }
629        val= CDR(val);        val= CDR(val);
630        switch(val->type){        switch(val->type){
# Line 568  void print_val(value *val, int noquote, Line 640  void print_val(value *val, int noquote,
640            depth++;            depth++;
641          }          }
642          if(titem != NULL){      /* If we found it on the stack, */          if(titem != NULL){      /* If we found it on the stack, */
643            printf(" . #%d#", depth); /* print a depth reference */            if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
644                perror("print_val");
645                env->err= 5;
646                goto printval_end;
647              }
648          } else {          } else {
649            printf(" ");            if(fprintf(stream, " ") < 0){
650                perror("print_val");
651                env->err= 5;
652                goto printval_end;
653              }
654          }          }
655          break;          break;
656        default:        default:
657          printf(" . ");          /* Improper list */          if(fprintf(stream, " . ") < 0){ /* Improper list */
658          print_val(val, noquote, tstack);            perror("print_val");
659              env->err= 5;
660              goto printval_end;
661            }
662            print_val(env, val, noquote, tstack, stream);
663        }        }
664      } while(val->type == tcons && titem == NULL);      } while(val->type == tcons && titem == NULL);
665    
666      printval_end:
667    
668      titem=tstack;      titem=tstack;
669      while(titem != stack){      while(titem != stack){
670        tstack=titem->next;        tstack=titem->next;
671        free(titem);        free(titem);
672        titem=tstack;        titem=tstack;
673      }      }
674      printf(" ]");  
675        if(! (env->err)){
676          if(fprintf(stream, " ]") < 0){
677            perror("print_val");
678            env->err= 5;
679          }
680        }
681      break;      break;
682    }    }
683  }  }
684    
685    /* Print the top element of the stack but don't discard it */
686  extern void print_(environment *env)  extern void print_(environment *env)
687  {  {
688    if(env->head->type==empty) {    if(env->head->type==empty) {
# Line 596  extern void print_(environment *env) Line 690  extern void print_(environment *env)
690      env->err= 1;      env->err= 1;
691      return;      return;
692    }    }
693    print_val(CAR(env->head), 0, NULL);    print_val(env, CAR(env->head), 0, NULL, stdout);
694    nl();    if(env->err) return;
695      nl(env);
696  }  }
697    
698  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack */
699  extern void print(environment *env)  extern void print(environment *env)
700  {  {
701    print_(env);    print_(env);
# Line 608  extern void print(environment *env) Line 703  extern void print(environment *env)
703    toss(env);    toss(env);
704  }  }
705    
706    /* Print the top element of the stack without quotes, but don't
707       discard it. */
708  extern void princ_(environment *env)  extern void princ_(environment *env)
709  {  {
710    if(env->head->type==empty) {    if(env->head->type==empty) {
# Line 615  extern void princ_(environment *env) Line 712  extern void princ_(environment *env)
712      env->err= 1;      env->err= 1;
713      return;      return;
714    }    }
715    print_val(CAR(env->head), 1, NULL);    print_val(env, CAR(env->head), 1, NULL, stdout);
716  }  }
717    
718  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack without quotes. */
719  extern void princ(environment *env)  extern void princ(environment *env)
720  {  {
721    princ_(env);    princ_(env);
# Line 626  extern void princ(environment *env) Line 723  extern void princ(environment *env)
723    toss(env);    toss(env);
724  }  }
725    
726  /* Only to be called by function printstack. */  /* Print a value to a port, but don't discard it */
727  void print_st(value *stack_head, long counter)  extern void printport_(environment *env)
728    {
729      if(env->head->type==empty ||  CDR(env->head)->type == empty) {
730        printerr("Too Few Arguments");
731        env->err= 1;
732        return;
733      }
734    
735      if(CAR(env->head)->type!=port) {
736        printerr("Bad Argument Type");
737        env->err= 2;
738        return;
739      }
740    
741      print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p);
742      if(env->err) return;
743      nlport(env);
744    }
745    
746    /* Print a value to a port */
747    extern void printport(environment *env)
748    {
749      printport_(env);
750      if(env->err) return;
751      toss(env);
752    }
753    
754    /* Print, without quotes, to a port, a value, but don't discard it. */
755    extern void princport_(environment *env)
756    {
757      if(env->head->type==empty ||  CDR(env->head)->type == empty) {
758        printerr("Too Few Arguments");
759        env->err= 1;
760        return;
761      }
762    
763      if(CAR(env->head)->type!=port) {
764        printerr("Bad Argument Type");
765        env->err= 2;
766        return;
767      }
768    
769      print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p);
770      toss(env); if(env->err) return;
771    }
772    
773    /* Print, without quotes, to a port, the top element. */
774    extern void princport(environment *env)
775    {
776      princport_(env);
777      if(env->err) return;
778      toss(env);
779    }
780    
781    /* Only to be called by itself function printstack. */
782    void print_st(environment *env, value *stack_head, long counter)
783  {  {
784    if(CDR(stack_head)->type != empty)    if(CDR(stack_head)->type != empty)
785      print_st(CDR(stack_head), counter+1);      print_st(env, CDR(stack_head), counter+1);
786    printf("%ld: ", counter);    printf("%ld: ", counter);
787    print_val(CAR(stack_head), 0, NULL);    print_val(env, CAR(stack_head), 0, NULL, stdout);
788    nl();    nl(env);
789  }  }
790    
791  /* Prints the stack. */  /* Prints the stack. */
# Line 644  extern void printstack(environment *env) Line 796  extern void printstack(environment *env)
796      return;      return;
797    }    }
798    
799    print_st(env->head, 1);    print_st(env, env->head, 1);
800  }  }
801    
802  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
# Line 780  extern void eval(environment *env) Line 932  extern void eval(environment *env)
932      return;      return;
933    
934    case empty:    case empty:
935        toss(env);
936    case integer:    case integer:
937    case tfloat:    case tfloat:
938    case string:    case string:
939      case port:
940      return;      return;
941    }    }
942  }  }
# Line 1121  under certain conditions; type 'copying; Line 1275  under certain conditions; type 'copying;
1275        if (myenv.interactive) {        if (myenv.interactive) {
1276          if(myenv.err) {          if(myenv.err) {
1277            printf("(error %d)\n", myenv.err);            printf("(error %d)\n", myenv.err);
1278              myenv.err= 0;
1279          }          }
1280          nl();          nl(&myenv);
1281          printstack(&myenv);          printstack(&myenv);
1282          printf("> ");          printf("> ");
1283        }        }
1284        myenv.err=0;        myenv.err=0;
1285      }      }
1286      sx_72656164(&myenv);        /* "read" */      sx_72656164(&myenv);        /* "read" */
1287      if (myenv.err==4) {         /* EOF */      if (myenv.err) {            /* EOF or other error */
1288        myenv.err=0;        myenv.err=0;
1289        quit(&myenv);        quit(&myenv);
1290      } else if(myenv.head->type!=empty      } else if(myenv.head->type!=empty
1291                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
1292                && CAR(myenv.head)->content.sym->id[0]                && CAR(myenv.head)->content.sym->id[0] == ';') {
1293                ==';') {        toss(&myenv); if(myenv.err) continue;
       toss(&myenv);             /* No error check in main */  
1294        eval(&myenv);        eval(&myenv);
1295        } else {
1296          gc_maybe(&myenv);
1297      }      }
     gc_maybe(&myenv);  
1298    }    }
1299    quit(&myenv);    quit(&myenv);
1300    return EXIT_FAILURE;    return EXIT_FAILURE;
# Line 1376  value *copy_val(environment *env, value Line 1531  value *copy_val(environment *env, value
1531    if(old_value==NULL)    if(old_value==NULL)
1532      return NULL;      return NULL;
1533    
   protect(old_value);  
1534    new_value= new_val(env);    new_value= new_val(env);
1535    new_value->type= old_value->type;    new_value->type= old_value->type;
1536    
# Line 1386  value *copy_val(environment *env, value Line 1540  value *copy_val(environment *env, value
1540    case func:    case func:
1541    case symb:    case symb:
1542    case empty:    case empty:
1543      case port:
1544      new_value->content= old_value->content;      new_value->content= old_value->content;
1545      break;      break;
1546    case string:    case string:
# Line 1403  value *copy_val(environment *env, value Line 1558  value *copy_val(environment *env, value
1558      break;      break;
1559    }    }
1560    
   unprotect(old_value);  
   
1561    return new_value;    return new_value;
1562  }  }
1563    
# Line 1486  extern void ifelse(environment *env) Line 1639  extern void ifelse(environment *env)
1639    eval(env);    eval(env);
1640  }  }
1641    
1642    /* "else" */
1643  extern void sx_656c7365(environment *env)  extern void sx_656c7365(environment *env)
1644  {  {
1645    if(env->head->type==empty || CDR(env->head)->type==empty    if(env->head->type==empty || CDR(env->head)->type==empty
# Line 1732  extern void to(environment *env) Line 1886  extern void to(environment *env)
1886  /* Read a string */  /* Read a string */
1887  extern void readline(environment *env)  extern void readline(environment *env)
1888  {  {
1889      readlinestream(env, env->inputstream);
1890    }
1891    
1892    /* Read a string from a port */
1893    extern void readlineport(environment *env)
1894    {
1895      FILE *stream;
1896    
1897      if(env->head->type==empty) {
1898        printerr("Too Few Arguments");
1899        env->err= 1;
1900        return;
1901      }
1902    
1903      if(CAR(env->head)->type!=port) {
1904        printerr("Bad Argument Type");
1905        env->err= 2;
1906        return;
1907      }
1908    
1909      stream=CAR(env->head)->content.p;
1910      readlinestream(env, stream); if(env->err) return;
1911    
1912      swap(env); if(env->err) return;
1913      toss(env);
1914    }
1915    
1916    /* read a line from a stream; used by readline */
1917    void readlinestream(environment *env, FILE *stream)
1918    {
1919    char in_string[101];    char in_string[101];
1920    
1921    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, stream)==NULL) {
1922      push_cstring(env, "");      push_cstring(env, "");
1923    else      if (! feof(stream)){
1924          perror("readline");
1925          env->err= 5;
1926        }
1927      } else {
1928      push_cstring(env, in_string);      push_cstring(env, in_string);
1929      }
1930  }  }
1931    
1932  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1933  extern void sx_72656164(environment *env)  extern void sx_72656164(environment *env)
1934  {  {
1935      readstream(env, env->inputstream);
1936    }
1937    
1938    /* "readport"; Read a value from a port and place on stack */
1939    extern void readport(environment *env)
1940    {
1941      FILE *stream;
1942    
1943      if(env->head->type==empty) {
1944        printerr("Too Few Arguments");
1945        env->err= 1;
1946        return;
1947      }
1948    
1949      if(CAR(env->head)->type!=port) {
1950        printerr("Bad Argument Type");
1951        env->err= 2;
1952        return;
1953      }
1954    
1955      stream=CAR(env->head)->content.p;
1956      readstream(env, stream); if(env->err) return;
1957    
1958      swap(env); if(env->err) return;
1959      toss(env);
1960    }
1961    
1962    /* read from a stream; used by "read" and "readport" */
1963    void readstream(environment *env, FILE *stream)
1964    {
1965    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1966    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1967    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 2526  void assocgen(environment *env, funcp eq Line 2745  void assocgen(environment *env, funcp eq
2745    swap(env); if(env->err) return;    swap(env); if(env->err) return;
2746    toss(env);    toss(env);
2747  }  }
2748    
2749    /* "do" */
2750    extern void sx_646f(environment *env)
2751    {
2752      swap(env); if(env->err) return;
2753      eval(env);
2754    }
2755    
2756    /* "open" */
2757    /* 2: "file"                                    */
2758    /* 1: "r"       =>      1: #<port 0x47114711>   */
2759    extern void sx_6f70656e(environment *env)
2760    {
2761      value *new_port;
2762      FILE *stream;
2763    
2764      if(env->head->type == empty || CDR(env->head)->type == empty) {
2765        printerr("Too Few Arguments");
2766        env->err=1;
2767        return;
2768      }
2769    
2770      if(CAR(env->head)->type != string
2771         || CAR(CDR(env->head))->type != string) {
2772        printerr("Bad Argument Type");
2773        env->err= 2;
2774        return;
2775      }
2776    
2777      stream=fopen(CAR(CDR(env->head))->content.ptr,
2778                   CAR(env->head)->content.ptr);
2779    
2780      if(stream == NULL) {
2781        perror("open");
2782        env->err= 5;
2783        return;
2784      }
2785    
2786      new_port=new_val(env);
2787      new_port->type=port;
2788      new_port->content.p=stream;
2789    
2790      push_val(env, new_port);
2791    
2792      swap(env); if(env->err) return;
2793      toss(env); if(env->err) return;
2794      swap(env); if(env->err) return;
2795      toss(env);
2796    }
2797    
2798    
2799    /* "close" */
2800    extern void sx_636c6f7365(environment *env)
2801    {
2802      int ret;
2803    
2804      if(env->head->type == empty) {
2805        printerr("Too Few Arguments");
2806        env->err=1;
2807        return;
2808      }
2809    
2810      if(CAR(env->head)->type != port) {
2811        printerr("Bad Argument Type");
2812        env->err= 2;
2813        return;
2814      }
2815    
2816      ret= fclose(CAR(env->head)->content.p);
2817    
2818      if(ret != 0){
2819        perror("close");
2820        env->err= 5;
2821        return;
2822      }
2823    
2824      toss(env);
2825    }
Legend:
Removed from v.1.122  
changed lines
  Added in v.1.125
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26