/[gcl]/gcl/o/read.d
ViewVC logotype

Diff of /gcl/o/read.d

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

revision 1.34 by camm, Thu Oct 6 20:30:08 2005 UTC revision 1.35 by camm, Wed Oct 12 03:12:57 2005 UTC
# Line 48  object dispatch_reader; Line 48  object dispatch_reader;
48    
49  #define cat(c)  (READtable->rt.rt_self[char_code((c))] \  #define cat(c)  (READtable->rt.rt_self[char_code((c))] \
50                   .rte_chattrib)                   .rte_chattrib)
51    #define trt(c)  (READtable->rt.rt_self[char_code((c))] \
52                     .rte_chatrait)
53    
54  #ifndef SHARP_EQ_CONTEXT_SIZE  #ifndef SHARP_EQ_CONTEXT_SIZE
55  #define SHARP_EQ_CONTEXT_SIZE   500  #define SHARP_EQ_CONTEXT_SIZE   500
# Line 73  struct sharp_eq_context_struct { Line 75  struct sharp_eq_context_struct {
75  */  */
76    
77    
78    /* FIXME What should this be? Apparently no reliable way to use value stack */
79    #define MAX_PACKAGE_STACK 1024
80    static object P0[MAX_PACKAGE_STACK],*PP0=P0,LP;
81    
82  static void  static void
83  setup_READ()  setup_READ()
84  {  {
# Line 101  setup_READ() Line 107  setup_READ()
107          sharp_eq_context_max = 0;          sharp_eq_context_max = 0;
108    
109          backq_level = 0;          backq_level = 0;
110    
111            PP0=P0;
112            LP=NULL;
113    
114  }  }
115    
116  static void  static void
# Line 396  too_long_token(void); Line 406  too_long_token(void);
406          This routine corresponds to COMMON Lisp function READ.          This routine corresponds to COMMON Lisp function READ.
407  */  */
408    
 /* FIXME What should this be? Apparently no reliable way to use value stack */  
 #define MAX_PACKAGE_STACK 1024  
 static object P0[MAX_PACKAGE_STACK],*PP0=P0,LP;  
   
409  object  object
410  read_object(in)  read_object(in)
411  object in;  object in;
# Line 431  BEGIN: Line 437  BEGIN:
437            if (df) {            if (df) {
438              vs_reset;              vs_reset;
439              return(OBJNULL);              return(OBJNULL);
440            } else            } else
441              end_of_stream(in);              end_of_stream(in);
442          });          });
443                  a = cat(c);                  a = cat(c);
444          } while (a == cat_whitespace);          } while (a == cat_whitespace);
445          if (c->ch.ch_code == '(') { /* Loose package extension */  
           LP=LP || PP0==P0 ? LP : PP0[-1]; /* push loose packages into nested lists */  
           if (LP) {  
             if (PP0-P0>=MAX_PACKAGE_STACK)  
               FEerror("Too many nested package specifiers",0);  
             *PP0++=LP;  
             LP=NULL;  
           }  
         } else if (LP)  
             FEerror("Loose package prefix must be followed by a list",0);  
         if (c->ch.ch_code==')' && PP0>P0) PP0--; /* regardless of error behavior,  
                                                     will pop stack to beginning as parens  
                                                     must match before the reader starts */  
