home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / c / read.d < prev    next >
Encoding:
Text File  |  1987-06-04  |  55.0 KB  |  2,618 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     read.d
  9. */
  10.  
  11. #include "include.h"
  12.  
  13. #define    token_buffer    token->st.st_self
  14.  
  15. object standard_readtable;
  16. object dispatch_reader;
  17.  
  18. object Vreadtable;
  19. object Vread_default_float_format;
  20. object Vread_base;
  21. object Vread_suppress;
  22.  
  23. object Kstart;
  24. object Kend;
  25. object Kradix;
  26. object Kjunk_allowed;
  27.  
  28. object READtable;
  29. int READdefault_float_format;
  30. int READbase;
  31. bool READsuppress;
  32.  
  33. object siSsharp_comma;
  34.  
  35. bool preserving_whitespace_flag;
  36. bool escape_flag;
  37. object delimiting_char;
  38. bool detect_eos_flag;
  39. bool in_list_flag;
  40. bool dot_flag;
  41. object default_dispatch_macro;
  42.  
  43. object big_register_0;
  44.  
  45. #define    cat(c)    (READtable->rt.rt_self[char_code((c))] \
  46.          .rte_chattrib)
  47.  
  48. #define    SHARP_EQ_CONTEXT_SIZE    64
  49.  
  50. setup_READtable()
  51. {
  52.     READtable = current_readtable();
  53. }
  54.  
  55. struct sharp_eq_context_struct {
  56.     object    sharp_index;
  57.     object    sharp_eq;
  58.     object    sharp_sharp;
  59. } sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
  60.  
  61. /*
  62.     NOTE:
  63.  
  64.         I believe that there is no need to enter
  65.         sharp_eq_context to mark_origin.
  66. */
  67.  
  68. int sharp_eq_context_max;
  69.  
  70. setup_READ()
  71. {
  72.     object x;
  73.  
  74.     READtable = current_readtable();
  75.     x = symbol_value(Vread_default_float_format);
  76.     if (x == Sshort_float)
  77.         READdefault_float_format = 'S';
  78.     else if (x == Ssingle_float || x == Sdouble_float || x == Slong_float)
  79.         READdefault_float_format = 'F';
  80.     else {
  81.         vs_push(x);
  82.         Vread_default_float_format->s.s_dbind = Ssingle_float;
  83.     FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.",
  84.             1, x);
  85.     }
  86.     x = symbol_value(Vread_base);
  87.     if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) {
  88.         vs_push(x);
  89.         Vread_base->s.s_dbind = make_fixnum(10);
  90.         FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x);
  91.     }
  92.     READbase = fix(x);
  93.     READsuppress = symbol_value(Vread_suppress) != Cnil;
  94.     sharp_eq_context_max = 0;
  95.  
  96.     backq_level = 0;
  97. }
  98.  
  99. setup_standard_READ()
  100. {
  101.     READtable = standard_readtable;
  102.     READdefault_float_format = 'F';
  103.     READbase = 10;
  104.     READsuppress = FALSE;
  105.     sharp_eq_context_max = 0;
  106.     backq_level = 0;
  107. }
  108.  
  109. object
  110. read_char(in)
  111. object in;
  112. {
  113.     return(code_char(readc_stream(in)));
  114. }
  115.  
  116. #define    read_char(in)    code_char(readc_stream(in))
  117.  
  118. unread_char(c, in)
  119. object c, in;
  120. {
  121.     if (type_of(c) != t_character)
  122.         FEwrong_type_argument(Scharacter, c);
  123.     unreadc_stream(char_code(c), in);
  124. }
  125.  
  126. /*
  127.     Peek_char corresponds to COMMON Lisp function PEEK-CHAR.
  128.     When pt is TRUE, preceeding whitespaces are ignored.
  129. */
  130. object
  131. peek_char(pt, in)
  132. bool pt;
  133. object in;
  134. {
  135.     object c;
  136.  
  137.     if (pt) {
  138.         do
  139.             c = read_char(in);
  140.         while (cat(c) == cat_whitespace);
  141.         unread_char(c, in);
  142.         return(c);
  143.     } else {
  144.         c = read_char(in);
  145.         unread_char(c, in);
  146.         return(c);
  147.     }
  148. }
  149.         
  150.  
  151. object
  152. read_object_recursive(in)
  153. {
  154.     object x;
  155.     bool e;
  156.  
  157.     object old_READtable = READtable;
  158.     int old_READdefault_float_format = READdefault_float_format;
  159.     int old_READbase = READbase;
  160.     bool old_READsuppress = READsuppress;
  161.  
  162.     /* BUG FIX by Toshiba */
  163.     vs_push(old_READtable);
  164.  
  165.     frs_push(FRS_PROTECT, Cnil);
  166.     if (nlj_active) {
  167.         e = TRUE;
  168.         goto L;
  169.     }
  170.  
  171.     READtable = current_readtable();
  172.     x = symbol_value(Vread_default_float_format);
  173.     if (x == Sshort_float)
  174.         READdefault_float_format = 'S';
  175.     else if (x == Ssingle_float || x == Sdouble_float || x == Slong_float)
  176.         READdefault_float_format = 'F';
  177.     else {
  178.         vs_push(x);
  179.         Vread_default_float_format->s.s_dbind = Ssingle_float;
  180.     FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.",
  181.             1, x);
  182.     }
  183.     x = symbol_value(Vread_base);
  184.     if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) {
  185.         vs_push(x);
  186.         Vread_base->s.s_dbind = make_fixnum(10);
  187.         FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x);
  188.     }
  189.     READbase = fix(x);
  190.     READsuppress = symbol_value(Vread_suppress) != Cnil;
  191.  
  192.     x = read_object(in);
  193.     e = FALSE;
  194.  
  195. L:
  196.     frs_pop();
  197.  
  198.     READtable = old_READtable;
  199.     READdefault_float_format = old_READdefault_float_format;
  200.     READbase = old_READbase;
  201.     READsuppress = old_READsuppress;
  202.  
  203.     /* BUG FIX by Toshiba */
  204.     vs_pop;
  205.  
  206.     if (e) {
  207.         nlj_active = FALSE;
  208.         unwind(nlj_fr, nlj_tag);
  209.     }
  210.  
  211.     return(x);
  212. }
  213.  
  214.  
  215. object
  216. read_object_non_recursive(in)
  217. object in;
  218. {
  219.     object x;
  220.     int i;
  221.     bool e;
  222.     object old_READtable;
  223.     int old_READdefault_float_format;
  224.     int old_READbase;
  225.     int old_READsuppress;
  226.     int old_sharp_eq_context_max;
  227.     struct sharp_eq_context_struct
  228.         old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
  229.     int old_backq_level;
  230.  
  231.     old_READtable = READtable;
  232.     old_READdefault_float_format = READdefault_float_format;
  233.     old_READbase = READbase;
  234.     old_READsuppress = READsuppress;
  235.     old_sharp_eq_context_max = sharp_eq_context_max;
  236.     /* BUG FIX by Toshiba */
  237.     vs_push(old_READtable);
  238.     for (i = 0;  i < sharp_eq_context_max;  i++)
  239.         old_sharp_eq_context[i] = sharp_eq_context[i];
  240.     old_backq_level = backq_level;
  241.     setup_READ();
  242.  
  243.     frs_push(FRS_PROTECT, Cnil);
  244.     if (nlj_active) {
  245.         e = TRUE;
  246.         goto L;
  247.     }
  248.  
  249.     x = read_object(in);
  250.     vs_push(x);
  251.  
  252.     if (sharp_eq_context_max > 0)
  253.         x = vs_head = patch_sharp(x);
  254.  
  255.     e = FALSE;
  256.  
  257. L:
  258.     frs_pop();
  259.  
  260.     READtable = old_READtable;
  261.     READdefault_float_format = old_READdefault_float_format;
  262.     READbase = old_READbase;
  263.     READsuppress = old_READsuppress;
  264.     sharp_eq_context_max = old_sharp_eq_context_max;
  265.     for (i = 0;  i < sharp_eq_context_max;  i++)
  266.         sharp_eq_context[i] = old_sharp_eq_context[i];
  267.     backq_level = old_backq_level;
  268.     if (e) {
  269.         nlj_active = FALSE;
  270.         unwind(nlj_fr, nlj_tag);
  271.     }
  272.     vs_pop;
  273.     /* BUG FIX by Toshiba */
  274.     vs_pop;
  275.     return(x);
  276. }
  277.  
  278. object
  279. standard_read_object_non_recursive(in)
  280. object in;
  281. {
  282.     object x;
  283.     int i;
  284.     bool e;
  285.     object old_READtable;
  286.     int old_READdefault_float_format;
  287.     int old_READbase;
  288.     int old_READsuppress;
  289.     int old_sharp_eq_context_max;
  290.     struct sharp_eq_context_struct
  291.         old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
  292.     int old_backq_level;
  293.  
  294.     old_READtable = READtable;
  295.     old_READdefault_float_format = READdefault_float_format;
  296.     old_READbase = READbase;
  297.     old_READsuppress = READsuppress;
  298.     old_sharp_eq_context_max = sharp_eq_context_max;
  299.     /* BUG FIX by Toshiba */
  300.     vs_push(old_READtable);
  301.     for (i = 0;  i < sharp_eq_context_max;  i++)
  302.         old_sharp_eq_context[i] = sharp_eq_context[i];
  303.     old_backq_level = backq_level;
  304.  
  305.     setup_standard_READ();
  306.  
  307.     frs_push(FRS_PROTECT, Cnil);
  308.     if (nlj_active) {
  309.         e = TRUE;
  310.         goto L;
  311.     }
  312.  
  313.     x = read_object(in);
  314.     vs_push(x);
  315.  
  316.     if (sharp_eq_context_max > 0)
  317.         x = vs_head = patch_sharp(x);
  318.  
  319.     e = FALSE;
  320.  
  321. L:
  322.     frs_pop();
  323.  
  324.     READtable = old_READtable;
  325.     READdefault_float_format = old_READdefault_float_format;
  326.     READbase = old_READbase;
  327.     READsuppress = old_READsuppress;
  328.     sharp_eq_context_max = old_sharp_eq_context_max;
  329.     for (i = 0;  i < sharp_eq_context_max;  i++)
  330.         sharp_eq_context[i] = old_sharp_eq_context[i];
  331.     backq_level = old_backq_level;
  332.     if (e) {
  333.         nlj_active = FALSE;
  334.         unwind(nlj_fr, nlj_tag);
  335.     }
  336.     vs_pop;
  337.     /* BUG FIX by Toshiba */
  338.     vs_pop;
  339.     return(x);
  340. }
  341.  
  342. /*
  343.     Read_object(in) reads an object from stream in.
  344.     This routine corresponds to COMMON Lisp function READ.
  345. */
  346. object
  347. read_object(in)
  348. object in;
  349. {
  350.     object x;
  351.     object c;
  352.     enum chattrib a;
  353.     object *old_vs_base;
  354.     object result;
  355.     object p;
  356.     int length, colon, colon_type;
  357.     int i, d;
  358.     bool df, ilf;
  359.     vs_mark;
  360.  
  361.     cs_check(in);
  362.  
  363.     vs_check_push(delimiting_char);
  364.     delimiting_char = OBJNULL;
  365.     df = detect_eos_flag;
  366.     detect_eos_flag = FALSE;
  367.     ilf = in_list_flag;
  368.     in_list_flag = FALSE;
  369.     dot_flag = FALSE;
  370.  
  371. BEGIN:
  372.     do {
  373.         if (stream_at_end(in)) {
  374.             if (df) {
  375.                 vs_reset;
  376.                 return(OBJNULL);
  377.             } else
  378.                 end_of_stream(in);
  379.         }
  380.         c = read_char(in);
  381.         a = cat(c);
  382.     } while (a == cat_whitespace);
  383.     delimiting_char = vs_head;
  384.     if (delimiting_char != OBJNULL && c == delimiting_char) {
  385.         delimiting_char = OBJNULL;
  386.         vs_reset;
  387.         return(OBJNULL);
  388.     }
  389.     delimiting_char = OBJNULL;
  390.     if (a == cat_terminating || a == cat_non_terminating)
  391.     {
  392.         object *fun_box = vs_top;
  393.  
  394.         old_vs_base = vs_base;
  395.         vs_push(Cnil);
  396.         vs_base = vs_top;
  397.         vs_push(in);
  398.         vs_push(c);
  399.  
  400.         x =
  401.         READtable->rt.rt_self[char_code(c)].rte_macro;
  402.         fun_box[0] = x;
  403.         super_funcall(x);
  404.  
  405.         i = vs_top - vs_base;
  406.         if (i == 0) {
  407.             vs_base = old_vs_base;
  408.             vs_top = old_vs_top + 1;
  409.             goto BEGIN;
  410.         }
  411.         if (i > 1) {
  412.             vs_push(make_fixnum(i));
  413.             FEerror("The readmacro ~S returned ~D values.",
  414.                  2, fun_box[0], vs_top[-1]);
  415.         }
  416.         result = vs_base[0];
  417.         vs_base = old_vs_base;
  418.         vs_reset;
  419.         return(result);
  420.     }
  421.     escape_flag = FALSE;
  422.     length = 0;
  423.     colon_type = 0;
  424.     goto L;
  425.     for (;;) {
  426.         if (length >= token->st.st_dim)
  427.             too_long_token();
  428.         token_buffer[length++] = char_code(c);
  429.     K:
  430.         if (stream_at_end(in))
  431.             goto M;
  432.         c = read_char(in);
  433.         a = cat(c);
  434.     L:
  435.         if (a == cat_single_escape) {
  436.             c = read_char(in);
  437.             a = cat_constituent;
  438.             escape_flag = TRUE;
  439.         } else if (a == cat_multiple_escape) {
  440.             escape_flag = TRUE;
  441.             for (;;) {
  442.                 if (stream_at_end(in))
  443.                     end_of_stream(in);
  444.                 c = read_char(in);
  445.                 a = cat(c);
  446.                 if (a == cat_single_escape) {
  447.                     c = read_char(in);
  448.                     a = cat_constituent;
  449.                 } else if (a == cat_multiple_escape)
  450.                     break;
  451.                 if (length >= token->st.st_dim)
  452.                     too_long_token();
  453.                 token_buffer[length++] = char_code(c);
  454.             }
  455.             goto K;
  456.         } else if ('a' <= char_code(c) && char_code(c) <= 'z')
  457.             c = code_char(char_code(c) - ('a' - 'A'));
  458.         else if (char_code(c) == ':') {
  459.             if (colon_type == 0) {
  460.                 colon_type = 1;
  461.                 colon = length;
  462.             } else if (colon_type == 1 && colon == length-1)
  463.                 colon_type = 2;
  464.             else
  465.                 colon_type = -1;
  466.                 /*  Colon has appeared twice.  */
  467.         }
  468.         if (a == cat_whitespace || a == cat_terminating)
  469.             break;
  470.     }
  471.     if (preserving_whitespace_flag || cat(c) != cat_whitespace)
  472.         unread_char(c, in);
  473.  
  474. M:
  475.     if (READsuppress) {
  476.         token->st.st_fillp = length;
  477.         vs_reset;
  478.         return(Cnil);
  479.     }
  480.     if (ilf && !escape_flag &&
  481.         length == 1 && token->st.st_self[0] == '.') {
  482.         dot_flag = TRUE;
  483.         vs_reset;
  484.         return(Cnil);
  485.     } else if (!escape_flag && length > 0) {
  486.         for (i = 0;  i < length;  i++)
  487.             if (token->st.st_self[i] != '.')
  488.                 goto N;
  489.         FEerror("Dots appeared illegally.", 0);
  490.     }
  491.  
  492. N:
  493.     token->st.st_fillp = length;
  494.     if (escape_flag)
  495.         goto SYMBOL;
  496.     x = parse_number(token_buffer, length, &i, READbase);
  497.     if (x != OBJNULL && length == i) {
  498.         vs_reset;
  499.         return(x);
  500.     }
  501.  
  502. SYMBOL:
  503.     if (colon_type == 1 /* && length > colon + 1 */) {
  504.         if (colon == 0)
  505.             p = keyword_package;
  506.         else {
  507.             token->st.st_fillp = colon;
  508.             p = find_package(token);
  509.             if (p == Cnil) {
  510.                 vs_push(copy_simple_string(token));
  511.                 FEerror("There is no package with the name ~A.",
  512.                     1, vs_head);
  513.             }
  514.         }
  515.         for (i = colon + 1;  i < length;  i++)
  516.             token_buffer[i - (colon + 1)]
  517.             = token_buffer[i];
  518.         token->st.st_fillp = length - (colon + 1);
  519.         if (colon > 0) {
  520.             x = find_symbol(token, p);
  521.             if (intern_flag != EXTERNAL) {
  522.                 vs_push(copy_simple_string(token));
  523.             FEerror("Cannot find the external symbol ~A in ~S.",
  524.                         2, vs_head, p);
  525.                 /*  no need to push a package  */
  526.             }
  527.             vs_reset;
  528.             return(x);
  529.         }
  530.     } else if (colon_type == 2 /* && colon > 0 && length > colon + 2 */) {
  531.         token->st.st_fillp = colon;
  532.         p = find_package(token);
  533.         if (p == Cnil) {
  534.             vs_push(copy_simple_string(token));
  535.             FEerror("There is no package with the name ~A.",
  536.                 1, vs_head);
  537.         }
  538.         for (i = colon + 2;  i < length;  i++)
  539.             token_buffer[i - (colon + 2)]
  540.             = token_buffer[i];
  541.         token->st.st_fillp = length - (colon + 2);
  542.     } else
  543.         p = current_package();
  544.     vs_push(p);
  545.     x = intern(token, p);
  546.     vs_push(x);
  547.     if (x->s.s_self == token_buffer) {
  548.         x->s.s_self = alloc_relblock(token->st.st_fillp);
  549.         for (i = 0;  i < token->st.st_fillp;  i++)
  550.             x->s.s_self[i] = token_buffer[i];
  551.     }
  552.     vs_reset;
  553.     return(x);
  554. }
  555.  
  556. Lleft_parenthesis_reader()
  557. {
  558.     object in, c, x;
  559.     object *p;
  560.  
  561.     check_arg(2);
  562.     in = vs_base[0];
  563.     vs_head = Cnil;
  564.     p = &vs_head;
  565.     for (;;) {
  566.         delimiting_char = code_char(')');
  567.         in_list_flag = TRUE;
  568.         x = read_object(in);
  569.         if (x == OBJNULL)
  570.             goto ENDUP;
  571.         if (dot_flag) {
  572.             if (p == &vs_head)
  573.     FEerror("A dot appeared after a left parenthesis.", 0);
  574.             in_list_flag = TRUE;
  575.             *p = read_object(in);
  576.             if (dot_flag)
  577.     FEerror("Two dots appeared consecutively.", 0);
  578.             c = read_char(in);
  579.             while (cat(c) == cat_whitespace)
  580.                 c = read_char(in);
  581.             if (char_code(c) != ')')
  582.     FEerror("A dot appeared before a right parenthesis.", 0);
  583.             goto ENDUP;
  584.         }
  585.         vs_push(x);
  586.         *p = make_cons(x, Cnil);
  587.         vs_pop;
  588.         p = &((*p)->c.c_cdr);
  589.     }
  590.  
  591. ENDUP:
  592.     vs_base[0] = vs_pop;
  593.     return;
  594. }
  595.  
  596. #define    is_exponent_marker(i)    \
  597.     ((i) == 'e' || (i) == 'E' ||    \
  598.      (i) == 's' || (i) == 'S' || (i) == 'f' || (i) == 'F' || \
  599.      (i) == 'd' || (i) == 'D' || (i) == 'l' || (i) == 'L' || \
  600.      (i) == 'b' || (i) == 'B')
  601.  
  602. /*
  603.     Parse_number(s, end, ep, radix) parses C string s
  604.     up to (but not including) s[end]
  605.     using radix as the radix for the rational number.
  606.     (For floating numbers, radix should be 10.)
  607.     When parsing has been succeeded,
  608.     the index of the next character is assigned to *ep,
  609.     and the number is returned as a lisp data object.
  610.     If not, OBJNULL is returned.
  611. */
  612. object
  613. parse_number(s, end, ep, radix)
  614. char *s;
  615. int end, *ep, radix;
  616. {
  617.     object x, r;
  618.     fixnum sign;
  619.     struct bignum *integer_part;
  620.     double fraction, fraction_unit, f;
  621.     char exponent_marker;
  622.     int exponent;
  623.     int i, j, k;
  624.     int d;
  625.     vs_mark;
  626.  
  627.     if (s[end-1] == '.')
  628.         radix = 10;
  629.         /*
  630.             DIRTY CODE!!
  631.         */
  632. BEGIN:
  633.     exponent_marker = 'E';
  634.     i = 0;
  635.     sign = 1;
  636.     if (s[i] == '+')
  637.         i++;
  638.     else if (s[i] == '-') {
  639.         sign = -1;
  640.         i++;
  641.     }
  642.     integer_part = (struct bignum *)big_register_0;
  643.     integer_part->big_car = 0;
  644.     integer_part->big_cdr = NULL;
  645.     vs_push((object)integer_part);
  646.     if (i >= end)
  647.         goto NO_NUMBER;
  648.     if (s[i] == '.') {
  649.         if (radix != 10) {
  650.             radix = 10;
  651.             goto BEGIN;
  652.         }
  653.         i++;
  654.         goto FRACTION;
  655.     }
  656.     if ((d = digitp(s[i], radix)) < 0)
  657.         goto NO_NUMBER;
  658.     do {
  659.         mul_int_big(radix, integer_part);
  660.         add_int_big(d, integer_part);
  661.         i++;
  662.     } while (i < end && (d = digitp(s[i], radix)) >= 0);
  663.     if (i >= end)
  664.         goto MAKE_INTEGER;
  665.     if (s[i] == '.') {
  666.         if (radix != 10) {
  667.             radix = 10;
  668.             goto BEGIN;
  669.         }
  670.         if (++i >= end)
  671.             goto MAKE_INTEGER;
  672.         else if (digitp(s[i], radix) >= 0)
  673.             goto FRACTION;
  674.         else if (is_exponent_marker(s[i])) {
  675.             fraction
  676.             = (double)sign * big_to_double(integer_part);
  677.             goto EXPONENT;
  678.         } else
  679.             goto MAKE_INTEGER;
  680.     }
  681.     if (s[i] == '/') {
  682.         i++;
  683.         goto DENOMINATOR;
  684.     }
  685.     if (is_exponent_marker(s[i])) {
  686.         fraction = (double)sign * big_to_double(integer_part);
  687.         goto EXPONENT;
  688.     }
  689. /*
  690.     goto NO_NUMBER;
  691. */
  692.  
  693. MAKE_INTEGER:
  694.     if (sign < 0)
  695.         complement_big(integer_part);
  696.     x = normalize_big_to_object(integer_part);
  697. /**/
  698.     if (x == big_register_0)
  699.         big_register_0 = alloc_object(t_bignum);
  700.     big_register_0->big.big_car = 0;
  701.     big_register_0->big.big_cdr = NULL;
  702. /**/
  703.     goto END;
  704.  
  705. FRACTION:
  706. /*
  707.     if (radix != 10)
  708.         goto NO_NUMBER;
  709. */
  710.     radix = 10;
  711.     if ((d = digitp(s[i], radix)) < 0)
  712.         goto NO_NUMBER;
  713.     fraction = 0.0;
  714.     fraction_unit = 0.000000001;
  715.     for (;;) {
  716.         k = j = 0;
  717.         do {
  718.             j = 10*j + d;
  719.             i++;
  720.             k++;
  721.             if (i < end)
  722.                 d = digitp(s[i], radix);
  723.             else
  724.                 break;
  725.         } while (k < 9 && d >= 0);
  726.         while (k++ < 9)
  727.             j *= 10;
  728.         fraction += fraction_unit * (double)j;
  729.         if (i >= end || d < 0)
  730.             break;
  731.         fraction_unit *= 0.000000001;
  732.     }
  733.     fraction += big_to_double(integer_part);
  734.     fraction *= (double)sign;
  735.     if (i >= end)
  736.         goto MAKE_FLOAT;
  737.     if (is_exponent_marker(s[i]))
  738.         goto EXPONENT;
  739.     goto MAKE_FLOAT;
  740.  
  741. EXPONENT:
  742. /*
  743.     if (radix != 10)
  744.         goto NO_NUMBER;
  745. */
  746.     radix = 10;
  747.     exponent_marker = s[i];
  748.     i++;
  749.     if (i >= end)
  750.         goto NO_NUMBER;
  751.     sign = 1;
  752.     if (s[i] == '+')
  753.         i++;
  754.     else if (s[i] == '-') {
  755.         sign = -1;
  756.         i++;
  757.     }
  758.     if (i >= end)
  759.         goto NO_NUMBER;
  760.     if ((d = digitp(s[i], radix)) < 0)
  761.         goto NO_NUMBER;
  762.     exponent = 0;
  763.     do {
  764.         exponent = 10 * exponent + d;
  765.         i++;
  766.     } while (i < end && (d = digitp(s[i], radix)) >= 0);
  767.     d = exponent;
  768.     f = 10.0;
  769.     fraction_unit = 1.0;
  770.     while (d > 0)
  771.         if (d%2 == 0) {
  772.             d /= 2;
  773.             f *= f;
  774.         } else {
  775.             --d;
  776.             fraction_unit *= f;
  777.         }
  778.     if (sign > 0)
  779.         fraction *= fraction_unit;
  780.     else
  781.         fraction /= fraction_unit;
  782.  
  783. MAKE_FLOAT:
  784. #ifdef IEEEFLOAT
  785.     if ((*(int *)&fraction & 0x7ff00000) == 0x7ff00000)
  786.         FEerror("Floating-point overflow.", 0);
  787. #endif
  788.     switch (exponent_marker) {
  789.  
  790.     case 'e':  case 'E':
  791.         exponent_marker = READdefault_float_format;
  792.         goto MAKE_FLOAT;
  793.  
  794.     case 's':  case 'S':
  795.         x = make_shortfloat((shortfloat)fraction);
  796.         break;
  797.  
  798.     case 'f':  case 'F':  case 'd':  case 'D':  case 'l':  case 'L':
  799.         x = make_longfloat((longfloat)fraction);
  800.         break;
  801.  
  802.     case 'b':  case 'B':
  803.         goto NO_NUMBER;
  804.     }
  805. /**/
  806.     big_register_0->big.big_car = 0;
  807.     big_register_0->big.big_cdr = NULL;
  808. /**/
  809.     goto END;
  810.  
  811. DENOMINATOR:
  812.     if (sign < 0)
  813.         complement_big(integer_part);
  814.     vs_push(normalize_big_to_object(integer_part));
  815. /**/
  816.     if (vs_head == big_register_0)
  817.         big_register_0 = alloc_object(t_bignum);
  818.     big_register_0->big.big_car = 0;
  819.     big_register_0->big.big_cdr = NULL;
  820. /**/
  821.     if ((d = digitp(s[i], radix)) < 0)
  822.         goto NO_NUMBER;
  823.     integer_part = (struct bignum *)alloc_object(t_bignum);
  824.     integer_part->big_car = 0;
  825.     integer_part->big_cdr = NULL;
  826.     do {
  827.         mul_int_big(radix, integer_part);
  828.         add_int_big(d, integer_part);
  829.         i++;
  830.     } while (i < end && (d = digitp(s[i], radix)) >= 0);
  831.     vs_push(normalize_big_to_object(integer_part));
  832.     x = make_ratio(vs_top[-2], vs_top[-1]);
  833.     goto END;
  834.  
  835. END:
  836.     *ep = i;
  837.     vs_reset;
  838.     return(x);
  839.  
  840. NO_NUMBER:
  841.     *ep = i;
  842.     vs_reset;
  843. /**/
  844.     big_register_0->big.big_car = 0;
  845.     big_register_0->big.big_cdr = NULL;
  846. /**/
  847.     return(OBJNULL);
  848. }
  849.  
  850. object
  851. parse_integer(s, end, ep, radix)
  852. char *s;
  853. int end, *ep, radix;
  854. {
  855.     object x, r;
  856.     fixnum sign;
  857.     struct bignum *integer_part;
  858.     int i, d;
  859.     vs_mark;
  860.  
  861.     i = 0;
  862.     sign = 1;
  863.     if (s[i] == '+')
  864.         i++;
  865.     else if (s[i] == '-') {
  866.         sign = -1;
  867.         i++;
  868.     }
  869.     integer_part = (struct bignum *)big_register_0;
  870.     vs_push((object)integer_part);
  871.     if (i >= end)
  872.         goto NO_NUMBER;
  873.     if ((d = digitp(s[i], radix)) < 0)
  874.         goto NO_NUMBER;
  875.     do {
  876.         mul_int_big(radix, integer_part);
  877.         add_int_big(d, integer_part);
  878.         i++;
  879.     } while (i < end && (d = digitp(s[i], radix)) >= 0);
  880.     if (sign < 0)
  881.         complement_big(integer_part);
  882.     x = normalize_big_to_object(integer_part);
  883. /**/
  884.     if (x == big_register_0)
  885.         big_register_0 = alloc_object(t_bignum);
  886.     big_register_0->big.big_car = 0;
  887.     big_register_0->big.big_cdr = NULL;
  888. /**/
  889.     *ep = i;
  890.     vs_reset;
  891.     return(x);
  892.  
  893. NO_NUMBER:
  894.     *ep = i;
  895.     vs_reset;
  896. /**/
  897.     big_register_0->big.big_car = 0;
  898.     big_register_0->big.big_cdr = NULL;
  899. /**/
  900.     return(OBJNULL);
  901. }
  902. /*
  903.     Read_string(delim, in) reads
  904.     a simple string    terminated by character code delim
  905.     and places it in token.
  906.     Delim is not included in the string but discarded.
  907. */
  908. read_string(delim, in)
  909. int delim;
  910. object in;
  911. {
  912.     int i;
  913.     object c;
  914.  
  915.     i = 0;
  916.     for (;;) {
  917.         c = read_char(in);
  918.         if (char_code(c) == delim)
  919.             break;
  920.         else if (cat(c) == cat_single_escape)
  921.             c = read_char(in);
  922.         if (i >= token->st.st_dim)
  923.             too_long_string();
  924.         token_buffer[i++] = char_code(c);
  925.     }
  926.     token->st.st_fillp = i;
  927. }
  928.  
  929. /*
  930.     Read_constituent(in) reads
  931.     a sequence of constituent characters from stream in
  932.     and places it in token_buffer.
  933. */
  934. read_constituent(in)
  935. object in;
  936. {
  937.     int i, j;
  938.     object c;
  939.  
  940.     i = 0;
  941.     for (;;) {
  942.         c = read_char(in);
  943.         if (cat(c) != cat_constituent) {
  944.             unread_char(c, in);
  945.             break;
  946.         }
  947.         j = char_code(c);
  948.         token_buffer[i++] = j;
  949.     }
  950.     token->st.st_fillp = i;
  951. }
  952.  
  953. Ldouble_quote_reader()
  954. {
  955.     check_arg(2);
  956.     vs_pop;
  957.     read_string('"', vs_base[0]);
  958.     vs_base[0] = copy_simple_string(token);
  959. }
  960.  
  961. Ldispatch_reader()
  962. {
  963.     object c, x;
  964.     int i, d;
  965.     object in;
  966.  
  967.     check_arg(2);
  968.     
  969.     in = vs_base[0];
  970.     c = vs_base[1];
  971.  
  972.     if (READtable->rt.rt_self[char_code(c)].rte_dtab == NULL)
  973.         FEerror("~C is not a dispatching macro character", 1, c);
  974.  
  975.     c = read_char(in);
  976.     d = digitp(char_code(c), 10);
  977.     if (d >= 0) {
  978.         i = 0;
  979.         do {
  980.             i = 10*i + d;
  981.             c = read_char(in);
  982.             d = digitp(char_code(c), 10);
  983.         } while (d >= 0);
  984.         vs_push(make_fixnum(i));
  985.     } else
  986.         vs_push(Cnil);
  987.  
  988.     x =
  989.     READtable->rt.rt_self[char_code(vs_base[1])].rte_dtab[char_code(c)];
  990.     vs_base[1] = c;
  991.     super_funcall(x);
  992. }
  993.  
  994. Lsingle_quote_reader()
  995. {
  996.     check_arg(2);
  997.     vs_pop;
  998.     vs_push(Squote);
  999.     vs_push(read_object(vs_base[0]));
  1000.     vs_push(Cnil);
  1001.     stack_cons();
  1002.     stack_cons();
  1003.     vs_base[0] = vs_pop;
  1004. }
  1005.  
  1006. Lright_parenthesis_reader()
  1007. {
  1008.     check_arg(2);
  1009.     vs_pop;
  1010.     vs_pop;
  1011.         /*  no result  */
  1012. }
  1013.  
  1014. /*
  1015. Lcomma_reader(){}
  1016. */
  1017.  
  1018. Lsemicolon_reader()
  1019. {
  1020.     object c;
  1021.  
  1022.     check_arg(2);
  1023.     vs_pop;
  1024.     do
  1025.         c = read_char(vs_base[0]);
  1026.     while (char_code(c) != '\n');
  1027.     vs_pop;
  1028.     vs_base[0] = Cnil;
  1029.     /*  no result  */
  1030. }
  1031.  
  1032. /*
  1033. Lbackquote_reader(){}
  1034. */
  1035.  
  1036. /*
  1037.     sharpmacro routines
  1038. */
  1039.  
  1040. Lsharp_C_reader()
  1041. {
  1042.     object x, c;
  1043.  
  1044.     check_arg(3);
  1045.     if (vs_base[2] != Cnil && !READsuppress)
  1046.         extra_argument('C');
  1047.     vs_pop;
  1048.     vs_pop;
  1049.     c = read_char(vs_base[0]);
  1050.     if (char_code(c) != '(')
  1051.         FEerror("A left parenthesis is expected.", 0);
  1052.     delimiting_char = code_char(')');
  1053.     x = read_object(vs_base[0]);
  1054.     if (x == OBJNULL)
  1055.         FEerror("No real part.", 0);
  1056.     vs_push(x);
  1057.     delimiting_char = code_char(')');
  1058.     x = read_object(vs_base[0]);
  1059.     if (x == OBJNULL)
  1060.         FEerror("No imaginary part.", 0);
  1061.     vs_push(x);
  1062.     delimiting_char = code_char(')');
  1063.     x = read_object(vs_base[0]);
  1064.     if (x != OBJNULL)
  1065.         FEerror("A right parenthesis is expected.", 0);
  1066.     if (contains_sharp_comma(vs_base[1]) ||
  1067.         contains_sharp_comma(vs_base[2])) {
  1068.         vs_base[0] = alloc_object(t_complex);
  1069.         vs_base[0]->cmp.cmp_real = vs_base[1];
  1070.         vs_base[0]->cmp.cmp_imag = vs_base[2];
  1071.     } else {
  1072.         check_type_number(&vs_base[1]);
  1073.         check_type_number(&vs_base[2]);
  1074.         vs_base[0] = make_complex(vs_base[1], vs_base[2]);
  1075.     }
  1076.     vs_top = vs_base + 1;
  1077. }
  1078.  
  1079. Lsharp_backslash_reader()
  1080. {
  1081.     object c;
  1082.  
  1083.     check_arg(3);
  1084.     if (vs_base[2] != Cnil && !READsuppress)
  1085.         if (type_of(vs_base[2]) != t_fixnum ||
  1086.             fix(vs_base[2]) != 0)
  1087.             FEerror("~S is an illegal CHAR-FONT.", 1, vs_base[2]);
  1088.             /*  assuming that CHAR-FONT-LIMIT is 1  */
  1089.     vs_pop;
  1090.     vs_pop;
  1091.     unread_char(code_char('\\'), vs_base[0]);
  1092.     if (READsuppress) {
  1093.         (void)read_object(vs_base[0]);
  1094.         vs_base[0] = Cnil;
  1095.         return;
  1096.     }
  1097.     READsuppress = TRUE;
  1098.     (void)read_object(vs_base[0]);
  1099.     READsuppress = FALSE;
  1100.     c = token;
  1101.     if (c->s.s_fillp == 1) {
  1102.         vs_base[0] = code_char(c->ust.ust_self[0]);
  1103.         return;
  1104.     }
  1105.     if (string_equal(c, STreturn))
  1106.         vs_base[0] = code_char('\r');
  1107.     else if (string_equal(c, STspace))
  1108.         vs_base[0] = code_char(' ');
  1109.     else if (string_equal(c, STrubout))
  1110.         vs_base[0] = code_char('\177');
  1111.     else if (string_equal(c, STpage))
  1112.         vs_base[0] = code_char('\f');
  1113.     else if (string_equal(c, STtab))
  1114.         vs_base[0] = code_char('\t');
  1115.     else if (string_equal(c, STbackspace))
  1116.         vs_base[0] = code_char('\b');
  1117.     else if (string_equal(c, STlinefeed) || string_equal(c, STnewline))
  1118.         vs_base[0] = code_char('\n');
  1119.     else if (c->s.s_fillp == 2 && c->s.s_self[0] == '^')
  1120.         vs_base[0] = code_char(c->s.s_self[1] & 037);
  1121.     else if (c->s.s_self[0] =='\\' && c->s.s_fillp > 1) {
  1122.         int i, n;
  1123.         for (n = 0, i = 1;  i < c->s.s_fillp;  i++)
  1124.             if (c->s.s_self[i] < '0' || '7' < c->s.s_self[i])
  1125.                 FEerror("Octal digit expected.", 0);
  1126.             else
  1127.                 n = 8*n + c->s.s_self[i] - '0';
  1128.         vs_base[0] = code_char(n & 0377);
  1129.     } else
  1130.         FEerror("~S is an illegal character name.", 1, c);
  1131. }
  1132.  
  1133. Lsharp_single_quote_reader()
  1134. {
  1135.  
  1136.     check_arg(3);
  1137.     if(vs_base[2] != Cnil && !READsuppress)
  1138.         extra_argument('#');
  1139.     vs_pop;
  1140.     vs_pop;
  1141.     vs_push(Sfunction);
  1142.     vs_push(read_object(vs_base[0]));
  1143.     vs_push(Cnil);
  1144.     stack_cons();
  1145.     stack_cons();
  1146.     vs_base[0] = vs_pop;
  1147. }
  1148.  
  1149. #define    QUOTE    1
  1150. #define    EVAL    2
  1151. #define    LIST    3
  1152. #define    LISTA    4
  1153. #define    APPEND    5
  1154. #define    NCONC    6
  1155.  
  1156. object siScomma;
  1157.  
  1158. Lsharp_left_parenthesis_reader()
  1159. {
  1160.     int dim;
  1161.     int dimcount;
  1162.     object in, x;
  1163.     int a;
  1164.     object *vsp;        
  1165.  
  1166.     check_arg(3);
  1167.     if (vs_base[2] == Cnil || READsuppress)
  1168.         dim = -1;
  1169.     else if (type_of(vs_base[2]) == t_fixnum)
  1170.         dim = fix(vs_base[2]);
  1171.     vs_pop;
  1172.     vs_pop;
  1173.     in = vs_base[0];
  1174.     if (backq_level > 0) {
  1175.         unreadc_stream('(', in);
  1176.         vs_push(read_object(in));
  1177.         a = backq_car(vs_base[1]);
  1178.         if (a == APPEND || a == NCONC)
  1179.         FEerror(",at or ,. has appeared in an illegal position.", 0);
  1180.         if (a == QUOTE) {
  1181.             vsp = vs_top;
  1182.             dimcount = 0;
  1183.             for (x = vs_base[2];  !endp(x);  x = x->c.c_cdr) {
  1184.                 vs_check_push(x->c.c_car);
  1185.                 dimcount++;
  1186.             }    
  1187.             goto L;
  1188.         }
  1189.         vs_push(siScomma);
  1190.         vs_push(Sapply);
  1191.         vs_push(Squote);
  1192.         vs_push(Svector);
  1193.         vs_push(Cnil);
  1194.         stack_cons();
  1195.         stack_cons();
  1196.         vs_push(vs_base[2]);
  1197.         vs_push(Cnil);
  1198.         stack_cons();
  1199.         stack_cons();
  1200.         stack_cons();
  1201.         stack_cons();
  1202.         vs_base = vs_top - 1;
  1203.         return;
  1204.     }
  1205.     vsp = vs_top;
  1206.     dimcount = 0;
  1207.     for (;;) {
  1208.         delimiting_char = code_char(')');
  1209.         x = read_object(in);
  1210.         if (x == OBJNULL)
  1211.             break;
  1212.         vs_check_push(x);
  1213.         dimcount++;
  1214.     }    
  1215. L:
  1216.     if (dim >= 0) {
  1217.         if (dimcount > dim)
  1218.             FEerror("Too many elements in #(...).", 0);
  1219.         else {
  1220.             if (dimcount == 0)
  1221.                 FEerror("Cannot fill the vector #().", 0);
  1222.             x = vs_head;
  1223.             for (;  dimcount < dim;  dimcount++)
  1224.                 vs_push(x);
  1225.         }
  1226.     }
  1227.     x = alloc_simple_vector(dimcount, aet_object);
  1228.     vs_push(x);
  1229.     x->v.v_self
  1230.     = (object *)alloc_relblock(dimcount * sizeof(object));
  1231.     vs_pop;
  1232.     for (dim = 0; dim < dimcount; dim++)
  1233.         x->v.v_self[dim] = vsp[dim];
  1234.     vs_top = vs_base;
  1235.     vs_push(x);
  1236. }
  1237.  
  1238. Lsharp_asterisk_reader()
  1239. {
  1240.     int dim;
  1241.     int dimcount;
  1242.     object in, x;
  1243.     object *vsp;        
  1244.  
  1245.     check_arg(3);
  1246.     if (READsuppress) {
  1247.         read_constituent(vs_base[0]);
  1248.         vs_pop;
  1249.         vs_pop;
  1250.         vs_base[0] = Cnil;
  1251.         return;
  1252.     }
  1253.     if (vs_head == Cnil)
  1254.         dim = -1;
  1255.     else if (type_of(vs_head) == t_fixnum)
  1256.         dim = fix(vs_head);
  1257.     vs_pop;
  1258.     vs_pop;
  1259.     in = vs_head;
  1260.     vsp = vs_top;
  1261.     dimcount = 0;
  1262.     for (;;) {
  1263.         if (stream_at_end(in))
  1264.             break;
  1265.         x = read_char(in);
  1266.         if (char_code(x) != '0' && char_code(x) != '1') {
  1267.             unread_char(x, in);
  1268.             break;
  1269.         }
  1270.         vs_check_push(x);
  1271.         dimcount++;
  1272.     }    
  1273.     if (dim >= 0) {
  1274.         if (dimcount > dim)
  1275.             FEerror("Too many elements in #*....", 0);
  1276.         else {
  1277.             if (dimcount == 0)
  1278.                 error("Cannot fill the bit-vector #*.");
  1279.             x = vs_head;
  1280.             for (;  dimcount < dim;  dimcount++)
  1281.                 vs_push(x);
  1282.         }
  1283.     }
  1284.     x = alloc_simple_bitvector(dimcount);
  1285.     vs_push(x);
  1286.     x->bv.bv_self = alloc_relblock((dimcount + 7)/8);
  1287.     vs_pop;
  1288.     for (dim = 0; dim < dimcount; dim++)
  1289.         if (char_code(vsp[dim]) == '0')
  1290.             x->bv.bv_self[dim/8] &= ~(0200 >> dim%8);
  1291.         else
  1292.             x->bv.bv_self[dim/8] |= 0200 >> dim%8;
  1293.     vs_top = vs_base;
  1294.     vs_push(x);
  1295. }
  1296.  
  1297. Lsharp_colon_reader()
  1298. {
  1299.     object in;
  1300.     int length;
  1301.     object c;
  1302.     enum chattrib a;
  1303.  
  1304.     if (vs_base[2] != Cnil && !READsuppress)
  1305.         extra_argument(':');
  1306.     vs_pop;
  1307.     vs_pop;
  1308.     in = vs_base[0];
  1309.     c = read_char(in);
  1310.     a = cat(c);
  1311.     escape_flag = FALSE;
  1312.     length = 0;
  1313.     goto L;
  1314.     for (;;) {
  1315.         if (length >= token->st.st_dim)
  1316.             too_long_token();
  1317.         token_buffer[length++] = char_code(c);
  1318.     K:
  1319.         if (stream_at_end(in))
  1320.             goto M;
  1321.         c = read_char(in);
  1322.         a = cat(c);
  1323.     L:
  1324.         if (a == cat_single_escape) {
  1325.             c = read_char(in);
  1326.             a = cat_constituent;
  1327.             escape_flag = TRUE;
  1328.         } else if (a == cat_multiple_escape) {
  1329.             escape_flag = TRUE;
  1330.             for (;;) {
  1331.                 if (stream_at_end(in))
  1332.                     end_of_stream(in);
  1333.                 c = read_char(in);
  1334.                 a = cat(c);
  1335.                 if (a == cat_single_escape) {
  1336.                     c = read_char(in);
  1337.                     a = cat_constituent;
  1338.                 } else if (a == cat_multiple_escape)
  1339.                     break;
  1340.                 if (length >= token->st.st_dim)
  1341.                     too_long_token();
  1342.                 token_buffer[length++] = char_code(c);
  1343.             }
  1344.             goto K;
  1345.         } else if ('a' <= char_code(c) && char_code(c) <= 'z')
  1346.             c = code_char(char_code(c) - ('a' - 'A'));
  1347.         if (a == cat_whitespace || a == cat_terminating)
  1348.             break;
  1349.     }
  1350.     if (preserving_whitespace_flag || cat(c) != cat_whitespace)
  1351.         unread_char(c, in);
  1352.  
  1353. M:
  1354.     if (READsuppress) {
  1355.         vs_base[0] = Cnil;
  1356.         return;
  1357.     }
  1358.     token->st.st_fillp = length;
  1359.     vs_base[0] = copy_simple_string(token);
  1360.     vs_base[0] = make_symbol(vs_base[0]);
  1361. }
  1362.  
  1363. Lsharp_dot_reader()
  1364. {
  1365.     check_arg(3);
  1366.     if(vs_base[2] != Cnil && !READsuppress)
  1367.         extra_argument('.');
  1368.     vs_pop;
  1369.     vs_pop;
  1370.     if (READsuppress) {
  1371.         vs_base[0] = Cnil;
  1372.         return;
  1373.     }
  1374.     vs_base[0] = read_object(vs_base[0]);
  1375.     vs_base[0] = ieval(vs_base[0]);
  1376. }
  1377.  
  1378. Lsharp_comma_reader()
  1379. {
  1380.     check_arg(3);
  1381.     if(vs_base[2] != Cnil && !READsuppress)
  1382.         extra_argument(',');
  1383.     vs_pop;
  1384.     vs_pop;
  1385.     if (READsuppress) {
  1386.         vs_base[0] = Cnil;
  1387.         return;
  1388.     }
  1389.     vs_base[0] = read_object(vs_base[0]);
  1390.     vs_base[0] = ieval(vs_base[0]);
  1391. }
  1392.  
  1393. siLsharp_comma_reader_for_compiler()
  1394. {
  1395.     check_arg(3);
  1396.     if(vs_base[2] != Cnil && !READsuppress)
  1397.         extra_argument(',');
  1398.     vs_pop;
  1399.     vs_pop;
  1400.     if (READsuppress) {
  1401.         vs_base[0] = Cnil;
  1402.         return;
  1403.     }
  1404.     vs_base[0] = read_object(vs_base[0]);
  1405.     vs_base[0] = make_cons(siSsharp_comma, vs_base[0]);
  1406. }
  1407.  
  1408. /*
  1409.     For fasload.
  1410. */
  1411. Lsharp_exclamation_reader()
  1412. {
  1413.     check_arg(3);
  1414.     if(vs_base[2] != Cnil && !READsuppress)
  1415.         extra_argument('!');
  1416.     vs_pop;
  1417.     vs_pop;
  1418.     if (READsuppress) {
  1419.         vs_base[0] = Cnil;
  1420.         return;
  1421.     }
  1422.     vs_base[0] = read_object(vs_base[0]);
  1423.     ieval(vs_base[0]);
  1424.     vs_pop;
  1425. }
  1426.  
  1427. Lsharp_B_reader()
  1428. {
  1429.     int i;
  1430.  
  1431.     if(vs_base[2] != Cnil && !READsuppress)
  1432.         extra_argument('B');
  1433.     vs_pop;
  1434.     vs_pop;
  1435.     read_constituent(vs_base[0]);
  1436.     if (READsuppress) {
  1437.         vs_base[0] = Cnil;
  1438.         return;
  1439.     }
  1440.     vs_base[0]
  1441.     = parse_number(token_buffer, token->st.st_fillp, &i, 2);
  1442.     if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
  1443.         FEerror("Cannot parse the #B readmacro.", 0);
  1444.     if (type_of(vs_base[0]) == t_shortfloat ||
  1445.         type_of(vs_base[0]) == t_longfloat)
  1446.         FEerror("The float ~S appeared after the #B readmacro.",
  1447.             1, vs_base[0]);
  1448. }
  1449.  
  1450. Lsharp_O_reader()
  1451. {
  1452.     int i;
  1453.  
  1454.     if(vs_base[2] != Cnil && !READsuppress)
  1455.         extra_argument('O');
  1456.     vs_pop;
  1457.     vs_pop;
  1458.     read_constituent(vs_base[0]);
  1459.     if (READsuppress) {
  1460.         vs_base[0] = Cnil;
  1461.         return;
  1462.     }
  1463.     vs_base[0]
  1464.     = parse_number(token_buffer, token->st.st_fillp, &i, 8);
  1465.     if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
  1466.         FEerror("Cannot parse the #O readmacro.", 0);
  1467.     if (type_of(vs_base[0]) == t_shortfloat ||
  1468.         type_of(vs_base[0]) == t_longfloat)
  1469.         FEerror("The float ~S appeared after the #O readmacro.",
  1470.             1, vs_base[0]);
  1471. }
  1472.  
  1473. Lsharp_X_reader()
  1474. {
  1475.     int i;
  1476.  
  1477.     if(vs_base[2] != Cnil && !READsuppress)
  1478.         extra_argument('X');
  1479.     vs_pop;
  1480.     vs_pop;
  1481.     read_constituent(vs_base[0]);
  1482.     if (READsuppress) {
  1483.         vs_base[0] = Cnil;
  1484.         return;
  1485.     }
  1486.     vs_base[0]
  1487.     = parse_number(token_buffer, token->st.st_fillp, &i, 16);
  1488.     if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
  1489.         FEerror("Cannot parse the #X readmacro.", 0);
  1490.     if (type_of(vs_base[0]) == t_shortfloat ||
  1491.         type_of(vs_base[0]) == t_longfloat)
  1492.         FEerror("The float ~S appeared after the #X readmacro.",
  1493.             1, vs_base[0]);
  1494. }
  1495.  
  1496. Lsharp_R_reader()
  1497. {
  1498.     int radix, i;
  1499.  
  1500.     check_arg(3);
  1501.     if (READsuppress)
  1502.         radix = 10;
  1503.     else if (type_of(vs_base[2]) == t_fixnum) {
  1504.         radix = fix(vs_base[2]);
  1505.         if (radix > 36 || radix < 2)
  1506.             FEerror("~S is an illegal radix.", 1, vs_base[2]);
  1507.     } else
  1508.         FEerror("No radix was supplied in the #R readmacro.", 0);
  1509.     vs_pop;
  1510.     vs_pop;
  1511.     read_constituent(vs_base[0]);
  1512.     if (READsuppress) {
  1513.         vs_base[0] = Cnil;
  1514.         return;
  1515.     }
  1516.     vs_base[0]
  1517.     = parse_number(token_buffer, token->st.st_fillp, &i, radix);
  1518.     if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
  1519.         FEerror("Cannot parse the #R readmacro.", 0);
  1520.     if (type_of(vs_base[0]) == t_shortfloat ||
  1521.         type_of(vs_base[0]) == t_longfloat)
  1522.         FEerror("The float ~S appeared after the #R readmacro.",
  1523.             1, vs_base[0]);
  1524. }
  1525.  
  1526. Lsharp_A_reader(){}
  1527.  
  1528. Lsharp_S_reader(){}
  1529.  
  1530. Lsharp_eq_reader()
  1531. {
  1532.     int i;
  1533.  
  1534.     check_arg(3);
  1535.     if (READsuppress) {
  1536.         vs_top = vs_base;
  1537.         return;
  1538.     }
  1539.     if (vs_base[2] == Cnil)
  1540.         FEerror("The #= readmacro requires an argument.", 0);
  1541.     for (i = 0;  i < sharp_eq_context_max;  i++)
  1542.         if (eql(sharp_eq_context[i].sharp_index, vs_base[2]))
  1543.             FEerror("Duplicate definitions for #~D=.",
  1544.                 1, vs_base[2]);
  1545.     if (sharp_eq_context_max >= SHARP_EQ_CONTEXT_SIZE)
  1546.         FEerror("Too many #= definitions.", 0);
  1547.     i = sharp_eq_context_max++;
  1548.     sharp_eq_context[i].sharp_index = vs_base[2];
  1549.     sharp_eq_context[i].sharp_sharp = OBJNULL;
  1550.     vs_base[0]
  1551.     = sharp_eq_context[i].sharp_eq
  1552.     = read_object(vs_base[0]);
  1553.     if (sharp_eq_context[i].sharp_eq
  1554.         == sharp_eq_context[i].sharp_sharp)
  1555.         FEerror("#~D# is defined by itself.",
  1556.             1, sharp_eq_context[i].sharp_index);
  1557.     vs_top = vs_base+1;
  1558. }
  1559.  
  1560. Lsharp_sharp_reader()
  1561. {
  1562.     int i;
  1563.  
  1564.     check_arg(3);
  1565.     if (READsuppress) {
  1566.         vs_pop;
  1567.         vs_pop;
  1568.         vs_base[0] = Cnil;
  1569.     }
  1570.     if (vs_base[2] == Cnil)
  1571.         FEerror("The ## readmacro requires an argument.", 0);
  1572.     for (i = 0;  ;  i++)
  1573.         if (i >= sharp_eq_context_max)
  1574.             FEerror("#~D# is undefined.", 1, vs_base[2]);
  1575.         else if (eql(sharp_eq_context[i].sharp_index,
  1576.                  vs_base[2]))
  1577.             break;
  1578.     if (sharp_eq_context[i].sharp_sharp == OBJNULL) {
  1579.         sharp_eq_context[i].sharp_sharp
  1580.         = alloc_object(t_spice);
  1581.     }
  1582.     vs_base[0] = sharp_eq_context[i].sharp_sharp;
  1583.     vs_top = vs_base+1;
  1584. }
  1585.  
  1586. patch_sharp_cons(x)
  1587. object x;
  1588. {
  1589.     for (;;) {
  1590.         x->c.c_car = patch_sharp(x->c.c_car);
  1591.         if (type_of(x->c.c_cdr) == t_cons)
  1592.             x = x->c.c_cdr;
  1593.         else {
  1594.             x->c.c_cdr = patch_sharp(x->c.c_cdr);
  1595.             break;
  1596.         }
  1597.     }
  1598. }
  1599.  
  1600. object
  1601. patch_sharp(x)
  1602. object x;
  1603. {
  1604.     cs_check(x);
  1605.  
  1606.     switch (type_of(x)) {
  1607.     case t_spice:
  1608.     {
  1609.         int i;
  1610.  
  1611.         for (i = 0;  i < sharp_eq_context_max;  i++)
  1612.             if (sharp_eq_context[i].sharp_sharp == x)
  1613.                 return(sharp_eq_context[i].sharp_eq);
  1614.         break;
  1615.     }
  1616.     case t_cons:
  1617.     /*
  1618.         x->c.c_car = patch_sharp(x->c.c_car);
  1619.         x->c.c_cdr = patch_sharp(x->c.c_cdr);
  1620.     */
  1621.         patch_sharp_cons(x);
  1622.         break;
  1623.  
  1624.     case t_vector:
  1625.     {
  1626.         int i;
  1627.  
  1628.         for (i = 0;  i < x->v.v_fillp;  i++)
  1629.             x->v.v_self[i] = patch_sharp(x->v.v_self[i]);
  1630.         break;
  1631.     }
  1632.     case t_array:
  1633.     {
  1634.         int i, j;
  1635.  
  1636.         for (i = 0, j = 1;  i < x->a.a_rank;  i++)
  1637.             j *= x->a.a_dims[i];
  1638.         for (i = 0;  i < j;  i++)
  1639.             x->a.a_self[i] = patch_sharp(x->a.a_self[i]);
  1640.         break;
  1641.     }
  1642.     }
  1643.     return(x);
  1644. }
  1645.  
  1646. Lsharp_plus_reader(){}
  1647.  
  1648. Lsharp_minus_reader(){}
  1649.  
  1650. Lsharp_less_than_reader(){}
  1651.  
  1652. Lsharp_whitespace_reader(){}
  1653.  
  1654. Lsharp_right_parenthesis_reader(){}
  1655.  
  1656. Lsharp_vertical_bar_reader()
  1657. {
  1658.     int c;
  1659.     int level = 0;
  1660.  
  1661.     check_arg(3);
  1662.     if (vs_base[2] != Cnil && !READsuppress)
  1663.         extra_argument('|');
  1664.     vs_pop;
  1665.     vs_pop;
  1666.     for (;;) {
  1667.         c = readc_stream(vs_base[0]);
  1668.     L:
  1669.         if (c == '#') {
  1670.             c = readc_stream(vs_base[0]);
  1671.             if (c == '|')
  1672.                 level++;
  1673.         } else if (c == '|') {
  1674.             c = readc_stream(vs_base[0]);
  1675.             if (c == '#') {
  1676.                 if (level == 0)
  1677.                     break;
  1678.                 else
  1679.                     --level;
  1680.             } else
  1681.                 goto L;
  1682.         }
  1683.     }
  1684.     vs_pop;
  1685.     vs_base[0] = Cnil;
  1686.     /*  no result  */
  1687. }
  1688.  
  1689. Ldefault_dispatch_macro()
  1690. {
  1691.     FEerror("The default dispatch macro signalled an error.", 0);
  1692. }
  1693.  
  1694. /*
  1695.     #" ... " returns the pathname with namestring ... .
  1696. */
  1697. Lsharp_double_quote_reader()
  1698. {
  1699.     check_arg(3);
  1700.  
  1701.     if (vs_base[2] != Cnil && !READsuppress)
  1702.         extra_argument('"');
  1703.     vs_pop;
  1704.     unread_char(vs_base[1], vs_base[0]);
  1705.     vs_pop;
  1706.     vs_base[0] = read_object(vs_base[0]);
  1707.     vs_base[0] = coerce_to_pathname(vs_base[0]);
  1708. }
  1709.  
  1710. /*
  1711.     #$ fixnum returns a random-state with the fixnum
  1712.     as its content.
  1713. */
  1714. Lsharp_dollar_reader()
  1715. {
  1716.     int i;
  1717.  
  1718.     check_arg(3);
  1719.     if (vs_base[2] != Cnil && !READsuppress)
  1720.         extra_argument('$');
  1721.     vs_pop;
  1722.     vs_pop;
  1723.     vs_base[0] = read_object(vs_base[0]);
  1724.     if (type_of(vs_base[0]) != t_fixnum)
  1725.         FEerror("Cannot make a random-state with the value ~S.",
  1726.             1, vs_base[0]);
  1727.     i = fix(vs_base[0]);
  1728.     vs_base[0] = alloc_object(t_random);
  1729.     vs_base[0]->rnd.rnd_value = i;
  1730. }
  1731.  
  1732. /*
  1733.     readtable routines
  1734. */
  1735.  
  1736. object
  1737. copy_readtable(from, to)
  1738. object from, to;
  1739. {
  1740.     struct rtent *rtab;
  1741.     int i, j;
  1742.     vs_mark;
  1743.  
  1744.     if (to == Cnil) {
  1745.         to = alloc_object(t_readtable);
  1746.         to->rt.rt_self = NULL;
  1747.             /*  For GBC not to go mad.  */
  1748.         vs_push(to);
  1749.             /*  Saving for GBC.  */
  1750.         to->rt.rt_self
  1751.         = rtab
  1752.          = (struct rtent *)
  1753.           alloc_contblock(RTABSIZE * sizeof(struct rtent));
  1754.         for (i = 0;  i < RTABSIZE;  i++)
  1755.             rtab[i] = from->rt.rt_self[i];
  1756.                 /*  structure assignment  */
  1757.     }
  1758.     for (i = 0;  i < RTABSIZE;  i++)
  1759.         if (rtab[i].rte_dtab != NULL) {
  1760.             rtab[i].rte_dtab
  1761.              = (object *)
  1762.               alloc_contblock(RTABSIZE * sizeof(object));
  1763.             for (j = 0;  j < RTABSIZE;  j++)
  1764.                 rtab[i].rte_dtab[j]
  1765.                 = from->rt.rt_self[i].rte_dtab[j];
  1766.         }
  1767.     vs_reset;
  1768.     return(to);
  1769. }
  1770.  
  1771. object
  1772. current_readtable()
  1773. {
  1774.     object r;
  1775.  
  1776.     r = symbol_value(Vreadtable);
  1777.     if (type_of(r) != t_readtable) {
  1778.         Vreadtable->s.s_dbind = copy_readtable(standard_readtable);
  1779.         FEerror("The value of *READTABLE*, ~S, was not a readtable.",
  1780.             1, r);
  1781.     }
  1782.     return(r);
  1783. }
  1784.  
  1785.  
  1786. @(defun read (&optional (strm `symbol_value(Vstandard_input)`)
  1787.             (eof_errorp Ct)
  1788.             eof_value
  1789.             recursivep
  1790.           &aux x)
  1791. @
  1792.     if (strm == Cnil)
  1793.         strm = symbol_value(Vstandard_input);
  1794.     else if (strm == Ct)
  1795.         strm = symbol_value(Vterminal_io);
  1796.     check_type_stream(&strm);
  1797.     if (recursivep == Cnil)
  1798.         preserving_whitespace_flag = FALSE;
  1799.     detect_eos_flag = TRUE;
  1800.     if (recursivep == Cnil)
  1801.         x = read_object_non_recursive(strm);
  1802.     else
  1803.         x = read_object_recursive(strm);
  1804.     if (x == OBJNULL) {
  1805.         if (eof_errorp == Cnil && recursivep == Cnil)
  1806.             @(return eof_value)
  1807.         end_of_stream(strm);
  1808.     }
  1809.     @(return x)
  1810. @)
  1811.  
  1812. @(defun read_preserving_whitespace
  1813.     (&optional (strm `symbol_value(Vstandard_input)`)
  1814.            (eof_errorp Ct)
  1815.            eof_value
  1816.            recursivep
  1817.      &aux x)
  1818.     object c;
  1819. @
  1820.     if (strm == Cnil)
  1821.         strm = symbol_value(Vstandard_input);
  1822.     else if (strm == Ct)
  1823.         strm = symbol_value(Vterminal_io);
  1824.     check_type_stream(&strm);
  1825.     while (!stream_at_end(strm)) {
  1826.         c = read_char(strm);
  1827.         if (cat(c) != cat_whitespace) {
  1828.             unread_char(c, strm);
  1829.             goto READ;
  1830.         }
  1831.     }
  1832.     if (eof_errorp == Cnil && recursivep == Cnil)
  1833.         @(return eof_value)
  1834.     end_of_stream(strm);
  1835.  
  1836. READ:
  1837.     if (recursivep == Cnil)
  1838.         preserving_whitespace_flag = TRUE;
  1839.     if (recursivep == Cnil)
  1840.         x = read_object_non_recursive(strm);
  1841.     else
  1842.         x = read_object_recursive(strm);
  1843.     @(return x)
  1844. @)
  1845.  
  1846. @(defun read_delimited_list
  1847.     (d
  1848.      &optional (strm `symbol_value(Vstandard_input)`)
  1849.            recursivep
  1850.      &aux l x)
  1851.  
  1852.     object *p;
  1853.  
  1854.     int i;
  1855.     bool e;
  1856.     int old_sharp_eq_context_max;
  1857.     struct sharp_eq_context_struct
  1858.         old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
  1859.     int old_backq_level;
  1860.  
  1861. @
  1862.  
  1863.     check_type_character(&d);
  1864.     if (strm == Cnil)
  1865.         strm = symbol_value(Vstandard_input);
  1866.     else if (strm == Ct)
  1867.         strm = symbol_value(Vterminal_io);
  1868.     check_type_stream(&strm);
  1869.     if (recursivep == Cnil) {
  1870.         old_sharp_eq_context_max = sharp_eq_context_max;
  1871.         for (i = 0;  i < sharp_eq_context_max;  i++)
  1872.             old_sharp_eq_context[i] = sharp_eq_context[i];
  1873.         old_backq_level = backq_level;
  1874.         setup_READ();
  1875.         frs_push(FRS_PROTECT, Cnil);
  1876.         if (nlj_active) {
  1877.             e = TRUE;
  1878.             goto L;
  1879.         }
  1880.     }
  1881.     l = Cnil;
  1882.     p = &l;
  1883.     preserving_whitespace_flag = FALSE;    /*  necessary?  */
  1884.     for (;;) {
  1885.         delimiting_char = d;
  1886.         x = read_object_recursive(strm);
  1887.         if (x == OBJNULL)
  1888.             break;
  1889.         *p = make_cons(x, Cnil);
  1890.         p = &((*p)->c.c_cdr);
  1891.     }
  1892.     if (recursivep == Cnil) {
  1893.         if (sharp_eq_context_max > 0)
  1894.             l = patch_sharp(l);
  1895.         e = FALSE;
  1896.     L:
  1897.         frs_pop();
  1898.         sharp_eq_context_max = old_sharp_eq_context_max;
  1899.         for (i = 0;  i < sharp_eq_context_max;  i++)
  1900.             sharp_eq_context[i] = old_sharp_eq_context[i];
  1901.         backq_level = old_backq_level;
  1902.         if (e) {
  1903.             nlj_active = FALSE;
  1904.             unwind(nlj_fr, nlj_tag);
  1905.         }
  1906.     }
  1907.     @(return l)
  1908. @)
  1909.  
  1910. @(defun read_line (&optional (strm `symbol_value(Vstandard_input)`)
  1911.                  (eof_errorp Ct)
  1912.                  eof_value
  1913.                  recursivep
  1914.            &aux c)
  1915.     int i;
  1916. @
  1917.     if (strm == Cnil)
  1918.         strm = symbol_value(Vstandard_input);
  1919.     else if (strm == Ct)
  1920.         strm = symbol_value(Vterminal_io);
  1921.     check_type_stream(&strm);
  1922.     if (stream_at_end(strm)) {
  1923.         if (eof_errorp == Cnil && recursivep == Cnil)
  1924.             @(return eof_value)
  1925.         else
  1926.             end_of_stream(strm);
  1927.     }
  1928.     i = 0;
  1929.     for (;;) {
  1930.         c = read_char(strm);
  1931.         if (char_code(c) == '\n') {
  1932.             c = Cnil;
  1933.             break;
  1934.         }
  1935.         if (i >= token->st.st_dim)
  1936.             too_long_string();
  1937.         token->st.st_self[i++] = char_code(c);
  1938.         if (stream_at_end(strm)) {
  1939.             c = Ct;
  1940.             break;
  1941.         }
  1942.     }
  1943.     token->st.st_fillp = i;
  1944.     @(return `copy_simple_string(token)` c)
  1945. @)
  1946.  
  1947. @(defun read_char (&optional (strm `symbol_value(Vstandard_input)`)
  1948.                  (eof_errorp Ct)
  1949.                  eof_value
  1950.                  recursivep)
  1951. @
  1952.     if (strm == Cnil)
  1953.         strm = symbol_value(Vstandard_input);
  1954.     else if (strm == Ct)
  1955.         strm = symbol_value(Vterminal_io);
  1956.     check_type_stream(&strm);
  1957.     if (stream_at_end(strm)) {
  1958.         if (eof_errorp == Cnil && recursivep == Cnil)
  1959.             @(return eof_value)
  1960.         else
  1961.             end_of_stream(strm);
  1962.     }
  1963.     @(return `read_char(strm)`)
  1964. @)
  1965.  
  1966. @(defun unread_char (c &optional (strm `symbol_value(Vstandard_input)`))
  1967. @
  1968.     check_type_character(&c);
  1969.     if (strm == Cnil)
  1970.         strm = symbol_value(Vstandard_input);
  1971.     else if (strm == Ct)
  1972.         strm = symbol_value(Vterminal_io);
  1973.     check_type_stream(&strm);
  1974.     unread_char(c, strm);
  1975.     @(return Cnil)
  1976. @)
  1977.  
  1978. @(defun peek_char (&optional peek_type
  1979.                  (strm `symbol_value(Vstandard_input)`)
  1980.                  (eof_errorp Ct)
  1981.                  eof_value
  1982.                  recursivep)
  1983.     object c;
  1984. @
  1985.     if (strm == Cnil)
  1986.         strm = symbol_value(Vstandard_input);
  1987.     else if (strm == Ct)
  1988.         strm = symbol_value(Vterminal_io);
  1989.     check_type_stream(&strm);
  1990.     setup_READtable();
  1991.     if (peek_type == Cnil) {
  1992.         if (stream_at_end(strm)) {
  1993.             if (eof_errorp == Cnil && recursivep == Cnil)
  1994.                 @(return eof_value)
  1995.             else
  1996.                 end_of_stream(strm);
  1997.         }
  1998.         c = read_char(strm);
  1999.         unread_char(c, strm);
  2000.         @(return c)
  2001.     }
  2002.     if (peek_type == Ct) {
  2003.         while (!stream_at_end(strm)) {
  2004.             c = read_char(strm);
  2005.             if (cat(c) != cat_whitespace) {
  2006.                 unread_char(c, strm);
  2007.                 @(return c)
  2008.             }
  2009.         }
  2010.         if (eof_errorp == Cnil)
  2011.             @(return eof_value)
  2012.         else
  2013.             end_of_stream(strm);
  2014.     }
  2015.     check_type_character(&peek_type);
  2016.     while (!stream_at_end(strm)) {
  2017.         c = read_char(strm);
  2018.         if (char_eq(c, peek_type)) {
  2019.             unread_char(c, strm);
  2020.             @(return c)
  2021.         }
  2022.     }
  2023.     if (eof_errorp == Cnil)
  2024.         @(return eof_value)
  2025.     else
  2026.         end_of_stream(strm);
  2027. @)
  2028.  
  2029. @(defun listen (&optional (strm `symbol_value(Vstandard_input)`))
  2030. @
  2031.     if (strm == Cnil)
  2032.         strm = symbol_value(Vstandard_input);
  2033.     else if (strm == Ct)
  2034.         strm = symbol_value(Vterminal_io);
  2035.     check_type_stream(&strm);
  2036.     if (listen_stream(strm))
  2037.         @(return Ct)
  2038.     else
  2039.         @(return Cnil)
  2040. @)
  2041.  
  2042. @(defun read_char_no_hang (&optional (strm `symbol_value(Vstandard_input)`)
  2043.                          (eof_errorp Ct)
  2044.                          eof_value
  2045.                          recursivep)
  2046. @
  2047.     if (strm == Cnil)
  2048.         strm = symbol_value(Vstandard_input);
  2049.     else if (strm == Ct)
  2050.         strm = symbol_value(Vterminal_io);
  2051.     check_type_stream(&strm);
  2052.     if (!listen_stream(strm))
  2053.         /* Incomplete! */
  2054.         @(return Cnil)
  2055.     @(return `read_char(strm)`)
  2056. @)
  2057.  
  2058. @(defun clear_input (&optional (strm `symbol_value(Vstandard_input)`))
  2059. @
  2060.     if (strm == Cnil)
  2061.         strm = symbol_value(Vstandard_input);
  2062.     else if (strm == Ct)
  2063.         strm = symbol_value(Vterminal_io);
  2064.     check_type_stream(&strm);
  2065.     @(return Cnil)
  2066. @)
  2067.  
  2068. @(defun parse_integer (strng
  2069.                &key start
  2070.                 end
  2071.                 (radix `make_fixnum(10)`)
  2072.                 junk_allowed
  2073.                &aux x)
  2074.     int s, e, ep;
  2075. @
  2076.     check_type_string(&strng);
  2077.     get_string_start_end(strng, start, end, &s, &e);
  2078.     if (type_of(radix) != t_fixnum ||
  2079.         fix(radix) < 2 || fix(radix) > 36)
  2080.         FEerror("~S is an illegal radix.", 1, radix);
  2081.     setup_READtable();
  2082.     while (READtable->rt.rt_self[strng->st.st_self[s]].rte_chattrib
  2083.            == cat_whitespace && s < e)
  2084.         s++;
  2085.     if (s >= e) {
  2086.         if (junk_allowed != Cnil)
  2087.             @(return Cnil `make_fixnum(s)`)
  2088.         else
  2089.             goto CANNOT_PARSE;
  2090.     }
  2091.     x = parse_integer(strng->st.st_self+s, e-s, &ep, fix(radix));
  2092.     if (x == OBJNULL) {
  2093.         if (junk_allowed != Cnil)
  2094.             @(return Cnil `make_fixnum(ep+s)`)
  2095.         else
  2096.             goto CANNOT_PARSE;
  2097.     }
  2098.     if (junk_allowed != Cnil)
  2099.         @(return x `make_fixnum(ep+s)`)
  2100.     for (s += ep ;  s < e;  s++)
  2101.         if (READtable->rt.rt_self[strng->st.st_self[s]]
  2102.             .rte_chattrib
  2103.             != cat_whitespace)
  2104.             goto CANNOT_PARSE;
  2105.     @(return x `make_fixnum(e)`)
  2106.  
  2107. CANNOT_PARSE:
  2108.     FEerror("Cannot parse an integer in the string ~S.", 1, strng);
  2109. @)
  2110.  
  2111. @(defun read_byte (binary_input_stream
  2112.            &optional eof_errorp eof_value)
  2113.     int c;
  2114. @
  2115.     check_type_stream(&binary_input_stream);
  2116.     if (stream_at_end(binary_input_stream)) {
  2117.         if (eof_errorp == Cnil)
  2118.             @(return eof_value)
  2119.         else
  2120.             end_of_stream(binary_input_stream);
  2121.     }
  2122.     c = readc_stream(binary_input_stream);
  2123.     @(return `make_fixnum(c)`)
  2124. @)
  2125.  
  2126. @(defun copy_readtable (&o (from `current_readtable()`) to)
  2127. @
  2128.     if (from == Cnil) {
  2129.         from = standard_readtable;
  2130.         if (to != Cnil)
  2131.             check_type_readtable(&to);
  2132.         to = copy_readtable(from, to);
  2133.         to->rt.rt_self['#'].rte_dtab['!']
  2134.         = default_dispatch_macro;
  2135.         /*  We must forget #! macro.  */
  2136.         @(return to)
  2137.     }
  2138.     check_type_readtable(&from);
  2139.     if (to != Cnil)
  2140.         check_type_readtable(&to);
  2141.     @(return `copy_readtable(from, to)`)
  2142. @)
  2143.  
  2144. Lreadtablep()
  2145. {
  2146.     check_arg(1);
  2147.  
  2148.     if (type_of(vs_base[0]) == t_readtable)
  2149.         vs_base[0] = Ct;
  2150.     else
  2151.         vs_base[0] = Cnil;
  2152. }
  2153.  
  2154. @(defun set_syntax_from_char (tochr fromchr
  2155.                   &o (tordtbl `current_readtable()`)
  2156.                  fromrdtbl)
  2157.     int i;
  2158. @
  2159.     check_type_character(&tochr);
  2160.     check_type_character(&fromchr);
  2161.     check_type_readtable(&tordtbl);
  2162.     if (fromrdtbl == Cnil)
  2163.         fromrdtbl = standard_readtable;
  2164.     else
  2165.         check_type_readtable(&fromrdtbl);
  2166.     tordtbl->rt.rt_self[char_code(tochr)].rte_chattrib
  2167.     = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_chattrib;
  2168.     tordtbl->rt.rt_self[char_code(tochr)].rte_macro
  2169.     = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_macro;
  2170.     if ((tordtbl->rt.rt_self[char_code(tochr)].rte_dtab
  2171.          = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_dtab)
  2172.         != NULL) {
  2173.         tordtbl->rt.rt_self[char_code(tochr)].rte_dtab
  2174.         = (object *)
  2175.           alloc_contblock(RTABSIZE * sizeof(object));
  2176.         for (i = 0;  i < RTABSIZE;  i++)
  2177.             tordtbl->rt.rt_self[char_code(tochr)]
  2178.             .rte_dtab[i]
  2179.             = fromrdtbl->rt.rt_self[char_code(fromchr)]
  2180.               .rte_dtab[i];
  2181.     }
  2182.     @(return Ct)
  2183. @)
  2184.  
  2185. @(defun set_macro_character (chr fnc
  2186.                  &optional ntp
  2187.                        (rdtbl `current_readtable()`))
  2188.     int c;
  2189. @
  2190.     check_type_character(&chr);
  2191.     check_type_readtable(&rdtbl);
  2192.     c = char_code(chr);
  2193.     if (ntp != Cnil)
  2194.         rdtbl->rt.rt_self[c].rte_chattrib
  2195.         = cat_non_terminating;
  2196.     else
  2197.         rdtbl->rt.rt_self[c].rte_chattrib
  2198.         = cat_terminating;
  2199.     rdtbl->rt.rt_self[c].rte_macro = fnc;
  2200.     @(return Ct)
  2201. @)
  2202.  
  2203. @(defun get_macro_character (chr &o (rdtbl `current_readtable()`))
  2204.     object m;
  2205. @
  2206.     check_type_character(&chr);
  2207.     check_type_readtable(&rdtbl);
  2208.     if ((m = rdtbl->rt.rt_self[char_code(chr)].rte_macro)
  2209.         == OBJNULL)
  2210.         @(return Cnil)
  2211.     if (rdtbl->rt.rt_self[char_code(chr)].rte_chattrib
  2212.         == cat_non_terminating)
  2213.         @(return m Ct)
  2214.     else
  2215.         @(return m Cnil)
  2216. @)
  2217.  
  2218. @(defun make_dispatch_macro_character (chr
  2219.     &optional ntp (rdtbl `current_readtable()`))
  2220.     int i;
  2221. @
  2222.     check_type_character(&chr);
  2223.     check_type_readtable(&rdtbl);
  2224.     if (ntp != Cnil)
  2225.         rdtbl->rt.rt_self[char_code(chr)].rte_chattrib
  2226.         = cat_non_terminating;
  2227.     else
  2228.         rdtbl->rt.rt_self[char_code(chr)].rte_chattrib
  2229.         = cat_terminating;
  2230.     rdtbl->rt.rt_self[char_code(chr)].rte_dtab
  2231.     = (object *)
  2232.       alloc_contblock(RTABSIZE * sizeof(object));
  2233.     for (i = 0;  i < RTABSIZE;  i++)
  2234.         rdtbl->rt.rt_self[char_code(chr)].rte_dtab[i]
  2235.         = default_dispatch_macro;
  2236.     rdtbl->rt.rt_self[char_code(chr)].rte_macro = dispatch_reader;
  2237.     @(return Ct)
  2238. @)
  2239.  
  2240. @(defun set_dispatch_macro_character (dspchr subchr fnc
  2241.     &optional (rdtbl `current_readtable()`))
  2242. @
  2243.     check_type_character(&dspchr);
  2244.     check_type_character(&subchr);
  2245.     check_type_readtable(&rdtbl);
  2246.     if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader
  2247.         || rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL)
  2248.         FEerror("~S is not a dispatch character.", 1, dspchr);
  2249.     rdtbl->rt.rt_self[char_code(dspchr)]
  2250.     .rte_dtab[char_code(subchr)] = fnc;
  2251.     if ('a' <= char_code(subchr) && char_code(subchr) <= 'z')
  2252.         rdtbl->rt.rt_self[char_code(dspchr)]
  2253.         .rte_dtab[char_code(subchr) - ('a' - 'A')] = fnc;
  2254.  
  2255.     @(return Ct)
  2256. @)
  2257.  
  2258. @(defun get_dispatch_macro_character (dspchr subchr
  2259.     &optional (rdtbl `current_readtable()`))
  2260. @
  2261.     check_type_character(&dspchr);
  2262.     check_type_character(&subchr);
  2263.     check_type_readtable(&rdtbl);
  2264.     if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader
  2265.         || rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL)
  2266.         FEerror("~S is not a dispatch character.", 1, dspchr);
  2267.     if (digitp(char_code(subchr),10) >= 0) @(return Cnil)
  2268.     else @(return `rdtbl->rt.rt_self[char_code(dspchr)]
  2269.           .rte_dtab[char_code(subchr)]`)
  2270. @)
  2271.  
  2272. object
  2273. string_to_object(x)
  2274. object x;
  2275. {
  2276.     object in;
  2277.     vs_mark;
  2278.  
  2279.     in = make_string_input_stream(x, 0, x->st.st_fillp);
  2280.     vs_push(in);
  2281.     preserving_whitespace_flag = FALSE;
  2282.     detect_eos_flag = FALSE;
  2283.     x = read_object(in);
  2284.     vs_reset;
  2285.     return(x);
  2286. }
  2287.     
  2288. siLstring_to_object()
  2289. {
  2290.     check_arg(1);
  2291.  
  2292.     check_type_string(&vs_base[0]);
  2293.     vs_base[0] = string_to_object(vs_base[0]);
  2294. }
  2295.  
  2296.  
  2297. siLstandard_readtable()
  2298. {
  2299.     check_arg(0);
  2300.  
  2301.     vs_push(standard_readtable);
  2302. }
  2303.  
  2304. too_long_token()
  2305. {
  2306.     char *q;
  2307.     int i;
  2308.  
  2309.     q = alloc_contblock(token->st.st_dim*2);
  2310.     for (i = 0;  i < token->st.st_dim;  i++)
  2311.         q[i] = token->st.st_self[i];
  2312.     token->st.st_self = q;
  2313.     token->st.st_dim *= 2;
  2314. /*
  2315.     token->st.st_fillp = token->st.st_dim;
  2316.     FEerror("Too long a token: ~A.", 1, token);
  2317. */
  2318. }
  2319.  
  2320. too_long_string()
  2321. {
  2322.     char *q;
  2323.     int i;
  2324.  
  2325.     q = alloc_contblock(token->st.st_dim*2);
  2326.     for (i = 0;  i < token->st.st_dim;  i++)
  2327.         q[i] = token->st.st_self[i];
  2328.     token->st.st_self = q;
  2329.     token->st.st_dim *= 2;
  2330. /*
  2331.     token->st.st_fillp = token->st.st_dim;
  2332.     FEerror("Too long a string: ~S.", 1, token);
  2333. */
  2334. }
  2335.  
  2336. extra_argument(c)
  2337. int c;
  2338. {
  2339.     FEerror("~S is an extra argument for the #~C readmacro.",
  2340.         2, vs_base[2], code_char(c));
  2341. }
  2342.  
  2343.  
  2344. #define    make_cf(f)    make_cfun((f), Cnil, Cnil, NULL, 0)
  2345.  
  2346. init_read()
  2347. {
  2348.     struct rtent *rtab;
  2349.     object *dtab;
  2350.     int i;
  2351.  
  2352.     standard_readtable = alloc_object(t_readtable);
  2353.     enter_mark_origin(&standard_readtable);
  2354.  
  2355.     standard_readtable->rt.rt_self
  2356.     = rtab
  2357.     = (struct rtent *)
  2358.       alloc_contblock(RTABSIZE * sizeof(struct rtent));
  2359.     for (i = 0;  i < RTABSIZE;  i++) {
  2360.         rtab[i].rte_chattrib = cat_constituent;
  2361.         rtab[i].rte_macro = OBJNULL;
  2362.         rtab[i].rte_dtab = NULL;
  2363.     }
  2364.  
  2365.     dispatch_reader = make_cf(Ldispatch_reader);
  2366.     enter_mark_origin(&dispatch_reader);
  2367.  
  2368.     rtab['\t'].rte_chattrib = cat_whitespace;
  2369.     rtab['\n'].rte_chattrib = cat_whitespace;
  2370.     rtab['\f'].rte_chattrib = cat_whitespace;
  2371.     rtab['\r'].rte_chattrib = cat_whitespace;
  2372.     rtab[' '].rte_chattrib = cat_whitespace;
  2373.     rtab['"'].rte_chattrib = cat_terminating;
  2374.     rtab['"'].rte_macro = make_cf(Ldouble_quote_reader);
  2375.     rtab['#'].rte_chattrib = cat_non_terminating;
  2376.     rtab['#'].rte_macro = dispatch_reader;
  2377.     rtab['\''].rte_chattrib = cat_terminating;
  2378.     rtab['\''].rte_macro = make_cf(Lsingle_quote_reader);
  2379.     rtab['('].rte_chattrib = cat_terminating;
  2380.     rtab['('].rte_macro = make_cf(Lleft_parenthesis_reader);
  2381.     rtab[')'].rte_chattrib = cat_terminating;
  2382.     rtab[')'].rte_macro = make_cf(Lright_parenthesis_reader);
  2383. /*
  2384.     rtab[','].rte_chattrib = cat_terminating;
  2385.     rtab[','].rte_macro = make_cf(Lcomma_reader);
  2386. */
  2387.     rtab[';'].rte_chattrib = cat_terminating;
  2388.     rtab[';'].rte_macro = make_cf(Lsemicolon_reader);
  2389.     rtab['\\'].rte_chattrib = cat_single_escape;
  2390. /*
  2391.     rtab['`'].rte_chattrib = cat_terminating;
  2392.     rtab['`'].rte_macro = make_cf(Lbackquote_reader);
  2393. */
  2394.     rtab['|'].rte_chattrib = cat_multiple_escape;
  2395. /*
  2396.     rtab['|'].rte_macro = make_cf(Lvertical_bar_reader);
  2397. */
  2398.  
  2399.     default_dispatch_macro = make_cf(Ldefault_dispatch_macro);
  2400.  
  2401.     rtab['#'].rte_dtab
  2402.     = dtab
  2403.     = (object *)alloc_contblock(RTABSIZE * sizeof(object));
  2404.     for (i = 0;  i < RTABSIZE;  i++)
  2405.         dtab[i] = default_dispatch_macro;
  2406.     dtab['C'] = dtab['c'] = make_cf(Lsharp_C_reader);
  2407.     dtab['\\'] = make_cf(Lsharp_backslash_reader);
  2408.     dtab['\''] = make_cf(Lsharp_single_quote_reader);
  2409.     dtab['('] = make_cf(Lsharp_left_parenthesis_reader);
  2410.     dtab['*'] = make_cf(Lsharp_asterisk_reader);
  2411.     dtab[':'] = make_cf(Lsharp_colon_reader);
  2412.     dtab['.'] = make_cf(Lsharp_dot_reader);
  2413.     dtab['!'] = make_cf(Lsharp_exclamation_reader);
  2414.     /*  Used for fasload only. */
  2415.     dtab[','] = make_cf(Lsharp_comma_reader);
  2416.     dtab['B'] = dtab['b'] = make_cf(Lsharp_B_reader);
  2417.     dtab['O'] = dtab['o'] = make_cf(Lsharp_O_reader);
  2418.     dtab['X'] = dtab['x'] = make_cf(Lsharp_X_reader);
  2419.     dtab['R'] = dtab['r'] = make_cf(Lsharp_R_reader);
  2420. /*
  2421.     dtab['A'] = dtab['a'] = make_cf(Lsharp_A_reader);
  2422.     dtab['S'] = dtab['s'] = make_cf(Lsharp_S_reader);
  2423. */
  2424.     dtab['A'] = dtab['a'] = make_si_ordinary("SHARP-A-READER");
  2425.     dtab['S'] = dtab['s'] = make_si_ordinary("SHARP-S-READER");
  2426.  
  2427.     dtab['='] = make_cf(Lsharp_eq_reader);
  2428.     dtab['#'] = make_cf(Lsharp_sharp_reader);
  2429.     dtab['+'] = make_cf(Lsharp_plus_reader);
  2430.     dtab['-'] = make_cf(Lsharp_minus_reader);
  2431. /*
  2432.     dtab['<'] = make_cf(Lsharp_less_than_reader);
  2433. */
  2434.     dtab['|'] = make_cf(Lsharp_vertical_bar_reader);
  2435.     dtab['"'] = make_cf(Lsharp_double_quote_reader);
  2436.     /*  This is specific to this implimentation  */
  2437.     dtab['$'] = make_cf(Lsharp_dollar_reader);
  2438.     /*  This is specific to this implimentation  */
  2439. /*
  2440.     dtab[' '] = dtab['\t'] = dtab['\n'] = dtab['\f']
  2441.     = make_cf(Lsharp_whitespace_reader);
  2442.     dtab[')'] = make_cf(Lsharp_right_parenthesis_reader);
  2443. */
  2444.  
  2445.     init_backq();
  2446.  
  2447.     Vreadtable
  2448.      = make_special("*READTABLE*",
  2449.                copy_readtable(standard_readtable, Cnil));
  2450.     Vreadtable->s.s_dbind->rt.rt_self['#'].rte_dtab['!']
  2451.     = default_dispatch_macro;
  2452.     /*  We must forget #! macro.  */
  2453.     Vread_default_float_format
  2454.     = make_special("*READ-DEFAULT-FLOAT-FORMAT*",
  2455.                Ssingle_float);
  2456.     Vread_base = make_special("*READ-BASE*", make_fixnum(10));
  2457.     Vread_suppress = make_special("*READ-SUPPRESS*", Cnil);
  2458.  
  2459.     Kstart = make_keyword("START");
  2460.     Kend = make_keyword("END");
  2461.     Kradix = make_keyword("RADIX");
  2462.     Kjunk_allowed = make_keyword("JUNK-ALLOWED");
  2463.  
  2464.     READtable = symbol_value(Vreadtable);
  2465.     enter_mark_origin(&READtable);
  2466.     READdefault_float_format = 'F';
  2467.     READbase = 10;
  2468.     READsuppress = FALSE;
  2469.  
  2470.     sharp_eq_context_max = 0;
  2471.  
  2472.     siSsharp_comma = make_si_ordinary("#,");
  2473.     enter_mark_origin(&siSsharp_comma);
  2474.  
  2475.     delimiting_char = OBJNULL;
  2476.     enter_mark_origin(&delimiting_char);
  2477.  
  2478.     detect_eos_flag = FALSE;
  2479.     in_list_flag = FALSE;
  2480.     dot_flag = FALSE;
  2481.  
  2482.     big_register_0 = alloc_object(t_bignum);
  2483.     big_register_0->big.big_car = 0;
  2484.     big_register_0->big.big_cdr = NULL;
  2485.     enter_mark_origin(&big_register_0);
  2486. /*
  2487.     NOTE:
  2488.  
  2489.         The value of big_register_0 changes
  2490.         along the execution of the read routines.
  2491. */
  2492. }
  2493.  
  2494. init_read_function()
  2495. {
  2496.     make_function("READ", Lread);
  2497.     make_function("READ-PRESERVING-WHITESPACE",
  2498.               Lread_preserving_whitespace);
  2499.     make_function("READ-DELIMITED-LIST", Lread_delimited_list);
  2500.     make_function("READ-LINE", Lread_line);
  2501.     make_function("READ-CHAR", Lread_char);
  2502.     make_function("UNREAD-CHAR", Lunread_char);
  2503.     make_function("PEEK-CHAR", Lpeek_char);
  2504.     make_function("LISTEN", Llisten);
  2505.     make_function("READ-CHAR-NO-HANG", Lread_char_no_hang);
  2506.     make_function("CLEAR-INPUT", Lclear_input);
  2507.  
  2508.     make_function("PARSE-INTEGER", Lparse_integer);
  2509.  
  2510.     make_function("READ-BYTE", Lread_byte);
  2511.  
  2512.     make_function("COPY-READTABLE", Lcopy_readtable);
  2513.     make_function("READTABLEP", Lreadtablep);
  2514.     make_function("SET-SYNTAX-FROM-CHAR", Lset_syntax_from_char);
  2515.     make_function("SET-MACRO-CHARACTER", Lset_macro_character);
  2516.     make_function("GET-MACRO-CHARACTER", Lget_macro_character);
  2517.     make_function("MAKE-DISPATCH-MACRO-CHARACTER",
  2518.               Lmake_dispatch_macro_character);
  2519.     make_function("SET-DISPATCH-MACRO-CHARACTER",
  2520.               Lset_dispatch_macro_character);
  2521.     make_function("GET-DISPATCH-MACRO-CHARACTER",
  2522.               Lget_dispatch_macro_character);
  2523.  
  2524.     make_si_function("SHARP-COMMA-READER-FOR-COMPILER",
  2525.              siLsharp_comma_reader_for_compiler);
  2526.  
  2527.     make_si_function("STRING-TO-OBJECT", siLstring_to_object);
  2528.  
  2529.     make_si_function("STANDARD-READTABLE", siLstandard_readtable);
  2530. }
  2531.  
  2532.  
  2533. object
  2534. read_fasl_vector(in)
  2535. object in;
  2536. {
  2537.     int dimcount, dim;
  2538.     object *vsp;        
  2539.  
  2540.     object x;
  2541.     int i;
  2542.     bool e;
  2543.     object old_READtable;
  2544.     int old_READdefault_float_format;
  2545.     int old_READbase;
  2546.     int old_READsuppress;
  2547.     int old_sharp_eq_context_max;
  2548.     struct sharp_eq_context_struct
  2549.         old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
  2550.     int old_backq_level;
  2551.  
  2552.     old_READtable = READtable;
  2553.     old_READdefault_float_format = READdefault_float_format;
  2554.     old_READbase = READbase;
  2555.     old_READsuppress = READsuppress;
  2556.     old_sharp_eq_context_max = sharp_eq_context_max;
  2557.     /* BUG FIX by Toshiba */
  2558.     vs_push(old_READtable);
  2559.     for (i = 0;  i < sharp_eq_context_max;  i++)
  2560.         old_sharp_eq_context[i] = sharp_eq_context[i];
  2561.     old_backq_level = backq_level;
  2562.  
  2563.     setup_standard_READ();
  2564.  
  2565.     frs_push(FRS_PROTECT, Cnil);
  2566.     if (nlj_active) {
  2567.         e = TRUE;
  2568.         goto L;
  2569.     }
  2570.  
  2571.     while (readc_stream(in) != '#')
  2572.         ;
  2573.     while (readc_stream(in) != '(')
  2574.         ;
  2575.     vsp = vs_top;
  2576.     dimcount = 0;
  2577.     for (;;) {
  2578.         sharp_eq_context_max = 0;
  2579.         backq_level = 0;
  2580.         delimiting_char = code_char(')');
  2581.         preserving_whitespace_flag = FALSE;
  2582.         detect_eos_flag = FALSE;
  2583.         x = read_object(in);
  2584.         if (x == OBJNULL)
  2585.             break;
  2586.         vs_check_push(x);
  2587.         if (sharp_eq_context_max > 0)
  2588.             x = vs_head = patch_sharp(x);
  2589.         dimcount++;
  2590.     }    
  2591.     x = alloc_simple_vector(dimcount, aet_object);
  2592.     vs_push(x);
  2593.     x->v.v_self
  2594.     = (object *)alloc_relblock(dimcount * sizeof(object));
  2595.     for (dim = 0; dim < dimcount; dim++)
  2596.         x->v.v_self[dim] = vsp[dim];
  2597.  
  2598.     e = FALSE;
  2599.  
  2600. L:
  2601.     frs_pop();
  2602.  
  2603.     READtable = old_READtable;
  2604.     READdefault_float_format = old_READdefault_float_format;
  2605.     READbase = old_READbase;
  2606.     READsuppress = old_READsuppress;
  2607.     sharp_eq_context_max = old_sharp_eq_context_max;
  2608.     for (i = 0;  i < sharp_eq_context_max;  i++)
  2609.         sharp_eq_context[i] = old_sharp_eq_context[i];
  2610.     backq_level = old_backq_level;
  2611.     if (e) {
  2612.         nlj_active = FALSE;
  2613.         unwind(nlj_fr, nlj_tag);
  2614.     }
  2615.     vs_top = vsp;
  2616.     return(x);
  2617. }
  2618.