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

Diff of /stack/stack.c

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

revision 1.123 by masse, Wed Mar 27 19:53:01 2002 UTC revision 1.124 by teddy, Sat Mar 30 02:31:24 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        }        }
# Line 1134  under certain conditions; type 'copying; Line 1289  under certain conditions; type 'copying;
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);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1294        eval(&myenv);        eval(&myenv);
1295      }      }
# Line 1376  value *copy_val(environment *env, value Line 1530  value *copy_val(environment *env, value
1530    if(old_value==NULL)    if(old_value==NULL)
1531      return NULL;      return NULL;
1532    
   protect(old_value);  
1533    new_value= new_val(env);    new_value= new_val(env);
1534    new_value->type= old_value->type;    new_value->type= old_value->type;
1535    
# Line 1386  value *copy_val(environment *env, value Line 1539  value *copy_val(environment *env, value
1539    case func:    case func:
1540    case symb:    case symb:
1541    case empty:    case empty:
1542      case port:
1543      new_value->content= old_value->content;      new_value->content= old_value->content;
1544      break;      break;
1545    case string:    case string:
# Line 1403  value *copy_val(environment *env, value Line 1557  value *copy_val(environment *env, value
1557      break;      break;
1558    }    }
1559    
   unprotect(old_value);  
   
1560    return new_value;    return new_value;
1561  }  }
1562    
# Line 1486  extern void ifelse(environment *env) Line 1638  extern void ifelse(environment *env)
1638    eval(env);    eval(env);
1639  }  }
1640    
1641    /* "else" */
1642  extern void sx_656c7365(environment *env)  extern void sx_656c7365(environment *env)
1643  {  {
1644    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 1885  extern void to(environment *env)
1885  /* Read a string */  /* Read a string */
1886  extern void readline(environment *env)  extern void readline(environment *env)
1887  {  {
1888      readlinestream(env, env->inputstream);
1889    }
1890    
1891    /* Read a string from a port */
1892    extern void readlineport(environment *env)
1893    {
1894      FILE *stream;
1895    
1896      if(env->head->type==empty) {
1897        printerr("Too Few Arguments");
1898        env->err= 1;
1899        return;
1900      }
1901    
1902      if(CAR(env->head)->type!=port) {
1903        printerr("Bad Argument Type");
1904        env->err= 2;
1905        return;
1906      }
1907    
1908      stream=CAR(env->head)->content.p;
1909      readlinestream(env, stream); if(env->err) return;
1910    
1911      swap(env); if(env->err) return;
1912      toss(env);
1913    }
1914    
1915    /* read a line from a stream; used by readline */
1916    void readlinestream(environment *env, FILE *stream)
1917    {
1918    char in_string[101];    char in_string[101];
1919    
1920    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, stream)==NULL) {
1921      push_cstring(env, "");      push_cstring(env, "");
1922    else      if (! feof(stream)){
1923          perror("readline");
1924          env->err= 5;
1925        }
1926      } else {
1927      push_cstring(env, in_string);      push_cstring(env, in_string);
1928      }
1929  }  }
1930    
1931  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1932  extern void sx_72656164(environment *env)  extern void sx_72656164(environment *env)
1933  {  {
1934      readstream(env, env->inputstream);
1935    }
1936    
1937    /* "readport"; Read a value from a port and place on stack */
1938    extern void readport(environment *env)
1939    {
1940      FILE *stream;
1941    
1942      if(env->head->type==empty) {
1943        printerr("Too Few Arguments");
1944        env->err= 1;
1945        return;
1946      }
1947    
1948      if(CAR(env->head)->type!=port) {
1949        printerr("Bad Argument Type");
1950        env->err= 2;
1951        return;
1952      }
1953    
1954      stream=CAR(env->head)->content.p;
1955      readstream(env, stream); if(env->err) return;
1956    
1957      swap(env); if(env->err) return;
1958      toss(env);
1959    }
1960    
1961    /* read from a stream; used by "read" and "readport" */
1962    void readstream(environment *env, FILE *stream)
1963    {
1964    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1965    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1966    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 2527  void assocgen(environment *env, funcp eq Line 2745  void assocgen(environment *env, funcp eq
2745    toss(env);    toss(env);
2746  }  }
2747    
2748    /* "do" */
2749  extern void sx_646f(environment *env)  extern void sx_646f(environment *env)
2750  {  {
2751    swap(env); if(env->err) return;    swap(env); if(env->err) return;
2752    eval(env);    eval(env);
2753  }  }
2754    
2755    /* "open" */
2756    /* 2: "file"                                    */
2757    /* 1: "r"       =>      1: #<port 0x47114711>   */
2758    extern void sx_6f70656e(environment *env)
2759    {
2760      value *new_port;
2761      FILE *stream;
2762    
2763      if(env->head->type == empty || CDR(env->head)->type == empty) {
2764        printerr("Too Few Arguments");
2765        env->err=1;
2766        return;
2767      }
2768    
2769      if(CAR(env->head)->type != string
2770         || CAR(CDR(env->head))->type != string) {
2771        printerr("Bad Argument Type");
2772        env->err= 2;
2773        return;
2774      }
2775    
2776      stream=fopen(CAR(CDR(env->head))->content.ptr,
2777                   CAR(env->head)->content.ptr);
2778    
2779      if(stream == NULL) {
2780        perror("open");
2781        env->err= 5;
2782        return;
2783      }
2784    
2785      new_port=new_val(env);
2786      new_port->type=port;
2787      new_port->content.p=stream;
2788    
2789      push_val(env, new_port);
2790    
2791      swap(env); if(env->err) return;
2792      toss(env); if(env->err) return;
2793      swap(env); if(env->err) return;
2794      toss(env);
2795    }
2796    
2797    
2798    /* "close" */
2799    extern void sx_636c6f7365(environment *env)
2800    {
2801      int ret;
2802    
2803      if(env->head->type == empty) {
2804        printerr("Too Few Arguments");
2805        env->err=1;
2806        return;
2807      }
2808    
2809      if(CAR(env->head)->type != port) {
2810        printerr("Bad Argument Type");
2811        env->err= 2;
2812        return;
2813      }
2814    
2815      ret= fclose(CAR(env->head)->content.p);
2816    
2817      if(ret != 0){
2818        perror("close");
2819        env->err= 5;
2820        return;
2821      }
2822    
2823      toss(env);
2824    }
Legend:
Removed from v.1.123  
changed lines
  Added in v.1.124
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26