446          delimiting_char = vs_head;          delimiting_char = vs_head;
447          if (delimiting_char != OBJNULL && c == delimiting_char) {          if (delimiting_char != OBJNULL && c == delimiting_char) {
448                  delimiting_char = OBJNULL;                  delimiting_char = OBJNULL;
449                  vs_reset;                  vs_reset;
450                    LP=NULL;
451                  return(OBJNULL);                  return(OBJNULL);
452          }          }
453          delimiting_char = OBJNULL;          delimiting_char = OBJNULL;
# Line 471  BEGIN: Line 466  BEGIN:
466                  fun_box[0] = x;                  fun_box[0] = x;
467                  super_funcall(x);                  super_funcall(x);
468    
469                    LP=NULL;
470                  i = vs_top - vs_base;                  i = vs_top - vs_base;
471                  if (i == 0) {                  if (i == 0) {
472                          vs_base = old_vs_base;                          vs_base = old_vs_base;
# Line 528  BEGIN: Line 524  BEGIN:
524                      goto K;                      goto K;
525                    else                    else
526                      break;                      break;
527                  }                  } else {
528                  else if ('a' <= char_code(c) && char_code(c) <= 'z')  
529                          c = code_char(char_code(c) - ('a' - 'A'));                    if (trt(c)==trait_invalid)
530                  else if (char_code(c) == ':') {                      READER_ERROR("Cannot read character");
531                          if (colon_type == 0) {  
532                                  colon_type = 1;                    if ('A' <= char_code(c) && char_code(c) <= 'z') {
533                                  colon = length;                      if ('a' <= char_code(c) && char_code(c) <= 'z' &&
534                          } else if (colon_type == 1 && colon == length-1)                          (READtable->rt.rt_case==sKupcase || READtable->rt.rt_case==sKinvert))
535                                  colon_type = 2;                        c = code_char(char_code(c) - ('a' - 'A'));
536                          else                      else if ('A' <= char_code(c) && char_code(c) <= 'Z' &&
537                                  colon_type = -1;                               (READtable->rt.rt_case==sKdowncase || READtable->rt.rt_case==sKinvert))
538                                  /*  Colon has appeared twice.  */                        c = code_char(char_code(c) + ('a' - 'A'));
539                      } else if (char_code(c) == ':') {
540                        if (colon_type == 0) {
541                          colon_type = 1;
542                          colon = length;
543                        } else if (colon_type == 1 && colon == length-1)
544                          colon_type = 2;
545                        else
546                          colon_type = -1;
547                        /*  Colon has appeared twice.  */
548                      }
549                  }                  }
550          }          }
551          if (preserving_whitespace_flag || cat(c) != cat_whitespace)          if (preserving_whitespace_flag || cat(c) != cat_whitespace)
# Line 638  SYMBOL: Line 644  SYMBOL:
644          return(x);          return(x);
645  }  }
646    
647    static int inlp;
648    
649  static void  static void
650  Lleft_parenthesis_reader()  Lleft_parenthesis_reader()
651  {  {
# Line 648  Lleft_parenthesis_reader() Line 656  Lleft_parenthesis_reader()
656          in = vs_base[0];          in = vs_base[0];
657          vs_head = Cnil;          vs_head = Cnil;
658          p = &vs_head;          p = &vs_head;
659            inlp=1;
660            LP=LP || PP0==P0 ? LP : PP0[-1]; /* push loose packages into nested lists */
661            if (LP) {
662              if (PP0-P0>=MAX_PACKAGE_STACK)
663                FEerror("Too many nested package specifiers",0);
664              *PP0++=LP;
665              LP=NULL;
666            }
667          for (;;) {          for (;;) {
668                  delimiting_char = code_char(')');                  delimiting_char = code_char(')');
669                  in_list_flag = TRUE;                  in_list_flag = TRUE;
# Line 666  Lleft_parenthesis_reader() Line 682  Lleft_parenthesis_reader()
682                                  c = read_char(in);                                  c = read_char(in);
683                          if (char_code(c) != ')')                          if (char_code(c) != ')')
684          FEerror("A dot appeared before a right parenthesis.", 0);          FEerror("A dot appeared before a right parenthesis.", 0);
                         else if (PP0>P0) PP0--; /* should be the only other place  
                                                    outside of read_object where  
                                                    closing parens are read */  
685                          goto ENDUP;                          goto ENDUP;
686                  }                  }
687                  vs_push(x);                  vs_push(x);
# Line 678  Lleft_parenthesis_reader() Line 691  Lleft_parenthesis_reader()
691          }          }
692    
693  ENDUP:  ENDUP:
694            if (PP0>P0) PP0--;
695          vs_base[0] = vs_pop;          vs_base[0] = vs_pop;
696            inlp=0;
697          return;          return;
698  }  }
699    
# Line 1060  object in; Line 1075  object in;
1075  static void  static void
1076  Ldouble_quote_reader()  Ldouble_quote_reader()
1077  {  {
1078          check_arg(2);    object c;
1079          vs_popp;    check_arg(2);
1080          read_string('"', vs_base[0]);    c=vs_base[1];
1081          vs_base[0] = copy_simple_string(token);    vs_popp;
1082      read_string(char_code(c), vs_base[0]);
1083      vs_base[0] = copy_simple_string(token);
1084    
1085  }  }
1086    
1087  static void  static void
# Line 1123  static void Line 1141  static void
1141  Lright_parenthesis_reader()  Lright_parenthesis_reader()
1142  {  {
1143          check_arg(2);          check_arg(2);
1144            if (!inlp)
1145              READER_ERROR("Right paren found with no left.");
1146          vs_popp;          vs_popp;
1147          vs_popp;          vs_popp;
1148                  /*  no result  */                  /*  no result  */
# Line 1860  Lsharp_vertical_bar_reader() Line 1880  Lsharp_vertical_bar_reader()
1880  static void  static void
1881  Ldefault_dispatch_macro()  Ldefault_dispatch_macro()
1882  {  {
1883          FEerror("The default dispatch macro signalled an error.", 0);          READER_ERROR("The default dispatch macro signalled an error.");
1884  }  }
1885    
1886  /*  /*
# Line 1960  object from, to; Line 1980  object from, to;
1980                                  rtab[i].rte_dtab[j]                                  rtab[i].rte_dtab[j]
1981                                  = from->rt.rt_self[i].rte_dtab[j];                                  = from->rt.rt_self[i].rte_dtab[j];
1982                  }                  }
1983            to->rt.rt_case=from->rt.rt_case;
1984          vs_reset;          vs_reset;
1985          END_NO_INTERRUPT;}          END_NO_INTERRUPT;}
1986          return(to);          return(to);
# Line 2409  LFD(Lreadtablep)() Line 2430  LFD(Lreadtablep)()
2430                  fromrdtbl = standard_readtable;                  fromrdtbl = standard_readtable;
2431          else          else
2432                  check_type_readtable(&fromrdtbl);                  check_type_readtable(&fromrdtbl);
2433          tordtbl->rt.rt_self[char_code(tochr)].rte_chattrib          tordtbl->rt.rt_self[char_code(tochr)].rte_chattrib
2434          = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_chattrib;            = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_chattrib;
2435          tordtbl->rt.rt_self[char_code(tochr)].rte_macro          tordtbl->rt.rt_self[char_code(tochr)].rte_macro
2436          = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_macro;          = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_macro;
2437          if ((tordtbl->rt.rt_self[char_code(tochr)].rte_dtab          if ((tordtbl->rt.rt_self[char_code(tochr)].rte_dtab
# Line 2504  LFD(Lreadtablep)() Line 2525  LFD(Lreadtablep)()
2525          @(return Ct)          @(return Ct)
2526  @)  @)
2527    
2528    DEFUNO_NEW("READTABLE-CASE",object,fLreadtable_case,LISP,1,1,NONE,OO,OO,OO,OO,void,Lreadtable_case,(object rt),"") {
2529      check_type_readtable_no_default(&rt);
2530      RETURN1(rt->rt.rt_case);
2531    }
2532    
2533    DEFUNO_NEW("SET-READTABLE-CASE",object,fSset_readtable_case,SI,2,2,NONE,
2534               OO,OO,OO,OO,void,siLset_readtable_case,(object rt,object cas),"") {
2535      check_type_readtable_no_default(&rt);
2536      if (cas!=sKupcase && cas!=sKdowncase && cas!=sKpreserve && cas!=sKinvert)
2537        TYPE_ERROR(cas,list(5,sLmember,sKupcase,sKdowncase,sKpreserve,sKinvert));
2538      RETURN1(rt->rt.rt_case=cas);
2539    }
2540    
2541    
2542    
2543  @(static defun get_dispatch_macro_character (dspchr subchr  @(static defun get_dispatch_macro_character (dspchr subchr
2544          &optional (rdtbl `current_readtable()`))          &optional (rdtbl `current_readtable()`))
2545  @  @
# Line 2628  gcl_init_read() Line 2664  gcl_init_read()
2664          dispatch_reader = make_cf(Ldispatch_reader);          dispatch_reader = make_cf(Ldispatch_reader);
2665          enter_mark_origin(&dispatch_reader);          enter_mark_origin(&dispatch_reader);
2666    
2667    
2668            rtab['\b'].rte_chatrait = trait_invalid;
2669            rtab['\t'].rte_chatrait = trait_invalid;
2670            rtab['\n'].rte_chatrait = trait_invalid;
2671            rtab['\r'].rte_chatrait = trait_invalid;
2672            rtab['\f'].rte_chatrait = trait_invalid;
2673            rtab[' '].rte_chatrait = trait_invalid;
2674            rtab['\177'].rte_chatrait = trait_invalid;
2675    
2676    
2677          rtab['\t'].rte_chattrib = cat_whitespace;          rtab['\t'].rte_chattrib = cat_whitespace;
2678            rtab['\r'].rte_chattrib = cat_whitespace;
2679          rtab['\n'].rte_chattrib = cat_whitespace;          rtab['\n'].rte_chattrib = cat_whitespace;
2680          rtab['\f'].rte_chattrib = cat_whitespace;          rtab['\f'].rte_chattrib = cat_whitespace;
         rtab['\r'].rte_chattrib = cat_whitespace;  
2681          rtab[' '].rte_chattrib = cat_whitespace;          rtab[' '].rte_chattrib = cat_whitespace;
2682          rtab['"'].rte_chattrib = cat_terminating;          rtab['"'].rte_chattrib = cat_terminating;
2683          rtab['"'].rte_macro = make_cf(Ldouble_quote_reader);          rtab['"'].rte_macro = make_cf(Ldouble_quote_reader);
# Line 2709  gcl_init_read() Line 2755  gcl_init_read()
2755    
2756          gcl_init_backq();          gcl_init_backq();
2757    
2758            sKupcase = make_keyword("UPCASE");
2759            sKdowncase = make_keyword("DOWNCASE");
2760            sKpreserve = make_keyword("PRESERVE");
2761            sKinvert = make_keyword("INVERT");
2762    
2763            standard_readtable->rt.rt_case=sKupcase;
2764    
2765          Vreadtable          Vreadtable
2766          = make_special("*READTABLE*",          = make_special("*READTABLE*",
2767                         copy_readtable(standard_readtable, Cnil));                         copy_readtable(standard_readtable, Cnil));

Legend:
Removed from v.1.34  
changed lines
  Added in v.1.35

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26