Back to index

plt-scheme  4.2.1
read.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 /* This file contains the MzScheme reader, including the normal reader
00027    and the one for .zo files. The normal reader is a recursive-descent
00028    parser. The really messy part is number parsing, which is in a
00029    different file, numstr.c. */
00030 
00031 /* Rule on using scheme_ungetc(): the reader is generally allowed to
00032    use scheme_ungetc() only when it will definitely re-read the
00033    character as it continues. If the character will not be re-read
00034    (e.g., because an exception will be raised), then the reader must
00035    peek, instead. However, read-symbol uses ungetc() if the port does
00036    not have a specific peek handler, and in that case, read-symbol
00037    only ungetc()s a single character (that had been read by itself). */
00038 
00039 #include "schpriv.h"
00040 #include "schmach.h"
00041 #include "schminc.h"
00042 #include "schcpt.h"
00043 #include "schvers.h"
00044 #include <stdlib.h>
00045 #include <ctype.h>
00046 #ifdef USE_STACKAVAIL
00047 # include <malloc.h>
00048 #endif
00049 
00050 #define MAX_QUICK_SYMBOL_SIZE 64
00051 
00052 /* Init options for embedding: */
00053 /* these are used to set initial config parameterizations */
00054 int scheme_square_brackets_are_parens = 1;
00055 int scheme_curly_braces_are_parens = 1;
00056 
00057 /* performance counter */ /* FIXME should be atomically incremented or not shared */
00058 int scheme_num_read_syntax_objects;
00059 
00060 /* global flag set from environment variable */
00061 static int use_perma_cache = 1;
00062 
00063 /* read-only global symbols */
00064 static char *builtin_fast;  /* FIXME possible init race condition */
00065 static unsigned char delim[128];
00066 /* Table of built-in variable refs for .zo loading: */
00067 static Scheme_Object **variable_references;
00068 static Scheme_Object *quote_symbol;
00069 static Scheme_Object *quasiquote_symbol;
00070 static Scheme_Object *unquote_symbol;
00071 static Scheme_Object *unquote_splicing_symbol;
00072 static Scheme_Object *syntax_symbol;
00073 static Scheme_Object *unsyntax_symbol;
00074 static Scheme_Object *unsyntax_splicing_symbol;
00075 static Scheme_Object *quasisyntax_symbol;
00076 static Scheme_Object *paren_shape_symbol;
00077 static Scheme_Object *terminating_macro_symbol;
00078 static Scheme_Object *non_terminating_macro_symbol;
00079 static Scheme_Object *dispatch_macro_symbol;
00080 static Scheme_Object *honu_comma;
00081 static Scheme_Object *honu_semicolon;
00082 static Scheme_Object *honu_parens;
00083 static Scheme_Object *honu_braces;
00084 static Scheme_Object *honu_brackets;
00085 static Scheme_Object *honu_angles;
00086 /* For matching angle brackets in Honu mode: */
00087 static Scheme_Object *honu_angle_open;
00088 static Scheme_Object *honu_angle_close;
00089 /* For recoginizing unresolved hash tables and commented-out graph introductions: */
00090 static Scheme_Object *unresolved_uninterned_symbol;
00091 static Scheme_Object *tainted_uninterned_symbol;
00092 
00093 /* local function prototypes */
00094 static Scheme_Object *read_case_sensitive(int, Scheme_Object *[]);
00095 static Scheme_Object *read_bracket_as_paren(int, Scheme_Object *[]);
00096 static Scheme_Object *read_brace_as_paren(int, Scheme_Object *[]);
00097 static Scheme_Object *read_accept_graph(int, Scheme_Object *[]);
00098 static Scheme_Object *read_accept_compiled(int, Scheme_Object *[]);
00099 static Scheme_Object *read_accept_box(int, Scheme_Object *[]);
00100 static Scheme_Object *read_accept_pipe_quote(int, Scheme_Object *[]);
00101 static Scheme_Object *read_decimal_as_inexact(int, Scheme_Object *[]);
00102 static Scheme_Object *read_accept_dot(int, Scheme_Object *[]);
00103 static Scheme_Object *read_accept_infix_dot(int, Scheme_Object *[]);
00104 static Scheme_Object *read_accept_quasi(int, Scheme_Object *[]);
00105 static Scheme_Object *read_accept_reader(int, Scheme_Object *[]);
00106 #ifdef LOAD_ON_DEMAND
00107 static Scheme_Object *read_delay_load(int, Scheme_Object *[]);
00108 #endif
00109 static Scheme_Object *print_graph(int, Scheme_Object *[]);
00110 static Scheme_Object *print_struct(int, Scheme_Object *[]);
00111 static Scheme_Object *print_box(int, Scheme_Object *[]);
00112 static Scheme_Object *print_vec_shorthand(int, Scheme_Object *[]);
00113 static Scheme_Object *print_hash_table(int, Scheme_Object *[]);
00114 static Scheme_Object *print_unreadable(int, Scheme_Object *[]);
00115 static Scheme_Object *print_pair_curly(int, Scheme_Object *[]);
00116 static Scheme_Object *print_mpair_curly(int, Scheme_Object *[]);
00117 static Scheme_Object *print_honu(int, Scheme_Object *[]);
00118 
00119 #define NOT_EOF_OR_SPECIAL(x) ((x) >= 0)
00120 
00121 #define mzSPAN(port, pos)  ()
00122 
00123 #define isdigit_ascii(n) ((n >= '0') && (n <= '9'))
00124 
00125 #define scheme_isxdigit(n) (isdigit_ascii(n) || ((n >= 'a') && (n <= 'f')) || ((n >= 'A') && (n <= 'F')))
00126 
00127 #define RETURN_FOR_SPECIAL_COMMENT  0x1
00128 #define RETURN_FOR_HASH_COMMENT     0x2
00129 #define RETURN_FOR_DELIM            0x4
00130 #define RETURN_FOR_COMMENT          0x8
00131 #define RETURN_HONU_ANGLE           0x10
00132 
00133 static MZ_INLINE long SPAN(Scheme_Object *port, long pos) {
00134   long cpos;
00135   scheme_tell_all(port, NULL, NULL, &cpos);
00136   return cpos - pos + 1;
00137 }
00138 
00139 /* For cases where we'd rather report the location as just the relevant prefix: */
00140 #define MINSPAN(port, pos, span) (span)
00141 
00142 #define SRCLOC_TMPL " in %q[%L%ld]"
00143 
00144 #define mz_shape_cons 0
00145 #define mz_shape_vec 1
00146 #define mz_shape_hash_list 2
00147 #define mz_shape_hash_elem 3
00148 #define mz_shape_vec_plus_infix 4
00149 
00150 typedef struct Readtable {
00151   Scheme_Object so;
00152   Scheme_Hash_Table *mapping; /* pos int -> (cons int proc-or-char); neg int -> proc */
00153   char *fast_mapping;
00154   Scheme_Object *symbol_parser; /* NULL or a Scheme function */
00155   char **names; /* error-message names */
00156 } Readtable;
00157 
00158 typedef struct ReadParams {
00159   MZTAG_IF_REQUIRED
00160   int can_read_compiled;
00161   int can_read_pipe_quote;
00162   int can_read_box;
00163   int can_read_graph;
00164   int can_read_reader;
00165   int case_sensitive;
00166   int square_brackets_are_parens;
00167   int curly_braces_are_parens;
00168   int read_decimal_inexact;
00169   int can_read_dot;
00170   int can_read_infix_dot;
00171   int can_read_quasi;
00172   int honu_mode;
00173   int skip_zo_vers_check;
00174   Readtable *table;
00175   Scheme_Object *magic_sym, *magic_val;
00176   Scheme_Object *delay_load_info;
00177 } ReadParams;
00178 
00179 #define THREAD_FOR_LOCALS scheme_current_thread
00180 #define local_list_stack (THREAD_FOR_LOCALS->list_stack)
00181 #define local_list_stack_pos (THREAD_FOR_LOCALS->list_stack_pos)
00182 
00183 static Scheme_Object *read_list(Scheme_Object *port, Scheme_Object *stxsrc,
00184                             long line, long col, long pos,
00185                             int opener, int closer,
00186                             int shape, int use_stack,
00187                             Scheme_Hash_Table **ht,
00188                             Scheme_Object *indentation,
00189                             ReadParams *params);
00190 static Scheme_Object *read_string(int is_byte, int is_honu_char,
00191                               Scheme_Object *port, Scheme_Object *stxsrc,
00192                               long line, long col, long pos,
00193                               Scheme_Hash_Table **ht,
00194                               Scheme_Object *indentation,
00195                               ReadParams *params, int err_ok);
00196 static Scheme_Object *read_here_string(Scheme_Object *port, Scheme_Object *stxsrc,
00197                                    long line, long col, long pos,
00198                                    Scheme_Object *indentation,
00199                                    ReadParams *params);
00200 static Scheme_Object *read_quote(char *who, Scheme_Object *quote_symbol, int len,
00201                              Scheme_Object *port, Scheme_Object *stxsrc,
00202                               long line, long col, long pos,
00203                              Scheme_Hash_Table **ht,
00204                              Scheme_Object *indentation,
00205                              ReadParams *params);
00206 static Scheme_Object *read_vector(Scheme_Object *port, Scheme_Object *stxsrc,
00207                               long line, long col, long pos,
00208                               int opener, char closer,
00209                               long reqLen, const mzchar *reqBuffer,
00210                               Scheme_Hash_Table **ht,
00211                               Scheme_Object *indentation,
00212                               ReadParams *params, int allow_infix);
00213 static Scheme_Object *read_number(int init_ch,
00214                               Scheme_Object *port, Scheme_Object *stxsrc,
00215                               long line, long col, long pos,
00216                               int, int, int, int,
00217                               Scheme_Hash_Table **ht,
00218                               Scheme_Object *indentation,
00219                               ReadParams *params,
00220                               Readtable *table);
00221 static Scheme_Object *read_symbol(int init_ch, int skip_rt,
00222                               Scheme_Object *port, Scheme_Object *stxsrc,
00223                               long line, long col, long pos,
00224                               Scheme_Hash_Table **ht,
00225                               Scheme_Object *indentation,
00226                               ReadParams *params,
00227                               Readtable *table);
00228 static Scheme_Object *read_keyword(int init_ch,
00229                                Scheme_Object *port, Scheme_Object *stxsrc,
00230                                long line, long col, long pos,
00231                                Scheme_Hash_Table **ht,
00232                                Scheme_Object *indentation,
00233                                ReadParams *params,
00234                                Readtable *table);
00235 static Scheme_Object *read_character(Scheme_Object *port, Scheme_Object *stcsrc,
00236                                  long line, long col, long pos,
00237                                  Scheme_Hash_Table **ht,
00238                                  Scheme_Object *indentation,
00239                                  ReadParams *params);
00240 static Scheme_Object *read_box(Scheme_Object *port, Scheme_Object *stxsrc,
00241                             long line, long col, long pos,
00242                             Scheme_Hash_Table **ht,
00243                             Scheme_Object *indentation,
00244                             ReadParams *params);
00245 static Scheme_Object *read_hash(Scheme_Object *port, Scheme_Object *stxsrc,
00246                             long line, long col, long pos,
00247                             int opener, char closer, int kind,
00248                             Scheme_Hash_Table **ht,
00249                             Scheme_Object *indentation,
00250                             ReadParams *params);
00251 static Scheme_Object *read_reader(Scheme_Object *port, Scheme_Object *stxsrc,
00252                               long line, long col, long pos,
00253                               Scheme_Hash_Table **ht,
00254                               Scheme_Object *indentation,
00255                               ReadParams *params);
00256 static Scheme_Object *read_lang(Scheme_Object *port, Scheme_Object *stxsrc,
00257                                 long line, long col, long pos,
00258                                 int get_info,
00259                                 Scheme_Hash_Table **ht,
00260                                 Scheme_Object *indentation,
00261                                 ReadParams *params,
00262                                 int init_ch);
00263 static Scheme_Object *read_compiled(Scheme_Object *port, Scheme_Object *stxsrc,
00264                                 long line, long col, long pos,
00265                                 Scheme_Hash_Table **ht,
00266                                 ReadParams *params);
00267 static void unexpected_closer(int ch,
00268                            Scheme_Object *port, Scheme_Object *stxsrc,
00269                            long line, long col, long pos,
00270                            Scheme_Object *indentation,
00271                               ReadParams *params);
00272 static Scheme_Object *expected_lang(const char *prefix, int ch,
00273                                     Scheme_Object *port, Scheme_Object *stxsrc,
00274                                     long line, long col, long pos,
00275                                     int get_info);
00276 static void pop_indentation(Scheme_Object *indentation);
00277 
00278 static int skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
00279                                 Scheme_Hash_Table **ht,
00280                                 Scheme_Object *indentation,
00281                                 ReadParams *params);
00282 
00283 static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, ReadParams *params,
00284                                  Scheme_Object *port, Scheme_Object *src, long line, long col, long pos,
00285                                      int get_info,
00286                                  Scheme_Hash_Table **ht, Scheme_Object *modpath_stx);
00287 
00288 #define READTABLE_WHITESPACE 0x1
00289 #define READTABLE_CONTINUING 0x2
00290 #define READTABLE_TERMINATING 0x4
00291 #define READTABLE_SINGLE_ESCAPE 0x8
00292 #define READTABLE_MULTIPLE_ESCAPE 0x10
00293 #define READTABLE_MAPPED 0x20
00294 static int readtable_kind(Readtable *t, int ch, ReadParams *params);
00295 static Scheme_Object *readtable_handle(Readtable *t, int *_ch, int *_use_default, ReadParams *params,
00296                                    Scheme_Object *port, Scheme_Object *src, long line, long col, long pos,
00297                                    Scheme_Hash_Table **ht);
00298 static Scheme_Object *readtable_handle_hash(Readtable *t, int ch, int *_use_default, ReadParams *params,
00299                                        Scheme_Object *port, Scheme_Object *src, long line, long col, long pos,
00300                                        Scheme_Hash_Table **ht);
00301 static int readtable_effective_char(Readtable *t, int ch);
00302 static Scheme_Object *make_readtable(int argc, Scheme_Object **argv);
00303 static Scheme_Object *readtable_p(int argc, Scheme_Object **argv);
00304 static Scheme_Object *readtable_mapping(int argc, Scheme_Object **argv);
00305 static Scheme_Object *current_readtable(int argc, Scheme_Object **argv);
00306 static Scheme_Object *current_reader_guard(int argc, Scheme_Object **argv);
00307 
00308 /* A list stack is used to speed up the creation of intermediate lists
00309    during .zo reading. */
00310 
00311 #define NUM_CELLS_PER_STACK 500
00312 
00313 #ifdef MZ_PRECISE_GC
00314 static void register_traversers(void);
00315 #endif
00316 
00317 typedef struct {
00318   Scheme_Type type;
00319   char closer;      /* expected close parent, bracket, etc. */
00320   char suspicious_closer; /* expected closer when suspicious line found */
00321   char multiline;   /* set to 1 if the match attempt spans a line */
00322   char quote_for_char; /* 1 => suspicious_quote refers to Honu char */
00323   long start_line;  /* opener's line */
00324   long last_line;   /* current line, already checked the identation */
00325   long suspicious_line; /* non-0 => first suspicious line since opener */
00326   long max_indent;  /* max indentation encountered so far since opener,
00327                      not counting indentation brackets by a more neseted
00328                      opener */
00329   long suspicious_quote; /* non-0 => first suspicious quote whose closer
00330                          is on a different line */
00331 } Scheme_Indent;
00332 
00333 #define SCHEME_OK          0x1
00334 #define HONU_OK            0x2
00335 #define HONU_SYM_OK        0x4
00336 #define HONU_NUM_OK        0x8
00337 #define HONU_INUM_OK       0x10
00338 #define HONU_INUM_SIGN_OK  0x20
00339 
00340 #define is_lang_nonsep_char(ch) (scheme_isalpha(ch)     \
00341                                  || scheme_isdigit(ch)  \
00342                                  || ((ch) == '-')       \
00343                                  || ((ch) == '+')       \
00344                                  || ((ch) == '_'))
00345 
00346 #define NEXT_LINE_CHAR 0x85
00347 #define LINE_SEPARATOR_CHAR 0x2028
00348 #define PARAGRAPH_SEPARATOR_CHAR 0x2029
00349 #define is_line_comment_end(ch) ((ch == '\n') || (ch == '\r') \
00350                                  || (ch == NEXT_LINE_CHAR) \
00351                                  || (ch == LINE_SEPARATOR_CHAR) \
00352                                  || (ch == PARAGRAPH_SEPARATOR_CHAR))
00353 
00354 /*========================================================================*/
00355 /*                             initialization                             */
00356 /*========================================================================*/
00357 
00358 void scheme_init_read(Scheme_Env *env)
00359 {
00360   REGISTER_SO(variable_references);
00361 
00362   REGISTER_SO(quote_symbol);
00363   REGISTER_SO(quasiquote_symbol);
00364   REGISTER_SO(unquote_symbol);
00365   REGISTER_SO(unquote_splicing_symbol);
00366   REGISTER_SO(syntax_symbol);
00367   REGISTER_SO(unsyntax_symbol);
00368   REGISTER_SO(unsyntax_splicing_symbol);
00369   REGISTER_SO(quasisyntax_symbol);
00370   REGISTER_SO(paren_shape_symbol);
00371 
00372   REGISTER_SO(unresolved_uninterned_symbol);
00373   REGISTER_SO(tainted_uninterned_symbol);
00374 
00375   quote_symbol                  = scheme_intern_symbol("quote");
00376   quasiquote_symbol             = scheme_intern_symbol("quasiquote");
00377   unquote_symbol                = scheme_intern_symbol("unquote");
00378   unquote_splicing_symbol       = scheme_intern_symbol("unquote-splicing");
00379   syntax_symbol                 = scheme_intern_symbol("syntax");
00380   unsyntax_symbol               = scheme_intern_symbol("unsyntax");
00381   unsyntax_splicing_symbol      = scheme_intern_symbol("unsyntax-splicing");
00382   quasisyntax_symbol            = scheme_intern_symbol("quasisyntax");
00383   paren_shape_symbol            = scheme_intern_symbol("paren-shape");
00384 
00385   unresolved_uninterned_symbol  = scheme_make_symbol("unresolved");
00386   tainted_uninterned_symbol     = scheme_make_symbol("tainted");
00387 
00388   
00389   REGISTER_SO(honu_comma);
00390   REGISTER_SO(honu_semicolon);
00391   REGISTER_SO(honu_parens);
00392   REGISTER_SO(honu_braces);
00393   REGISTER_SO(honu_brackets);
00394   REGISTER_SO(honu_angles);
00395   REGISTER_SO(honu_angle_open);
00396   REGISTER_SO(honu_angle_close);
00397 
00398   honu_comma        = scheme_intern_symbol(",");
00399   honu_semicolon    = scheme_intern_symbol(";");
00400   honu_parens       = scheme_intern_symbol("#%parens");
00401   honu_braces       = scheme_intern_symbol("#%braces");
00402   honu_brackets     = scheme_intern_symbol("#%brackets");
00403   honu_angles       = scheme_intern_symbol("#%angles");
00404   honu_angle_open   = scheme_make_symbol("<"); /* uninterned */
00405   honu_angle_close  = scheme_make_symbol(">"); /* uninterned */
00406 
00407   {
00408     int i;
00409     for (i = 0; i < 128; i++) {
00410       delim[i] = SCHEME_OK;
00411     }
00412     for (i = 'A'; i <= 'Z'; i++) {
00413       delim[i] |= HONU_OK;
00414       delim[i + ('a'-'A')] |= HONU_OK;
00415     }
00416     for (i = '0'; i <= '9'; i++) {
00417       delim[i] |= (HONU_OK | HONU_NUM_OK);
00418     }
00419     delim['('] -= SCHEME_OK;
00420     delim[')'] -= SCHEME_OK;
00421     delim['['] -= SCHEME_OK;
00422     delim[']'] -= SCHEME_OK;
00423     delim['{'] -= SCHEME_OK;
00424     delim['}'] -= SCHEME_OK;
00425     delim['"'] -= SCHEME_OK;
00426     delim['\''] -= SCHEME_OK;
00427     delim[','] -= SCHEME_OK;
00428     delim[';'] -= SCHEME_OK;
00429     delim['`'] -= SCHEME_OK;
00430     delim['_'] |= HONU_OK;
00431     {
00432       GC_CAN_IGNORE const char *syms = "+-=?:<>.!%^&*/~|";
00433       for (i = 0; syms[i]; i++) {
00434        delim[(int)syms[i]] |= HONU_SYM_OK;
00435       }
00436     }
00437     delim['.'] |= HONU_NUM_OK;
00438     delim['e'] |= HONU_INUM_OK;
00439     delim['E'] |= HONU_INUM_OK;
00440     delim['d'] |= HONU_INUM_OK;
00441     delim['D'] |= HONU_INUM_OK;
00442     delim['f'] |= HONU_INUM_OK;
00443     delim['F'] |= HONU_INUM_OK;
00444     delim['+'] |= HONU_INUM_SIGN_OK;
00445     delim['-'] |= HONU_INUM_SIGN_OK;
00446   }
00447 
00448 #ifdef MZ_PRECISE_GC
00449   register_traversers();
00450 #endif
00451 
00452   GLOBAL_PARAMETER("current-readtable",             current_readtable,      MZCONFIG_READTABLE,                   env);
00453   GLOBAL_PARAMETER("current-reader-guard",          current_reader_guard,   MZCONFIG_READER_GUARD,                env);
00454   GLOBAL_PARAMETER("read-case-sensitive",           read_case_sensitive,    MZCONFIG_CASE_SENS,                   env);
00455   GLOBAL_PARAMETER("read-square-bracket-as-paren",  read_bracket_as_paren,  MZCONFIG_SQUARE_BRACKETS_ARE_PARENS,  env);
00456   GLOBAL_PARAMETER("read-curly-brace-as-paren",     read_brace_as_paren,    MZCONFIG_CURLY_BRACES_ARE_PARENS,     env);
00457   GLOBAL_PARAMETER("read-accept-graph",             read_accept_graph,      MZCONFIG_CAN_READ_GRAPH,              env);
00458   GLOBAL_PARAMETER("read-accept-compiled",          read_accept_compiled,   MZCONFIG_CAN_READ_COMPILED,           env);
00459   GLOBAL_PARAMETER("read-accept-box",               read_accept_box,        MZCONFIG_CAN_READ_BOX,                env);
00460   GLOBAL_PARAMETER("read-accept-bar-quote",         read_accept_pipe_quote, MZCONFIG_CAN_READ_PIPE_QUOTE,         env);
00461   GLOBAL_PARAMETER("read-decimal-as-inexact",       read_decimal_as_inexact,MZCONFIG_READ_DECIMAL_INEXACT,        env);
00462   GLOBAL_PARAMETER("read-accept-dot",               read_accept_dot,        MZCONFIG_CAN_READ_DOT,                env);
00463   GLOBAL_PARAMETER("read-accept-infix-dot",         read_accept_infix_dot,  MZCONFIG_CAN_READ_INFIX_DOT,          env);
00464   GLOBAL_PARAMETER("read-accept-quasiquote",        read_accept_quasi,      MZCONFIG_CAN_READ_QUASI,              env);
00465   GLOBAL_PARAMETER("read-accept-reader",            read_accept_reader,     MZCONFIG_CAN_READ_READER,             env);
00466 #ifdef LOAD_ON_DEMAND
00467   GLOBAL_PARAMETER("read-on-demand-source",         read_delay_load,        MZCONFIG_DELAY_LOAD_INFO,             env);
00468 #endif
00469   GLOBAL_PARAMETER("print-graph",                   print_graph,            MZCONFIG_PRINT_GRAPH,                 env);
00470   GLOBAL_PARAMETER("print-struct",                  print_struct,           MZCONFIG_PRINT_STRUCT,                env);
00471   GLOBAL_PARAMETER("print-box",                     print_box,              MZCONFIG_PRINT_BOX,                   env);
00472   GLOBAL_PARAMETER("print-vector-length",           print_vec_shorthand,    MZCONFIG_PRINT_VEC_SHORTHAND,         env);
00473   GLOBAL_PARAMETER("print-hash-table",              print_hash_table,       MZCONFIG_PRINT_HASH_TABLE,            env);
00474   GLOBAL_PARAMETER("print-unreadable",              print_unreadable,       MZCONFIG_PRINT_UNREADABLE,            env);
00475   GLOBAL_PARAMETER("print-pair-curly-braces",       print_pair_curly,       MZCONFIG_PRINT_PAIR_CURLY,            env);
00476   GLOBAL_PARAMETER("print-mpair-curly-braces",      print_mpair_curly,      MZCONFIG_PRINT_MPAIR_CURLY,           env);
00477   GLOBAL_PARAMETER("print-honu",                    print_honu,             MZCONFIG_HONU_MODE,                   env);
00478 
00479   GLOBAL_PRIM_W_ARITY("make-readtable",     make_readtable,     1, -1,      env);
00480   GLOBAL_FOLDING_PRIM("readtable?",         readtable_p,        1, 1, 1,    env);
00481   GLOBAL_PRIM_W_ARITY2("readtable-mapping", readtable_mapping,  2, 2, 3, 3, env);
00482 
00483   if (getenv("PLT_DELAY_FROM_ZO")) {
00484     use_perma_cache = 0;
00485   }
00486 }
00487 
00488 static Scheme_Simple_Object *malloc_list_stack()
00489 {
00490 #ifdef MZ_PRECISE_GC
00491   long sz = sizeof(Scheme_Simple_Object) * NUM_CELLS_PER_STACK;
00492   Scheme_Simple_Object *r;
00493 
00494   if (sz < GC_malloc_stays_put_threshold()) {
00495     sz = GC_malloc_stays_put_threshold();
00496     while (sz % sizeof(Scheme_Simple_Object)) {
00497       sz++;
00498     }
00499   }
00500 
00501   r = (Scheme_Simple_Object *)GC_malloc_array_tagged(sz);
00502 
00503   /* Must set the tag on the first element: */
00504   r[0].iso.so.type = scheme_pair_type;
00505   return r;
00506 #else
00507   return MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
00508 #endif
00509 }
00510 
00511 void scheme_alloc_list_stack(Scheme_Thread *p)
00512 {
00513   Scheme_Simple_Object *sa;
00514   p->list_stack_pos = 0;
00515   sa = malloc_list_stack();
00516   p->list_stack = sa;
00517 }
00518 
00519 void scheme_clean_list_stack(Scheme_Thread *p)
00520 {
00521   if (p->list_stack) {
00522     memset(p->list_stack + p->list_stack_pos, 0,
00523           (NUM_CELLS_PER_STACK - p->list_stack_pos) * sizeof(Scheme_Simple_Object));
00524 #ifdef MZ_PRECISE_GC
00525     if (!p->list_stack_pos) {
00526       /* Must set the tag on the first element: */
00527       p->list_stack[0].iso.so.type = scheme_pair_type;
00528     }
00529 #endif
00530   }
00531 }
00532 
00533 static void track_indentation(Scheme_Object *indentation, int line, int col)
00534 {
00535   if (!SCHEME_NULLP(indentation)) {
00536     Scheme_Indent *indt = (Scheme_Indent *)SCHEME_CAR(indentation);
00537     /* Already checked this line? */
00538     if (line > indt->last_line) {
00539       indt->last_line = line;
00540       indt->multiline = 1;
00541       /* At least as indented as before? */
00542       if (col >= indt->max_indent)
00543        indt->max_indent = col;
00544       else if (!indt->suspicious_line) {
00545        /* Not as indented, and no suspicious line found
00546           already. Suspect that the closer should have
00547           appeared earlier. */
00548        indt->suspicious_closer = indt->closer;
00549        indt->suspicious_line = line;
00550       }
00551     }
00552   }
00553 }
00554 
00555 /*========================================================================*/
00556 /*                             parameters                                 */
00557 /*========================================================================*/
00558 
00559 #define DO_CHAR_PARAM(name, pos) \
00560   return scheme_param_config(name, scheme_make_integer(pos), argc, argv, -1, NULL, NULL, 1)
00561 
00562 static Scheme_Object *
00563 read_case_sensitive(int argc, Scheme_Object *argv[])
00564 {
00565   DO_CHAR_PARAM("read-case-sensitive", MZCONFIG_CASE_SENS);
00566 }
00567 
00568 static Scheme_Object *
00569 read_bracket_as_paren(int argc, Scheme_Object *argv[])
00570 {
00571   DO_CHAR_PARAM("read-square-bracket-as-paren", MZCONFIG_SQUARE_BRACKETS_ARE_PARENS);
00572 }
00573 
00574 static Scheme_Object *
00575 read_brace_as_paren(int argc, Scheme_Object *argv[])
00576 {
00577   DO_CHAR_PARAM("read-curly-brace-as-paren", MZCONFIG_CURLY_BRACES_ARE_PARENS);
00578 }
00579 
00580 static Scheme_Object *
00581 read_accept_graph(int argc, Scheme_Object *argv[])
00582 {
00583   DO_CHAR_PARAM("read-accept-graph", MZCONFIG_CAN_READ_GRAPH);
00584 }
00585 
00586 static Scheme_Object *
00587 read_accept_compiled(int argc, Scheme_Object *argv[])
00588 {
00589   DO_CHAR_PARAM("read-accept-compiled", MZCONFIG_CAN_READ_COMPILED);
00590 }
00591 
00592 static Scheme_Object *
00593 read_accept_box(int argc, Scheme_Object *argv[])
00594 {
00595   DO_CHAR_PARAM("read-accept-box", MZCONFIG_CAN_READ_BOX);
00596 }
00597 
00598 static Scheme_Object *
00599 read_accept_pipe_quote(int argc, Scheme_Object *argv[])
00600 {
00601   DO_CHAR_PARAM("read-accept-pipe-quote", MZCONFIG_CAN_READ_PIPE_QUOTE);
00602 }
00603 
00604 static Scheme_Object *
00605 read_decimal_as_inexact(int argc, Scheme_Object *argv[])
00606 {
00607   DO_CHAR_PARAM("read-decimal-as-inexact", MZCONFIG_READ_DECIMAL_INEXACT);
00608 }
00609 
00610 static Scheme_Object *
00611 read_accept_dot(int argc, Scheme_Object *argv[])
00612 {
00613   DO_CHAR_PARAM("read-accept-dot", MZCONFIG_CAN_READ_DOT);
00614 }
00615 
00616 static Scheme_Object *
00617 read_accept_infix_dot(int argc, Scheme_Object *argv[])
00618 {
00619   DO_CHAR_PARAM("read-accept-infix-dot", MZCONFIG_CAN_READ_INFIX_DOT);
00620 }
00621 
00622 static Scheme_Object *
00623 read_accept_quasi(int argc, Scheme_Object *argv[])
00624 {
00625   DO_CHAR_PARAM("read-accept-quasiquote", MZCONFIG_CAN_READ_QUASI);
00626 }
00627 
00628 static Scheme_Object *
00629 read_accept_reader(int argc, Scheme_Object *argv[])
00630 {
00631   DO_CHAR_PARAM("read-accept-reader", MZCONFIG_CAN_READ_READER);
00632 }
00633 
00634 static Scheme_Object *
00635 print_graph(int argc, Scheme_Object *argv[])
00636 {
00637   DO_CHAR_PARAM("print-graph", MZCONFIG_PRINT_GRAPH);
00638 }
00639 
00640 static Scheme_Object *
00641 print_struct(int argc, Scheme_Object *argv[])
00642 {
00643   DO_CHAR_PARAM("print-struct", MZCONFIG_PRINT_STRUCT);
00644 }
00645 
00646 static Scheme_Object *
00647 print_box(int argc, Scheme_Object *argv[])
00648 {
00649   DO_CHAR_PARAM("print-box", MZCONFIG_PRINT_BOX);
00650 }
00651 
00652 static Scheme_Object *
00653 print_vec_shorthand(int argc, Scheme_Object *argv[])
00654 {
00655   DO_CHAR_PARAM("print-vector-length", MZCONFIG_PRINT_VEC_SHORTHAND);
00656 }
00657 
00658 static Scheme_Object *
00659 print_hash_table(int argc, Scheme_Object *argv[])
00660 {
00661   DO_CHAR_PARAM("print-hash-table", MZCONFIG_PRINT_HASH_TABLE);
00662 }
00663 
00664 static Scheme_Object *
00665 print_unreadable(int argc, Scheme_Object *argv[])
00666 {
00667   DO_CHAR_PARAM("print-unreadable", MZCONFIG_PRINT_UNREADABLE);
00668 }
00669 
00670 static Scheme_Object *
00671 print_pair_curly(int argc, Scheme_Object *argv[])
00672 {
00673   DO_CHAR_PARAM("print-pair-curly", MZCONFIG_PRINT_PAIR_CURLY);
00674 }
00675 
00676 static Scheme_Object *
00677 print_mpair_curly(int argc, Scheme_Object *argv[])
00678 {
00679   DO_CHAR_PARAM("print-mpair-curly", MZCONFIG_PRINT_MPAIR_CURLY);
00680 }
00681 
00682 static Scheme_Object *
00683 print_honu(int argc, Scheme_Object *argv[])
00684 {
00685   DO_CHAR_PARAM("print-honu", MZCONFIG_HONU_MODE);
00686 }
00687 
00688 #ifdef LOAD_ON_DEMAND
00689 static Scheme_Object *rdl_check(int argc, Scheme_Object **argv)
00690 {
00691   return argv[0];
00692 }
00693 
00694 static Scheme_Object *
00695 read_delay_load(int argc, Scheme_Object *argv[])
00696 {
00697   return scheme_param_config("read-on-demand-source",
00698                           scheme_make_integer(MZCONFIG_DELAY_LOAD_INFO),
00699                           argc, argv,
00700                           -1, rdl_check, 
00701                           "complete path or string, optionally paired with an exact integer", 1);
00702 
00703 }
00704 #endif
00705 
00706 /*========================================================================*/
00707 /*                             main read loop                             */
00708 /*========================================================================*/
00709 
00710 #ifdef DO_STACK_CHECK
00711 
00712 static Scheme_Object *read_inner_inner(Scheme_Object *port,
00713                                    Scheme_Object *stxsrc,
00714                                    Scheme_Hash_Table **ht,
00715                                    Scheme_Object *indentation,
00716                                    ReadParams *params,
00717                                    int comment_mode,
00718                                    int pre_char,
00719                                    Readtable *init_readtable,
00720                                        int get_info);
00721 static Scheme_Object *read_inner(Scheme_Object *port, 
00722                              Scheme_Object *stxsrc, 
00723                              Scheme_Hash_Table **ht,
00724                              Scheme_Object *indentation, 
00725                              ReadParams *params,
00726                              int comment_mode);
00727 
00728 static void set_need_copy(Scheme_Hash_Table **ht)
00729 {
00730   /* Set indicator in *ht that we need to copy: */
00731   if (!*ht) {
00732     Scheme_Hash_Table *tht;
00733     tht = scheme_make_hash_table(SCHEME_hash_ptr);
00734     *ht = tht;
00735   }
00736   scheme_hash_set(*ht, tainted_uninterned_symbol, scheme_true);
00737 }
00738 
00739 static Scheme_Object *read_inner_inner_k(void)
00740 {
00741   Scheme_Thread *p = scheme_current_thread;
00742   Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
00743   Scheme_Hash_Table **ht = (Scheme_Hash_Table **)p->ku.k.p2;
00744   Scheme_Object *stxsrc = (Scheme_Object *)p->ku.k.p3;
00745   Scheme_Object *indentation = SCHEME_CAR((Scheme_Object *)p->ku.k.p4);
00746   ReadParams *params = (ReadParams *)SCHEME_CDR((Scheme_Object *)p->ku.k.p4);
00747   Readtable *table = (Readtable *)p->ku.k.p5;
00748 
00749   p->ku.k.p1 = NULL;
00750   p->ku.k.p2 = NULL;
00751   p->ku.k.p3 = NULL;
00752   p->ku.k.p4 = NULL;
00753   p->ku.k.p5 = NULL;
00754 
00755   return read_inner_inner(o, stxsrc, ht, indentation, params, p->ku.k.i1, p->ku.k.i2, table, p->ku.k.i3);
00756 }
00757 #endif
00758 
00759 #define MAX_GRAPH_ID_DIGITS 8
00760 
00761 static Scheme_Object *
00762 read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht,
00763                Scheme_Object *indentation, ReadParams *params,
00764                int comment_mode, int pre_char, Readtable *table,
00765                  int get_info)
00766 {
00767   int ch, ch2, depth, dispatch_ch, special_value_need_copy = 0;
00768   long line = 0, col = 0, pos = 0;
00769   Scheme_Object *special_value;
00770 
00771 #ifdef DO_STACK_CHECK
00772   {
00773 # include "mzstkchk.h"
00774     {
00775       Scheme_Thread *p = scheme_current_thread;
00776       Scheme_Object *pr;
00777       ReadParams *params2;
00778 
00779       /* params may be on the stack, so move it to the heap: */
00780       params2 = MALLOC_ONE_RT(ReadParams);
00781       memcpy(params2, params, sizeof(ReadParams));
00782 #ifdef MZ_PRECISE_GC
00783       params2->type = scheme_rt_read_params;
00784 #endif
00785 
00786       p->ku.k.p1 = (void *)port;
00787       p->ku.k.p2 = (void *)ht;
00788       p->ku.k.p3 = (void *)stxsrc;
00789 
00790       pr = scheme_make_pair(indentation, (Scheme_Object *)params2);
00791       p->ku.k.p4 = (void *)pr;
00792 
00793       p->ku.k.p5 = (void *)table;
00794 
00795       p->ku.k.i1 = comment_mode;
00796       p->ku.k.i2 = pre_char;
00797       p->ku.k.i3 = get_info;
00798       return scheme_handle_stack_overflow(read_inner_inner_k);
00799     }
00800   }
00801 #endif
00802 
00803  start_over:
00804 
00805   SCHEME_USE_FUEL(1);
00806 
00807   while (1) {
00808     if (pre_char >= 0) {
00809       ch = pre_char;
00810       pre_char = -1;
00811     } else
00812       ch = scheme_getc_special_ok(port);
00813     if (NOT_EOF_OR_SPECIAL(ch)) {
00814       if (table) {
00815        if (!(readtable_kind(table, ch, params) & READTABLE_WHITESPACE))
00816          break;
00817       } else if (!scheme_isspace(ch))
00818        break;
00819     } else
00820       break;
00821   }
00822 
00823  start_over_with_ch:
00824 
00825   scheme_tell_all(port, &line, &col, &pos);
00826 
00827   /* Found non-whitespace. Track indentation: */
00828   if (col >= 0) {
00829     if (SCHEME_PAIRP(indentation)) {
00830       int effective_ch;
00831       effective_ch = readtable_effective_char(table, ch);
00832       /* Ignore if it's a comment start or spurious closer: */
00833       if ((effective_ch != ';')
00834          && !((effective_ch == '#') && (scheme_peekc_special_ok(port) == '|'))
00835          && (effective_ch != ')')
00836          && ((effective_ch != '}') || !params->curly_braces_are_parens)
00837          && ((effective_ch != ']') || !params->square_brackets_are_parens)) {
00838        track_indentation(indentation, line, col);
00839       }
00840     }
00841   }
00842 
00843   special_value = NULL;
00844   if (table && NOT_EOF_OR_SPECIAL(ch)) {
00845     Scheme_Object *v;
00846     int use_default, ch2 = ch;
00847     v = readtable_handle(table, &ch2, &use_default, params,
00848                       port, stxsrc, line, col, pos, ht);
00849     if (!use_default) {
00850       dispatch_ch = SCHEME_SPECIAL;
00851       special_value = v;
00852     } else
00853       dispatch_ch = ch2;
00854   } else
00855     dispatch_ch = ch;
00856 
00857   if (get_info && (dispatch_ch != '#') && (dispatch_ch != ';')) {
00858     return expected_lang("", ch, port, stxsrc, line, col, pos, get_info);
00859   }
00860 
00861   switch ( dispatch_ch )
00862     {
00863     case EOF: 
00864       return scheme_eof;
00865     case SCHEME_SPECIAL:
00866       {
00867        if (!special_value) {
00868          special_value = scheme_get_special(port, stxsrc, line, col, pos, 0, ht);
00869          special_value_need_copy = 1;
00870        }
00871        break;
00872       }
00873     case ']':
00874       if (!params->square_brackets_are_parens) {
00875        scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of close square bracket");
00876        return NULL;
00877       } else {
00878        unexpected_closer(ch, port, stxsrc, line, col, pos, indentation, params);
00879        return NULL;
00880       }
00881     case '}':
00882       if (!params->curly_braces_are_parens) {
00883        scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of close curly brace");
00884        return NULL;
00885       } else {
00886        unexpected_closer(ch, port, stxsrc, line, col, pos, indentation, params);
00887        return NULL;
00888       }
00889     case ')':
00890       unexpected_closer(ch, port, stxsrc, line, col, pos, indentation, params);
00891       return NULL;
00892     case '(':
00893       return read_list(port, stxsrc, line, col, pos, ch, ')', mz_shape_cons, 0, ht, indentation, params);
00894     case '[':
00895       if (!params->square_brackets_are_parens) {
00896        scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open square bracket");
00897        return NULL;
00898       } else
00899        return read_list(port, stxsrc, line, col, pos, ch, ']', mz_shape_cons, 0, ht, indentation, params);
00900     case '{':
00901       if (!params->curly_braces_are_parens) {
00902        scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open curly brace");
00903        return NULL;
00904       } else
00905        return read_list(port, stxsrc, line, col, pos, ch, '}', mz_shape_cons, 0, ht, indentation, params);
00906     case '|':
00907       special_value = read_symbol(ch, 1, port, stxsrc, line, col, pos, ht, indentation, params, table);
00908       break;
00909     case '"':
00910       return read_string(0, 0, port, stxsrc, line, col, pos, ht, indentation, params, 1);
00911     case '\'':
00912       if (params->honu_mode) {
00913        return read_string(0, 1, port, stxsrc, line, col, pos, ht, indentation, params, 1);
00914       } else {
00915        return read_quote("quoting '", quote_symbol, 1, port, stxsrc, line, col, pos, ht, indentation, params);
00916       }
00917     case '`':
00918       if (params->honu_mode) {
00919        /* Raises illegal-char error: */
00920        return read_symbol(ch, 1, port, stxsrc, line, col, pos, ht, indentation, params, table);
00921       } else if (!params->can_read_quasi) {
00922        scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of backquote");
00923        return NULL;
00924       } else
00925        return read_quote("quasiquoting `", quasiquote_symbol, 1, port, stxsrc, line, col, pos, ht, indentation, params);
00926     case ',':
00927       if (params->honu_mode) {
00928        if (stxsrc)
00929          return scheme_make_stx_w_offset(honu_comma, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
00930        else
00931          return honu_comma;
00932       } else if (!params->can_read_quasi) {
00933        scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of comma");
00934        return NULL;
00935       } else {
00936        if (scheme_peekc_special_ok(port) == '@') {
00937          ch = scheme_getc(port); /* must be '@' */
00938          return read_quote("unquoting ,@", unquote_splicing_symbol, 2, port, stxsrc, line, col, pos, ht, indentation, params);
00939        } else
00940          return read_quote("unquoting ,", unquote_symbol, 1, port, stxsrc, line, col, pos, ht, indentation, params);
00941       }
00942     case ';':
00943       if (params->honu_mode) {
00944        if (stxsrc)
00945          return scheme_make_stx_w_offset(honu_semicolon, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
00946        else
00947          return honu_semicolon;
00948       } else {
00949        while (((ch = scheme_getc_special_ok(port)) != '\n') 
00950                && !is_line_comment_end(ch)) {
00951          if (ch == EOF) {
00952             if (comment_mode & RETURN_FOR_COMMENT)
00953               return NULL;
00954            return scheme_eof;
00955           }
00956          if (ch == SCHEME_SPECIAL)
00957            scheme_get_ready_read_special(port, stxsrc, ht);
00958        }
00959        if ((table && (comment_mode & RETURN_FOR_SPECIAL_COMMENT))
00960            || (comment_mode & RETURN_FOR_COMMENT))
00961          return NULL;
00962        goto start_over;
00963       }
00964     case '+':
00965     case '-':
00966       if (params->honu_mode) {
00967        special_value = read_symbol(ch, 1, port, stxsrc, line, col, pos, ht, indentation, params, table);
00968        break;
00969       }
00970     case '.': /* ^^^ fallthrough ^^^ */
00971       ch2 = scheme_peekc_special_ok(port);
00972       if ((NOT_EOF_OR_SPECIAL(ch2) && isdigit_ascii(ch2)) || (ch2 == '.')
00973          || (!params->honu_mode
00974              && ((ch2 == 'i') || (ch2 == 'I') /* Maybe inf */
00975                 || (ch2 == 'n') || (ch2 == 'N') /* Maybe nan*/ ))) {
00976        /* read_number tries to get a number, but produces a symbol if number parsing doesn't work: */
00977        special_value = read_number(ch, port, stxsrc, line, col, pos, 0, 0, 10, 0, ht, indentation, params, table);
00978       } else {
00979        special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
00980       }
00981       break;
00982     case '#':
00983       ch = scheme_getc_special_ok(port);
00984 
00985       if (get_info && (ch != '|') && (ch != '!') && (ch != 'l') && (ch != ';')) {
00986         return expected_lang("#", ch, port, stxsrc, line, col, pos, get_info);
00987       }
00988 
00989       if (table) {
00990        Scheme_Object *v;
00991        int use_default;
00992        v = readtable_handle_hash(table, ch, &use_default, params,
00993                               port, stxsrc, line, col, pos, ht);
00994        if (!use_default) {
00995          if (v)
00996            return v;
00997          if (comment_mode & RETURN_FOR_SPECIAL_COMMENT)
00998            return NULL;
00999          goto start_over;
01000        }
01001       }
01002 
01003       special_value = NULL;
01004 
01005       switch (ch)
01006        {
01007        case EOF:
01008        case SCHEME_SPECIAL:
01009          scheme_read_err(port, stxsrc, line, col, pos, 1, ch, indentation, "read: bad syntax `#'");
01010          break;
01011        case ';':
01012          {
01013            Scheme_Object *skipped;
01014            skipped = read_inner(port, stxsrc, ht, indentation, params, 0);
01015            if (SCHEME_EOFP(skipped))
01016              scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation,
01017                            "read: expected a commented-out element for `#;' (found end-of-file)");
01018            /* For resolving graphs introduced in #; : */
01019            if (*ht) {
01020              Scheme_Object *v;
01021              v = scheme_hash_get(*ht, unresolved_uninterned_symbol);
01022              if (!v)
01023               v = scheme_null;
01024              v = scheme_make_pair(skipped, v);
01025              scheme_hash_set(*ht, unresolved_uninterned_symbol, v);
01026            }
01027 
01028            if ((comment_mode & RETURN_FOR_HASH_COMMENT)
01029               || (table && (comment_mode & RETURN_FOR_SPECIAL_COMMENT))
01030               || (comment_mode & RETURN_FOR_COMMENT))
01031              return NULL;
01032 
01033            goto start_over;
01034          }
01035          break;
01036        case '%':
01037          if (!params->honu_mode) {
01038            scheme_ungetc('%', port);
01039            special_value = read_symbol('#', 1, port, stxsrc, line, col, pos, ht, indentation, params, table);
01040          }
01041          break;
01042        case ':':
01043          if (!params->honu_mode) {
01044            return read_keyword(-1, port, stxsrc, line, col, pos, ht, indentation, params, table);
01045          }
01046          break;
01047        case '(':
01048          if (!params->honu_mode) {
01049            return read_vector(port, stxsrc, line, col, pos, ch, ')', -1, NULL, ht, indentation, params, 0);
01050          }
01051          break;
01052        case '[':
01053          if (!params->honu_mode) {
01054            if (!params->square_brackets_are_parens) {
01055              scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#['");
01056              return NULL;
01057            } else
01058              return read_vector(port, stxsrc, line, col, pos, ch, ']', -1, NULL, ht, indentation, params, 0);
01059          }
01060          break;
01061        case '{':
01062          if (!params->honu_mode) {
01063            if (!params->curly_braces_are_parens) {
01064              scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#{'");
01065              return NULL;
01066            } else
01067              return read_vector(port, stxsrc, line, col, pos, ch, '}', -1, NULL, ht, indentation, params, 0);
01068          }
01069          break;
01070        case '\\':
01071          if (!params->honu_mode) {
01072            Scheme_Object *chr;
01073            chr = read_character(port, stxsrc, line, col, pos, ht, indentation, params);
01074            if (stxsrc)
01075              chr = scheme_make_stx_w_offset(chr, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
01076            return chr;
01077          }
01078          break;
01079        case 'T':
01080        case 't': 
01081          if (!params->honu_mode) {
01082            return (stxsrc
01083                   ? scheme_make_stx_w_offset(scheme_true, line, col, pos, 2, stxsrc, STX_SRCTAG)
01084                   : scheme_true);
01085          }
01086        case 'F':
01087        case 'f': 
01088          if (!params->honu_mode) {
01089            return (stxsrc
01090                   ? scheme_make_stx_w_offset(scheme_false, line, col, pos, 2, stxsrc, STX_SRCTAG)
01091                   : scheme_false);
01092          }
01093        case 'c':
01094        case 'C':
01095          if (!params->honu_mode) {
01096            Scheme_Object *v;
01097            int sens = 0;
01098            int save_sens;
01099 
01100            ch = scheme_getc_special_ok(port);
01101            switch ( ch ) {
01102            case 'i':
01103            case 'I':
01104              sens = 0;
01105              break;
01106            case 's':
01107            case 'S':
01108              sens = 1;
01109              break;
01110            default:
01111              scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation,
01112                            "read: expected `s' or `i' after #c");
01113              return NULL;
01114            }
01115 
01116 
01117            save_sens = params->case_sensitive;
01118            params->case_sensitive = sens;
01119            
01120            v = read_inner(port, stxsrc, ht, indentation, params, 0);
01121            
01122            params->case_sensitive = save_sens;
01123            
01124            if (SCHEME_EOFP(v)) {
01125              scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation,
01126                            "read: end-of-file after #c%c",
01127                            sens ? 's' : 'i');
01128              return NULL;
01129            }
01130 
01131            return v;
01132          }
01133          break;
01134        case 's':
01135        case 'S':
01136           {
01137             int orig_ch = ch, effective_ch;
01138             ch = scheme_getc_special_ok(port);
01139             if (NOT_EOF_OR_SPECIAL(ch))
01140               effective_ch = readtable_effective_char(params->table, ch);
01141             else
01142               effective_ch = ch;
01143             if ((orig_ch == 's') 
01144                 && ((effective_ch == '(')
01145                     || (effective_ch == '[' && params->square_brackets_are_parens)
01146                     || (effective_ch == '{' && params->curly_braces_are_parens))) {
01147               Scheme_Object *v;
01148               Scheme_Struct_Type *st;
01149               
01150               if (effective_ch == '(')
01151                 ch = ')';
01152               else if (effective_ch == '[')
01153                 ch = ']';
01154               else if (effective_ch == '{')
01155                 ch = '}';
01156 
01157               v = read_vector(port, stxsrc, line, col, pos, orig_ch, ch, -1, NULL, ht, indentation, params, 1);
01158               if (stxsrc)
01159                 v = SCHEME_STX_VAL(v);
01160 
01161               if (SCHEME_VEC_SIZE(v)) {
01162                 Scheme_Object *key;
01163                 key = SCHEME_VEC_ELS(v)[0];
01164                 if (stxsrc)
01165                   key = scheme_syntax_to_datum(key, 0, NULL);
01166                 st = scheme_lookup_prefab_type(key, SCHEME_VEC_SIZE(v) - 1);
01167               } else
01168                 st = NULL;
01169 
01170               if (!st || (st->num_slots != (SCHEME_VEC_SIZE(v) - 1))) {
01171                 scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), EOF, indentation,
01172                                 (SCHEME_VEC_SIZE(v)
01173                                  ? (st
01174                                     ? ("read: mismatch between structure description"
01175                                        " and number of provided field values in `#s' form")
01176                                     : "read: invalid structure description in `#s' form")
01177                                  : "read: missing structure description in `#s' form"));
01178                 return NULL;
01179               }
01180 
01181               if (stxsrc && !(MZ_OPT_HASH_KEY(&st->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
01182                 scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), EOF, indentation,
01183                                 "read: cannot read mutable `#s' form as syntax");
01184               }
01185 
01186               v = scheme_make_prefab_struct_instance(st, v);
01187 
01188               if (stxsrc)
01189                 v = scheme_make_stx_w_offset(v, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
01190 
01191               return v;
01192             } else if ((ch == 'x') || (ch == 'X')) {
01193               ReadParams params_copy;
01194               Scheme_Object *v;
01195 
01196               memcpy(&params_copy, params, sizeof(ReadParams));
01197               params_copy.honu_mode = 0;
01198 
01199               v = read_inner(port, stxsrc, ht, indentation, &params_copy, 0);
01200 
01201               if (SCHEME_EOFP(v)) {
01202                 scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation,
01203                                 "read: end-of-file after #sx");
01204                 return NULL;
01205               }
01206 
01207               return v;
01208             } else {
01209               scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation,
01210                               "read: expected `x'%s after `#%c'",
01211                               (orig_ch == 's' ? "or `('" : ""),
01212                               orig_ch);
01213               return NULL;
01214             }
01215           }
01216        case 'X':
01217        case 'x': 
01218          if (!params->honu_mode) {
01219            return read_number(-1, port, stxsrc, line, col, pos, 0, 0, 16, 1, ht, indentation, params, table);
01220          }
01221          break;
01222        case 'B':
01223        case 'b': 
01224          if (!params->honu_mode) {
01225            return read_number(-1, port, stxsrc, line, col, pos, 0, 0, 2, 1, ht, indentation, params, table);
01226          }
01227          break;
01228        case 'O':
01229        case 'o': 
01230          if (!params->honu_mode) {
01231            return read_number(-1, port, stxsrc, line, col, pos, 0, 0, 8, 1, ht, indentation, params, table);
01232          }
01233          break;
01234        case 'D':
01235        case 'd': 
01236          if (!params->honu_mode) {
01237            return read_number(-1, port, stxsrc, line, col, pos, 0, 0, 10, 1, ht, indentation, params, table);
01238          }
01239          break;
01240        case 'E':
01241        case 'e': 
01242          if (!params->honu_mode) {
01243            return read_number(-1, port, stxsrc, line, col, pos, 0, 1, 10, 0, ht, indentation, params, table);
01244          }
01245          break;
01246        case 'I':
01247        case 'i': 
01248          if (!params->honu_mode) {
01249            return read_number(-1, port, stxsrc, line, col, pos, 1, 0, 10, 0, ht, indentation, params, table);
01250          }
01251          break;
01252        case '\'':
01253          if (!params->honu_mode) {
01254            return read_quote("quoting #'", syntax_symbol, 2, port, stxsrc, line, col, pos, ht, indentation, params);
01255          }
01256          break;
01257        case '`':
01258          if (!params->honu_mode) {
01259            return read_quote("quasiquoting #`", quasisyntax_symbol, 2, port, stxsrc, line, col, pos, ht, indentation, params);
01260          }
01261          break;
01262        case ',':
01263          if (!params->honu_mode) {
01264            if (scheme_peekc_special_ok(port) == '@') {
01265              ch = scheme_getc(port); /* must be '@' */
01266              return read_quote("unquoting #`@", unsyntax_splicing_symbol, 3, port, stxsrc, line, col, pos, ht, indentation, params);
01267            } else
01268              return read_quote("unquoting #`", unsyntax_symbol, 2, port, stxsrc, line, col, pos, ht, indentation, params);
01269          }
01270          break;
01271        case '~':
01272          if (!params->honu_mode) {
01273            if (params->can_read_compiled) {
01274              Scheme_Object *cpld;
01275              cpld = read_compiled(port, stxsrc, line, col, pos, ht, params);
01276              if (stxsrc)
01277               cpld = scheme_make_stx_w_offset(cpld, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
01278              return cpld;
01279            } else {
01280              scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation,
01281                            "read: #~ compiled expressions not currently enabled");
01282              return NULL;
01283            }
01284          }
01285          break;
01286        case '|':
01287          if (!params->honu_mode) {
01288            /* FIXME: integer overflow possible */
01289            depth = 0;
01290            ch2 = 0;
01291            do {
01292              ch = scheme_getc_special_ok(port);
01293 
01294              if (ch == EOF)
01295               scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation,
01296                             "read: end of file in #| comment");
01297              else if (ch == SCHEME_SPECIAL)
01298               scheme_get_ready_read_special(port, stxsrc, ht);
01299 
01300              if ((ch2 == '|') && (ch == '#')) {
01301               if (!(depth--)) {
01302                 if ((table && (comment_mode & RETURN_FOR_SPECIAL_COMMENT))
01303                     || (comment_mode & RETURN_FOR_COMMENT))
01304                   return NULL;
01305                 goto start_over;
01306               }
01307               ch = 0; /* So we don't count '#' toward an opening "#|" */
01308              } else if ((ch2 == '#') && (ch == '|')) {
01309               depth++;
01310               ch = 0; /* So we don't count '|' toward a closing "|#" */
01311              }
01312              ch2 = ch;
01313            } while (1);
01314          }
01315          break;
01316        case '&':
01317          if (!params->honu_mode) {
01318            if (params->can_read_box)
01319              return read_box(port, stxsrc, line, col, pos, ht, indentation, params);
01320            else {
01321              scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation,
01322                            "read: #& expressions not currently enabled");
01323              return NULL;
01324            }
01325          }
01326          break;
01327         case 'l':
01328           {
01329             mzchar found[5];
01330             int fl = 1;
01331             found[0] = 'l';
01332             ch = scheme_getc_special_ok(port);
01333             found[fl++] = ch;
01334            if (ch == 'a') {
01335               ch = scheme_getc_special_ok(port);
01336               found[fl++] = ch;
01337               if (ch == 'n') {
01338                 ch = scheme_getc_special_ok(port);
01339                 found[fl++] = ch;
01340                 if (ch == 'g') {
01341                   ch = scheme_getc_special_ok(port);
01342                   found[fl++] = ch;
01343                   if (ch == ' ') {
01344                     /* #lang */
01345                     Scheme_Object *v;
01346                     if (!params->can_read_reader) {
01347                       scheme_read_err(port, stxsrc, line, col, pos, 6, 0, indentation,
01348                                       "read: #lang expressions not currently enabled");
01349                       return NULL;
01350                     }
01351                     v = read_lang(port, stxsrc, line, col, pos, get_info, ht, indentation, params, 0);
01352                     if (!v) {
01353                       if (comment_mode & RETURN_FOR_SPECIAL_COMMENT)
01354                         return NULL;
01355                       goto start_over;
01356                     }
01357                     return v;
01358                   } else {
01359                     scheme_read_err(port, stxsrc, line, col, pos, 6, ch, indentation,
01360                                     "read: expected a single space after `#lang'",
01361                                     found, fl);
01362                     return NULL;
01363                   }
01364                 }
01365               }
01366             }
01367             scheme_read_err(port, stxsrc, line, col, pos, fl, ch, indentation,
01368                             "read: bad input: `#%u'",
01369                             found, fl);
01370             return NULL;
01371           }
01372           break;
01373        case 'r':
01374        case 'p':
01375          if (!params->honu_mode) {
01376            int orig_ch = ch;
01377            int cnt = 0, is_byte = 0;
01378            char *expect;
01379 
01380            ch = scheme_getc_special_ok(port);
01381            if (ch == 'x') {
01382              expect = "x#";
01383              ch = scheme_getc_special_ok(port);
01384              cnt++;
01385              if (ch == '#') {
01386               is_byte = 1;
01387               cnt++;
01388               ch = scheme_getc_special_ok(port);
01389              }
01390              if (ch == '"') {
01391               Scheme_Object *str;
01392               int is_err;
01393                 long sline = 0, scol = 0, spos = 0;
01394 
01395               /* Skip #rx[#]: */
01396               scheme_tell_all(port, &sline, &scol, &spos);
01397 
01398               str = read_string(is_byte, 0, port, stxsrc, sline, scol, spos, ht, indentation, params, 1);
01399 
01400               if (stxsrc)
01401                 str = SCHEME_STX_VAL(str);
01402 
01403               str = scheme_make_regexp(str, is_byte, (orig_ch == 'p'), &is_err);
01404 
01405               if (is_err) {
01406                 scheme_read_err(port, stxsrc, sline, scol, spos, 2, 0, indentation,
01407                               "read: bad %sregexp string: %s", 
01408                               (orig_ch == 'r') ? "" : "p",
01409                               (char *)str);
01410                 return NULL;
01411               }
01412 
01413               if (stxsrc)
01414                 str = scheme_make_stx_w_offset(str, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
01415 
01416               return str;
01417              }
01418            } else if ((orig_ch == 'r') && (ch == 'e')) {
01419              expect = "eader";
01420              cnt++;
01421              while (expect[cnt]) {
01422               ch = scheme_getc_special_ok(port);
01423               if (ch != expect[cnt])
01424                 break;
01425               cnt++;
01426              }
01427              if (!expect[cnt]) {
01428               /* Found #reader. Read an S-exp. */
01429               Scheme_Object *v;
01430 
01431               if (!params->can_read_reader) {
01432                 scheme_read_err(port, stxsrc, line, col, pos, 7, 0, indentation,
01433                               "read: #reader expressions not currently enabled");
01434                 return NULL;
01435               }
01436 
01437               v = read_reader(port, stxsrc, line, col, pos, ht, indentation, params);
01438               if (!v) {
01439                 if (comment_mode & RETURN_FOR_SPECIAL_COMMENT)
01440                   return NULL;
01441                 goto start_over;
01442               }
01443               return v;
01444              }
01445            } else
01446              expect = "";
01447 
01448            {
01449              mzchar a[6];
01450              int i;
01451 
01452              for (i = 0; i < cnt; i++) {
01453               a[i] = expect[i];
01454              }
01455              if (NOT_EOF_OR_SPECIAL(ch)) {
01456               a[cnt++] = ch;
01457              }
01458 
01459              scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos),
01460                            ch, indentation,
01461                            "read: bad syntax `#%c%u'",
01462                            orig_ch, a, cnt);
01463              return NULL;
01464            }
01465          }
01466          break;
01467        case 'h':
01468          {
01469            int honu = 0;
01470 
01471            ch = scheme_getc_special_ok(port);
01472            switch ( ch ) {
01473            case 'a':
01474              honu = 0;
01475              break;
01476            case 'x':
01477              honu = 1;
01478              break;
01479            default:
01480              if (!params->honu_mode) {
01481               scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation,
01482                             "read: expected `a' or `x' after #h");
01483               return NULL;
01484              }
01485              honu = 0;
01486              break;
01487            }
01488 
01489            if (params->honu_mode && (honu != 1)) {
01490              scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation,
01491                            "read: expected `x' after #h");
01492              return NULL;
01493            }
01494 
01495            if (honu) {
01496              ReadParams params_copy;
01497              Scheme_Object *v;
01498 
01499              memcpy(&params_copy, params, sizeof(ReadParams));
01500              params_copy.honu_mode = 1;
01501 
01502               v = read_inner(port, stxsrc, ht, indentation, &params_copy, 0);
01503               if (SCHEME_EOFP(v)) {
01504                 scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation,
01505                                 "read: end-of-file after #hx");
01506                 return NULL;
01507               }
01508 
01509              return v;
01510            } else {
01511              GC_CAN_IGNORE const mzchar str[] = { 's', 'h', 'e', 'q', 'v', 0 };
01512              int scanpos = 0, failed = 0;
01513 
01514              do {
01515               ch = scheme_getc_special_ok(port);
01516               if ((mzchar)ch == str[scanpos]) {
01517                 scanpos++;
01518               } else {
01519                 if ((scanpos == 2) || (scanpos == 4)) {
01520                     int effective_ch;
01521                     effective_ch = readtable_effective_char(table, ch);
01522                   if (!(effective_ch == '(')
01523                      && !(effective_ch == '[' && params->square_brackets_are_parens)
01524                      && !(effective_ch == '{' && params->curly_braces_are_parens))
01525                     failed = 1;
01526                 } else
01527                   failed = 1;
01528                 break;
01529               }
01530              } while (str[scanpos]);
01531 
01532              if (!failed) {
01533               /* Found recognized tag. Look for open paren... */
01534                 int effective_ch, kind;
01535 
01536               if (scanpos > 4)
01537                 ch = scheme_getc_special_ok(port);
01538                 
01539                 effective_ch = readtable_effective_char(table, ch);
01540 
01541                 if (scanpos == 4)
01542                   kind = 0;
01543                 else if (scanpos == 2)
01544                   kind = 1;
01545                 else 
01546                   kind = 2;
01547 
01548               if (effective_ch == '(')
01549                 return read_hash(port, stxsrc, line, col, pos, ch, ')', kind, ht, indentation, params);
01550               if (effective_ch == '[' && params->square_brackets_are_parens)
01551                 return read_hash(port, stxsrc, line, col, pos, ch, ']', kind, ht, indentation, params);
01552               if (effective_ch == '{' && params->curly_braces_are_parens)
01553                 return read_hash(port, stxsrc, line, col, pos, ch, '}', kind, ht, indentation, params);
01554              }
01555 
01556              /* Report an error. So far, we read 'ha', then scanpos chars of str, then ch. */
01557              {
01558               mzchar str_part[7], one_more[2];
01559 
01560               memcpy(str_part, str, scanpos * sizeof(mzchar));
01561               str_part[scanpos] = 0;
01562               if (NOT_EOF_OR_SPECIAL(ch)) {
01563                 one_more[0] = ch;
01564                 one_more[1] = 0;
01565               } else
01566                 one_more[0] = 0;
01567 
01568               scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos),
01569                             ch, indentation,
01570                             "read: bad syntax `#ha%5%u'",
01571                             str_part,
01572                             one_more, NOT_EOF_OR_SPECIAL(ch) ? 1 : 0);
01573               return NULL;
01574              }
01575            }
01576          }
01577          break;
01578        case '"':
01579          if (!params->honu_mode) {
01580            return read_string(1, 0, port, stxsrc, line, col, pos, ht, indentation, params, 1);
01581          }
01582          break;
01583        case '<':
01584          if (!params->honu_mode) {
01585            if (scheme_peekc_special_ok(port) == '<') {
01586              /* Here-string */
01587              ch = scheme_getc_special_ok(port);
01588              return read_here_string(port, stxsrc, line, col, pos,indentation, params);
01589            } else {
01590              scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#<'");
01591              return NULL;
01592            }
01593          }
01594          break;
01595         case '!':
01596           ch = scheme_getc_special_ok(port);
01597           if ((ch == ' ') || (ch == '/')) {
01598             /* line comment, with '\' as a continuation */
01599             int was_backslash = 0, was_backslash_cr = 0, prev_backslash_cr;
01600             while(1) {
01601               prev_backslash_cr = was_backslash_cr;
01602               was_backslash_cr = 0;
01603               ch = scheme_getc_special_ok(port);
01604               if (ch == EOF) {
01605                 break;
01606               } else if (ch == SCHEME_SPECIAL) {
01607               scheme_get_ready_read_special(port, stxsrc, ht);
01608               } else if (ch == '\r') {
01609                 if (was_backslash) {
01610                   was_backslash_cr = 1;
01611                 } else
01612                   break;
01613               } else if (ch == '\n') {
01614                 if (!was_backslash && !was_backslash_cr)
01615                   break;
01616               }
01617               was_backslash = (ch == '\\');
01618             }
01619             if (comment_mode & RETURN_FOR_COMMENT)
01620               return NULL;
01621             goto start_over;
01622           } else if ((ch < 128) && is_lang_nonsep_char(ch)) {
01623             Scheme_Object *v;
01624             if (!params->can_read_reader) {
01625               scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation,
01626                               "read: #! reader expressions not currently enabled");
01627               return NULL;
01628             }
01629             v = read_lang(port, stxsrc, line, col, pos, get_info, ht, indentation, params, ch);
01630             if (!v) {
01631               if (comment_mode & RETURN_FOR_SPECIAL_COMMENT)
01632                 return NULL;
01633               goto start_over;
01634             }
01635             return v;
01636           } else {
01637             if (NOT_EOF_OR_SPECIAL(ch))
01638               scheme_read_err(port, stxsrc, line, col, pos, 3, 
01639                               ch, indentation, "read: bad syntax `#!%c'", ch);
01640             else
01641               scheme_read_err(port, stxsrc, line, col, pos, 2, 
01642                               ch, indentation, "read: bad syntax `#!'", ch);
01643             return NULL;
01644           }
01645           break;
01646        default:
01647          if (!params->honu_mode) {
01648            int vector_length = -1;
01649            int i = 0, j = 0, overflow = 0, digits = 0, effective_ch;
01650            mzchar tagbuf[64], vecbuf[64]; /* just for errors */
01651 
01652            while (NOT_EOF_OR_SPECIAL(ch) && isdigit_ascii(ch)) {
01653              if (digits <= MAX_GRAPH_ID_DIGITS)
01654               digits++;
01655 
01656              /* For vector error msgs, want to drop leading zeros: */
01657              if (j || (ch != '0')) {
01658               if (j < 60) {
01659                 vecbuf[j++] = ch;
01660               } else if (j == 60) {
01661                 vecbuf[j++] = '.';
01662                 vecbuf[j++] = '.';
01663                 vecbuf[j++] = '.';
01664                 vecbuf[j] = 0;
01665               }
01666              }
01667 
01668              /* For tag error msgs, want to keep zeros: */
01669              if (i < 60) {
01670               tagbuf[i++] = ch;
01671              } else if (i == 60) {
01672               tagbuf[i++] = '.';
01673               tagbuf[i++] = '.';
01674               tagbuf[i++] = '.';
01675               tagbuf[i] = 0;
01676              }
01677 
01678              if (!overflow) {
01679               long old_len;
01680 
01681               if (vector_length < 0)
01682                 vector_length = 0;
01683 
01684               old_len = vector_length;
01685               vector_length = (vector_length * 10) + (ch - 48);
01686               if ((vector_length < 0)|| ((vector_length / 10) != old_len)) {
01687                 overflow = 1;
01688               }
01689              }
01690              ch = scheme_getc_special_ok(port);
01691            }
01692 
01693            if (overflow)
01694              vector_length = -2;
01695            vecbuf[j] = 0;
01696            tagbuf[i] = 0;
01697 
01698             effective_ch = readtable_effective_char(table, ch);
01699 
01700            if (effective_ch == '(')
01701              return read_vector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, 0);
01702            if (effective_ch == '[' && params->square_brackets_are_parens)
01703              return read_vector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, 0);
01704            if (effective_ch == '{' && params->curly_braces_are_parens)
01705              return read_vector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, 0);
01706 
01707            if (ch == '#' && (vector_length != -1)) {
01708              /* Not a vector after all: a graph reference */
01709              Scheme_Object *ph;
01710 
01711              if (stxsrc)
01712               scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
01713                             "read: #..# expressions not allowed in read-syntax mode");
01714 
01715              if (!params->can_read_graph)
01716               scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
01717                             "read: #..# expressions not currently enabled");
01718 
01719              if (digits > MAX_GRAPH_ID_DIGITS)
01720               scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
01721                             "read: graph id too long in #%5#",
01722                             tagbuf);
01723 
01724              if (*ht)
01725               ph = (Scheme_Object *)scheme_hash_get(*ht, scheme_make_integer(vector_length));
01726              else
01727               ph = NULL;
01728 
01729              if (!ph) {
01730               scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
01731                             "read: no #%ld= preceding #%ld#",
01732                             vector_length, vector_length);
01733               return scheme_void;
01734              }
01735              return ph;
01736            }
01737            if (ch == '=' && (vector_length != -1)) {
01738              /* Not a vector after all: a graph definition */
01739              Scheme_Object *v, *ph;
01740               long in_pos;
01741 
01742              if (stxsrc)
01743               scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
01744                             "read: #..= expressions not allowed in read-syntax mode");
01745 
01746              if (!params->can_read_graph)
01747               scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
01748                              "read: #..= expressions not currently enabled");
01749 
01750              if (digits > MAX_GRAPH_ID_DIGITS)
01751               scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
01752                              "read: graph id too long in #%s=",
01753                              tagbuf);
01754 
01755              if (*ht) {
01756               if (scheme_hash_get(*ht, scheme_make_integer(vector_length))) {
01757                 scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
01758                               "read: multiple #%ld= tags",
01759                               vector_length);
01760                 return NULL;
01761               }
01762              } else {
01763               Scheme_Hash_Table *tht;
01764               tht = scheme_make_hash_table(SCHEME_hash_ptr);
01765               *ht = tht;
01766              }
01767              ph = scheme_alloc_small_object();
01768              ph->type = scheme_placeholder_type;
01769 
01770              scheme_hash_set(*ht, scheme_make_integer(vector_length), (void *)ph);
01771 
01772               scheme_tell_all(port, NULL, NULL, &in_pos);
01773 
01774              v = read_inner(port, stxsrc, ht, indentation, params, 0);
01775              if (SCHEME_EOFP(v))
01776               scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, in_pos-pos), EOF, indentation,
01777                             "read: expected an element for graph (found end-of-file)");
01778              SCHEME_PTR_VAL(ph) = v;
01779 
01780              return v;
01781            }
01782 
01783            {
01784              char *lbuffer;
01785              int pch = ch, ulen, blen;
01786 
01787              if ((pch == EOF) || (pch == SCHEME_SPECIAL))
01788               pch = 0;
01789 
01790              ulen = scheme_char_strlen(tagbuf);
01791              blen = scheme_utf8_encode_all(tagbuf, ulen, NULL);
01792              lbuffer = (char *)scheme_malloc_atomic(blen + MAX_UTF8_CHAR_BYTES + 1);
01793              scheme_utf8_encode_all(tagbuf, ulen, (unsigned char *)lbuffer);
01794              blen += scheme_utf8_encode((mzchar *)&pch, 0, 1,
01795                                     (unsigned char *)lbuffer, blen,
01796                                     0);
01797              lbuffer[blen] = 0;
01798 
01799              scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation,
01800                            "read: bad syntax `#%s'",
01801                            lbuffer);
01802 
01803              return NULL;
01804            }
01805          }
01806          break;
01807        }
01808       if (!special_value) {
01809        /* We get here only in honu mode */
01810        scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation,
01811                      "read: bad syntax `#%c'",
01812                      ch);
01813        return NULL;
01814       }
01815       break;
01816     case '/':
01817       if (params->honu_mode) {
01818        int ch2;
01819        ch2 = scheme_peekc_special_ok(port);
01820        if ((ch2 == '/') || (ch2 == '*')) {
01821          /* Comment */
01822          scheme_ungetc('/', port);
01823          ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params);
01824          goto start_over_with_ch;
01825        }
01826       }
01827       special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
01828       break;
01829     case '>':
01830     case '<':
01831       if ((params->honu_mode) && (comment_mode & RETURN_HONU_ANGLE)) {
01832         Scheme_Object *v;
01833         v = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
01834         special_value = v;
01835         if (SCHEME_STXP(v))
01836           v = SCHEME_STX_VAL(v);
01837         if (SCHEME_SYMBOLP(v) && (SCHEME_SYM_LEN(v) == 1)
01838             && ((SCHEME_SYM_VAL(v)[0] == '>') || (SCHEME_SYM_VAL(v)[0] == '<'))) {
01839           if (SCHEME_SYM_VAL(v)[0] == '<')
01840             v = honu_angle_open;
01841           else
01842             v = honu_angle_close;
01843           if (SCHEME_STXP(special_value))
01844             special_value = scheme_datum_to_syntax(v, scheme_false, special_value, 0, 1);
01845           else
01846             special_value = v;
01847         }
01848       } else
01849         special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
01850       break;
01851     default:
01852       if (isdigit_ascii(ch))
01853        special_value = read_number(ch, port, stxsrc, line, col, pos, 0, 0, 10, 0, ht, indentation, params, table);
01854       else
01855        special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
01856       break;
01857     }
01858 
01859   /* We get here after reading a "symbol". Check for a comment. */
01860   {
01861     Scheme_Object *v = special_value;
01862 
01863     if (scheme_special_comment_value(v)) {
01864       /* a "comment" */
01865       if (comment_mode & RETURN_FOR_SPECIAL_COMMENT)
01866        return NULL;
01867       else {
01868        special_value_need_copy = 0;
01869        goto start_over;
01870       }
01871     } else if (SCHEME_STXP(v)) {
01872       if (!stxsrc)
01873        v = scheme_syntax_to_datum(v, 0, NULL);
01874     } else if (stxsrc) {
01875       Scheme_Object *s;
01876       s = scheme_make_stx_w_offset(scheme_false, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
01877       v = scheme_datum_to_syntax(v, s, scheme_false, 1, 0);
01878     }
01879     if (special_value_need_copy && !stxsrc) {
01880       set_need_copy(ht);
01881     }
01882     return v;
01883   }
01884 }
01885 
01886 static Scheme_Object *
01887 read_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht,
01888           Scheme_Object *indentation, ReadParams *params,
01889           int comment_mode)
01890 {
01891   return read_inner_inner(port, stxsrc, ht, indentation, params, comment_mode, -1, params->table, 0);
01892 }
01893 
01894 #ifdef DO_STACK_CHECK
01895 static Scheme_Object *resolve_references(Scheme_Object *obj,
01896                                     Scheme_Object *port,
01897                                     Scheme_Object *top,
01898                                          Scheme_Hash_Table *dht,
01899                                          Scheme_Hash_Table *tht,
01900                                          int clone,
01901                                          int tail_depth);
01902 
01903 static Scheme_Object *resolve_k(void)
01904 {
01905   Scheme_Thread *p = scheme_current_thread;
01906   Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
01907   Scheme_Object *port = (Scheme_Object *)p->ku.k.p2;
01908   Scheme_Object *top = (Scheme_Object *)p->ku.k.p5;
01909   Scheme_Hash_Table *dht = (Scheme_Hash_Table *)p->ku.k.p3;
01910   Scheme_Hash_Table *tht = (Scheme_Hash_Table *)p->ku.k.p4;
01911 
01912   p->ku.k.p1 = NULL;
01913   p->ku.k.p2 = NULL;
01914   p->ku.k.p3 = NULL;
01915   p->ku.k.p4 = NULL;
01916   p->ku.k.p5 = NULL;
01917 
01918   return resolve_references(o, port, top, dht, tht, p->ku.k.i1, p->ku.k.i2);
01919 }
01920 #endif
01921 
01922 static Scheme_Object *resolve_references(Scheme_Object *obj,
01923                                     Scheme_Object *port,
01924                                     Scheme_Object *top,
01925                                     Scheme_Hash_Table *dht,
01926                                     Scheme_Hash_Table *tht,
01927                                          int clone,
01928                                          int tail_depth)
01929 {
01930   Scheme_Object *result;
01931 
01932 #ifdef DO_STACK_CHECK
01933   {
01934 # include "mzstkchk.h"
01935     {
01936       Scheme_Thread *p = scheme_current_thread;
01937       p->ku.k.p1 = (void *)obj;
01938       p->ku.k.p2 = (void *)port;
01939       p->ku.k.p5 = (void *)top;
01940       p->ku.k.p3 = (void *)dht;
01941       p->ku.k.p4 = (void *)tht;
01942       p->ku.k.i1 = clone;
01943       p->ku.k.i2 = tail_depth;
01944       return scheme_handle_stack_overflow(resolve_k);
01945     }
01946   }
01947 #endif
01948 
01949   SCHEME_USE_FUEL(1);
01950 
01951   if (SAME_TYPE(SCHEME_TYPE(obj), scheme_placeholder_type)) {
01952     Scheme_Object *start = obj;
01953     while (SAME_TYPE(SCHEME_TYPE(obj), scheme_placeholder_type)) {
01954       obj = (Scheme_Object *)SCHEME_PTR_VAL(obj);
01955       if (SAME_OBJ(start, obj)) {
01956         if (port)
01957           scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
01958                           "read: illegal placeholder cycle");
01959         else {
01960           scheme_arg_mismatch("make-reader-graph",
01961                               "illegal placeholder cycle in value: ",
01962                               top);
01963         }
01964         return NULL;
01965       }
01966     }
01967   }
01968 
01969   result = scheme_hash_get(dht, obj);
01970   if (result) {
01971     if (SCHEME_PAIRP(result)) {
01972       obj = scheme_hash_get(tht, result);
01973       if (obj && (SCHEME_INT_VAL(obj) == tail_depth))
01974         SCHEME_PAIR_FLAGS(result) |= PAIR_IS_NON_LIST;
01975     }
01976     return result;
01977   }
01978 
01979   result = obj;
01980 
01981   if (SCHEME_PAIRP(obj)) {
01982     Scheme_Object *rr;
01983 
01984     if (clone)
01985       result = scheme_make_pair(scheme_false, scheme_false);
01986     scheme_hash_set(dht, obj, result);
01987 
01988     rr = resolve_references(SCHEME_CAR(obj), port, top, dht, tht, clone, tail_depth + 1);
01989     SCHEME_CAR(result) = rr;
01990 
01991     scheme_hash_set(tht, result, scheme_make_integer(tail_depth));
01992 
01993     rr = resolve_references(SCHEME_CDR(obj), port, top, dht, tht, clone, tail_depth);
01994     SCHEME_CDR(result) = rr;
01995 
01996     scheme_hash_set(tht, result, NULL);
01997 
01998     if (clone
01999         && SAME_OBJ(SCHEME_CAR(obj), SCHEME_CAR(result))
02000         && SAME_OBJ(SCHEME_CDR(obj), SCHEME_CDR(result))) {
02001       /* No changes, so we don't actually have to clone. */
02002       result = obj;
02003       scheme_hash_set(dht, obj, result);
02004     }
02005   } else if (SCHEME_BOXP(obj)) {
02006     Scheme_Object *rr;
02007 
02008     if (clone) {
02009       result = scheme_box(scheme_false);
02010       if (SCHEME_IMMUTABLEP(obj))
02011         SCHEME_SET_IMMUTABLE(result);
02012     }
02013     scheme_hash_set(dht, obj, result);
02014 
02015     rr = resolve_references(SCHEME_BOX_VAL(obj), port, top, dht, tht, clone, tail_depth + 1);
02016     SCHEME_BOX_VAL(result) = rr;
02017 
02018     if (clone
02019         && SAME_OBJ(SCHEME_PTR_VAL(obj), SCHEME_PTR_VAL(result))) {
02020       result = obj;
02021       scheme_hash_set(dht, obj, result);
02022     }
02023   } else if (SCHEME_VECTORP(obj)) {
02024     int i, len, diff = 0;
02025     Scheme_Object *prev_rr, *prev_v;
02026 
02027     len = SCHEME_VEC_SIZE(obj);
02028 
02029     if (clone) {
02030       result = scheme_make_vector(len, scheme_false);
02031       if (SCHEME_IMMUTABLEP(obj))
02032         SCHEME_SET_IMMUTABLE(result);
02033     }
02034     scheme_hash_set(dht, obj, result);
02035 
02036     prev_v = prev_rr = NULL;
02037     for (i = 0; i < len; i++) {
02038       Scheme_Object *rr;
02039       if (SCHEME_VEC_ELS(obj)[i] == prev_v) {
02040        rr = prev_rr;
02041       } else {
02042        prev_v = SCHEME_VEC_ELS(obj)[i];
02043        rr = resolve_references(prev_v, port, top, dht, tht, clone, tail_depth + 1);
02044         if (!SAME_OBJ(prev_v, rr))
02045           diff = 1;
02046        prev_rr = rr;
02047       }
02048       SCHEME_VEC_ELS(result)[i] = rr;
02049     }
02050 
02051     if (clone && !diff) {
02052       result = obj;
02053       scheme_hash_set(dht, obj, result);
02054     }
02055   } else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_table_placeholder_type)
02056              || SCHEME_HASHTRP(obj)) {
02057     Scheme_Hash_Tree *t, *base;
02058     Scheme_Object *a, *key, *val, *lst;
02059     int kind;
02060 
02061     if (SCHEME_HASHTRP(obj)) {
02062       int i;
02063       if (scheme_is_hash_tree_equal(obj))
02064         kind = 1;
02065       else if (scheme_is_hash_tree_equal(obj))
02066         kind = 2;
02067       else
02068         kind = 0;
02069       t = (Scheme_Hash_Tree *)obj;
02070       lst = scheme_null;
02071       for (i = t->count; i--; ) {
02072         scheme_hash_tree_index(t, i, &key, &val);
02073         lst = scheme_make_pair(scheme_make_pair(key, val), lst);
02074       }
02075     } else {
02076       kind = SCHEME_PINT_VAL(obj);
02077       lst = SCHEME_IPTR_VAL(obj);
02078     }
02079 
02080     /* Create `t' to be overwritten, and create `base' to extend. */
02081     t = scheme_make_hash_tree(kind);
02082     base = scheme_make_hash_tree(kind);
02083 
02084     result = (Scheme_Object *)t;
02085     scheme_hash_set(dht, obj, result);
02086 
02087     lst = resolve_references(lst, port, top, dht, tht, clone, tail_depth + 1);
02088 
02089     for (; SCHEME_PAIRP(lst); lst = SCHEME_CDR(lst)) {
02090       a = SCHEME_CAR(lst);
02091       key = SCHEME_CAR(a);
02092       val = SCHEME_CDR(a);
02093      
02094       base = scheme_hash_tree_set(base, key, val);
02095     }
02096     
02097     t->count = base->count;
02098     t->root = base->root;
02099     t->elems_box = base->elems_box;
02100   } else if (SCHEME_HASHTP(obj)) {
02101     int i;
02102     Scheme_Object *key, *val, *l = scheme_null, *orig_l;
02103     Scheme_Hash_Table *t = (Scheme_Hash_Table *)obj, *t2;
02104 
02105     t2 = scheme_clone_hash_table(t);
02106     scheme_reset_hash_table(t2, NULL);
02107     result = (Scheme_Object *)t2;
02108 
02109     scheme_hash_set(dht, obj, (Scheme_Object *)t2);
02110     
02111     for (i = t->size; i--; ) {
02112       if (t->vals[i]) {
02113         key = t->keys[i];
02114         val = t->vals[i];
02115         l = scheme_make_pair(scheme_make_pair(key, val), l);
02116       }
02117     }
02118 
02119     orig_l = l;
02120     l = resolve_references(l, port, top, dht, tht, clone, tail_depth + 1);
02121 
02122     if (SAME_OBJ(l, orig_l)) {
02123       result = obj;
02124       scheme_hash_set(dht, obj, result);
02125     } else {
02126       for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
02127         val = SCHEME_CAR(l);
02128         key = SCHEME_CAR(val);
02129         val = SCHEME_CDR(val);
02130         
02131         scheme_hash_set(t2, key, val);
02132       }
02133     }
02134   } else if (SCHEME_STRUCTP(obj)) {
02135     Scheme_Structure *s = (Scheme_Structure *)obj;
02136     if (s->stype->prefab_key) {
02137       /* prefab */
02138       int c, i, diff;
02139       Scheme_Object *prev_v, *v;
02140 
02141       if (clone) {
02142         result = scheme_clone_prefab_struct_instance(s);
02143       }
02144       scheme_hash_set(dht, obj, result);
02145 
02146       c = s->stype->num_slots;
02147       diff = 0;
02148       for (i = 0; i < c; i++) {
02149         prev_v = s->slots[i];
02150        v = resolve_references(prev_v, port, top, dht, tht, clone, tail_depth + 1);
02151         if (!SAME_OBJ(prev_v, v))
02152           diff = 1;
02153         ((Scheme_Structure *)result)->slots[i] = v;
02154       }
02155 
02156       if (clone && !diff) {
02157         result = obj;
02158         scheme_hash_set(dht, obj, result);
02159       }
02160     }
02161   }
02162 
02163   return result;
02164 }
02165 
02166 static Scheme_Object *
02167 _internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cant_fail, int honu_mode, 
02168                int recur, int expose_comment, int extra_char, Scheme_Object *init_readtable,
02169                Scheme_Object *magic_sym, Scheme_Object *magic_val,
02170                Scheme_Object *delay_load_info, int get_info)
02171 {
02172   Scheme_Object *v, *v2;
02173   Scheme_Config *config;
02174   Scheme_Hash_Table **ht = NULL;
02175   ReadParams params;
02176 
02177   config = scheme_current_config();
02178 
02179   if (get_info) {
02180     params.table = NULL;
02181   } else {
02182     v = scheme_get_param(config, MZCONFIG_READTABLE);
02183     if (SCHEME_TRUEP(v))
02184       params.table = (Readtable *)v;
02185     else
02186       params.table = NULL;
02187   }
02188   params.can_read_compiled = crc;
02189   v = scheme_get_param(config, MZCONFIG_CAN_READ_PIPE_QUOTE);
02190   params.can_read_pipe_quote = SCHEME_TRUEP(v);
02191   v = scheme_get_param(config, MZCONFIG_CAN_READ_BOX);
02192   params.can_read_box = SCHEME_TRUEP(v);
02193   v = scheme_get_param(config, MZCONFIG_CAN_READ_GRAPH);
02194   params.can_read_graph = SCHEME_TRUEP(v);
02195   if (crc || get_info) {
02196     params.can_read_reader = 1;
02197   } else {
02198     v = scheme_get_param(config, MZCONFIG_CAN_READ_READER);
02199     params.can_read_reader = SCHEME_TRUEP(v);
02200   }
02201   v = scheme_get_param(config, MZCONFIG_CASE_SENS);
02202   params.case_sensitive = SCHEME_TRUEP(v);
02203   v = scheme_get_param(config, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS);
02204   params.square_brackets_are_parens = SCHEME_TRUEP(v);
02205   v = scheme_get_param(config, MZCONFIG_CURLY_BRACES_ARE_PARENS);
02206   params.curly_braces_are_parens = SCHEME_TRUEP(v);
02207   v = scheme_get_param(config, MZCONFIG_READ_DECIMAL_INEXACT);
02208   params.read_decimal_inexact = SCHEME_TRUEP(v);
02209   v = scheme_get_param(config, MZCONFIG_CAN_READ_QUASI);
02210   params.can_read_quasi = SCHEME_TRUEP(v);
02211   v = scheme_get_param(config, MZCONFIG_CAN_READ_DOT);
02212   params.can_read_dot = SCHEME_TRUEP(v);
02213   v = scheme_get_param(config, MZCONFIG_CAN_READ_INFIX_DOT);
02214   params.can_read_infix_dot = SCHEME_TRUEP(v);
02215   if (!delay_load_info)
02216     delay_load_info = scheme_get_param(config, MZCONFIG_DELAY_LOAD_INFO);
02217   if (SCHEME_TRUEP(delay_load_info))
02218     params.delay_load_info = delay_load_info;
02219   else
02220     params.delay_load_info = NULL;
02221   params.honu_mode = honu_mode;
02222   if (honu_mode)
02223     params.table = NULL;
02224   params.skip_zo_vers_check = cant_fail;
02225   params.magic_sym = magic_sym;
02226   params.magic_val = magic_val;
02227 
02228   ht = NULL;
02229   if (recur) {
02230     /* Check whether this is really a recursive call. If so,
02231        we get a pointer to a hash table for cycles: */
02232     v = scheme_extract_one_cc_mark(NULL, unresolved_uninterned_symbol);
02233     if (v && SCHEME_RPAIRP(v)) {
02234       if (SCHEME_FALSEP(SCHEME_CDR(v)) == !stxsrc)
02235        ht = (Scheme_Hash_Table **)SCHEME_CAR(v);
02236     }
02237   }
02238   if (!ht) {
02239     ht = MALLOC_N(Scheme_Hash_Table *, 1);
02240     recur = 0;
02241   }
02242 
02243   do {
02244     v = read_inner_inner(port, stxsrc, ht, scheme_null, &params, 
02245                       (RETURN_FOR_HASH_COMMENT 
02246                        | (expose_comment ? (RETURN_FOR_COMMENT | RETURN_FOR_SPECIAL_COMMENT) : 0)),
02247                       extra_char, 
02248                       (init_readtable 
02249                        ? (SCHEME_FALSEP(init_readtable)
02250                           ? NULL
02251                           : (Readtable *)init_readtable)
02252                        : params.table),
02253                          get_info);
02254 
02255     extra_char = -1;
02256 
02257     if (*ht && !recur) {
02258       /* Resolve placeholders: */
02259       int clone = 0;
02260       Scheme_Hash_Table *dht, *tht;
02261 
02262       if (stxsrc)
02263         scheme_signal_error("internal error: read-syntax has graph references");
02264 
02265       /* If we ever called an external reader, 
02266          then we need to clone everything. */
02267       if (scheme_hash_get(*ht, tainted_uninterned_symbol))
02268         clone = 1;
02269 
02270       dht = scheme_make_hash_table(SCHEME_hash_ptr);
02271       tht = scheme_make_hash_table(SCHEME_hash_ptr);
02272 
02273       if (v)
02274        v = resolve_references(v, port, NULL, dht, tht, clone, 0);
02275 
02276       /* In case some placeholders were introduced by #;: */
02277       v2 = scheme_hash_get(*ht, unresolved_uninterned_symbol);
02278       if (v2)
02279        resolve_references(v2, port, NULL, dht, tht, clone, 0);
02280 
02281       if (!v)
02282        *ht = NULL;
02283     }
02284 
02285     if (!v && expose_comment) {
02286       /* Return to indicate comment: */
02287       v = scheme_alloc_small_object();
02288       v->type = scheme_special_comment_type;
02289       SCHEME_PTR_VAL(v) = scheme_false;
02290       return v;
02291     }
02292   } while (!v);
02293 
02294   return v;
02295 }
02296 
02297 static void *scheme_internal_read_k(void)
02298 {
02299   Scheme_Thread *p = scheme_current_thread;
02300   Scheme_Object *port = (Scheme_Object *)p->ku.k.p1;
02301   Scheme_Object *stxsrc = (Scheme_Object *)p->ku.k.p2;
02302   Scheme_Object *init_readtable = (Scheme_Object *)p->ku.k.p3;
02303   Scheme_Object *magic_sym = (Scheme_Object *)p->ku.k.p4;
02304   Scheme_Object *magic_val = NULL;
02305   Scheme_Object *delay_load_info = (Scheme_Object *)p->ku.k.p5;
02306 
02307   p->ku.k.p1 = NULL;
02308   p->ku.k.p2 = NULL;
02309   p->ku.k.p3 = NULL;
02310   p->ku.k.p4 = NULL;
02311   p->ku.k.p5 = NULL;
02312 
02313   if (magic_sym) {
02314     magic_val = SCHEME_CDR(magic_sym);
02315     magic_sym = SCHEME_CAR(magic_sym);
02316   }
02317 
02318   return (void *)_internal_read(port, stxsrc, p->ku.k.i1, 0, p->ku.k.i2, 
02319                                 p->ku.k.i3 & 0x2, p->ku.k.i3 & 0x1, 
02320                                 p->ku.k.i4, init_readtable,
02321                                 magic_sym, magic_val, delay_load_info, 0);
02322 }
02323 
02324 Scheme_Object *
02325 scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail, int honu_mode, 
02326                    int recur, int expose_comment, int pre_char, Scheme_Object *init_readtable, 
02327                    Scheme_Object *magic_sym, Scheme_Object *magic_val,
02328                      Scheme_Object *delay_load_info)
02329 {
02330   Scheme_Thread *p = scheme_current_thread;
02331 
02332   if (crc < 0)
02333     crc = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_CAN_READ_COMPILED));
02334 
02335   if (cantfail) {
02336     return _internal_read(port, stxsrc, crc, cantfail, honu_mode, recur, expose_comment, -1, NULL, 
02337                           magic_sym, magic_val, delay_load_info, 0);
02338   } else {
02339     if (magic_sym)
02340       magic_sym = scheme_make_pair(magic_sym, magic_val);
02341 
02342     p->ku.k.p1 = (void *)port;
02343     p->ku.k.p2 = (void *)stxsrc;
02344     p->ku.k.i1 = crc;
02345     p->ku.k.i2 = honu_mode;
02346     p->ku.k.i3 = ((recur ? 0x2 : 0) | (expose_comment ? 0x1 : 0));
02347     p->ku.k.i4 = pre_char;
02348     p->ku.k.p3 = (void *)init_readtable;
02349     p->ku.k.p4 = (void *)magic_sym;
02350     p->ku.k.p5 = (void *)delay_load_info;
02351 
02352     return (Scheme_Object *)scheme_top_level_do(scheme_internal_read_k, 0);
02353   }
02354 }
02355 
02356 Scheme_Object *scheme_read(Scheme_Object *port)
02357 {
02358   return scheme_internal_read(port, NULL, -1, 0, 0, 0, 0, -1, NULL, NULL, NULL, 0);
02359 }
02360 
02361 Scheme_Object *scheme_read_syntax(Scheme_Object *port, Scheme_Object *stxsrc)
02362 {
02363   return scheme_internal_read(port, stxsrc, -1, 0, 0, 0, 0, -1, NULL, NULL, NULL, 0);
02364 }
02365 
02366 Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj)
02367 {
02368   return resolve_references(obj, NULL, obj, 
02369                             scheme_make_hash_table(SCHEME_hash_ptr),
02370                             scheme_make_hash_table(SCHEME_hash_ptr),
02371                             1, 0);
02372 }
02373 
02374 /*========================================================================*/
02375 /*                             list reader                                */
02376 /*========================================================================*/
02377 
02378 static Scheme_Object *attach_shape_property(Scheme_Object *list, 
02379                                        Scheme_Object *stxsrc, 
02380                                        ReadParams *params, 
02381                                        int closer);
02382 
02383 static int next_is_delim(Scheme_Object *port,
02384                       ReadParams *params,
02385                       int brackets,
02386                       int braces)
02387 {
02388   int next;
02389   next = scheme_peekc_special_ok(port);
02390   return ((next == EOF)
02391          || (next == SCHEME_SPECIAL)
02392          || (!params->table 
02393              && (scheme_isspace(next)
02394                 || (next == '(')
02395                 || (next == ')')
02396                 || (next == '"')
02397                 || (next == ';')
02398                 || (next == '\'')
02399                 || (next == '`')
02400                 || (next == ',')
02401                 || ((next == '[') && brackets)
02402                 || ((next == '{') && braces)
02403                 || ((next == ']') && brackets)
02404                 || ((next == '}') && braces)))
02405          || (params->table 
02406              && (readtable_kind(params->table, next, params) 
02407                 & (READTABLE_WHITESPACE | READTABLE_TERMINATING))));
02408 }
02409 
02410 static const char *mapping_name(ReadParams *params, int ch, const char *def, int name_pos)
02411 {
02412   if (params->table) {
02413     int i;
02414     char *buf = "";
02415     Scheme_Object *v;
02416     Scheme_Hash_Table *mapping;
02417 
02418     if (params->table->names) {
02419       if (params->table->names[name_pos])
02420         return params->table->names[name_pos];
02421     }
02422 
02423     mapping = params->table->mapping;
02424     if (!scheme_hash_get(mapping, scheme_make_integer(ch))) {
02425       buf = (char *)scheme_malloc_atomic(4);
02426       sprintf(buf, "`%c'", ch);
02427     }
02428 
02429     for (i = mapping->size; i--; ) {
02430       if (mapping->vals[i]) {
02431         v = mapping->vals[i];
02432         if ((SCHEME_INT_VAL(SCHEME_CAR(v)) == READTABLE_MAPPED)
02433             && (SCHEME_INT_VAL(SCHEME_CDR(v)) == ch)) {
02434           int len;
02435           mzchar a[2];
02436           char *naya, utf8_buf[MAX_UTF8_CHAR_BYTES + 1];
02437 
02438           v = mapping->keys[i];
02439           a[0] = (mzchar)SCHEME_INT_VAL(v);
02440           len = scheme_utf8_encode_all(a, 1, (unsigned char *)utf8_buf);
02441           utf8_buf[len] = 0;
02442 
02443           naya = (char *)scheme_malloc_atomic(len + 5 + strlen(buf));
02444           sprintf(naya, "`%s'", utf8_buf);
02445           if (*buf) {
02446             sprintf(naya XFORM_OK_PLUS len + 2, " or %s", buf);
02447           }
02448           buf = naya;
02449         }
02450       }
02451     }
02452 
02453     if (!params->table->names) {
02454       char **a;
02455       a = MALLOC_N(char*, 7);
02456       params->table->names = a;
02457     }
02458     params->table->names[name_pos] = buf;
02459 
02460     return buf;
02461   } else
02462     return def;
02463 }
02464 
02465 static const char *closer_name(ReadParams *params, int closer)
02466 {
02467   int pos;
02468   const char *def;
02469 
02470   switch (closer) {
02471   case ')':
02472     pos = 0;
02473     def = "`)'";
02474     break;
02475   case ']':
02476     pos = 1;
02477     def = "`]'";
02478     break;
02479   case '}':
02480   default:
02481     pos = 2;
02482     def = "`}'";
02483     break;
02484   }
02485 
02486   return mapping_name(params, closer, def, pos);
02487 }
02488 
02489 static const char *opener_name(ReadParams *params, int opener)
02490 {
02491   int pos;
02492   const char *def;
02493 
02494   switch (opener) {
02495   case '(':
02496     pos = 3;
02497     def = "`('";
02498     break;
02499   case '[':
02500     pos = 4;
02501     def = "`['";
02502     break;
02503   case '{':
02504   default:
02505     pos = 5;
02506     def = "`{'";
02507     break;
02508   }
02509 
02510   return mapping_name(params, opener, def, pos);
02511 }
02512 
02513 static const char *dot_name(ReadParams *params)
02514 {
02515   return mapping_name(params, '.', "`.'", 6);
02516 }
02517 
02518 static Scheme_Object *combine_angle_brackets(Scheme_Object *list);
02519 
02520 /* "(" (or other opener) has already been read */
02521 static Scheme_Object *
02522 read_list(Scheme_Object *port,
02523          Scheme_Object *stxsrc, long line, long col, long pos,
02524          int opener, int closer, int shape, int use_stack,
02525          Scheme_Hash_Table **ht,
02526          Scheme_Object *indentation,
02527          ReadParams *params)
02528 {
02529   Scheme_Object *list = NULL, *last = NULL, *car, *cdr, *pair, *infixed = NULL, *prefetched = NULL;
02530   int ch = 0, got_ch_already = 0, effective_ch;
02531   int brackets = params->square_brackets_are_parens;
02532   int braces = params->curly_braces_are_parens;
02533   long start, startcol, startline, dotpos, dotcol, dotline, dot2pos, dot2line, dot2col, init_span;
02534 
02535   scheme_tell_all(port, &startline, &startcol, &start);
02536   init_span = 1;
02537 
02538   if (stxsrc) {
02539     /* Push onto the indentation stack: */
02540     Scheme_Indent *indt;
02541     indt = (Scheme_Indent *)scheme_malloc_atomic_tagged(sizeof(Scheme_Indent));
02542     indt->type = scheme_indent_type;
02543 
02544     indt->closer = closer;
02545     indt->max_indent = startcol + 1;
02546     indt->multiline = 0;
02547     indt->suspicious_line = 0;
02548     indt->suspicious_quote = 0;
02549     indt->start_line = startline;
02550     indt->last_line = startline;
02551 
02552     indentation = scheme_make_pair((Scheme_Object *)indt, indentation);
02553   }
02554 
02555   while (1) {
02556     if (prefetched)
02557       ch = 0;
02558     else if (got_ch_already)
02559       got_ch_already = 0;
02560     else
02561       ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params);
02562 
02563     if ((ch == EOF) && (closer != EOF)) {
02564       char *suggestion = "";
02565       if (SCHEME_PAIRP(indentation)) {
02566        Scheme_Indent *indt;
02567 
02568        indt = (Scheme_Indent *)SCHEME_CAR(indentation);
02569        if (indt->suspicious_line) {
02570          suggestion = scheme_malloc_atomic(100);
02571          sprintf(suggestion,
02572                 "; indentation suggests a missing %s before line %ld",
02573                 closer_name(params, indt->suspicious_closer),
02574                 indt->suspicious_line);
02575        }
02576       }
02577 
02578       scheme_read_err(port, stxsrc, startline, startcol, start, MINSPAN(port, start, init_span), EOF, indentation,
02579                     "read: expected a %s to close `%c'%s", 
02580                       closer_name(params, closer), 
02581                       opener,
02582                       suggestion);
02583       return NULL;
02584     }
02585 
02586     effective_ch = readtable_effective_char(params->table, ch);
02587 
02588     if (effective_ch == closer) {
02589       if (shape == mz_shape_hash_elem) {
02590        scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation,
02591                      "read: expected hash pair (with key and value separated by %s) before `%c'",
02592                         dot_name(params),
02593                      ch);
02594        return NULL;
02595       }
02596 
02597       if (params->honu_mode) {
02598        /* Finish up the list */
02599        if (!list)
02600          list = scheme_null;
02601        if (closer == ')')
02602          car = honu_parens;
02603        else if (closer == ']')
02604          car = honu_brackets;
02605        else if (closer == '}')
02606          car = honu_braces;
02607        else
02608          car = NULL;
02609        if (car) {
02610          if (stxsrc)
02611            car = scheme_make_stx_w_offset(car, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
02612          list = scheme_make_pair(car, list);
02613        }
02614       } else {
02615        if (!list) {
02616          list = scheme_null;
02617        }
02618       }
02619       pop_indentation(indentation);
02620       list = combine_angle_brackets(list);
02621       list = (stxsrc
02622              ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG)
02623              : list);
02624       list = attach_shape_property(list, stxsrc, params, closer);
02625       return list;
02626     }
02627 
02628     if (shape == mz_shape_hash_list) {
02629       /* Make sure we found a parenthesized something. */
02630       if (!(effective_ch == '(')
02631          && !(effective_ch == '[' && params->square_brackets_are_parens)
02632          && !(effective_ch == '{' && params->curly_braces_are_parens)) {
02633        long xl, xc, xp;
02634         const char *sbname, *cbname;
02635        
02636        /* If it's a special or we have a readtable, we need to read ahead
02637           to make sure that it's not a comment. For consistency, always
02638           read ahead. */
02639        scheme_ungetc(ch, port);
02640        prefetched = read_inner(port, stxsrc, ht, indentation, params, 
02641                                 RETURN_FOR_SPECIAL_COMMENT | RETURN_HONU_ANGLE);
02642        if (!prefetched)
02643          continue; /* It was a comment; try again. */
02644 
02645         sbname = (params->square_brackets_are_parens ? opener_name(params, '[') : "");
02646         cbname = (params->curly_braces_are_parens ? opener_name(params, '{') : "");
02647 
02648         scheme_tell_all(port, &xl, &xc, &xp);
02649        scheme_read_err(port, stxsrc, xl, xc, xp, 1,
02650                      ch, indentation,
02651                      "read: expected %s%s%s%s%s to start a hash pair",
02652                         opener_name(params, '('),
02653                         params->square_brackets_are_parens ? " or " : "",
02654                         sbname,
02655                         params->curly_braces_are_parens ? " or " : "",
02656                         cbname);
02657        return NULL;
02658       } else {
02659        /* Found paren. Use read_list directly so we can specify mz_shape_hash_elem. */
02660        long xl, xc, xp;
02661        scheme_tell_all(port, &xl, &xc, &xp);
02662        car = read_list(port, stxsrc, xl, xc, xp,
02663                      ch, ((effective_ch == '(') ? ')' : ((effective_ch == '[') ? ']' : '}')),
02664                      mz_shape_hash_elem, use_stack, ht, indentation, params);
02665        /* car is guaranteed to have an appropriate shape */
02666       }
02667     } else {
02668       if (prefetched) {
02669        car = prefetched;
02670        prefetched = NULL;
02671       } else {
02672        scheme_ungetc(ch, port);
02673        car = read_inner(port, stxsrc, ht, indentation, params, 
02674                          RETURN_FOR_SPECIAL_COMMENT | RETURN_HONU_ANGLE);
02675        if (!car) continue; /* special was a comment */
02676       }
02677       /* can't be eof, due to check above */
02678     }
02679 
02680     pair = scheme_make_pair(car, scheme_null);
02681 
02682   retry_before_dot:
02683 
02684     ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params);
02685     effective_ch = readtable_effective_char(params->table, ch);
02686     if ((effective_ch == closer) && !params->honu_mode) {
02687       if (shape == mz_shape_hash_elem) {
02688        scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation,
02689                      "read: expected %s and value for hash before `%c'",
02690                         dot_name(params),
02691                      ch);
02692        return NULL;
02693       }
02694 
02695       cdr = pair;
02696       if (!list)
02697        list = cdr;
02698       else
02699        SCHEME_CDR(last) = cdr;
02700 
02701       if (infixed) {
02702        /* Assert: we're not using the list stack */
02703        list = scheme_make_pair(infixed, list);
02704       }
02705 
02706       pop_indentation(indentation);
02707       if (params->honu_mode)
02708         list = combine_angle_brackets(list);
02709       list = (stxsrc
02710              ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG)
02711              : list);
02712       list = attach_shape_property(list, stxsrc, params, closer);
02713       return list;
02714     } else if (!params->honu_mode
02715               && params->can_read_dot
02716               && (effective_ch == '.')
02717               && next_is_delim(port, params, brackets, braces)) {
02718       int dot_ch = ch;
02719 
02720       scheme_tell_all(port, &dotline, &dotcol, &dotpos);
02721 
02722       track_indentation(indentation, dotline, dotcol);
02723 
02724       if (((shape != mz_shape_cons) 
02725            && (shape != mz_shape_hash_elem)
02726            && (shape != mz_shape_vec_plus_infix))
02727           || infixed) {
02728        scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, 0, indentation,
02729                      "read: illegal use of `%c'",
02730                         dot_ch);
02731        return NULL;
02732       }
02733       /* can't be eof, due to check above: */
02734       cdr = read_inner(port, stxsrc, ht, indentation, params, RETURN_HONU_ANGLE);
02735       ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params);
02736       effective_ch = readtable_effective_char(params->table, ch);
02737       if ((effective_ch != closer) || (shape == mz_shape_vec_plus_infix)) {
02738        if (params->can_read_infix_dot 
02739             && (effective_ch == '.') 
02740             && next_is_delim(port, params, brackets, braces)) {
02741          /* Parse as infix: */
02742 
02743          if (shape == mz_shape_hash_elem) {
02744            scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation,
02745                          "read: expected %s after hash value",
02746                          closer_name(params, closer));
02747            return NULL;
02748          }
02749 
02750          {
02751            scheme_tell_all(port, &dot2line, &dot2col, &dot2pos);
02752            track_indentation(indentation, dot2line, dot2col);
02753          }
02754 
02755          infixed = cdr;
02756 
02757          if (!list)
02758            list = pair;
02759          else
02760            SCHEME_CDR(last) = pair;
02761          last = pair;
02762 
02763          /* Make sure there's not a closing paren immediately after the dot: */
02764          ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params);
02765           effective_ch = readtable_effective_char(params->table, ch);
02766          if ((effective_ch == closer) || (ch == EOF)) {
02767            scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation,
02768                          "read: illegal use of `%c'", ch);
02769            return NULL;
02770          }
02771          got_ch_already = 1;
02772        } else {
02773          scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation,
02774                        "read: illegal use of `%c'",
02775                           dot_ch);
02776          return NULL;
02777        }
02778       } else {
02779        SCHEME_CDR(pair) = cdr;
02780        cdr = pair;
02781        if (!list)
02782          list = cdr;
02783        else
02784          SCHEME_CDR(last) = cdr;
02785 
02786        /* Assert: infixed is NULL (otherwise we raised an exception above) */
02787 
02788        pop_indentation(indentation);
02789         if (params->honu_mode)
02790           list = combine_angle_brackets(list);
02791        list = (stxsrc
02792               ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG)
02793               : list);
02794        list = attach_shape_property(list, stxsrc, params, closer);
02795        return list;
02796       }
02797     } else {
02798       if ((ch == SCHEME_SPECIAL) 
02799           || (params->table && (ch != EOF) && (shape != mz_shape_hash_list))) {
02800        /* We have to try the read, because it might be a comment. */
02801        scheme_ungetc(ch, port);
02802        prefetched = read_inner(port, stxsrc, ht, indentation, params, 
02803                                 RETURN_FOR_SPECIAL_COMMENT | RETURN_HONU_ANGLE);
02804        if (!prefetched)
02805          goto retry_before_dot;
02806       } else {
02807        got_ch_already = 1;
02808       }
02809 
02810       if (shape == mz_shape_hash_elem) {
02811        scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation,
02812                      "read: expected %s and value for hash",
02813                         dot_name(params));
02814        return NULL;
02815       }
02816 
02817       cdr = pair;
02818       if (!list)
02819        list = cdr;
02820       else
02821        SCHEME_CDR(last) = cdr;
02822       last = cdr;
02823     }
02824   }
02825 }
02826 
02827 static Scheme_Object *combine_angle_brackets(Scheme_Object *list)
02828 {
02829   Scheme_Object *l, *a, *open_stack = NULL, *prev = NULL;
02830   int i, ch;
02831 
02832   for (l = list; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
02833     a = SCHEME_CAR(l);
02834     if (SCHEME_STXP(a))
02835       a = SCHEME_STX_VAL(a);
02836     if (SAME_OBJ(a, honu_angle_open)) {
02837       open_stack = scheme_make_raw_pair(scheme_make_raw_pair(l, prev),
02838                                         open_stack);
02839       /* Tentatively assume no matching close: */
02840       a = scheme_intern_symbol("<");
02841       if (SCHEME_STXP(SCHEME_CAR(l)))
02842         a = scheme_datum_to_syntax(a, scheme_false, SCHEME_CAR(l), 0, 1);
02843       SCHEME_CAR(l) = a;
02844     } else if (SAME_OBJ(a, honu_angle_close)) {
02845       if (open_stack) {
02846         /* A matching close --- combine the angle brackets! */
02847         Scheme_Object *open, *open_prev;
02848         Scheme_Object *naya, *ang, *seq;
02849         open = SCHEME_CAR(open_stack);
02850         open_prev = SCHEME_CDR(open);
02851         open = SCHEME_CAR(open);
02852         open_stack = SCHEME_CDR(open_stack);
02853         ang = honu_angles;
02854         if (SCHEME_STXP(SCHEME_CAR(l))) {
02855           Scheme_Stx *o, *c;
02856           int span;
02857           o = (Scheme_Stx *)SCHEME_CAR(open);
02858           c = (Scheme_Stx *)SCHEME_CAR(l);
02859           if ((o->srcloc->pos >= 0) && (c->srcloc->pos >= 0))
02860             span = (c->srcloc->pos - o->srcloc->pos) + c->srcloc->span;
02861           else
02862             span = -1;
02863           ang = scheme_make_stx_w_offset(ang, 
02864                                          o->srcloc->line,
02865                                          o->srcloc->col,
02866                                          o->srcloc->pos,
02867                                          span,
02868                                          o->srcloc->src,
02869                                          STX_SRCTAG);
02870         }
02871         seq = scheme_make_pair(ang, SCHEME_CDR(open));
02872         SCHEME_CDR(prev) = scheme_null;
02873         if (SCHEME_STXP(ang)) {
02874           seq = scheme_datum_to_syntax(seq, scheme_false, ang, 0, 1);
02875         }
02876         naya = scheme_make_pair(seq, SCHEME_CDR(l));
02877         if (open_prev) {
02878           SCHEME_CDR(open_prev) = naya;
02879         } else {
02880           list = naya;
02881         }
02882         l = naya;
02883       } else {
02884         /* Not a matching close: */
02885         a = scheme_intern_symbol(">");
02886         if (SCHEME_STXP(SCHEME_CAR(l)))
02887           a = scheme_datum_to_syntax(a, scheme_false, SCHEME_CAR(l), 0, 1);
02888         SCHEME_CAR(l) = a;
02889       }
02890     } else if (open_stack && SCHEME_SYMBOLP(a)) {
02891       /* Check for ids containing -, |, or &, which have lower
02892          operator precedence than < and >, and which therefore break up 
02893          angle brackets. */
02894       for (i = SCHEME_SYM_LEN(a); i--; ) {
02895         ch = SCHEME_SYM_VAL(a)[i];
02896         if ((ch == '=') || (ch == '|') || (ch == '&')) {
02897           open_stack = NULL;
02898           break;
02899         }
02900       }
02901     }
02902     prev = l;
02903   }
02904 
02905   return list;
02906 }
02907 
02908 static Scheme_Object *attach_shape_property(Scheme_Object *list, 
02909                                        Scheme_Object *stxsrc, 
02910                                        ReadParams *params, 
02911                                        int closer)
02912 {
02913   if ((closer != ')') && stxsrc && !params->honu_mode) {
02914     Scheme_Object *opener;
02915     opener = ((closer == '}') 
02916              ? scheme_make_ascii_character('{')
02917              : scheme_make_ascii_character('['));
02918     return scheme_stx_property(list, paren_shape_symbol, opener);
02919   }
02920   return list;
02921 }
02922 
02923 /*========================================================================*/
02924 /*                            string reader                               */
02925 /*========================================================================*/
02926 
02927 /* '"' has already been read */
02928 static Scheme_Object *
02929 read_string(int is_byte, int is_honu_char, Scheme_Object *port,
02930            Scheme_Object *stxsrc, long line, long col, long pos,
02931            Scheme_Hash_Table **ht,
02932            Scheme_Object *indentation, ReadParams *params,
02933            int err_ok)
02934 {
02935   mzchar *buf, *oldbuf, onstack[32];
02936   int i, j, n, n1, ch, closer = (is_honu_char ? '\'' : '"');
02937   long size = 31, oldsize, in_pos, init_span;
02938   Scheme_Object *result;
02939 
02940   scheme_tell_all(port, NULL, NULL, &in_pos);
02941   init_span = in_pos - pos + 1;
02942 
02943   i = 0;
02944   buf = onstack;
02945   while ((ch = scheme_getc_special_ok(port)) != closer) {
02946     if ((ch == EOF) || (is_honu_char && (i > 0))) {
02947       if (err_ok)
02948        scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), ch, indentation,
02949                      "read: expected a closing %s%s",
02950                      is_honu_char ? "'" : "'\"'",
02951                      (ch == EOF) ? "" : " after one character");
02952       return NULL;
02953     } else if (ch == SCHEME_SPECIAL) {
02954       scheme_get_ready_read_special(port, stxsrc, ht);
02955       if (err_ok)
02956        scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation,
02957                      "read: found non-character while reading a %s",
02958                      is_honu_char ? "character constant" : "string");
02959       return NULL;
02960     }
02961     /* Note: errors will tend to leave junk on the port, with an open \". */
02962     /* Escape-sequence handling by Eli Barzilay. */
02963     if (ch == '\\') {
02964       ch = scheme_getc_special_ok(port);
02965       if (ch == EOF) {
02966        if (err_ok)
02967          scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), EOF, indentation,
02968                        "read: expected a closing %s",
02969                        is_honu_char ? "'" : "'\"'");
02970        return NULL;
02971       } else if (ch == SCHEME_SPECIAL) {
02972        scheme_get_ready_read_special(port, stxsrc, ht);
02973        if (err_ok)
02974          scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation,
02975                        "read: found non-character while reading a %s",
02976                        is_honu_char ? "character constant" : "string");
02977        return NULL;
02978       }
02979       switch ( ch ) {
02980       case '\\': case '\"': case '\'': break;
02981       case 'a': ch = '\a'; break;
02982       case 'b': ch = '\b'; break;
02983       case 'e': ch = 27; break; /* escape */
02984       case 'f': ch = '\f'; break;
02985       case 'n': ch = '\n'; break;
02986       case 'r': ch = '\r'; break;
02987       case 't': ch = '\t'; break;
02988       case 'v': ch = '\v'; break;
02989       case '\r':
02990         if (scheme_peekc_special_ok(port) == '\n')
02991          scheme_getc(port);
02992        continue; /* <---------- !!!! */
02993       case '\n':
02994         continue; /* <---------- !!!! */
02995       case 'x':
02996        ch = scheme_getc_special_ok(port);
02997        if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
02998          n = ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10);
02999          ch = scheme_peekc_special_ok(port);
03000          if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
03001            n = n*16 + (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10));
03002            scheme_getc(port); /* must be ch */
03003          }
03004          ch = n;
03005        } else {
03006          if (ch == SCHEME_SPECIAL)
03007            scheme_get_ready_read_special(port, stxsrc, ht);
03008          if (err_ok)
03009            scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation,
03010                          "read: no hex digit following \\x in %s",
03011                          is_honu_char ? "character constant" : "string");
03012          return NULL;
03013        }
03014        break;
03015       case 'u':
03016       case 'U':
03017        if (!is_byte) {
03018          int maxc = ((ch == 'u') ? 4 : 8);
03019          ch = scheme_getc_special_ok(port);
03020          if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
03021            int count = 1;
03022            n = ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10);
03023            while (count < maxc) {
03024              ch = scheme_peekc_special_ok(port);
03025              if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
03026               n = n*16 + (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10));
03027               scheme_getc(port); /* must be ch */
03028               count++;
03029              } else
03030               break;
03031            }
03032            /* disallow surrogate points, etc */
03033            if (((n >= 0xD800) && (n <= 0xDFFF))
03034               || (n > 0x10FFFF)) {
03035              ch = -1;
03036            } else {
03037              ch = n;
03038            }
03039          } else {
03040            if (ch == SCHEME_SPECIAL)
03041              scheme_get_ready_read_special(port, stxsrc, ht);
03042            if (err_ok)
03043              scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation,
03044                            "read: no hex digit following \\%c in %s",
03045                            ((maxc == 4) ? 'u' : 'U'),
03046                            is_honu_char ? "character constant" : "string");
03047            return NULL;
03048          }
03049          break;
03050        } /* else FALLTHROUGH!!! */
03051       default:
03052        if ((ch >= '0') && (ch <= '7')) {
03053          for (n = j = 0; j < 3; j++) {
03054            n1 = 8*n + ch - '0';
03055            if (n1 > 255) {
03056              if (err_ok)
03057               scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
03058                             "read: escape sequence \\%o out of range in %s", n1,
03059                             is_honu_char ? "character constant" : "string");
03060              return NULL;
03061            }
03062            n = n1;
03063            if (j < 2) {
03064              ch = scheme_peekc_special_ok(port);
03065              if (!((ch >= '0') && (ch <= '7'))) {
03066               break;
03067              } else {
03068               scheme_getc(port); /* must be ch */
03069              }
03070            }
03071          }
03072          ch = n;
03073        } else {
03074          if (err_ok)
03075            scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
03076                          "read: unknown escape sequence \\%c in %s%s", ch,
03077                          is_byte ? "byte " : "",
03078                          is_honu_char ? "character constant" : "string");
03079          return NULL;
03080        }
03081        break;
03082       }
03083     } else if ((ch == '\n') || (ch == '\r')) {
03084       /* Suspicious string... remember the line */
03085       if (line > 0) {
03086        if (SCHEME_PAIRP(indentation)) {
03087          Scheme_Indent *indt;
03088          indt = (Scheme_Indent *)SCHEME_CAR(indentation);
03089          /* Only remember if there's no earlier suspcious string line: */
03090          if (!indt->suspicious_quote) {
03091            indt->suspicious_quote = line;
03092            indt->quote_for_char = is_honu_char;
03093          }
03094        }
03095       }
03096     }
03097 
03098     if (ch < 0) {
03099       if (err_ok)
03100        scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
03101                      "read: out-of-range character in %s%s",
03102                      is_byte ? "byte " : "",
03103                      is_honu_char ? "character constant" : "string");
03104       return NULL;
03105     }
03106 
03107     if (i >= size) {
03108       oldsize = size;
03109       oldbuf = buf;
03110 
03111       size *= 2;
03112       buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar));
03113       memcpy(buf, oldbuf, oldsize * sizeof(mzchar));
03114     }
03115     buf[i++] = ch;
03116   }
03117   buf[i] = '\0';
03118 
03119   if (is_honu_char) {
03120     if (i)
03121       result = scheme_make_character(buf[0]);
03122     else {
03123       if (err_ok)
03124        scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation,
03125                      "read: expected one character before closing '");
03126       return NULL;
03127     }
03128   } else if (!is_byte)
03129     result = scheme_make_immutable_sized_char_string(buf, i, i <= 31);
03130   else {
03131     /* buf is not UTF-8 encoded; all of the chars are less than 256.
03132        We just need to change to bytes.. */
03133     char *s;
03134     s = (char *)scheme_malloc_atomic(i + 1);
03135     for (j = 0; j < i; j++) {
03136       ((unsigned char *)s)[j] = buf[j];
03137     }
03138     s[i] = 0;
03139     result = scheme_make_immutable_sized_byte_string(s, i, 0);
03140   }
03141   if (stxsrc)
03142     result =  scheme_make_stx_w_offset(result, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
03143   return result;
03144 }
03145 
03146 Scheme_Object *scheme_read_byte_string(Scheme_Object *port)
03147 /* used by MrEd */
03148 {
03149   return read_string(1, 0, port,
03150                    NULL, 0, 0, 0,
03151                    NULL,
03152                    NULL, NULL,
03153                    0);
03154 }
03155 
03156 static Scheme_Object *
03157 read_here_string(Scheme_Object *port, Scheme_Object *stxsrc,
03158                long line, long col, long pos,
03159                Scheme_Object *indentation,
03160                ReadParams *params)
03161      /* #<< has been read already */
03162 {
03163   int tlen = 0, len = 0, size = 12;
03164   mzchar *tag, *naya, *s, buf[12], c;
03165   long in_pos, init_span;
03166   Scheme_Object *str;
03167 
03168   scheme_tell_all(port, NULL, NULL, &in_pos);
03169   init_span = in_pos - pos + 1;
03170 
03171   tag = buf;
03172   while (1) {
03173     c = scheme_getc(port);
03174     if (c == '\n') {
03175       break;
03176     } else if (c == EOF) {
03177       scheme_read_err(port, stxsrc, line, col, pos, 3 + tlen, EOF, indentation,
03178                     "read: found end-of-file after #<< and before first and-of-line");
03179       return NULL;
03180     } else {
03181       if (tlen >= size) {
03182        size *= 2;
03183        naya = (mzchar *)scheme_malloc_atomic(size * sizeof(mzchar));
03184        memcpy(naya, tag, tlen * sizeof(mzchar));
03185        tag = naya;
03186       }
03187       tag[tlen++] = c;
03188     }
03189   }
03190   if (!tlen) {
03191     scheme_read_err(port, stxsrc, line, col, pos, 3, 0, indentation,
03192                   "read: no characters after #<< before and-of-line");
03193     return NULL;
03194   }
03195 
03196   size = 10 + tlen;
03197   s = (mzchar *)scheme_malloc_atomic(size * sizeof(mzchar));
03198   while (1) {
03199     c = scheme_getc(port);
03200     if (c == EOF) {
03201       scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), EOF, indentation,
03202                     "read: found end-of-file before terminating %u%s",
03203                     tag, 
03204                     (tlen > 50) ? 50 : tlen,
03205                     (tlen > 50) ? "..." : "");
03206       return NULL;
03207     }
03208     if (len >= size) {
03209       size *= 2;
03210       naya = (mzchar *)scheme_malloc_atomic(size * sizeof(mzchar));
03211       memcpy(naya, s, len * sizeof(mzchar));
03212       s = naya;
03213     }
03214     s[len++] = c;
03215     if ((len >= tlen)
03216        && ((len == tlen)
03217            || (s[len - tlen - 1] == '\n'))
03218        && !memcmp(s XFORM_OK_PLUS (len - tlen), tag, sizeof(mzchar) * tlen)) {
03219       c = scheme_peekc(port);
03220       if ((c == '\r') || (c == '\n') || (c == EOF))
03221        break;
03222     }
03223   }
03224 
03225   len -= (tlen + 1);
03226   if (len < 0)
03227     len = 0;
03228 
03229   str = scheme_make_sized_char_string(s, len, 1);
03230 
03231   if (stxsrc)
03232     str = scheme_make_stx_w_offset(str, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
03233   
03234   return str;
03235 }
03236 
03237 char *scheme_extract_indentation_suggestions(Scheme_Object *indentation)
03238 {
03239   long suspicious_quote = 0;
03240   int is_honu_char = 0;
03241   char *suspicions = "";
03242 
03243   /* search back through indentation records to find the
03244      first suspicious quote */
03245   while (SCHEME_PAIRP(indentation)) {
03246     Scheme_Indent *indt;
03247     indt = (Scheme_Indent *)SCHEME_CAR(indentation);
03248     indentation = SCHEME_CDR(indentation);
03249     if (indt->suspicious_quote) {
03250       suspicious_quote = indt->suspicious_quote;
03251       is_honu_char = indt->quote_for_char;
03252     }
03253   }
03254 
03255   if (suspicious_quote) {
03256     suspicions = (char *)scheme_malloc_atomic(64);
03257     sprintf(suspicions,
03258            "; newline within %s suggests a missing %s on line %ld",
03259            is_honu_char ? "character" : "string",
03260            is_honu_char ? "'" : "'\"'",
03261            suspicious_quote);
03262   }
03263 
03264   return suspicions;
03265 }
03266 
03267 /*========================================================================*/
03268 /*                            vector reader                               */
03269 /*========================================================================*/
03270 
03271 /* "#(" has been read */
03272 static Scheme_Object *
03273 read_vector (Scheme_Object *port,
03274             Scheme_Object *stxsrc, long line, long col, long pos,
03275             int opener, char closer,
03276             long requestLength, const mzchar *reqBuffer,
03277             Scheme_Hash_Table **ht,
03278             Scheme_Object *indentation, ReadParams *params, int allow_infix)
03279 /* requestLength == -1 => no request
03280    requestLength == -2 => overflow */
03281 {
03282   Scheme_Object *lresult, *obj, *vec, **els;
03283   int len, i;
03284 
03285   lresult = read_list(port, stxsrc, line, col, pos, opener, closer, 
03286                       allow_infix ? mz_shape_vec_plus_infix : mz_shape_vec, 
03287                       1, ht, indentation, params);
03288 
03289   if (requestLength == -2) {
03290     scheme_raise_out_of_memory("read", "making vector of size %5", reqBuffer);
03291     return NULL;
03292   }
03293 
03294   if (stxsrc)
03295     obj = ((Scheme_Stx *)lresult)->val;
03296   else
03297     obj = lresult;
03298 
03299   len = scheme_list_length(obj);
03300   if (requestLength >= 0 && len > requestLength) {
03301     char buffer[20];
03302     sprintf(buffer, "%ld", requestLength);
03303     scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
03304                   "read: vector length %ld is too small, "
03305                   "%d values provided",
03306                   requestLength, len);
03307     return NULL;
03308   }
03309   if (requestLength < 0)
03310     requestLength = len;
03311   vec = scheme_make_vector(requestLength, NULL);
03312   els = SCHEME_VEC_ELS(vec);
03313   for (i = 0; i < len ; i++) {
03314     els[i] = SCHEME_CAR(obj);
03315     obj = SCHEME_CDR(obj);
03316   }
03317   els = NULL;
03318   if (i < requestLength) {
03319     if (len)
03320       obj = SCHEME_VEC_ELS(vec)[len - 1];
03321     else {
03322       obj = scheme_make_integer(0);
03323       if (stxsrc)
03324        obj = scheme_make_stx_w_offset(obj, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
03325     }
03326 
03327     els = SCHEME_VEC_ELS(vec);
03328     for (; i < requestLength; i++) {
03329       els[i] = obj;
03330     }
03331     els = NULL;
03332   }
03333 
03334   if (stxsrc) {
03335     if (SCHEME_VEC_SIZE(vec) > 0)
03336       SCHEME_SET_VECTOR_IMMUTABLE(vec);
03337     ((Scheme_Stx *)lresult)->val = vec;
03338     return lresult;
03339   } else
03340     return vec;
03341 }
03342 
03343 /*========================================================================*/
03344 /*                            symbol reader                               */
03345 /*========================================================================*/
03346 
03347 /* Also dispatches to number reader, since things not-a-number are
03348    symbols. */
03349 
03350 static int check_honu_num(mzchar *buf, int i);
03351 typedef int (*Getc_Fun_r)(Scheme_Object *port);
03352 
03353 /* nothing has been read, except maybe some flags */
03354 static Scheme_Object  *
03355 read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port,
03356                     Scheme_Object *stxsrc, long line, long col, long pos,
03357                     int is_float, int is_not_float,
03358                     int radix, int radix_set,
03359                     int is_symbol, int is_kw, int pipe_quote,
03360                     Scheme_Hash_Table **ht,
03361                     Scheme_Object *indentation, ReadParams *params, Readtable *table)
03362 {
03363   mzchar *buf, *oldbuf, onstack[MAX_QUICK_SYMBOL_SIZE];
03364   int size, oldsize;
03365   int i, ch, quoted, quoted_ever = 0, running_quote = 0;
03366   int running_quote_ch = 0;
03367   long rq_pos = 0, rq_col = 0, rq_line = 0;
03368   int case_sens = params->case_sensitive;
03369   int decimal_inexact = params->read_decimal_inexact;
03370   Scheme_Object *o;
03371   int delim_ok;
03372   int ungetc_ok;
03373   int honu_mode, e_ok = 0;
03374   int far_char_ok;
03375   int single_escape, multiple_escape, norm_count = 0;
03376   Getc_Fun_r getc_special_ok_fun;
03377 
03378   if (!skip_rt && table) {
03379     /* If the readtable provides a "symbol" reader, then use it: */
03380     if (table->symbol_parser) {
03381       return readtable_call(1, init_ch, table->symbol_parser, params, 
03382                          port, stxsrc, line, col, pos, 0, ht, NULL);
03383       /* Special-comment result is handled in main loop. */
03384     }
03385   }
03386 
03387   ungetc_ok = scheme_peekc_is_ungetc(port);
03388 
03389   if (ungetc_ok) {
03390     getc_special_ok_fun = scheme_getc_special_ok;
03391   } else {
03392     getc_special_ok_fun = scheme_peekc_special_ok;
03393   }
03394 
03395   i = 0;
03396   size = MAX_QUICK_SYMBOL_SIZE - 1;
03397   buf = onstack;
03398 
03399   if (init_ch < 0)
03400     ch = getc_special_ok_fun(port);
03401   else {
03402     /* Assert: this one won't need to be ungotten */
03403     ch = init_ch;
03404   }
03405 
03406   if (is_float || is_not_float || radix_set)
03407     honu_mode = 0;
03408   else
03409     honu_mode = params->honu_mode;
03410 
03411   if (table) {
03412     far_char_ok = 0;
03413     delim_ok = 0;
03414   } else if (!honu_mode) {
03415     delim_ok = SCHEME_OK;
03416     far_char_ok = 1;
03417   } else {
03418     pipe_quote = 0;
03419     if (!is_symbol) {
03420       delim_ok = (HONU_NUM_OK | HONU_INUM_OK);
03421       e_ok = 1;
03422       far_char_ok = 0;
03423     } else if (delim[ch] & HONU_SYM_OK) {
03424       delim_ok = HONU_SYM_OK;
03425       far_char_ok = 0;
03426     } else {
03427       delim_ok = HONU_OK;
03428       far_char_ok = 1;
03429     }
03430   }
03431 
03432   while (NOT_EOF_OR_SPECIAL(ch)
03433         && (running_quote
03434             || (!table 
03435                && !scheme_isspace(ch) 
03436                && (((ch < 128) && (delim[ch] & delim_ok))
03437                    || ((ch >= 128) && far_char_ok)))
03438             || table)) {
03439     if (table) {
03440       int v;
03441       v = readtable_kind(table, ch, params);
03442       if (!running_quote && (v & (READTABLE_TERMINATING | READTABLE_WHITESPACE)))
03443        break;
03444       single_escape = (v & READTABLE_SINGLE_ESCAPE);
03445       multiple_escape = (v & READTABLE_MULTIPLE_ESCAPE);
03446     } else {
03447       single_escape = (ch == '\\');
03448       multiple_escape = ((ch == '|') && pipe_quote);
03449     }
03450     if (!ungetc_ok) {
03451       if (init_ch < 0)
03452        scheme_getc(port); /* must be a character */
03453       else
03454        init_ch = -1;
03455     }
03456     if (single_escape && !running_quote) {
03457       int esc_ch = ch;
03458       ch = scheme_getc_special_ok(port);
03459       if (ch == EOF) {
03460        scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), EOF, indentation,
03461                      "read: EOF following `%c' in %s", esc_ch, is_kw ? "keyword" : "symbol");
03462        return NULL;
03463       } else if (ch == SCHEME_SPECIAL) {
03464        scheme_get_ready_read_special(port, stxsrc, ht);
03465        scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation,
03466                      "read: non-character following `%c' in %s", esc_ch, is_kw ? "keyword" : "symbol");
03467        return NULL;
03468       }
03469       quoted = 1;
03470       quoted_ever = 1;
03471     } else if (multiple_escape && (!running_quote || (ch == running_quote_ch))) {
03472       quoted_ever = 1;
03473       running_quote = !running_quote;
03474       running_quote_ch = ch;
03475       quoted = 0;
03476 
03477       scheme_tell_all(port, &rq_line, &rq_col, &rq_pos);
03478 
03479       ch = getc_special_ok_fun(port);
03480       continue; /* <-- !!! */
03481     } else
03482       quoted = 0;
03483 
03484     if (i >= size) {
03485       oldsize = size;
03486       oldbuf = buf;
03487 
03488       size *= 2;
03489       buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar));
03490       memcpy(buf, oldbuf, oldsize * sizeof(mzchar));
03491     }
03492 
03493     if (!case_sens && !quoted && !running_quote)
03494       norm_count++;
03495     else if (norm_count) {
03496       /* case-normalize the last norm_count characters */
03497       mzchar *s;
03498       int newlen;
03499       s = scheme_string_recase(buf, i - norm_count, norm_count, 3, 1, &newlen);
03500       if (s != buf) {
03501        if ((i + newlen - norm_count) >= size) {
03502          oldsize = size;
03503          oldbuf = buf;
03504          
03505          size *= 2;
03506          if (size <= (i + newlen - norm_count))
03507            size = 2 * (i + (newlen - norm_count));
03508          buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar));
03509          memcpy(buf, oldbuf, oldsize * sizeof(mzchar));
03510        }
03511        memcpy(buf + i - norm_count, s, sizeof(mzchar) * newlen);
03512       }
03513       i += (newlen - norm_count);
03514       norm_count = 0;
03515     }
03516 
03517     buf[i++] = ch;
03518 
03519     if (delim_ok & HONU_INUM_OK) {
03520       if ((ch == 'e') || (ch == 'E')) {
03521        /* Allow a +/- next */
03522        delim_ok = (HONU_NUM_OK | HONU_INUM_OK | HONU_INUM_SIGN_OK);
03523       } else
03524        delim_ok = (HONU_NUM_OK | HONU_INUM_OK);
03525     }
03526 
03527     ch = getc_special_ok_fun(port);
03528   }
03529 
03530   if (running_quote && (ch == SCHEME_SPECIAL)) {
03531     scheme_get_ready_read_special(port, stxsrc, ht);
03532     scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation,
03533                   "read: non-character following `%c' in %s", running_quote_ch,
03534                   is_kw ? "keyword" : "symbol");
03535   }
03536 
03537   if (ungetc_ok)
03538     scheme_ungetc(ch, port);
03539 
03540   if (running_quote) {
03541     scheme_read_err(port, stxsrc, rq_line, rq_col, rq_pos, SPAN(port, rq_pos), EOF, indentation,
03542                   "read: unbalanced `%c'", running_quote_ch);
03543     return NULL;
03544   }
03545 
03546   if (norm_count) {
03547     /* case-normalize the last norm_count characters */
03548     mzchar *s;
03549     int newlen;
03550     s = scheme_string_recase(buf, i - norm_count, norm_count, 3, 1, &newlen);
03551     if (s != buf) {
03552       oldsize = size;
03553       oldbuf = buf;
03554       size = i + (newlen - norm_count) + 1;
03555       buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar));
03556       memcpy(buf, oldbuf, oldsize * sizeof(mzchar));
03557       memcpy(buf + i - norm_count, s, sizeof(mzchar) * newlen);
03558     }
03559     i += (newlen - norm_count);
03560   }
03561 
03562   buf[i] = '\0';
03563 
03564   if (!quoted_ever && (i == 1) 
03565       && (readtable_effective_char(params->table, buf[0]) == '.') 
03566       && !honu_mode) {
03567     long xl, xc, xp;
03568     scheme_tell_all(port, &xl, &xc, &xp);
03569     scheme_read_err(port, stxsrc, xl, xc, xp,
03570                   1, 0, indentation,
03571                   "read: illegal use of \".\"");
03572     return NULL;
03573   }
03574 
03575   if (!i && honu_mode) {
03576     /* If we end up with an empty string, then the first character
03577        is simply illegal */
03578     scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation,
03579                   "read: illegal character: %c", ch);
03580     return NULL;
03581   }
03582 
03583   if (honu_mode && !is_symbol) {
03584     /* Honu inexact syntax is not quite a subset of Scheme: it can end
03585        in an "f" or "d" to indicate the precision. We can easily check
03586        whether the string has the right shape, and then move the "f"
03587        or "d" in place of the "e" in that case. */
03588     int found_e;
03589     found_e = check_honu_num(buf, i);
03590     if (found_e < 0) {
03591       scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
03592                     "read: bad number: %5", buf);
03593       return NULL;
03594     }
03595     if (delim[buf[i - 1]] & HONU_INUM_OK) {
03596       /* We have a precision id to move */
03597       if (found_e) {
03598        /* Easy case: replace e: */
03599        buf[found_e] = buf[i - 1];
03600        i--;
03601       } else {
03602        /* Slightly harder: add a 0 at the end for the exponent */
03603        if (i >= size) {
03604          oldsize = size;
03605          oldbuf = buf;
03606 
03607          size *= 2;
03608          buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar));
03609          memcpy(buf, oldbuf, oldsize * sizeof(mzchar));
03610        }
03611        buf[i++] = '0';
03612        buf[i] = 0;
03613       }
03614     }
03615   }
03616 
03617   if ((is_symbol || quoted_ever) && !is_float && !is_not_float && !radix_set)
03618     o = scheme_false;
03619   else {
03620     o = scheme_read_number(buf, i,
03621                         is_float, is_not_float, decimal_inexact,
03622                         radix, radix_set,
03623                         port, NULL, 0,
03624                         stxsrc, line, col, pos, SPAN(port, pos),
03625                         indentation);
03626   }
03627 
03628   if (SAME_OBJ(o, scheme_false)) {
03629     if (honu_mode && !is_symbol) {
03630       scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
03631                     "read: bad number: %5", buf);
03632       return NULL;
03633     }
03634     if (is_kw) {
03635       o = scheme_intern_exact_char_keyword(buf, i);
03636     } else
03637       o = scheme_intern_exact_char_symbol(buf, i);
03638   }
03639 
03640   if (stxsrc)
03641     o = scheme_make_stx_w_offset(o, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
03642 
03643   return o;
03644 }
03645 
03646 static Scheme_Object  *
03647 read_number(int init_ch,
03648            Scheme_Object *port,
03649            Scheme_Object *stxsrc, long line, long col, long pos,
03650            int is_float, int is_not_float,
03651            int radix, int radix_set,
03652            Scheme_Hash_Table **ht,
03653            Scheme_Object *indentation, ReadParams *params, Readtable *table)
03654 {
03655   return read_number_or_symbol(init_ch, init_ch < 0,
03656                             port, stxsrc, line, col, pos,
03657                             is_float, is_not_float,
03658                             radix, radix_set, 0, 0,
03659                             params->can_read_pipe_quote,
03660                             ht, indentation, params, table);
03661 }
03662 
03663 static Scheme_Object  *
03664 read_symbol(int init_ch,
03665            int skip_rt,
03666            Scheme_Object *port,
03667            Scheme_Object *stxsrc, long line, long col, long pos,
03668            Scheme_Hash_Table **ht,
03669            Scheme_Object *indentation, ReadParams *params, Readtable *table)
03670 {
03671   return read_number_or_symbol(init_ch, skip_rt,
03672                             port, stxsrc, line, col, pos,
03673                             0, 0, 10, 0, 1, 0,
03674                             params->can_read_pipe_quote,
03675                             ht, indentation, params, table);
03676 }
03677 
03678 static Scheme_Object  *
03679 read_keyword(int init_ch,
03680             Scheme_Object *port,
03681             Scheme_Object *stxsrc, long line, long col, long pos,
03682             Scheme_Hash_Table **ht,
03683             Scheme_Object *indentation, ReadParams *params, Readtable *table)
03684 {
03685   return read_number_or_symbol(init_ch, 1,
03686                             port, stxsrc, line, col, pos,
03687                             0, 0, 10, 0, 1, 1,
03688                             params->can_read_pipe_quote,
03689                             ht, indentation, params, table);
03690 }
03691 
03692 static int check_honu_num(mzchar *buf, int i)
03693 {
03694   int j, found_e = 0, found_dot = 0;
03695   for (j = 0; j < i; j++) {
03696     if (buf[j] == '.') {
03697       if (found_dot) {
03698        j = 0;
03699        break; /* bad number */
03700       }
03701       found_dot = 1;
03702     } else if ((buf[j] == 'e') || (buf[j] == 'E')) {
03703       if (!j)
03704        break; /* bad number */
03705       found_e = j;
03706       /* Allow a sign next: */
03707       j++;
03708       if ((buf[j] == '+') || (buf[j] == '-'))
03709        j++;
03710       /* At least one digit: */
03711       if (!isdigit_ascii(buf[j])) {
03712        j = 0;
03713        break;
03714       }
03715       /* All digits, up to end: */
03716       while (isdigit_ascii(buf[j])) {
03717        j++;
03718       }
03719       if (!buf[j])
03720        break; /* good number */
03721       if (buf[j + 1]) {
03722        j = 0;
03723        break; /* bad number */
03724       }
03725       switch (buf[j]) {
03726       case 'd':
03727       case 'D':
03728       case 'f':
03729       case 'F':
03730        break; /* good number */
03731       default:
03732        j = 0;
03733        break; /* bad number */
03734       }
03735       break;
03736     } else if (delim[buf[j]] & HONU_INUM_OK) {
03737       if (j + 1 == i) {
03738        /* Fine -- ends in d/f, even though there's no e */
03739       } else {
03740        j = 0;
03741        break; /* bad number */
03742       }
03743     }
03744   }
03745   if (!j) {
03746     return -1;
03747   }
03748   return found_e;
03749 }
03750 
03751 /*========================================================================*/
03752 /*                              char reader                               */
03753 /*========================================================================*/
03754 
03755 static int u_strcmp(mzchar *s, const char *_t)
03756 {
03757   int i;
03758   unsigned char *t = (unsigned char *)_t;
03759 
03760   for (i = 0; s[i] && (scheme_tolower(s[i]) == scheme_tolower((mzchar)((unsigned char *)t)[i])); i++) {
03761   }
03762   if (s[i] || t[i])
03763     return 1;
03764   return 0;
03765 }
03766 
03767 /* "#\" has been read */
03768 static Scheme_Object *
03769 read_character(Scheme_Object *port,
03770               Scheme_Object *stxsrc, long line, long col, long pos,
03771               Scheme_Hash_Table **ht,
03772               Scheme_Object *indentation, ReadParams *params)
03773 {
03774   int ch, next;
03775 
03776   ch = scheme_getc_special_ok(port);
03777 
03778   if (ch == SCHEME_SPECIAL) {
03779     scheme_get_ready_read_special(port, stxsrc, ht);
03780     scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation,
03781                   "read: found non-character after #\\");
03782     return NULL;
03783   }
03784 
03785   next = scheme_peekc_special_ok(port);
03786 
03787   if ((ch >= '0' && ch <= '7') && (next >= '0' && next <= '7')) {
03788     /* a is the same as next */
03789     int last;
03790 
03791     last = (scheme_getc(port) /* is char */, scheme_peekc_special_ok(port));
03792 
03793     if (last != SCHEME_SPECIAL)
03794       scheme_getc(port); /* must be last */
03795 
03796     if (last < '0' || last > '7' || ch > '3') {
03797       scheme_read_err(port, stxsrc, line, col, pos, ((last == EOF) || (last == SCHEME_SPECIAL)) ? 3 : 4, last, indentation,
03798                     "read: bad character constant #\\%c%c%c",
03799                     ch, next, ((last == EOF) || (last == SCHEME_SPECIAL)) ? ' ' : last);
03800       return NULL;
03801     }
03802 
03803     ch = ((ch - '0') << 6) + ((next - '0') << 3) + (last - '0');
03804 
03805     return scheme_make_char(ch);
03806   }
03807 
03808   if (((ch == 'u') || (ch == 'U')) && NOT_EOF_OR_SPECIAL(next) && scheme_isxdigit(next)) {
03809     int count = 0, n = 0, nbuf[10], maxc = ((ch == 'u') ? 4 : 8);
03810     while (count < maxc) {
03811       ch = scheme_peekc_special_ok(port);
03812       if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
03813        nbuf[count] = ch;
03814        n = n*16 + (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10));
03815        scheme_getc(port); /* must be ch */
03816        count++;
03817       } else
03818        break;
03819     }
03820     /* disallow surrogate points, etc. */
03821     if ((n < 0)
03822        || ((n >= 0xD800) && (n <= 0xDFFF))
03823        || (n > 0x10FFFF)) {
03824       scheme_read_err(port, stxsrc, line, col, pos, count + 2, 0, indentation,
03825                     "read: bad character constant #\\%c%u",
03826                     (maxc == 4) ? 'u' : 'U',
03827                     nbuf, count);
03828       return NULL;
03829     } else {
03830       ch = n;
03831     }
03832   } else if ((ch != EOF) && scheme_isalpha(ch) && NOT_EOF_OR_SPECIAL(next) && scheme_isalpha(next)) {
03833     mzchar *buf, *oldbuf, onstack[32];
03834     int i;
03835     long size = 31, oldsize;
03836 
03837     i = 1;
03838     buf = onstack;
03839     buf[0] = ch;
03840     while ((ch = scheme_peekc_special_ok(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isalpha(ch))) {
03841       scheme_getc(port); /* is alpha character */
03842       if (i >= size) {
03843        oldsize = size;
03844        oldbuf = buf;
03845 
03846        size *= 2;
03847        buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar));
03848        memcpy(buf, oldbuf, oldsize * sizeof(mzchar));
03849       }
03850       buf[i++] = ch;
03851     }
03852     buf[i] = '\0';
03853 
03854     switch (scheme_tolower(buf[0])) {
03855     case 'n': /* maybe `newline' or 'null' or 'nul' */
03856       if (!u_strcmp(buf, "newline"))
03857        return scheme_make_char('\n');
03858       if (!u_strcmp(buf, "null") || !u_strcmp(buf, "nul"))
03859        return scheme_make_char('\0');
03860       break;
03861     case 's': /* maybe `space' */
03862       if (!u_strcmp(buf, "space"))
03863        return scheme_make_char(' ');
03864       break;
03865     case 'r': /* maybe `rubout' or `return' */
03866       if (!u_strcmp(buf, "rubout"))
03867        return scheme_make_char(0x7f);
03868       if (!u_strcmp(buf, "return"))
03869        return scheme_make_char('\r');
03870       break;
03871     case 'p': /* maybe `page' */
03872       if (!u_strcmp(buf, "page"))
03873        return scheme_make_char('\f');
03874       break;
03875     case 't': /* maybe `tab' */
03876       if (!u_strcmp(buf, "tab"))
03877        return scheme_make_char('\t');
03878       break;
03879     case 'v': /* maybe `vtab' */
03880       if (!u_strcmp(buf, "vtab"))
03881        return scheme_make_char(0xb);
03882       break;
03883     case 'b': /* maybe `backspace' */
03884       if (!u_strcmp(buf, "backspace"))
03885        return scheme_make_char('\b');
03886       break;
03887     case 'l': /* maybe `linefeed' */
03888       if (!u_strcmp(buf, "linefeed"))
03889        return scheme_make_char('\n');
03890       break;
03891     default:
03892       break;
03893     }
03894 
03895     scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
03896                   "read: bad character constant: #\\%5",
03897                   buf);
03898   }
03899 
03900   if (ch == EOF) {
03901     scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation,
03902                   "read: expected a character after #\\");
03903   }
03904 
03905   return scheme_make_char(ch);
03906 }
03907 
03908 /*========================================================================*/
03909 /*                            quote readers                               */
03910 /*========================================================================*/
03911 
03912 /* "'", etc. has been read */
03913 static Scheme_Object *
03914 read_quote(char *who, Scheme_Object *quote_symbol, int len,
03915           Scheme_Object *port,
03916           Scheme_Object *stxsrc, long line, long col, long pos,
03917           Scheme_Hash_Table **ht,
03918           Scheme_Object *indentation, ReadParams *params)
03919 {
03920   Scheme_Object *obj, *ret;
03921 
03922   obj = read_inner(port, stxsrc, ht, indentation, params, 0);
03923   if (SCHEME_EOFP(obj))
03924     scheme_read_err(port, stxsrc, line, col, pos, len, EOF, indentation,
03925                   "read: expected an element for %s (found end-of-file)",
03926                   who);
03927   ret = (stxsrc
03928         ? scheme_make_stx_w_offset(quote_symbol, line, col, pos, len, stxsrc, STX_SRCTAG)
03929         : quote_symbol);
03930   ret = scheme_make_pair(ret, scheme_make_pair(obj, scheme_null));
03931   if (stxsrc) {
03932     ret = scheme_make_stx_w_offset(ret, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
03933   }
03934   return ret;
03935 }
03936 
03937 /* "#&" has been read */
03938 static Scheme_Object *read_box(Scheme_Object *port,
03939                             Scheme_Object *stxsrc, long line, long col, long pos,
03940                             Scheme_Hash_Table **ht,
03941                             Scheme_Object *indentation, ReadParams *params)
03942 {
03943   Scheme_Object *o, *bx;
03944 
03945   o = read_inner(port, stxsrc, ht, indentation, params, 0);
03946 
03947   if (SCHEME_EOFP(o))
03948     scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation,
03949                   "read: expected an element for #& box (found end-of-file)");
03950 
03951   bx = scheme_box(o);
03952 
03953   if (stxsrc) {
03954     SCHEME_SET_BOX_IMMUTABLE(bx);
03955     bx = scheme_make_stx_w_offset(bx, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
03956   }
03957 
03958   return bx;
03959 }
03960 
03961 /*========================================================================*/
03962 /*                         hash table reader                              */
03963 /*========================================================================*/
03964 
03965 /* "(" has been read */
03966 static Scheme_Object *read_hash(Scheme_Object *port, Scheme_Object *stxsrc,
03967                             long line, long col, long pos,
03968                             int opener, char closer,  int kind,
03969                             Scheme_Hash_Table **ht,
03970                             Scheme_Object *indentation, ReadParams *params)
03971 {
03972   Scheme_Object *l;
03973 
03974   /* using mz_shape_hash_list ensures that l is a list of pairs */
03975   l = read_list(port, stxsrc, line, col, pos, opener, closer, mz_shape_hash_list, 0, ht, indentation, params);
03976 
03977   if (stxsrc) {
03978     Scheme_Object *key, *val;
03979     Scheme_Hash_Tree *t;
03980 
03981     t = scheme_make_hash_tree(kind);
03982 
03983     for (; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
03984       val = SCHEME_STX_CAR(l);
03985       key = SCHEME_STX_CAR(val);
03986       key = scheme_syntax_to_datum(key, 0, NULL);
03987       val = SCHEME_STX_CDR(val);
03988       
03989       t = scheme_hash_tree_set(t, key, val);
03990     }
03991     
03992     return scheme_make_stx_w_offset((Scheme_Object *)t, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
03993   } else {
03994     /* Wait for placeholders to be resolved before mapping keys to
03995        values, because a placeholder may be used in a key. */
03996     Scheme_Object *ph;
03997 
03998     ph = scheme_alloc_object();
03999     ph->type = scheme_table_placeholder_type;
04000     SCHEME_IPTR_VAL(ph) = l;
04001     SCHEME_PINT_VAL(ph) = kind;
04002 
04003     if (!*ht) {
04004       /* So that resolve_references is called to build the table: */
04005       Scheme_Hash_Table *tht;
04006       tht = scheme_make_hash_table(SCHEME_hash_ptr);
04007       *ht = tht;
04008     }
04009 
04010     return ph;
04011   }
04012 }
04013 
04014 /*========================================================================*/
04015 /*                               utilities                                */
04016 /*========================================================================*/
04017 
04018 static int
04019 skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
04020                       Scheme_Hash_Table **ht, Scheme_Object *indentation, ReadParams *params)
04021 {
04022   int ch;
04023   int blockc_1, blockc_2;
04024 
04025   if (params->honu_mode) {
04026     blockc_1 = '/';
04027     blockc_2 = '*';
04028   } else {
04029     blockc_1 = '#';
04030     blockc_2 = '|';
04031   }
04032 
04033  start_over:
04034 
04035   if (params->table) {
04036     while ((ch = scheme_getc_special_ok(port), NOT_EOF_OR_SPECIAL(ch))) {
04037       if (!(readtable_kind(params->table, ch, params) & READTABLE_WHITESPACE))
04038        break;
04039     }
04040     return ch;
04041   } else {
04042     while ((ch = scheme_getc_special_ok(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isspace(ch))) {}
04043   }
04044 
04045   if ((!params->honu_mode && (ch == ';'))
04046       || (params->honu_mode && (ch == '/')
04047          && (scheme_peekc_special_ok(port) == '/'))) {
04048     do {
04049       ch = scheme_getc_special_ok(port);
04050       if (ch == SCHEME_SPECIAL)
04051        scheme_get_ready_read_special(port, stxsrc, ht);
04052     } while (!is_line_comment_end(ch) && ch != EOF);
04053     goto start_over;
04054   }
04055 
04056   if (ch == blockc_1 && (scheme_peekc_special_ok(port) == blockc_2)) {
04057     int depth = 0;
04058     int ch2 = 0;
04059     long col, pos, line;
04060 
04061     scheme_tell_all(port, &line, &col, &pos);
04062 
04063     (void)scheme_getc(port); /* re-read '|' */
04064     do {
04065       ch = scheme_getc_special_ok(port);
04066 
04067       if (ch == EOF)
04068        scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation,
04069                      "read: end of file in #| comment");
04070       else if (ch == SCHEME_SPECIAL)
04071        scheme_get_ready_read_special(port, stxsrc, ht);
04072 
04073       if ((ch2 == blockc_2) && (ch == blockc_1)) {
04074        if (!(depth--))
04075          goto start_over;
04076        ch = 0; /* So we don't count '#' toward an opening "#|" */
04077       } else if ((ch2 == blockc_1) && (ch == blockc_2)) {
04078        depth++;
04079        ch = 0; /* So we don't count '|' toward a closing "|#" */
04080       }
04081       ch2 = ch;
04082     } while (1);
04083 
04084     goto start_over;
04085   }
04086   if (ch == '#' && (scheme_peekc_special_ok(port) == ';')) {
04087     Scheme_Object *skipped;
04088     long col, pos, line;
04089 
04090     scheme_tell_all(port, &line, &col, &pos);
04091 
04092     track_indentation(indentation, line, col);
04093 
04094     (void)scheme_getc(port); /* re-read ';' */
04095 
04096     skipped = read_inner(port, stxsrc, ht, indentation, params, 0);
04097     if (SCHEME_EOFP(skipped))
04098       scheme_read_err(port, stxsrc, line, col, pos,  MINSPAN(port, pos, 2), EOF, indentation,
04099                     "read: expected a commented-out element for `#;' (found end-of-file)");
04100 
04101     /* For resolving graphs introduced in #; : */
04102     if (*ht) {
04103       Scheme_Object *v;
04104       v = scheme_hash_get(*ht, unresolved_uninterned_symbol);
04105       if (!v)
04106        v = scheme_null;
04107       v = scheme_make_pair(skipped, v);
04108       scheme_hash_set(*ht, unresolved_uninterned_symbol, v);
04109     }
04110 
04111     goto start_over;
04112   }
04113 
04114   return ch;
04115 }
04116 
04117 static void unexpected_closer(int ch,
04118                            Scheme_Object *port, Scheme_Object *stxsrc,
04119                            long line, long col, long pos,
04120                            Scheme_Object *indentation,
04121                               ReadParams *params)
04122 {
04123   char *suggestion = "", *found = "unexpected";
04124 
04125   if (SCHEME_PAIRP(indentation)) {
04126     Scheme_Indent *indt;
04127     int opener;
04128     char *missing;
04129 
04130     indt = (Scheme_Indent *)SCHEME_CAR(indentation);
04131 
04132     found = scheme_malloc_atomic(100);
04133 
04134     if (indt->closer == '}')
04135       opener = '{';
04136     else if (indt->closer == ']')
04137       opener = '[';
04138     else
04139       opener = '(';
04140 
04141     /* Missing intermediate closers, or just need something else entirely? */
04142     {
04143       Scheme_Object *l;
04144       Scheme_Indent *indt2;
04145 
04146       missing = "expected";
04147       for (l = SCHEME_CDR(indentation); SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
04148        indt2 = (Scheme_Indent *)SCHEME_CAR(l);
04149        if (indt2->closer == ch) {
04150          missing = "missing";
04151        }
04152       }
04153     }
04154 
04155     if (ch == indt->closer) {
04156       sprintf(found, "unexpected");
04157     } else if (indt->multiline) {
04158       sprintf(found,
04159              "%s %s to close %s on line %ld, found instead",
04160              missing,
04161              closer_name(params, indt->closer),
04162              opener_name(params, opener),
04163              indt->start_line);
04164     } else {
04165       sprintf(found,
04166              "%s %s to close preceding %s, found instead",
04167              missing,
04168              closer_name(params, indt->closer),
04169              opener_name(params, opener));
04170     }
04171 
04172     if (indt->suspicious_line) {
04173       suggestion = scheme_malloc_atomic(100);
04174       sprintf(suggestion,
04175              "; indentation suggests a missing %s before line %ld",
04176              closer_name(params, indt->suspicious_closer),
04177              indt->suspicious_line);
04178     }
04179   }
04180 
04181   scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: %s `%c'%s",
04182                 found, ch, suggestion);
04183 }
04184 
04185 static void pop_indentation(Scheme_Object *indentation)
04186 {
04187   /* Pop off indentation stack, and propagate
04188      suspicions if none found earlier. */
04189   if (SCHEME_PAIRP(indentation)) {
04190     Scheme_Indent *indt;
04191     indt = (Scheme_Indent *)SCHEME_CAR(indentation);
04192     indentation = SCHEME_CDR(indentation);
04193     if (SCHEME_PAIRP(indentation)) {
04194       Scheme_Indent *old_indt;
04195       old_indt = (Scheme_Indent *)SCHEME_CAR(indentation);
04196 
04197       if (!old_indt->suspicious_line) {
04198        if (indt->suspicious_line) {
04199          old_indt->suspicious_line = indt->suspicious_line;
04200          old_indt->suspicious_closer = indt->suspicious_closer;
04201        }
04202       }
04203       if (!old_indt->suspicious_quote) {
04204        if (indt->suspicious_quote) {
04205          old_indt->suspicious_quote = indt->suspicious_quote;
04206          old_indt->quote_for_char = indt->quote_for_char;
04207        }
04208       }
04209     }
04210   }
04211 }
04212 
04213 /*========================================================================*/
04214 /*                               .zo reader                               */
04215 /*========================================================================*/
04216 
04217 typedef struct Scheme_Load_Delay {
04218   MZTAG_IF_REQUIRED
04219   Scheme_Object *path;
04220   long file_offset, size;
04221   unsigned long symtab_size;
04222   Scheme_Object **symtab;
04223   long *shared_offsets;
04224   Scheme_Object *insp;
04225   Scheme_Object *relto;
04226   Scheme_Unmarshal_Tables *ut;
04227   struct CPort *current_rp;
04228   int perma_cache;
04229   unsigned char *cached;
04230   Scheme_Object *cached_port;
04231   struct Scheme_Load_Delay *clear_bytes_prev, *clear_bytes_next;
04232 } Scheme_Load_Delay;
04233 
04234 #define ZO_CHECK(x) if (!(x)) scheme_ill_formed_code(port);
04235 #define RANGE_CHECK(x, y) ZO_CHECK (x y)
04236 #define RANGE_CHECK_GETS(x) RANGE_CHECK(x, <= port->size - port->pos)
04237 
04238 typedef struct CPort {
04239   MZTAG_IF_REQUIRED
04240   unsigned long pos, size;
04241   unsigned char *start;
04242   unsigned long symtab_size;
04243   long base;
04244   Scheme_Object *orig_port;
04245   Scheme_Hash_Table **ht;
04246   Scheme_Unmarshal_Tables *ut;
04247   Scheme_Object **symtab;
04248   Scheme_Object *insp; /* inspector for module-variable access */
04249   Scheme_Object *magic_sym, *magic_val;
04250   Scheme_Object *relto;
04251   long *shared_offsets;
04252   Scheme_Load_Delay *delay_info;
04253 } CPort;
04254 #define CP_GETC(cp) ((int)(cp->start[cp->pos++]))
04255 #define CP_TELL(port) (port->pos + port->base)
04256 
04257 static Scheme_Object *read_marshalled(int type, CPort *port);
04258 static Scheme_Object *read_compact_list(int c, int proper, int use_stack, CPort *port);
04259 static Scheme_Object *read_compact_quote(CPort *port, int embedded);
04260 
04261 void scheme_ill_formed(struct CPort *port
04262 #if TRACK_ILL_FORMED_CATCH_LINES
04263                      , const char *file, int line
04264 #endif
04265                      )
04266 {
04267   scheme_read_err(port ? port->orig_port : NULL, 
04268                   NULL, -1, -1, port ? CP_TELL(port) : 0, -1, 0, NULL,
04269                 "read (compiled): ill-formed code"
04270 #if TRACK_ILL_FORMED_CATCH_LINES
04271                 " [%s:%d]", file, line
04272 #endif
04273                 );
04274 }
04275 
04276 /* Since read_compact_number is called often, we want it to be
04277    a cheap call in 3m, so avoid anything that allocated --- even
04278    error reporting, since we can make up a valid number. */
04279 #define NUM_ZO_CHECK(x) if (!(x)) return 0;
04280 
04281 XFORM_NONGCING static long read_compact_number(CPort *port)
04282 {
04283   long flag, v, a, b, c, d;
04284 
04285   NUM_ZO_CHECK(port->pos < port->size);
04286 
04287   flag = CP_GETC(port);
04288 
04289   if (flag < 128)
04290     return flag;
04291   else if (!(flag & 0x40)) {
04292     NUM_ZO_CHECK(port->pos < port->size);
04293 
04294     a = CP_GETC(port);
04295 
04296     v = (flag & 0x3F)
04297       + (a << 6);
04298     return v;
04299   } else if (!(flag & 0x20)) {
04300     return -(flag & 0x1F);
04301   }
04302 
04303   NUM_ZO_CHECK(port->pos + 3 < port->size);
04304 
04305   a = CP_GETC(port);
04306   b = CP_GETC(port);
04307   c = CP_GETC(port);
04308   d = CP_GETC(port);
04309 
04310   v = a
04311     + (b << 8)
04312     + (c << 16)
04313     + (d << 24);
04314 
04315   if (flag & 0x10)
04316     return v;
04317   else
04318     return -v;
04319 }
04320 
04321 static char *read_compact_chars(CPort *port,
04322                             char *buffer,
04323                             int bsize, int l)
04324 {
04325   /* Range check is performed before the function is called. */
04326   char *s;
04327 
04328   if (l < bsize)
04329     s = buffer;
04330   else
04331     s = (char *)scheme_malloc_atomic(l + 1);
04332 
04333   memcpy(s, port->start + port->pos, l);
04334   port->pos += l;
04335 
04336   s[l] = 0;
04337 
04338   return s;
04339 }
04340 
04341 static Scheme_Object *read_compact_svector(CPort *port, int l)
04342 {
04343   Scheme_Object *o;
04344   mzshort *v;
04345 
04346   o = scheme_alloc_object();
04347   o->type = scheme_svector_type;
04348 
04349   SCHEME_SVEC_LEN(o) = l;
04350   if (l > 0)
04351     v = MALLOC_N_ATOMIC(mzshort, l);
04352   else
04353     v = NULL;
04354   SCHEME_SVEC_VEC(o) = v;
04355 
04356   while (l--) {
04357     mzshort cn;
04358     cn = read_compact_number(port);
04359     v[l] = cn;
04360   }
04361 
04362   return o;
04363 }
04364 
04365 static Scheme_Object *read_compact_escape(CPort *port) 
04366 {
04367 #if defined(MZ_PRECISE_GC)
04368 # define ESC_BLK_BUF_SIZE 32
04369   char buffer[ESC_BLK_BUF_SIZE];
04370 #endif
04371   int len;
04372   Scheme_Object *ep;
04373   char *s;
04374   ReadParams params;
04375   
04376   len = read_compact_number(port);
04377   
04378   RANGE_CHECK_GETS((unsigned)len);
04379   
04380 #if defined(MZ_PRECISE_GC)
04381   s = read_compact_chars(port, buffer, ESC_BLK_BUF_SIZE, len);
04382   if (s != buffer)
04383     len = -len; /* no alloc in sized_byte_string_input_port */
04384 #else
04385   s = (char *)port->start + port->pos;
04386   port->pos += len;
04387   len = -len; /* no alloc in sized_byte_string_input_port */
04388 #endif
04389   
04390   ep = scheme_make_sized_byte_string_input_port(s, len);
04391   
04392   params.can_read_compiled = 1;
04393   params.can_read_pipe_quote = 1;
04394   params.can_read_box = 1;
04395   params.can_read_graph = 1;
04396   /* Use startup value of case sensitivity so legacy code will work. */
04397   params.case_sensitive = scheme_case_sensitive;
04398   params.square_brackets_are_parens = 1;
04399   params.curly_braces_are_parens = 1;
04400   params.read_decimal_inexact = 1;
04401   params.can_read_dot = 1;
04402   params.can_read_infix_dot = 1;
04403   params.can_read_quasi = 1;
04404   params.honu_mode = 0;
04405   params.skip_zo_vers_check = 0;
04406   params.table = NULL;
04407 
04408   return read_inner(ep, NULL, port->ht, scheme_null, &params, 0);
04409 }
04410 
04411 static unsigned char cpt_branch[256];
04412 
04413 static Scheme_Object *read_compact(CPort *port, int use_stack);
04414 
04415 static Scheme_Object *read_compact_k(void)
04416 {
04417   Scheme_Thread *p = scheme_current_thread;
04418   CPort *port = (CPort *)p->ku.k.p1;
04419 
04420   p->ku.k.p1 = NULL;
04421 
04422   return read_compact(port, p->ku.k.i1);
04423 }
04424 
04425 static Scheme_Object *read_compact(CPort *port, int use_stack)
04426 {
04427 #define BLK_BUF_SIZE 32
04428   unsigned int l;
04429   char *s, buffer[BLK_BUF_SIZE];
04430   int ch;
04431   Scheme_Object *v;
04432 
04433 #ifdef DO_STACK_CHECK
04434   {
04435 # include "mzstkchk.h"
04436     {
04437       Scheme_Thread *p = scheme_current_thread;
04438       p->ku.k.p1 = (void *)port;
04439       p->ku.k.i1 = use_stack;
04440       return scheme_handle_stack_overflow(read_compact_k);
04441     }
04442   }
04443 #endif
04444 
04445   {
04446     ZO_CHECK(port->pos < port->size);
04447     ch = CP_GETC(port);
04448 
04449     switch(cpt_branch[ch]) {
04450     case CPT_ESCAPE:
04451       v = read_compact_escape(port);
04452       break;
04453     case CPT_SYMBOL:
04454       l = read_compact_number(port);
04455       RANGE_CHECK_GETS(l);
04456       s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
04457       v = scheme_intern_exact_symbol(s, l);
04458 
04459       if (SAME_OBJ(v, port->magic_sym))
04460        v = port->magic_val;
04461       break;
04462     case CPT_SYMREF:
04463       l = read_compact_number(port);
04464       RANGE_CHECK(l, < port->symtab_size);
04465       v = port->symtab[l];
04466       if (!v) {
04467         long save_pos = port->pos;
04468         port->pos = port->shared_offsets[l - 1];
04469         v = read_compact(port, 0);
04470         port->pos = save_pos;
04471         port->symtab[l] = v;
04472       }
04473       break;
04474     case CPT_WEIRD_SYMBOL:
04475       {
04476        int uninterned;
04477 
04478        uninterned = read_compact_number(port);
04479 
04480        l = read_compact_number(port);
04481        RANGE_CHECK_GETS(l);
04482        s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
04483 
04484        if (uninterned)
04485          v = scheme_make_exact_symbol(s, l);
04486        else
04487          v = scheme_intern_exact_parallel_symbol(s, l);
04488         
04489        /* The fact that all uses of the symbol go through the table
04490           means that uninterned symbols are consistently re-created for
04491           a particular compiled expression. */
04492       }
04493       break;
04494     case CPT_KEYWORD:
04495       l = read_compact_number(port);
04496       RANGE_CHECK_GETS(l);
04497       s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
04498       v = scheme_intern_exact_keyword(s, l);
04499       break;
04500     case CPT_BYTE_STRING:
04501       l = read_compact_number(port);
04502       RANGE_CHECK_GETS(l);
04503       s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
04504       v = scheme_make_immutable_sized_byte_string(s, l, l < BLK_BUF_SIZE);
04505       break;
04506     case CPT_CHAR_STRING:
04507       {
04508        unsigned int el;
04509        mzchar *us;
04510        el = read_compact_number(port);
04511        l = read_compact_number(port);
04512        RANGE_CHECK_GETS(el);
04513        s = read_compact_chars(port, buffer, BLK_BUF_SIZE, el);
04514        us = (mzchar *)scheme_malloc_atomic((l + 1) * sizeof(mzchar));
04515        scheme_utf8_decode_all((const unsigned char *)s, el, us, 0);
04516        us[l] = 0;
04517        v = scheme_make_immutable_sized_char_string(us, l, 0);
04518       }
04519       break;
04520     case CPT_CHAR:
04521       l = read_compact_number(port);
04522       return scheme_make_character(l);
04523       break;
04524     case CPT_INT:
04525       return scheme_make_integer(read_compact_number(port));
04526       break;
04527     case CPT_NULL:
04528       return scheme_null;
04529       break;
04530     case CPT_TRUE:
04531       return scheme_true;
04532       break;
04533     case CPT_FALSE:
04534       return scheme_false;
04535       break;
04536     case CPT_VOID:
04537       return scheme_void;
04538       break;
04539     case CPT_BOX:
04540       v = scheme_box(read_compact(port, 0));
04541       SCHEME_SET_IMMUTABLE(v);
04542       break;
04543     case CPT_PAIR:
04544       {
04545        v = read_compact(port, 0);
04546        return scheme_make_pair(v, read_compact(port, 0));
04547       }
04548       break;
04549     case CPT_LIST:
04550       l = read_compact_number(port);
04551       if (l == 1) {
04552         v = read_compact(port, 0);
04553         return scheme_make_pair(v, read_compact(port, 0));
04554       } else
04555         return read_compact_list(l, 0, 0, port);
04556       break;
04557     case CPT_VECTOR:
04558       {
04559        Scheme_Object *vec;
04560        unsigned int i;
04561 
04562        l = read_compact_number(port);
04563        vec = scheme_make_vector(l, NULL);
04564 
04565        for (i = 0; i < l; i++) {
04566          v = read_compact(port, 0);
04567          SCHEME_VEC_ELS(vec)[i] = v;
04568        }
04569 
04570         SCHEME_SET_IMMUTABLE(vec);
04571 
04572        return vec;
04573       }
04574       break;
04575     case CPT_HASH_TABLE:
04576       {
04577        Scheme_Object *l;
04578        int kind, len;
04579         Scheme_Object *k;
04580 
04581        kind = read_compact_number(port);
04582        len = read_compact_number(port);
04583        
04584        l = scheme_null;
04585        while (len--) {
04586          k = read_compact(port, 0);
04587          v = read_compact(port, 0);
04588          /* We can't always hash directly, because a key or value
04589             might have a graph reference inside it. */
04590          l = scheme_make_pair(scheme_make_pair(k, v), l);
04591        }
04592 
04593        if (!(*port->ht)) {
04594          /* So that resolve_references is called to build the table: */
04595          Scheme_Hash_Table *tht;
04596          tht = scheme_make_hash_table(SCHEME_hash_ptr);
04597          *(port->ht) = tht;
04598        }
04599 
04600        /* Let resolve_references complete the table construction: */
04601         v = scheme_alloc_object();
04602         v->type = scheme_table_placeholder_type;
04603         SCHEME_PINT_VAL(v) = kind;
04604         SCHEME_IPTR_VAL(v) = l;
04605       }
04606       break;
04607     case CPT_STX:
04608     case CPT_GSTX:
04609       {
04610        if (!port->ut) {
04611           Scheme_Unmarshal_Tables *ut;
04612          Scheme_Hash_Table *rht;
04613           char *decoded;
04614 
04615           ut = MALLOC_ONE_RT(Scheme_Unmarshal_Tables);
04616           SET_REQUIRED_TAG(ut->type = scheme_rt_unmarshal_info);
04617           port->ut = ut;
04618           ut->rp = port;
04619           if (port->delay_info)
04620             port->delay_info->ut = ut;
04621 
04622           decoded = (char *)scheme_malloc_atomic(port->symtab_size);
04623           memset(decoded, 0, port->symtab_size);
04624           ut->decoded = decoded;
04625 
04626          rht = scheme_make_hash_table(SCHEME_hash_ptr);
04627          port->ut->rns = rht;
04628        }
04629 
04630         if (*port->ht)
04631           scheme_ill_formed_code(port);
04632 
04633        v = read_compact(port, 1);
04634 
04635         if (*port->ht) {
04636           *port->ht = NULL;
04637           v = resolve_references(v, port->orig_port, NULL,
04638                                  scheme_make_hash_table(SCHEME_hash_ptr), 
04639                                  scheme_make_hash_table(SCHEME_hash_ptr), 
04640                                  0, 0);
04641         }
04642 
04643        v = scheme_unmarshal_datum_to_syntax(v, port->ut, ch == CPT_GSTX);
04644        scheme_num_read_syntax_objects++;
04645        if (!v)
04646          scheme_ill_formed_code(port);
04647       }
04648       break;
04649     case CPT_MARSHALLED:
04650       v = read_marshalled(read_compact_number(port), port);
04651       break;
04652     case CPT_QUOTE:
04653       v = read_compact_quote(port, 1);
04654       break;
04655     case CPT_REFERENCE:
04656       l = read_compact_number(port);
04657       RANGE_CHECK(l, < EXPECTED_PRIM_COUNT);
04658       return variable_references[l];
04659       break;
04660     case CPT_LOCAL:
04661       {
04662        int p, flags;
04663        p = read_compact_number(port);
04664         if (p < 0) {
04665           p = -(p + 1);
04666           flags = read_compact_number(port);
04667         } else
04668           flags = 0;
04669        return scheme_make_local(scheme_local_type, p, flags);
04670       }
04671       break;
04672     case CPT_LOCAL_UNBOX:
04673       {
04674        int p, flags;
04675        p = read_compact_number(port);
04676         if (p < 0) {
04677           p = -(p + 1);
04678           flags = read_compact_number(port);
04679         } else
04680           flags = 0;
04681        return scheme_make_local(scheme_local_unbox_type, p, flags);
04682       }
04683       break;
04684     case CPT_SVECTOR:
04685       {
04686        int l;
04687        l = read_compact_number(port);
04688        v = read_compact_svector(port, l);
04689       }
04690       break;
04691     case CPT_APPLICATION:
04692       {
04693        int c, i;
04694        Scheme_App_Rec *a;
04695 
04696        c = read_compact_number(port) + 1;
04697 
04698        a = scheme_malloc_application(c);
04699        for (i = 0; i < c; i++) {
04700          v = read_compact(port, 1);
04701          a->args[i] = v;
04702        }
04703 
04704        scheme_finish_application(a);
04705        return (Scheme_Object *)a;
04706       }
04707       break;
04708     case CPT_LET_ONE:
04709       {
04710        Scheme_Let_One *lo;
04711        int et;
04712 
04713        lo = (Scheme_Let_One *)scheme_malloc_tagged(sizeof(Scheme_Let_One));
04714        lo->iso.so.type = scheme_let_one_type;
04715 
04716        v = read_compact(port, 1);
04717        lo->value = v;
04718        v = read_compact(port, 1);
04719        lo->body = v;
04720        et = scheme_get_eval_type(lo->value);
04721        SCHEME_LET_EVAL_TYPE(lo) = et;
04722 
04723        return (Scheme_Object *)lo;
04724       }
04725       break;
04726     case CPT_BRANCH:
04727       {
04728        Scheme_Object *test, *tbranch, *fbranch;
04729        test = read_compact(port, 1);
04730        tbranch = read_compact(port, 1);
04731        fbranch = read_compact(port, 1);
04732        return scheme_make_branch(test, tbranch, fbranch);
04733       }
04734       break;
04735     case CPT_MODULE_INDEX:
04736        {
04737          Scheme_Object *path, *base;
04738 
04739          path = read_compact(port, 0);
04740          base = read_compact(port, 0);
04741 
04742          return scheme_make_modidx(path, base, scheme_false);
04743        }
04744        break;
04745     case CPT_MODULE_VAR:
04746       {
04747        Module_Variable *mv;
04748        Scheme_Object *mod, *var;
04749        int pos;
04750 
04751        mod = read_compact(port, 0);
04752        var = read_compact(port, 0);
04753        pos = read_compact_number(port);
04754 
04755        mv = MALLOC_ONE_TAGGED(Module_Variable);
04756        mv->so.type = scheme_module_variable_type;
04757         if (SCHEME_SYMBOLP(mod))
04758           mod = scheme_intern_resolved_module_path(mod);
04759        mv->modidx = mod;
04760        mv->insp = port->insp;
04761        mv->sym = var;
04762         if (pos == -2) {
04763           mv->mod_phase = 1;
04764           pos = read_compact_number(port);
04765           mv->pos = pos;
04766         } else
04767           mv->pos = pos;
04768 
04769        return (Scheme_Object *)mv;
04770       }
04771       break;
04772     case CPT_PATH:
04773       {
04774        l = read_compact_number(port);
04775        RANGE_CHECK_GETS(l);
04776        s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
04777        v = scheme_make_sized_path(s, l, l < BLK_BUF_SIZE);
04778 
04779        if (scheme_is_relative_path(SCHEME_PATH_VAL(v), SCHEME_PATH_LEN(v), SCHEME_PLATFORM_PATH_KIND)) {
04780          /* Resolve relative path using the current load-relative directory: */
04781          if (SCHEME_PATHP(port->relto)) {
04782            Scheme_Object *a[2];
04783            a[0] = port->relto;
04784            a[1] = v;
04785            v = scheme_build_path(2, a);
04786          }
04787        }
04788       }
04789       break;
04790     case CPT_CLOSURE:
04791       {
04792         Scheme_Closure *cl;
04793         l = read_compact_number(port);
04794         RANGE_CHECK(l, < port->symtab_size);
04795         cl = scheme_malloc_empty_closure();
04796         port->symtab[l] = (Scheme_Object *)cl;
04797         v = read_compact(port, 0);
04798         if (!SAME_TYPE(SCHEME_TYPE(v), scheme_closure_type)
04799             || ((Scheme_Closure *)v)->code->closure_size) {
04800           scheme_ill_formed_code(port);
04801           return NULL;
04802         }
04803         cl->code = ((Scheme_Closure *)v)->code;
04804         return (Scheme_Object *)cl;
04805         break;
04806       }
04807     case CPT_DELAY_REF:
04808       {
04809         l = read_compact_number(port);
04810         RANGE_CHECK(l, < port->symtab_size);
04811         v = port->symtab[l];
04812         if (!v) {
04813           if (port->delay_info) {
04814             /* This is where we construct information for
04815                loading the syntax object on demand. */
04816             v = scheme_make_raw_pair(scheme_make_integer(l),
04817                                      (Scheme_Object *)port->delay_info);
04818           } else {
04819             long save_pos = port->pos;
04820             port->pos = port->shared_offsets[l - 1];
04821             v = read_compact(port, 0);
04822             port->pos = save_pos;
04823             port->symtab[l] = v;
04824           }
04825         }
04826         return v;
04827         break;
04828       }
04829     case CPT_PREFAB:
04830       {
04831         Scheme_Struct_Type *st;
04832         v = read_compact(port, 0);
04833         if (!SCHEME_VECTORP(v) || !SCHEME_VEC_SIZE(v))
04834           v = NULL;
04835         else {
04836           st = scheme_lookup_prefab_type(SCHEME_VEC_ELS(v)[0], SCHEME_VEC_SIZE(v) - 1);
04837           if (!st || (st->num_slots != (SCHEME_VEC_SIZE(v) - 1)))
04838             v = NULL;
04839           else {
04840             v = scheme_make_prefab_struct_instance(st, v);
04841           }
04842         }
04843         break;
04844       }
04845     case CPT_SMALL_LOCAL_START:
04846     case CPT_SMALL_LOCAL_UNBOX_START:
04847       {
04848        Scheme_Type type;
04849 
04850        if (CPT_BETWEEN(ch, SMALL_LOCAL_UNBOX)) {
04851          type = scheme_local_unbox_type;
04852          ch -= CPT_SMALL_LOCAL_UNBOX_START;
04853        } else {
04854          type = scheme_local_type;
04855          ch -= CPT_SMALL_LOCAL_START;
04856        }
04857        return scheme_make_local(type, ch, 0);
04858       }
04859       break;
04860     case CPT_SMALL_MARSHALLED_START:
04861       {
04862        l = ch - CPT_SMALL_MARSHALLED_START;
04863        v = read_marshalled(l, port);
04864       }
04865       break;
04866     case CPT_SMALL_SYMBOL_START:
04867       {
04868        l = ch - CPT_SMALL_SYMBOL_START;
04869        RANGE_CHECK_GETS(l);
04870        s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
04871        v = scheme_intern_exact_symbol(s, l);
04872 
04873        if (SAME_OBJ(v, port->magic_sym))
04874          v = port->magic_val;
04875       }
04876       break;
04877     case CPT_SMALL_NUMBER_START:
04878       {
04879        l = ch - CPT_SMALL_NUMBER_START;
04880        return scheme_make_integer(l);
04881       }
04882       break;
04883     case CPT_SMALL_SVECTOR_START:
04884       {
04885        l = ch - CPT_SMALL_SVECTOR_START;
04886        v = read_compact_svector(port, l);
04887       }
04888       break;
04889     case CPT_SMALL_PROPER_LIST_START:
04890     case CPT_SMALL_LIST_START:
04891       {
04892        int ppr = CPT_BETWEEN(ch, SMALL_PROPER_LIST);
04893        l = ch - (ppr ? CPT_SMALL_PROPER_LIST_START : CPT_SMALL_LIST_START);
04894        if (l == 1) {
04895           Scheme_Object *cdr;
04896           v = read_compact(port, 0);
04897           cdr = (ppr
04898                  ? scheme_null
04899                  : read_compact(port, 0));
04900           return scheme_make_pair(v, cdr);
04901         } else
04902           return read_compact_list(l, ppr, /* use_stack */ 0, port);
04903       }
04904       break;
04905     case CPT_SMALL_APPLICATION_START:
04906       {
04907        int c, i;
04908        Scheme_App_Rec *a;
04909 
04910        c = (ch - CPT_SMALL_APPLICATION_START) + 1;
04911 
04912        a = scheme_malloc_application(c);
04913        for (i = 0; i < c; i++) {
04914          v = read_compact(port, 1);
04915          a->args[i] = v;
04916        }
04917 
04918        scheme_finish_application(a);
04919 
04920        return (Scheme_Object *)a;
04921       }
04922       break;
04923     case CPT_SMALL_APPLICATION2:
04924       {
04925        short et;
04926        Scheme_App2_Rec *app;
04927 
04928        app = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
04929        app->iso.so.type = scheme_application2_type;
04930 
04931        v = read_compact(port, 1);
04932        app->rator = v;
04933        v = read_compact(port, 1);
04934        app->rand = v;
04935 
04936        et = scheme_get_eval_type(app->rand);
04937        et = et << 3;
04938        et += scheme_get_eval_type(app->rator);
04939        SCHEME_APPN_FLAGS(app) = et;
04940 
04941        return (Scheme_Object *)app;
04942       }
04943       break;
04944     case CPT_SMALL_APPLICATION3:
04945       {
04946        short et;
04947        Scheme_App3_Rec *app;
04948 
04949        app = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
04950        app->iso.so.type = scheme_application3_type;
04951 
04952        v = read_compact(port, 1);
04953        app->rator = v;
04954        v = read_compact(port, 1);
04955        app->rand1 = v;
04956        v = read_compact(port, 1);
04957        app->rand2 = v;
04958 
04959        et = scheme_get_eval_type(app->rand2);
04960        et = et << 3;
04961        et += scheme_get_eval_type(app->rand1);
04962        et = et << 3;
04963        et += scheme_get_eval_type(app->rator);
04964        SCHEME_APPN_FLAGS(app) = et;
04965 
04966        return (Scheme_Object *)app;
04967       }
04968       break;
04969     default:
04970       v = NULL;
04971       break;
04972     }
04973 
04974     /* Some cases where v != NULL return directly */
04975 
04976     if (!v)
04977       scheme_ill_formed_code(port);
04978   }
04979 
04980   return v;
04981 }
04982 
04983 static Scheme_Object *read_compact_list(int c, int proper, int use_stack, CPort *port)
04984 {
04985   Scheme_Object *v, *first, *last, *pair;
04986 
04987   v = read_compact(port, 0);
04988   last = scheme_make_pair(v, scheme_null);
04989 
04990   first = last;
04991 
04992   while (--c) {
04993     v = read_compact(port, 0);
04994 
04995     pair = scheme_make_pair(v, scheme_null);
04996 
04997     SCHEME_CDR(last) = pair;
04998     last = pair;
04999   }
05000 
05001   if (!proper) {
05002     v = read_compact(port, 0);
05003     SCHEME_CDR(last) = v;
05004   }
05005 
05006   return first;
05007 }
05008 
05009 static Scheme_Object *read_compact_quote(CPort *port, int embedded)
05010 {
05011   Scheme_Hash_Table **q_ht, **old_ht;
05012   Scheme_Object *v;
05013 
05014   /* Use a new hash table. A compiled quoted form may have graph
05015      structure, but only local graph structure is allowed. */
05016   q_ht = MALLOC_N(Scheme_Hash_Table *, 1);
05017   *q_ht = NULL;
05018 
05019   old_ht = port->ht;
05020   port->ht = q_ht;
05021 
05022   v = read_compact(port, 0);
05023 
05024   port->ht = old_ht;
05025 
05026   if (*q_ht)
05027     v = resolve_references(v, port->orig_port, NULL,
05028                            scheme_make_hash_table(SCHEME_hash_ptr), 
05029                            scheme_make_hash_table(SCHEME_hash_ptr), 
05030                            0, 0);
05031 
05032   return v;
05033 }
05034 
05035 static Scheme_Object *read_marshalled(int type, CPort *port)
05036 {
05037   Scheme_Object *l;
05038   Scheme_Type_Reader reader;
05039 
05040   l = read_compact(port, 1);
05041 
05042   if ((type < 0) || (type >= _scheme_last_type_)) {
05043     scheme_ill_formed_code(port);
05044   }
05045 
05046   reader = scheme_type_readers[type];
05047 
05048   if (!reader) {
05049     scheme_ill_formed_code(port);
05050   }
05051 
05052   l = reader(l);
05053 
05054   if (!l)
05055     scheme_ill_formed_code(port);
05056 
05057   return l;
05058 }
05059 
05060 static long read_simple_number_from_port(Scheme_Object *port)
05061 {
05062   long a, b, c, d;
05063 
05064   a = (unsigned char)scheme_get_byte(port);
05065   b = (unsigned char)scheme_get_byte(port);
05066   c = (unsigned char)scheme_get_byte(port);
05067   d = (unsigned char)scheme_get_byte(port);
05068 
05069   return (a
05070           + (b << 8)
05071           + (c << 16)
05072           + (d << 24));
05073 }
05074 
05075 /* "#~" has been read */
05076 static Scheme_Object *read_compiled(Scheme_Object *port,
05077                                 Scheme_Object *stxsrc,
05078                                 long line, long col, long pos,
05079                                 Scheme_Hash_Table **ht,
05080                                 ReadParams *params)
05081 {
05082   Scheme_Object *result, *insp;
05083   long size, shared_size, got, offset = 0;
05084   CPort *rp;
05085   long symtabsize;
05086   Scheme_Object **symtab;
05087   long *so;
05088   Scheme_Load_Delay *delay_info;
05089   Scheme_Hash_Table **local_ht;
05090   int all_short;
05091   int perma_cache = use_perma_cache;
05092   Scheme_Object *dir;
05093   Scheme_Config *config;
05094          
05095   if (!cpt_branch[1]) {
05096     int i;
05097 
05098     for (i = 0; i < 256; i++) {
05099       cpt_branch[i] = i;
05100     }
05101 
05102 #define FILL_IN(v) \
05103     for (i = CPT_ ## v ## _START; i < CPT_ ## v ## _END; i++) { \
05104       cpt_branch[i] = CPT_ ## v ## _START; \
05105     }
05106     FILL_IN(SMALL_NUMBER);
05107     FILL_IN(SMALL_SYMBOL);
05108     FILL_IN(SMALL_MARSHALLED);
05109     FILL_IN(SMALL_LIST);
05110     FILL_IN(SMALL_PROPER_LIST);
05111     FILL_IN(SMALL_LOCAL);
05112     FILL_IN(SMALL_LOCAL_UNBOX);
05113     FILL_IN(SMALL_SVECTOR);
05114     FILL_IN(SMALL_APPLICATION);
05115 
05116     /* These two are handled specially: */
05117     cpt_branch[CPT_SMALL_APPLICATION2] = CPT_SMALL_APPLICATION2;
05118     cpt_branch[CPT_SMALL_APPLICATION3] = CPT_SMALL_APPLICATION3;
05119   }
05120 
05121   if (!variable_references)
05122     variable_references = scheme_make_builtin_references_table();
05123 
05124   /* Allow delays? */
05125   if (params->delay_load_info) {
05126     delay_info = MALLOC_ONE_RT(Scheme_Load_Delay);
05127     SET_REQUIRED_TAG(delay_info->type = scheme_rt_delay_load_info);
05128     delay_info->path = params->delay_load_info;
05129   } else
05130     delay_info = NULL;
05131 
05132   /* Check version: */
05133   size = scheme_get_byte(port);
05134   {
05135     char buf[64];
05136 
05137     if (size < 0) size = 0;
05138     if (size > 63) size = 63;
05139 
05140     got = scheme_get_bytes(port, size, buf, 0);
05141     buf[got] = 0;
05142 
05143     if (!params->skip_zo_vers_check)
05144       if (strcmp(buf, MZSCHEME_VERSION))
05145         scheme_read_err(port, stxsrc, line, col, pos, got, 0, NULL,
05146                         "read (compiled): code compiled for version %s, not %s",
05147                         (buf[0] ? buf : "???"), MZSCHEME_VERSION);
05148   }
05149   offset += size + 1;
05150 
05151   symtabsize = read_simple_number_from_port(port);
05152   offset += 4;
05153   
05154   /* Load table mapping symtab indices to stream positions: */
05155 
05156   all_short = scheme_get_byte(port);
05157   so = (long *)scheme_malloc_fail_ok(scheme_malloc_atomic, sizeof(long) * symtabsize);
05158   if ((got = scheme_get_bytes(port, (all_short ? 2 : 4) * (symtabsize - 1), (char *)so, 0)) 
05159       != ((all_short ? 2 : 4) * (symtabsize - 1)))
05160     scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
05161                   "read (compiled): ill-formed code (bad table count: %ld != %ld)",
05162                   got, (all_short ? 2 : 4) * (symtabsize - 1));
05163   offset += got;
05164 
05165   {
05166     /* This loop runs top to bottom, since sizeof(long) may be larger
05167        than the decoded integers (but it's never shorter) */
05168     long j, v;
05169     unsigned char *so_c = (unsigned char *)so;
05170     for (j = symtabsize - 1; j--; ) {
05171       if (all_short) {
05172         v = so_c[j * 2]
05173           + (so_c[j * 2 + 1] << 8);
05174       } else {
05175         v = so_c[j * 4]
05176           + (so_c[j * 4 + 1] << 8)
05177           + (so_c[j * 4 + 2] << 16)
05178           + (so_c[j * 4 + 3] << 24);
05179       }
05180       so[j] = v;
05181     }
05182   }
05183 
05184   /* Continue reading content */
05185 
05186   shared_size = read_simple_number_from_port(port);
05187   size = read_simple_number_from_port(port);
05188 
05189   if (shared_size >= size) {
05190     scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
05191                   "read (compiled): ill-formed code (shared size %ld >= total size %ld)",
05192                   shared_size, size);
05193   }
05194 
05195   offset += 8;
05196 
05197   rp = MALLOC_ONE_RT(CPort);
05198   SET_REQUIRED_TAG(rp->type = scheme_rt_compact_port);
05199   {
05200     unsigned char *st;
05201     st = (unsigned char *)scheme_malloc_fail_ok(scheme_malloc_atomic, size + 1);
05202     rp->start = st;
05203   }
05204   rp->pos = 0;
05205   {
05206     long base;
05207     scheme_tell_all(port, NULL, NULL, &base);
05208     rp->base = base;
05209   }
05210   rp->orig_port = port;
05211   rp->size = size;
05212   if ((got = scheme_get_bytes(port, size, (char *)rp->start, 0)) != size)
05213     scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
05214                   "read (compiled): ill-formed code (bad count: %ld != %ld, started at %ld)",
05215                   got, size, rp->base);
05216 
05217   local_ht = MALLOC_N(Scheme_Hash_Table *, 1);
05218 
05219   symtab = MALLOC_N(Scheme_Object *, symtabsize);
05220   rp->symtab_size = symtabsize;
05221   rp->ht = local_ht;
05222   rp->symtab = symtab;
05223 
05224   config = scheme_current_config();
05225 
05226   insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR);
05227   rp->insp = insp;
05228 
05229   dir = scheme_get_param(config, MZCONFIG_LOAD_DIRECTORY);
05230   rp->relto = dir;
05231 
05232   rp->magic_sym = params->magic_sym;
05233   rp->magic_val = params->magic_val;
05234 
05235   rp->shared_offsets = so;
05236   rp->delay_info = delay_info;
05237 
05238   if (!delay_info) {
05239     /* Read shared parts: */
05240     long j, len;
05241     Scheme_Object *v;
05242     len = symtabsize;
05243     for (j = 1; j < len; j++) {
05244       if (!symtab[j]) {
05245         v = read_compact(rp, 0);
05246         symtab[j] = v;
05247       } else {
05248         if (j+1 < len)
05249           rp->pos = so[j];
05250         else
05251           rp->pos = shared_size;
05252       }
05253     }
05254   } else {
05255     scheme_reserve_file_descriptor();
05256     rp->pos = shared_size; /* skip shared part */
05257     delay_info->file_offset = offset + 2 + 1; /* +2 is for #~; +1 is ???? */
05258     delay_info->size = shared_size;
05259     delay_info->symtab_size = rp->symtab_size;
05260     delay_info->symtab = rp->symtab;
05261     delay_info->shared_offsets = rp->shared_offsets;
05262     delay_info->insp = rp->insp;
05263     delay_info->relto = rp->relto;
05264 
05265     if (perma_cache) {
05266       unsigned char *cache;
05267       cache = (unsigned char *)scheme_malloc_atomic(shared_size);
05268       memcpy(cache, rp->start, shared_size);
05269       delay_info->cached = cache;
05270       delay_info->cached_port = port;
05271       delay_info->perma_cache = 1;
05272     }
05273   }
05274 
05275   /* Read main body: */
05276   result = read_marshalled(scheme_compilation_top_type, rp);
05277 
05278   if (delay_info)
05279     if (delay_info->ut)
05280       delay_info->ut->rp = NULL; /* clean up */
05281 
05282   if (*local_ht) {
05283     scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
05284                   "read (compiled): ill-formed code (unexpected graph structure)");
05285     return NULL;
05286   }
05287 
05288   if (SAME_TYPE(SCHEME_TYPE(result), scheme_compilation_top_type)) {
05289     Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)result;
05290 
05291     scheme_validate_code(rp, top->code,
05292                       top->max_let_depth,
05293                       top->prefix->num_toplevels,
05294                       top->prefix->num_stxes,
05295                       top->prefix->num_lifts,
05296                          0);
05297     /* If no exception, the resulting code is ok. */
05298   } else
05299     scheme_ill_formed_code(rp);
05300 
05301   return result;
05302 }
05303 
05304 static Scheme_Load_Delay *clear_bytes_chain;
05305 
05306 void scheme_clear_delayed_load_cache()
05307 {
05308   Scheme_Load_Delay *next;
05309 
05310   while (clear_bytes_chain) {
05311     next = clear_bytes_chain->clear_bytes_next;
05312     clear_bytes_chain->cached = NULL;
05313     clear_bytes_chain->cached_port = NULL;
05314     clear_bytes_chain->clear_bytes_next = NULL;
05315     clear_bytes_chain->clear_bytes_prev = NULL;
05316     clear_bytes_chain = next;
05317   }
05318 }
05319 
05320 Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_info)
05321 {
05322   Scheme_Load_Delay * volatile delay_info = _delay_info;
05323   CPort *rp;
05324   CPort * volatile old_rp;
05325   volatile int which = _which;
05326   long size, got;
05327   unsigned char *st;
05328   Scheme_Object * volatile port;
05329   Scheme_Object * volatile v;
05330   Scheme_Object * volatile v_exn;
05331   Scheme_Hash_Table ** volatile ht;
05332   mz_jmp_buf newbuf, * volatile savebuf;
05333 
05334   /* Remove from cache-clearing chain: */
05335   if (!delay_info->perma_cache) {
05336     if (delay_info->clear_bytes_prev)
05337       delay_info->clear_bytes_prev->clear_bytes_next = delay_info->clear_bytes_next;
05338     else if (clear_bytes_chain == delay_info)
05339       clear_bytes_chain = delay_info->clear_bytes_next;
05340     if (delay_info->clear_bytes_next)
05341       delay_info->clear_bytes_next->clear_bytes_prev = delay_info->clear_bytes_prev;
05342     
05343     delay_info->clear_bytes_prev = NULL;
05344     delay_info->clear_bytes_next = NULL;
05345   }
05346 
05347   size = delay_info->size;
05348 
05349   /* Load in file bytes: */
05350   if (!delay_info->cached) {
05351     Scheme_Object *a[1];
05352 
05353     scheme_start_atomic();
05354     scheme_release_file_descriptor();
05355 
05356     a[0] = delay_info->path;
05357     port = scheme_do_open_input_file("on-demand-loader", 0, 1, a, 0);
05358 
05359     savebuf = scheme_current_thread->error_buf;
05360     scheme_current_thread->error_buf = &newbuf;
05361     if (scheme_setjmp(newbuf)) {
05362       scheme_end_atomic_no_swap();
05363       scheme_close_input_port(port);
05364       scheme_current_thread->error_buf = savebuf;
05365       scheme_longjmp(*savebuf, 1);
05366       return NULL;
05367     } else {
05368       st = (unsigned char *)scheme_malloc_atomic(size + 1);
05369 
05370       scheme_set_file_position(port, delay_info->file_offset);
05371       
05372       if ((got = scheme_get_bytes(port, size, (char *)st, 0)) != size)
05373         scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
05374                         "on-demand load: ill-formed code (bad count: %ld != %ld, started at %ld)",
05375                         got, size, 0);
05376     }
05377     scheme_current_thread->error_buf = savebuf;
05378 
05379     scheme_close_input_port(port);
05380     scheme_reserve_file_descriptor();
05381 
05382     scheme_end_atomic_no_swap();
05383 
05384     delay_info->cached = st;
05385     delay_info->cached_port = port;
05386   } else {
05387     port = delay_info->cached_port;
05388   }
05389 
05390   /* Allow only one thread at a time. This is a little questionable,
05391      because unmarshalling could take arbitrarily long, and an
05392      untrusted program might construct an adversarial bytecode. That
05393      would be relatively difficult, though. In practice, unmarshalling
05394      will be fast. */
05395   scheme_start_atomic();
05396 
05397   old_rp = delay_info->current_rp;
05398 
05399   /* Create a port for reading: */
05400   rp = MALLOC_ONE_RT(CPort);
05401   SET_REQUIRED_TAG(rp->type = scheme_rt_compact_port);
05402   rp->start = delay_info->cached;
05403   rp->pos = 0;
05404   rp->base = 0;
05405   rp->orig_port = port;
05406   rp->size = size;
05407   rp->ut = delay_info->ut;
05408   if (delay_info->ut)
05409     delay_info->ut->rp = rp;
05410 
05411   ht = MALLOC_N(Scheme_Hash_Table *, 1);
05412 
05413   rp->symtab_size = delay_info->symtab_size;
05414   rp->ht = ht;
05415   rp->symtab = delay_info->symtab;
05416   rp->insp = delay_info->insp;
05417   rp->relto = delay_info->relto;
05418   rp->shared_offsets = delay_info->shared_offsets;
05419   rp->delay_info = delay_info;
05420 
05421   rp->pos = delay_info->shared_offsets[which - 1];
05422 
05423   /* Perform the read, catching escapes so we can clean up: */
05424   savebuf = scheme_current_thread->error_buf;
05425   scheme_current_thread->error_buf = &newbuf;
05426   scheme_current_thread->reading_delayed = scheme_true;
05427   if (scheme_setjmp(newbuf)) {
05428     v = NULL;
05429     v_exn = scheme_current_thread->reading_delayed;
05430   } else {
05431     v = read_compact(rp, 0);
05432     v_exn = NULL;
05433   }
05434   scheme_current_thread->error_buf = savebuf;
05435   scheme_current_thread->reading_delayed = NULL;
05436 
05437   /* Clean up: */
05438 
05439   delay_info->current_rp = old_rp;
05440   if (delay_info->ut)
05441     delay_info->ut->rp = old_rp;
05442 
05443   if (!old_rp && !delay_info->perma_cache) {
05444     /* No one using the cache, to register it to be cleaned up */
05445     delay_info->clear_bytes_next = clear_bytes_chain;
05446     if (clear_bytes_chain)
05447       clear_bytes_chain->clear_bytes_prev = delay_info;
05448     clear_bytes_chain = delay_info;
05449   }
05450 
05451   scheme_end_atomic_no_swap();
05452   
05453   if (v) {
05454     if (*ht) {
05455       v = resolve_references(v, port, NULL,
05456                              scheme_make_hash_table(SCHEME_hash_ptr), 
05457                              scheme_make_hash_table(SCHEME_hash_ptr), 
05458                              0, 0);
05459     }
05460 
05461     delay_info->symtab[which] = v;
05462         
05463     return v;
05464   } else {
05465     if (v_exn && !scheme_current_thread->cjs.is_kill)
05466       scheme_raise(v_exn);
05467     scheme_longjmp(*scheme_current_thread->error_buf, 1);
05468     return NULL;
05469   }
05470 }
05471 
05472 Scheme_Object *scheme_unmarshal_wrap_get(Scheme_Unmarshal_Tables *ut, 
05473                                          Scheme_Object *wraps_key, 
05474                                          int *_decoded)
05475 {
05476   long l;
05477   l = SCHEME_INT_VAL(wraps_key);
05478 
05479   if ((l < 0) || ((unsigned long)l >= ut->rp->symtab_size))
05480     scheme_ill_formed_code(ut->rp);
05481 
05482   if (!ut->rp->symtab[l]) {
05483     Scheme_Object *v;
05484     long save_pos;
05485 
05486     if (!ut->rp->delay_info)
05487       scheme_ill_formed_code(ut->rp);
05488 
05489     save_pos = ut->rp->pos;
05490     ut->rp->pos = ut->rp->shared_offsets[l - 1];
05491     v = read_compact(ut->rp, 0);
05492     ut->rp->pos = save_pos;
05493     ut->rp->symtab[l] = v;
05494   }
05495 
05496   *_decoded = ut->decoded[l];
05497   return ut->rp->symtab[l];
05498 }
05499 
05500 void scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables *ut, 
05501                                Scheme_Object *wraps_key, 
05502                                Scheme_Object *v)
05503 {
05504   long l;
05505   l = SCHEME_INT_VAL(wraps_key);
05506 
05507   ut->rp->symtab[l] = v;
05508   ut->decoded[l] = 1;
05509 }
05510 
05511 /*========================================================================*/
05512 /*                           readtable support                            */
05513 /*========================================================================*/
05514 
05515 Scheme_Object *scheme_make_default_readtable()
05516 {
05517   return scheme_false;
05518 }
05519 
05520 static int readtable_kind(Readtable *t, int ch, ReadParams *params)
05521 {
05522   int k;
05523   Scheme_Object *v;
05524 
05525   if (ch < 128)
05526     k = t->fast_mapping[ch];
05527   else {
05528     v = scheme_hash_get(t->mapping, scheme_make_integer(ch));
05529     if (!v) {
05530       if (scheme_isspace(ch))
05531        k = READTABLE_WHITESPACE;
05532       else
05533        k = READTABLE_CONTINUING;
05534     } else
05535       k = SCHEME_INT_VAL(SCHEME_CAR(v));
05536   }
05537 
05538   if (k == READTABLE_MAPPED) {
05539     /* ch is mapped to a default behavior: */
05540     v = scheme_hash_get(t->mapping, scheme_make_integer(ch));
05541     ch = SCHEME_INT_VAL(SCHEME_CDR(v));
05542     if (ch < 128)
05543       k = builtin_fast[ch];
05544     else if (scheme_isspace(ch))
05545       k = READTABLE_WHITESPACE;
05546     else
05547       k = READTABLE_CONTINUING;
05548   }
05549 
05550   if (k == READTABLE_MULTIPLE_ESCAPE) {
05551     /* This is the only one sensitive to params. */
05552     if (!params->can_read_pipe_quote)
05553       return READTABLE_CONTINUING;
05554   }
05555 
05556   return k;
05557 }
05558 
05559 static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, ReadParams *params,
05560                                  Scheme_Object *port, Scheme_Object *src, long line, long col, long pos,
05561                                  int get_info, 
05562                                      Scheme_Hash_Table **ht, Scheme_Object *modpath_stx)
05563 {
05564   int cnt, add_srcloc = 0;
05565   Scheme_Object *a[6], *v;
05566   Scheme_Cont_Frame_Data cframe;
05567   
05568   if (w_char) {
05569     a[0] = scheme_make_character(ch);
05570     a[1] = port;
05571     a[2] = proc;
05572     if (!src && scheme_check_proc_arity(NULL, 2, 2, 3, a)) {
05573       cnt = 2;
05574     } else {
05575       cnt = 6;
05576       a[2] = (src ? src : scheme_false);
05577       add_srcloc = 3;
05578     }
05579   } else {
05580     if (src) {
05581       a[0] = src;
05582       a[1] = port;
05583       if (modpath_stx) {
05584         a[2] = modpath_stx;
05585         add_srcloc = 3;
05586         cnt = 6;
05587       } else
05588         cnt = 2;
05589     } else {
05590       a[0] = port;
05591       if (modpath_stx) {
05592         a[1] = modpath_stx;
05593         add_srcloc = 2;
05594         cnt = 5;
05595       } else
05596         cnt = 1;
05597     }
05598   }
05599 
05600   if (add_srcloc) {
05601     a[add_srcloc + 0] = (line > 0) ? scheme_make_integer(line) : scheme_false;
05602     a[add_srcloc + 1] = (col > 0) ? scheme_make_integer(col-1) : scheme_false;
05603     a[add_srcloc + 2] = (pos > 0) ? scheme_make_integer(pos) : scheme_false;
05604   }
05605 
05606   if (src) {
05607     /* fresh ht in case nested uses recursive `read' instead of recursive `read-syntax': */
05608     ht = MALLOC_N(Scheme_Hash_Table *, 1);
05609   }
05610 
05611   if (!get_info) {
05612     scheme_push_continuation_frame(&cframe);
05613     scheme_set_in_read_mark(src, ht);
05614   }
05615 
05616   v = scheme_apply(proc, cnt, a);
05617 
05618   if (get_info) {
05619     a[0] = v;
05620     if (!scheme_check_proc_arity(NULL, 1, 0, 1, a)) {
05621       scheme_wrong_type("read-language", "procedure (arity 1)", -1, -1, a);
05622     }
05623   }
05624 
05625   if (!get_info) {
05626     scheme_pop_continuation_frame(&cframe);
05627   }
05628 
05629   if (!get_info && !scheme_special_comment_value(v)) {
05630     if (SCHEME_STXP(v)) {
05631       if (!src)
05632        v = scheme_syntax_to_datum(v, 0, NULL);
05633     } else if (src) {
05634       Scheme_Object *s;
05635 
05636       if (*ht) {
05637         /* resolve references from recursive `read': */
05638         v = resolve_references(v, port, NULL,
05639                                scheme_make_hash_table(SCHEME_hash_ptr), 
05640                                scheme_make_hash_table(SCHEME_hash_ptr), 
05641                                1, 0);
05642       }
05643 
05644       s = scheme_make_stx_w_offset(scheme_false, line, col, pos, SPAN(port, pos), src, STX_SRCTAG);
05645       v = scheme_datum_to_syntax(v, s, scheme_false, 1, 1);
05646     }
05647 
05648     if (!src)
05649       set_need_copy(ht);
05650   }
05651   
05652   return v;
05653 }
05654 
05655 void scheme_set_in_read_mark(Scheme_Object *src, Scheme_Hash_Table **ht)
05656 {
05657   Scheme_Object *v;
05658 
05659   if (ht)
05660     v = scheme_make_raw_pair((Scheme_Object *)ht, 
05661                           (src ? scheme_true : scheme_false));
05662   else
05663     v = scheme_false;
05664   scheme_set_cont_mark(unresolved_uninterned_symbol, v);
05665 }
05666 
05667 static Scheme_Object *readtable_handle(Readtable *t, int *_ch, int *_use_default, ReadParams *params,
05668                                    Scheme_Object *port, Scheme_Object *src, long line, long col, long pos,
05669                                    Scheme_Hash_Table **ht)
05670 {
05671   int ch = *_ch;
05672   Scheme_Object *v;
05673 
05674   v = scheme_hash_get(t->mapping, scheme_make_integer(ch));
05675 
05676   if (!v) {
05677     *_use_default = 1;
05678     return NULL;
05679   }
05680 
05681   if (SCHEME_INT_VAL(SCHEME_CAR(v)) == READTABLE_MAPPED) {
05682     *_ch = SCHEME_INT_VAL(SCHEME_CDR(v));
05683     *_use_default = 1;
05684     return NULL;
05685   }
05686 
05687   *_use_default = 0;
05688 
05689   v = SCHEME_CDR(v);
05690 
05691   v = readtable_call(1, ch, v, params, port, src, line, col, pos, 0, ht, NULL);
05692   
05693   return v;
05694 }
05695 
05696 static int readtable_effective_char(Readtable *t, int ch)
05697 {
05698   Scheme_Object *v;
05699 
05700   if (!t) return ch;
05701 
05702   v = scheme_hash_get(t->mapping, scheme_make_integer(ch));
05703 
05704   if (v) {
05705     if (SCHEME_INT_VAL(SCHEME_CAR(v)) == READTABLE_MAPPED)
05706       return SCHEME_INT_VAL(SCHEME_CDR(v));
05707     return 0; /* not equivalent to any standard char mapping */
05708   } else
05709     return ch;
05710 }
05711 
05712 static Scheme_Object *readtable_handle_hash(Readtable *t, int ch, int *_use_default, ReadParams *params,
05713                                        Scheme_Object *port, Scheme_Object *src, long line, long col, long pos,
05714                                        Scheme_Hash_Table **ht)
05715 {
05716   Scheme_Object *v;
05717 
05718   v = scheme_hash_get(t->mapping, scheme_make_integer(-ch));
05719 
05720   if (!v) {
05721     *_use_default = 1;
05722     return NULL;
05723   }
05724 
05725   *_use_default = 0;
05726 
05727   v = readtable_call(1, ch, v, params, port, src, line, col, pos, 0, ht, NULL);
05728 
05729   if (scheme_special_comment_value(v))
05730     return NULL;
05731   else
05732     return v;
05733 }
05734 
05735 static Scheme_Object *make_readtable(int argc, Scheme_Object **argv)
05736 {
05737   Scheme_Object *sym, *val;
05738   Readtable *t, *orig_t;
05739   Scheme_Hash_Table *ht;
05740   char *fast;
05741   int i, ch;
05742 
05743   if (SCHEME_FALSEP(argv[0]))
05744     orig_t = NULL;
05745   else {
05746     if (!SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(argv[0]))) {
05747       scheme_wrong_type("make-readtable", "readtable or #f", 0, argc, argv);
05748       return NULL;
05749     }
05750     orig_t = (Readtable *)argv[0];
05751   }
05752 
05753   if (!terminating_macro_symbol) {
05754     REGISTER_SO(terminating_macro_symbol);
05755     REGISTER_SO(non_terminating_macro_symbol);
05756     REGISTER_SO(dispatch_macro_symbol);
05757     REGISTER_SO(builtin_fast);
05758     terminating_macro_symbol = scheme_intern_symbol("terminating-macro");
05759     non_terminating_macro_symbol = scheme_intern_symbol("non-terminating-macro");
05760     dispatch_macro_symbol = scheme_intern_symbol("dispatch-macro");
05761     
05762     fast = scheme_malloc_atomic(128);
05763     memset(fast, READTABLE_CONTINUING, 128);
05764     for (i = 0; i < 128; i++) {
05765       if (scheme_isspace(i))
05766        fast[i] = READTABLE_WHITESPACE;
05767     }
05768     fast[';'] = READTABLE_TERMINATING;
05769     fast['\''] = READTABLE_TERMINATING;
05770     fast[','] = READTABLE_TERMINATING;
05771     fast['"'] = READTABLE_TERMINATING;
05772     fast['|'] = READTABLE_MULTIPLE_ESCAPE;
05773     fast['\\'] = READTABLE_SINGLE_ESCAPE;
05774     fast['('] = READTABLE_TERMINATING;
05775     fast['['] = READTABLE_TERMINATING;
05776     fast['{'] = READTABLE_TERMINATING;
05777     fast[')'] = READTABLE_TERMINATING;
05778     fast[']'] = READTABLE_TERMINATING;
05779     fast['}'] = READTABLE_TERMINATING;
05780     builtin_fast = fast;
05781   }
05782 
05783   t = MALLOC_ONE_TAGGED(Readtable);
05784   t->so.type = scheme_readtable_type;
05785   if (orig_t)
05786     ht = scheme_clone_hash_table(orig_t->mapping);
05787   else
05788     ht = scheme_make_hash_table(SCHEME_hash_ptr);
05789   t->mapping = ht;
05790   fast = scheme_malloc_atomic(128);
05791   memcpy(fast, (orig_t ? orig_t->fast_mapping : builtin_fast), 128);
05792   t->fast_mapping = fast;
05793   t->symbol_parser = (orig_t ? orig_t->symbol_parser : NULL);
05794 
05795   for (i = 1; i < argc; i += 3) {
05796     if (!SCHEME_FALSEP(argv[i]) && !SCHEME_CHARP(argv[i])) {
05797       scheme_wrong_type("make-readtable", "character or #f", i, argc, argv);
05798       return NULL;
05799     }
05800 
05801     if (i + 1 >= argc) {
05802       if (SCHEME_FALSEP(argv[i]))
05803        scheme_arg_mismatch("make-readtable",
05804                          "expected 'non-terminating-macro after #f",
05805                          NULL);
05806       else
05807        scheme_arg_mismatch("make-readtable",
05808                          "expected 'terminating-macro, 'non-terminating-macro, 'dispatch-macro,"
05809                          " or character argument after character argument: ",
05810                          argv[i]);
05811     }
05812 
05813     sym = argv[i + 1];
05814     if (!SAME_OBJ(sym, terminating_macro_symbol)
05815        && !SAME_OBJ(sym, non_terminating_macro_symbol)
05816        && !SAME_OBJ(sym, dispatch_macro_symbol)
05817        && !SCHEME_CHARP(sym)) {
05818       scheme_wrong_type("make-readtable", 
05819                      "'terminating-macro, 'non-terminating-macro, 'dispatch-macro, or character", 
05820                      i+1, argc, argv);
05821       return NULL;
05822     }
05823     if (SCHEME_FALSEP(argv[i])
05824        && !SAME_OBJ(sym, non_terminating_macro_symbol)) {
05825       scheme_arg_mismatch("make-readtable",
05826                        "expected 'non-terminating-macro after #f, given: ",
05827                        sym);
05828     }
05829 
05830     if (i + 2 >= argc) {
05831       scheme_arg_mismatch("make-readtable",
05832                        (SCHEME_CHARP(sym) 
05833                         ? "expected readtable or #f argument after character argument, given: "
05834                         : "expected procedure argument after symbol argument, given: "),
05835                        argv[i+1]);
05836     }
05837 
05838     if (SCHEME_FALSEP(argv[i])) {
05839       scheme_check_proc_arity("make-readtable", 6, i+2, argc, argv);
05840       t->symbol_parser = argv[i + 2];
05841     } else if (SAME_OBJ(sym, dispatch_macro_symbol)) {
05842       ch = SCHEME_CHAR_VAL(argv[i]);
05843       scheme_check_proc_arity("make-readtable", 6, i+2, argc, argv);
05844       scheme_hash_set(t->mapping, scheme_make_integer(-ch), argv[i+2]);
05845     } else {
05846       if (SCHEME_CHARP(sym)) {
05847        Readtable *src;
05848        int sch;
05849 
05850        if (SCHEME_FALSEP(argv[i+2])) {
05851          src = NULL;
05852        } else {
05853          if (!SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(argv[i+2]))) {
05854            scheme_wrong_type("make-readtable", "readtable or #f", i+2, argc, argv);
05855            return NULL;
05856          }
05857          src = (Readtable *)(argv[i+2]);
05858        }
05859        sch = SCHEME_CHAR_VAL(argv[i+1]);
05860        if (!src)
05861          val = NULL; /* use default */
05862        else
05863          val = scheme_hash_get(src->mapping, scheme_make_integer(sch));
05864        if (!val)
05865          val = scheme_make_pair(scheme_make_integer(READTABLE_MAPPED), scheme_make_integer(sch));
05866       } else {
05867        int kind;
05868        scheme_check_proc_arity("make-readtable", 6, i+2, argc, argv);
05869        kind = (SAME_OBJ(sym, non_terminating_macro_symbol)
05870               ? READTABLE_CONTINUING
05871               : READTABLE_TERMINATING);
05872        val = scheme_make_pair(scheme_make_integer(kind), argv[i+2]);
05873       }
05874 
05875       ch = SCHEME_CHAR_VAL(argv[i]);
05876       if (!val) {
05877        scheme_hash_set(t->mapping, scheme_make_integer(ch), NULL);
05878        if (ch < 128)
05879          t->fast_mapping[ch] = 0;
05880       } else {
05881        scheme_hash_set(t->mapping, scheme_make_integer(ch), val);
05882        if (ch < 128)
05883          t->fast_mapping[ch] = (char)SCHEME_INT_VAL(SCHEME_CAR(val));
05884       }
05885     }
05886   }
05887 
05888   return (Scheme_Object *)t;
05889 }
05890 
05891 static Scheme_Object *readtable_mapping(int argc, Scheme_Object **argv)
05892 {
05893   Scheme_Object *v1, *v2, *a[3];
05894   Readtable *t;
05895   int ch;
05896 
05897   if (!SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(argv[0]))) {
05898     scheme_wrong_type("readtable-mapping", "readtable", 0, argc, argv);
05899     return NULL;
05900   }
05901   if (!SCHEME_CHARP(argv[1])) {
05902     scheme_wrong_type("readtable-mapping", "character", 1, argc, argv);
05903     return NULL;
05904   }
05905   
05906   t = (Readtable *)argv[0];
05907   ch = SCHEME_CHAR_VAL(argv[1]);
05908   
05909   v1 = scheme_hash_get(t->mapping, scheme_make_integer(ch));
05910   v2 = scheme_hash_get(t->mapping, scheme_make_integer(-ch));
05911 
05912   a[0] = argv[1];
05913   a[1] = scheme_false;
05914   if (v1) {
05915     int v;
05916     v = SCHEME_INT_VAL(SCHEME_CAR(v1));
05917     if (v & READTABLE_MAPPED) {
05918       v = SCHEME_INT_VAL(SCHEME_CDR(v1));
05919       a[0] = scheme_make_character(v);
05920       a[1] = scheme_false;
05921     } else if (v & READTABLE_CONTINUING) {
05922       a[0] = non_terminating_macro_symbol;
05923       a[1] = SCHEME_CDR(v1);
05924     } else if (v & READTABLE_TERMINATING) {
05925       a[0] = terminating_macro_symbol;
05926       a[1] = SCHEME_CDR(v1);
05927     }
05928   }
05929   a[2] = scheme_false;
05930   if (v2) {
05931     a[2] = v2;
05932   }
05933 
05934   return scheme_values(3, a);
05935 }
05936 
05937 static Scheme_Object *readtable_p(int argc, Scheme_Object **argv)
05938 {
05939   return (SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(argv[0]))
05940          ? scheme_true
05941          : scheme_false);
05942 }
05943 
05944 static Scheme_Object *readtable_or_false_p(int argc, Scheme_Object **argv)
05945 {
05946   if (SCHEME_FALSEP(argv[0]))
05947     return scheme_true;
05948   return readtable_p(argc, argv);
05949 }
05950 
05951 static Scheme_Object *current_readtable(int argc, Scheme_Object **argv)
05952 {
05953   return scheme_param_config("current-readtable", 
05954                           scheme_make_integer(MZCONFIG_READTABLE),
05955                           argc, argv,
05956                           -1, readtable_or_false_p, "readtable", 0);
05957 }
05958 
05959 static Scheme_Object *current_reader_guard(int argc, Scheme_Object **argv)
05960 {
05961   return scheme_param_config("current-reader-guard", 
05962                           scheme_make_integer(MZCONFIG_READER_GUARD),
05963                           argc, argv,
05964                           1, NULL, NULL, 0);
05965 }
05966 
05967 static Scheme_Object *no_val_thunk(void *d, int argc, Scheme_Object **argv)
05968 {
05969   return (Scheme_Object *)d;
05970 }
05971 
05972 static Scheme_Object *do_reader(Scheme_Object *modpath_stx,
05973                                 Scheme_Object *port,
05974                                 Scheme_Object *stxsrc, long line, long col, long pos,
05975                                 int get_info,
05976                                 Scheme_Hash_Table **ht,
05977                                 Scheme_Object *indentation, ReadParams *params)
05978 {
05979   Scheme_Object *modpath, *name, *a[3], *proc, *v, *no_val;
05980   int num_a;
05981 
05982   if (stxsrc)
05983     modpath = scheme_syntax_to_datum(modpath_stx, 0, NULL);
05984   else
05985     modpath = modpath_stx;
05986 
05987   proc = scheme_get_param(scheme_current_config(), MZCONFIG_READER_GUARD);
05988 
05989   a[0] = modpath;
05990   modpath = scheme_apply(proc, 1, a);
05991   
05992   a[0] = modpath;
05993   if (get_info)
05994     name = scheme_intern_symbol("get-info");
05995   else if (stxsrc)
05996     name = scheme_intern_symbol("read-syntax");
05997   else
05998     name = scheme_intern_symbol("read");
05999   a[1] = name;
06000   if (get_info) {
06001     no_val = scheme_make_pair(scheme_false, scheme_false);
06002     a[2] = scheme_make_closed_prim(no_val_thunk, no_val);
06003     num_a = 3;
06004   } else {
06005     no_val = NULL;
06006     num_a = 2;
06007   }
06008 
06009   proc = scheme_dynamic_require(num_a, a);
06010   if (get_info) {
06011     proc = scheme_force_value(proc);
06012   }
06013 
06014   if (get_info && SAME_OBJ(proc, no_val))
06015     return scheme_false;
06016 
06017   a[0] = proc;
06018   if (scheme_check_proc_arity(NULL, stxsrc ? 6 : 5, 0, 1, a)) {
06019     /* provide modpath_stx to reader */
06020   } else if (!get_info && scheme_check_proc_arity(NULL, stxsrc ? 2 : 1, 0, 1, a)) {
06021     /* don't provide modpath_stx to reader */
06022     modpath_stx = NULL;
06023   } else {
06024     scheme_wrong_type("#reader",
06025                     (stxsrc ? "procedure (arity 2 or 6)" 
06026                        : (get_info
06027                           ? "procedure (arity 5)"
06028                           : "procedure (arity 1 or 5)")),
06029                     -1, -1, a);
06030     return NULL;
06031   }
06032 
06033   v = readtable_call(0, 0, proc, params,
06034                    port, stxsrc, line, col, pos,
06035                    get_info, ht, modpath_stx);
06036 
06037   if (!get_info && scheme_special_comment_value(v))
06038     return NULL;
06039   else
06040     return v;
06041 }
06042 
06043 /* "#reader" has been read */
06044 static Scheme_Object *read_reader(Scheme_Object *port,
06045                               Scheme_Object *stxsrc, long line, long col, long pos,
06046                               Scheme_Hash_Table **ht,
06047                               Scheme_Object *indentation, ReadParams *params)
06048 {
06049   Scheme_Object *modpath;
06050 
06051   if (stxsrc)
06052     modpath = scheme_read_syntax(port, stxsrc);
06053   else
06054     modpath = scheme_read(port);
06055 
06056   if (SCHEME_EOFP(modpath)) {
06057     scheme_read_err(port, stxsrc, line, col, pos, 1, EOF, indentation, 
06058                   "read: expected a datum after #reader, found end-of-file");
06059     return NULL;
06060   }
06061 
06062   return do_reader(modpath, port, stxsrc, line, col, pos, 0, ht, indentation, params);
06063 }
06064 
06065 /* "#lang " has been read */
06066 static Scheme_Object *read_lang(Scheme_Object *port,
06067                                 Scheme_Object *stxsrc, long line, long col, long pos,
06068                                 int get_info,
06069                                 Scheme_Hash_Table **ht,
06070                                 Scheme_Object *indentation, ReadParams *params,
06071                                 int init_ch)
06072 {
06073   int size, len;
06074   GC_CAN_IGNORE char *sfx;
06075   char *buf, *naya;
06076   int ch = 0;
06077   Scheme_Object *modpath;
06078   long name_line = -1, name_col = -1, name_pos = -1;
06079 
06080   size = 32;
06081   buf = MALLOC_N_ATOMIC(char, size);
06082   len = 0;
06083 
06084   if (init_ch) {
06085     ch = init_ch;
06086   } else {
06087     ch = scheme_getc_special_ok(port);
06088   }
06089   scheme_tell_all(port, &name_line, &name_col, &name_pos);
06090 
06091   while (1) {
06092     /* ch was only peeked at this point (except for the first iteration), so we
06093        can leave the input immediately after the language spec */
06094     if (ch == EOF) {
06095       break;
06096     } else if (ch == SCHEME_SPECIAL) {
06097       ch = scheme_getc_special_ok(port);
06098       scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation,
06099                       "read: found non-character while reading `#lang'");
06100     } else if (scheme_isspace(ch)) {
06101       break;
06102     } else {
06103       if (len) ch = scheme_getc_special_ok(port);
06104       if ((ch < 128)
06105           && (is_lang_nonsep_char(ch)
06106               || (ch == '/'))) {
06107         if (len + 1 >= size) {
06108           size *= 2;
06109           naya = MALLOC_N_ATOMIC(char, size);
06110           memcpy(naya, buf, len * sizeof(char));
06111           buf = naya;
06112         }
06113         buf[len++] = ch;
06114       } else {
06115         scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, 
06116                         "read: expected only alphanumberic, `-', `+', `_', or `/'"
06117                         " characters for `#%s', found %c",
06118                         init_ch ? "!" : "lang",
06119                         ch);
06120         return NULL;
06121       }
06122     }
06123     ch = scheme_peekc_special_ok(port);
06124   }
06125 
06126   if (!len) {
06127     scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, 
06128                     (((ch == ' ') && !init_ch)
06129                      ? "read: expected a single space after `#lang'"
06130                      : "read: expected a non-empty sequence of alphanumberic, `-', `+', `_', or `/' after `#%s'"),
06131                     init_ch ? "!" : "lang ");
06132     return NULL;
06133   }
06134   if (buf[0] == '/') {
06135     scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, 
06136                     "read: expected a name that does not start `/' after `#lang'");
06137     return NULL;
06138   }
06139   if (buf[len - 1] == '/') {
06140     scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, 
06141                     "read: expected a name that does not end `/' after `#%s'",
06142                     init_ch ? "!" : "lang");
06143     return NULL;
06144   }
06145 
06146   if (len + 16 >= size) {
06147     size += 16;
06148     naya = MALLOC_N_ATOMIC(char, size * sizeof(char));
06149     memcpy(naya, buf, len * sizeof(char));
06150     buf = naya;
06151   }
06152   sfx = "/lang/reader";
06153   while (*sfx) {
06154     buf[len++] = *(sfx++);
06155   }
06156   buf[len] = 0;
06157 
06158   modpath = scheme_intern_symbol(buf);
06159   if (stxsrc) {
06160     long span;
06161     span = SPAN(port, name_pos);
06162     modpath = scheme_make_stx_w_offset(modpath, name_line, name_col, name_pos, 
06163                                        span, 
06164                                        stxsrc, STX_SRCTAG);
06165   }
06166 
06167   return do_reader(modpath, port, stxsrc, line, col, pos, get_info, ht, indentation, params);
06168 }
06169 
06170 Scheme_Object *scheme_read_language(Scheme_Object *port, int nonlang_ok)
06171 {
06172   return _internal_read(port, NULL, 0, 0, 0, 0, 0, -1,
06173                         NULL, NULL, NULL, NULL, nonlang_ok ? 2 : 1);
06174 }
06175 
06176 static Scheme_Object *expected_lang(const char *prefix, int ch,
06177                                     Scheme_Object *port, Scheme_Object *stxsrc,
06178                                     long line, long col, long pos,
06179                                     int get_lang)
06180 {
06181   if (get_lang > 1) {
06182     return scheme_void;
06183   } else {
06184     mzchar chs[2];
06185     char *more;
06186 
06187     chs[0] = 0;
06188     chs[1] = 0;
06189       
06190     if (ch == EOF)
06191       more = "an end-of-file";
06192     else if (ch == SCHEME_SPECIAL)
06193       more = "a non-character";
06194     else {
06195       chs[0] = ch;
06196       more = "";
06197     }
06198 
06199     scheme_read_err(port, stxsrc, line, col, pos, 1, ch, NULL, 
06200                     "read-language: expected (after whitespace and comments)"
06201                     " `#lang ' or `#!' followed"
06202                     " immediately by a language name, found %s%s%5%s%s%s",
06203                     (*prefix || *chs) ? "`" : "", 
06204                     prefix, chs, 
06205                     (*prefix || *chs) ? "`" : "", 
06206                     ((*prefix || *chs) && *more) ? " followed by " : "", 
06207                     more);
06208     
06209     return NULL;
06210   }
06211 }
06212 
06213 /*========================================================================*/
06214 /*                         precise GC traversers                          */
06215 /*========================================================================*/
06216 
06217 #ifdef MZ_PRECISE_GC
06218 
06219 START_XFORM_SKIP;
06220 
06221 #define MARKS_FOR_READ_C
06222 #include "mzmark.c"
06223 
06224 static void register_traversers(void)
06225 {
06226   GC_REG_TRAV(scheme_indent_type, mark_indent);
06227   GC_REG_TRAV(scheme_rt_compact_port, mark_cport);
06228   GC_REG_TRAV(scheme_readtable_type, mark_readtable);
06229   GC_REG_TRAV(scheme_rt_read_params, mark_read_params);
06230   GC_REG_TRAV(scheme_rt_delay_load_info, mark_delay_load);
06231   GC_REG_TRAV(scheme_rt_unmarshal_info, mark_unmarshal_tables);
06232 }
06233 
06234 END_XFORM_SKIP;
06235 
06236 #endif