read.c 66 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364
  1. /* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2003, 2004, 2006,
  2. * 2007, 2008, 2009, 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
  3. *
  4. * This library is free software; you can redistribute it and/or
  5. * modify it under the terms of the GNU Lesser General Public License
  6. * as published by the Free Software Foundation; either version 3 of
  7. * the License, or (at your option) any later version.
  8. *
  9. * This library is distributed in the hope that it will be useful, but
  10. * WITHOUT ANY WARRANTY; without even the implied warranty of
  11. * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. * Lesser General Public License for more details.
  13. *
  14. * You should have received a copy of the GNU Lesser General Public
  15. * License along with this library; if not, write to the Free Software
  16. * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17. * 02110-1301 USA
  18. */
  19. #ifdef HAVE_CONFIG_H
  20. # include <config.h>
  21. #endif
  22. #include <stdio.h>
  23. #include <string.h>
  24. #include <unistd.h>
  25. #include <unicase.h>
  26. #include <unictype.h>
  27. #include <c-strcase.h>
  28. #include <c-ctype.h>
  29. #include "libguile/_scm.h"
  30. #include "libguile/bytevectors.h"
  31. #include "libguile/chars.h"
  32. #include "libguile/eval.h"
  33. #include "libguile/arrays.h"
  34. #include "libguile/bitvectors.h"
  35. #include "libguile/keywords.h"
  36. #include "libguile/alist.h"
  37. #include "libguile/srcprop.h"
  38. #include "libguile/hashtab.h"
  39. #include "libguile/hash.h"
  40. #include "libguile/ports.h"
  41. #include "libguile/ports-internal.h"
  42. #include "libguile/fports.h"
  43. #include "libguile/root.h"
  44. #include "libguile/strings.h"
  45. #include "libguile/strports.h"
  46. #include "libguile/vectors.h"
  47. #include "libguile/validate.h"
  48. #include "libguile/srfi-4.h"
  49. #include "libguile/srfi-13.h"
  50. #include "libguile/read.h"
  51. #include "libguile/private-options.h"
  52. SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
  53. SCM_SYMBOL (scm_keyword_prefix, "prefix");
  54. SCM_SYMBOL (scm_keyword_postfix, "postfix");
  55. SCM_SYMBOL (sym_nil, "nil");
  56. /* SRFI-105 curly infix expression support */
  57. SCM_SYMBOL (sym_nfx, "$nfx$");
  58. SCM_SYMBOL (sym_bracket_list, "$bracket-list$");
  59. SCM_SYMBOL (sym_bracket_apply, "$bracket-apply$");
  60. scm_t_option scm_read_opts[] =
  61. {
  62. { SCM_OPTION_BOOLEAN, "copy", 0,
  63. "Copy source code expressions." },
  64. { SCM_OPTION_BOOLEAN, "positions", 1,
  65. "Record positions of source code expressions." },
  66. { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
  67. "Convert symbols to lower case."},
  68. { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F_BITS,
  69. "Style of keyword recognition: #f, 'prefix or 'postfix."},
  70. { SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
  71. "Use R6RS variable-length character and string hex escapes."},
  72. { SCM_OPTION_BOOLEAN, "square-brackets", 1,
  73. "Treat `[' and `]' as parentheses, for R6RS compatibility."},
  74. { SCM_OPTION_BOOLEAN, "hungry-eol-escapes", 0,
  75. "In strings, consume leading whitespace after an escaped end-of-line."},
  76. { SCM_OPTION_BOOLEAN, "curly-infix", 0,
  77. "Support SRFI-105 curly infix expressions."},
  78. { SCM_OPTION_BOOLEAN, "r7rs-symbols", 0,
  79. "Support R7RS |...| symbol notation."},
  80. { 0, },
  81. };
  82. /* Internal read options structure. This is initialized by 'scm_read'
  83. from the global and per-port read options, and a pointer is passed
  84. down to all helper functions. */
  85. enum t_keyword_style
  86. {
  87. KEYWORD_STYLE_HASH_PREFIX,
  88. KEYWORD_STYLE_PREFIX,
  89. KEYWORD_STYLE_POSTFIX
  90. };
  91. struct t_read_opts
  92. {
  93. enum t_keyword_style keyword_style;
  94. unsigned int copy_source_p : 1;
  95. unsigned int record_positions_p : 1;
  96. unsigned int case_insensitive_p : 1;
  97. unsigned int r6rs_escapes_p : 1;
  98. unsigned int square_brackets_p : 1;
  99. unsigned int hungry_eol_escapes_p : 1;
  100. unsigned int curly_infix_p : 1;
  101. unsigned int neoteric_p : 1;
  102. unsigned int r7rs_symbols_p : 1;
  103. };
  104. typedef struct t_read_opts scm_t_read_opts;
  105. /*
  106. Give meaningful error messages for errors
  107. We use the format
  108. FILE:LINE:COL: MESSAGE
  109. This happened in ....
  110. This is not standard GNU format, but the test-suite likes the real
  111. message to be in front.
  112. */
  113. void
  114. scm_i_input_error (char const *function,
  115. SCM port, const char *message, SCM arg)
  116. {
  117. SCM fn = (scm_is_string (SCM_FILENAME(port))
  118. ? SCM_FILENAME(port)
  119. : scm_from_locale_string ("#<unknown port>"));
  120. SCM string_port = scm_open_output_string ();
  121. SCM string = SCM_EOL;
  122. scm_simple_format (string_port,
  123. scm_from_locale_string ("~A:~S:~S: ~A"),
  124. scm_list_4 (fn,
  125. scm_from_long (SCM_LINUM (port) + 1),
  126. scm_from_int (SCM_COL (port) + 1),
  127. scm_from_locale_string (message)));
  128. string = scm_get_output_string (string_port);
  129. scm_close_output_port (string_port);
  130. scm_error_scm (scm_from_latin1_symbol ("read-error"),
  131. function? scm_from_locale_string (function) : SCM_BOOL_F,
  132. string,
  133. arg,
  134. SCM_BOOL_F);
  135. }
  136. SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0,
  137. (SCM setting),
  138. "Option interface for the read options. Instead of using\n"
  139. "this procedure directly, use the procedures @code{read-enable},\n"
  140. "@code{read-disable}, @code{read-set!} and @code{read-options}.")
  141. #define FUNC_NAME s_scm_read_options
  142. {
  143. SCM ans = scm_options (setting,
  144. scm_read_opts,
  145. FUNC_NAME);
  146. if (SCM_COPY_SOURCE_P)
  147. SCM_RECORD_POSITIONS_P = 1;
  148. return ans;
  149. }
  150. #undef FUNC_NAME
  151. /* A fluid referring to an association list mapping extra hash
  152. characters to procedures. */
  153. static SCM *scm_i_read_hash_procedures;
  154. static SCM
  155. scm_i_read_hash_procedures_ref (void)
  156. {
  157. return scm_fluid_ref (*scm_i_read_hash_procedures);
  158. }
  159. static void
  160. scm_i_read_hash_procedures_set_x (SCM value)
  161. {
  162. scm_fluid_set_x (*scm_i_read_hash_procedures, value);
  163. }
  164. /* Token readers. */
  165. /* Size of the C buffer used to read symbols and numbers. */
  166. #define READER_BUFFER_SIZE 128
  167. /* Number of 32-bit codepoints in the buffer used to read strings. */
  168. #define READER_STRING_BUFFER_SIZE 128
  169. /* The maximum size of Scheme character names. */
  170. #define READER_CHAR_NAME_MAX_SIZE 50
  171. /* The maximum size of reader directive names. */
  172. #define READER_DIRECTIVE_NAME_MAX_SIZE 50
  173. /* `isblank' is only in C99. */
  174. #define CHAR_IS_BLANK_(_chr) \
  175. (((_chr) == ' ') || ((_chr) == '\t') || ((_chr) == '\n') \
  176. || ((_chr) == '\f') || ((_chr) == '\r'))
  177. #ifdef MSDOS
  178. # define CHAR_IS_BLANK(_chr) \
  179. ((CHAR_IS_BLANK_ (chr)) || ((_chr) == 26))
  180. #else
  181. # define CHAR_IS_BLANK CHAR_IS_BLANK_
  182. #endif
  183. /* R5RS one-character delimiters (see section 7.1.1, ``Lexical
  184. structure''). */
  185. #define CHAR_IS_R5RS_DELIMITER(c) \
  186. (CHAR_IS_BLANK (c) \
  187. || (c) == ')' || (c) == '(' || (c) == ';' || (c) == '"')
  188. #define CHAR_IS_DELIMITER(c) \
  189. (CHAR_IS_R5RS_DELIMITER (c) \
  190. || (((c) == ']' || (c) == '[') && (opts->square_brackets_p \
  191. || opts->curly_infix_p)) \
  192. || (((c) == '}' || (c) == '{') && opts->curly_infix_p))
  193. /* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical
  194. Structure''. */
  195. #define CHAR_IS_EXPONENT_MARKER(_chr) \
  196. (((_chr) == 'e') || ((_chr) == 's') || ((_chr) == 'f') \
  197. || ((_chr) == 'd') || ((_chr) == 'l'))
  198. /* Read an SCSH block comment. */
  199. static SCM scm_read_scsh_block_comment (scm_t_wchar, SCM);
  200. static SCM scm_read_r6rs_block_comment (scm_t_wchar, SCM);
  201. static SCM scm_read_commented_expression (scm_t_wchar, SCM, scm_t_read_opts *);
  202. static SCM scm_read_shebang (scm_t_wchar, SCM, scm_t_read_opts *);
  203. static SCM scm_get_hash_procedure (int);
  204. /* Read from PORT until a delimiter (e.g., a whitespace) is read. Put the
  205. result in the pre-allocated buffer BUF. Return zero if the whole token has
  206. fewer than BUF_SIZE bytes, non-zero otherwise. READ will be set the number of
  207. bytes actually read. */
  208. static int
  209. read_token (SCM port, scm_t_read_opts *opts,
  210. char *buf, size_t buf_size, size_t *read)
  211. {
  212. *read = 0;
  213. while (*read < buf_size)
  214. {
  215. int chr;
  216. chr = scm_get_byte_or_eof_unlocked (port);
  217. if (chr == EOF)
  218. return 0;
  219. else if (CHAR_IS_DELIMITER (chr))
  220. {
  221. scm_unget_byte_unlocked (chr, port);
  222. return 0;
  223. }
  224. else
  225. {
  226. *buf = (char) chr;
  227. buf++, (*read)++;
  228. }
  229. }
  230. return 1;
  231. }
  232. /* Like `read_token', but return either BUFFER, or a GC-allocated buffer
  233. if the token doesn't fit in BUFFER_SIZE bytes. */
  234. static char *
  235. read_complete_token (SCM port, scm_t_read_opts *opts,
  236. char *buffer, size_t buffer_size, size_t *read)
  237. {
  238. int overflow = 0;
  239. size_t bytes_read, overflow_size = 0;
  240. char *overflow_buffer = NULL;
  241. do
  242. {
  243. overflow = read_token (port, opts, buffer, buffer_size, &bytes_read);
  244. if (bytes_read == 0)
  245. break;
  246. if (overflow || overflow_size != 0)
  247. {
  248. if (overflow_size == 0)
  249. {
  250. overflow_buffer = scm_gc_malloc_pointerless (bytes_read, "read");
  251. memcpy (overflow_buffer, buffer, bytes_read);
  252. overflow_size = bytes_read;
  253. }
  254. else
  255. {
  256. char *new_buf =
  257. scm_gc_malloc_pointerless (overflow_size + bytes_read, "read");
  258. memcpy (new_buf, overflow_buffer, overflow_size);
  259. memcpy (new_buf + overflow_size, buffer, bytes_read);
  260. overflow_buffer = new_buf;
  261. overflow_size += bytes_read;
  262. }
  263. }
  264. }
  265. while (overflow);
  266. if (overflow_size)
  267. *read = overflow_size;
  268. else
  269. *read = bytes_read;
  270. return (overflow_size > 0 ? overflow_buffer : buffer);
  271. }
  272. /* Skip whitespace from PORT and return the first non-whitespace character
  273. read. Raise an error on end-of-file. */
  274. static int
  275. flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr)
  276. {
  277. scm_t_wchar c;
  278. while (1)
  279. switch (c = scm_getc_unlocked (port))
  280. {
  281. case EOF:
  282. goteof:
  283. if (eoferr)
  284. {
  285. scm_i_input_error (eoferr,
  286. port,
  287. "end of file",
  288. SCM_EOL);
  289. }
  290. return c;
  291. case ';':
  292. lp:
  293. switch (c = scm_getc_unlocked (port))
  294. {
  295. case EOF:
  296. goto goteof;
  297. default:
  298. goto lp;
  299. case SCM_LINE_INCREMENTORS:
  300. break;
  301. }
  302. break;
  303. case '#':
  304. switch (c = scm_getc_unlocked (port))
  305. {
  306. case EOF:
  307. eoferr = "read_sharp";
  308. goto goteof;
  309. case '!':
  310. scm_read_shebang (c, port, opts);
  311. break;
  312. case ';':
  313. scm_read_commented_expression (c, port, opts);
  314. break;
  315. case '|':
  316. if (scm_is_false (scm_get_hash_procedure (c)))
  317. {
  318. scm_read_r6rs_block_comment (c, port);
  319. break;
  320. }
  321. /* fall through */
  322. default:
  323. scm_ungetc_unlocked (c, port);
  324. return '#';
  325. }
  326. break;
  327. case SCM_LINE_INCREMENTORS:
  328. case SCM_SINGLE_SPACES:
  329. case '\t':
  330. break;
  331. default:
  332. return c;
  333. }
  334. return 0;
  335. }
  336. /* Token readers. */
  337. static SCM scm_read_expression (SCM port, scm_t_read_opts *opts);
  338. static SCM scm_read_sharp (int chr, SCM port, scm_t_read_opts *opts,
  339. long line, int column);
  340. static SCM
  341. maybe_annotate_source (SCM x, SCM port, scm_t_read_opts *opts,
  342. long line, int column)
  343. {
  344. if (opts->record_positions_p)
  345. scm_i_set_source_properties_x (x, line, column, SCM_FILENAME (port));
  346. return x;
  347. }
  348. static SCM
  349. scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
  350. #define FUNC_NAME "scm_i_lreadparen"
  351. {
  352. int c;
  353. SCM tmp, tl, ans = SCM_EOL;
  354. const int curly_list_p = (chr == '{') && opts->curly_infix_p;
  355. const int terminating_char = ((chr == '{') ? '}'
  356. : ((chr == '[') ? ']'
  357. : ')'));
  358. /* Need to capture line and column numbers here. */
  359. long line = SCM_LINUM (port);
  360. int column = SCM_COL (port) - 1;
  361. c = flush_ws (port, opts, FUNC_NAME);
  362. if (terminating_char == c)
  363. return SCM_EOL;
  364. scm_ungetc_unlocked (c, port);
  365. tmp = scm_read_expression (port, opts);
  366. /* Note that it is possible for scm_read_expression to return
  367. scm_sym_dot, but not as part of a dotted pair: as in #{.}#. So
  368. check that it's a real dot by checking `c'. */
  369. if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
  370. {
  371. ans = scm_read_expression (port, opts);
  372. if (terminating_char != (c = flush_ws (port, opts, FUNC_NAME)))
  373. scm_i_input_error (FUNC_NAME, port, "missing close paren",
  374. SCM_EOL);
  375. return ans;
  376. }
  377. /* Build the head of the list structure. */
  378. ans = tl = scm_cons (tmp, SCM_EOL);
  379. while (terminating_char != (c = flush_ws (port, opts, FUNC_NAME)))
  380. {
  381. SCM new_tail;
  382. if (c == ')' || (c == ']' && opts->square_brackets_p)
  383. || ((c == '}' || c == ']') && opts->curly_infix_p))
  384. scm_i_input_error (FUNC_NAME, port,
  385. "in pair: mismatched close paren: ~A",
  386. scm_list_1 (SCM_MAKE_CHAR (c)));
  387. scm_ungetc_unlocked (c, port);
  388. tmp = scm_read_expression (port, opts);
  389. /* See above note about scm_sym_dot. */
  390. if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
  391. {
  392. SCM_SETCDR (tl, scm_read_expression (port, opts));
  393. c = flush_ws (port, opts, FUNC_NAME);
  394. if (terminating_char != c)
  395. scm_i_input_error (FUNC_NAME, port,
  396. "in pair: missing close paren", SCM_EOL);
  397. break;
  398. }
  399. new_tail = scm_cons (tmp, SCM_EOL);
  400. SCM_SETCDR (tl, new_tail);
  401. tl = new_tail;
  402. }
  403. if (curly_list_p)
  404. {
  405. /* In addition to finding the length, 'scm_ilength' checks for
  406. improper or circular lists, in which case it returns -1. */
  407. int len = scm_ilength (ans);
  408. /* The (len == 0) case is handled above */
  409. if (len == 1)
  410. /* Return directly to avoid re-annotating the element's source
  411. location with the position of the outer brace. Also, it
  412. might not be possible to annotate the element. */
  413. return scm_car (ans); /* {e} => e */
  414. else if (len == 2)
  415. ; /* Leave the list unchanged: {e1 e2} => (e1 e2) */
  416. else if (len >= 3 && (len & 1))
  417. {
  418. /* It's a proper list whose length is odd and at least 3. If
  419. the elements at odd indices (the infix operator positions)
  420. are all 'equal?', then it's a simple curly-infix list.
  421. Otherwise it's a mixed curly-infix list. */
  422. SCM op = scm_cadr (ans);
  423. /* Check to see if the elements at odd indices are 'equal?' */
  424. for (tl = scm_cdddr (ans); ; tl = scm_cddr (tl))
  425. {
  426. if (scm_is_null (tl))
  427. {
  428. /* Convert simple curly-infix list to prefix:
  429. {a <op> b <op> ...} => (<op> a b ...) */
  430. tl = ans;
  431. while (scm_is_pair (scm_cdr (tl)))
  432. {
  433. tmp = scm_cddr (tl);
  434. SCM_SETCDR (tl, tmp);
  435. tl = tmp;
  436. }
  437. ans = scm_cons (op, ans);
  438. break;
  439. }
  440. else if (scm_is_false (scm_equal_p (op, scm_car (tl))))
  441. {
  442. /* Mixed curly-infix list: {e ...} => ($nfx$ e ...) */
  443. ans = scm_cons (sym_nfx, ans);
  444. break;
  445. }
  446. }
  447. }
  448. else
  449. /* Mixed curly-infix (possibly improper) list:
  450. {e . tail} => ($nfx$ e . tail) */
  451. ans = scm_cons (sym_nfx, ans);
  452. }
  453. return maybe_annotate_source (ans, port, opts, line, column);
  454. }
  455. #undef FUNC_NAME
  456. /* Read a hexadecimal number NDIGITS in length. Put its value into the variable
  457. C. If TERMINATOR is non-null, terminate early if the TERMINATOR character is
  458. found. */
  459. #define SCM_READ_HEX_ESCAPE(ndigits, terminator) \
  460. do \
  461. { \
  462. scm_t_wchar a; \
  463. size_t i = 0; \
  464. c = 0; \
  465. while (i < ndigits) \
  466. { \
  467. a = scm_getc_unlocked (port); \
  468. if (a == EOF) \
  469. goto str_eof; \
  470. if (terminator \
  471. && (a == (scm_t_wchar) terminator) \
  472. && (i > 0)) \
  473. break; \
  474. if ('0' <= a && a <= '9') \
  475. a -= '0'; \
  476. else if ('A' <= a && a <= 'F') \
  477. a = a - 'A' + 10; \
  478. else if ('a' <= a && a <= 'f') \
  479. a = a - 'a' + 10; \
  480. else \
  481. { \
  482. c = a; \
  483. goto bad_escaped; \
  484. } \
  485. c = c * 16 + a; \
  486. i ++; \
  487. } \
  488. } while (0)
  489. static void
  490. skip_intraline_whitespace (SCM port)
  491. {
  492. scm_t_wchar c;
  493. do
  494. {
  495. c = scm_getc_unlocked (port);
  496. if (c == EOF)
  497. return;
  498. }
  499. while (c == '\t' || uc_is_general_category (c, UC_SPACE_SEPARATOR));
  500. scm_ungetc_unlocked (c, port);
  501. }
  502. /* Read either a double-quoted string or an R7RS-style symbol delimited
  503. by vertical lines, depending on the value of 'chr' ('"' or '|').
  504. Regardless, the result is always returned as a string. */
  505. static SCM
  506. scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts)
  507. #define FUNC_NAME "scm_lreadr"
  508. {
  509. /* For strings smaller than C_STR, this function creates only one Scheme
  510. object (the string returned). */
  511. SCM str = SCM_EOL;
  512. size_t c_str_len = 0;
  513. scm_t_wchar c, c_str[READER_STRING_BUFFER_SIZE];
  514. /* Need to capture line and column numbers here. */
  515. long line = SCM_LINUM (port);
  516. int column = SCM_COL (port) - 1;
  517. while (chr != (c = scm_getc_unlocked (port)))
  518. {
  519. if (c == EOF)
  520. {
  521. str_eof:
  522. scm_i_input_error (FUNC_NAME, port,
  523. (chr == '|'
  524. ? "end of file in symbol"
  525. : "end of file in string constant"),
  526. SCM_EOL);
  527. }
  528. if (c_str_len + 1 >= READER_STRING_BUFFER_SIZE)
  529. {
  530. str = scm_cons (scm_from_utf32_stringn (c_str, c_str_len), str);
  531. c_str_len = 0;
  532. }
  533. if (c == '\\')
  534. {
  535. switch (c = scm_getc_unlocked (port))
  536. {
  537. case EOF:
  538. goto str_eof;
  539. case '|':
  540. case '\\':
  541. break;
  542. case '\n':
  543. if (opts->hungry_eol_escapes_p)
  544. skip_intraline_whitespace (port);
  545. continue;
  546. case '0':
  547. c = '\0';
  548. break;
  549. case 'f':
  550. c = '\f';
  551. break;
  552. case 'n':
  553. c = '\n';
  554. break;
  555. case 'r':
  556. c = '\r';
  557. break;
  558. case 't':
  559. c = '\t';
  560. break;
  561. case 'a':
  562. c = '\007';
  563. break;
  564. case 'v':
  565. c = '\v';
  566. break;
  567. case 'b':
  568. c = '\010';
  569. break;
  570. case 'x':
  571. if (opts->r6rs_escapes_p || chr == '|')
  572. SCM_READ_HEX_ESCAPE (10, ';');
  573. else
  574. SCM_READ_HEX_ESCAPE (2, '\0');
  575. break;
  576. case 'u':
  577. if (!opts->r6rs_escapes_p)
  578. {
  579. SCM_READ_HEX_ESCAPE (4, '\0');
  580. break;
  581. }
  582. case 'U':
  583. if (!opts->r6rs_escapes_p)
  584. {
  585. SCM_READ_HEX_ESCAPE (6, '\0');
  586. break;
  587. }
  588. default:
  589. if (c == chr)
  590. break;
  591. bad_escaped:
  592. scm_i_input_error (FUNC_NAME, port,
  593. "illegal character in escape sequence: ~S",
  594. scm_list_1 (SCM_MAKE_CHAR (c)));
  595. }
  596. }
  597. c_str[c_str_len++] = c;
  598. }
  599. if (scm_is_null (str))
  600. /* Fast path: we got a string that fits in C_STR. */
  601. str = scm_from_utf32_stringn (c_str, c_str_len);
  602. else
  603. {
  604. if (c_str_len > 0)
  605. str = scm_cons (scm_from_utf32_stringn (c_str, c_str_len), str);
  606. str = scm_string_concatenate_reverse (str, SCM_UNDEFINED, SCM_UNDEFINED);
  607. }
  608. return maybe_annotate_source (str, port, opts, line, column);
  609. }
  610. #undef FUNC_NAME
  611. static SCM
  612. scm_read_string (int chr, SCM port, scm_t_read_opts *opts)
  613. {
  614. return scm_read_string_like_syntax (chr, port, opts);
  615. }
  616. static SCM
  617. scm_read_r7rs_symbol (int chr, SCM port, scm_t_read_opts *opts)
  618. {
  619. return scm_string_to_symbol (scm_read_string_like_syntax (chr, port, opts));
  620. }
  621. static SCM
  622. scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
  623. {
  624. SCM result, str = SCM_EOL;
  625. char local_buffer[READER_BUFFER_SIZE], *buffer;
  626. size_t bytes_read;
  627. /* Need to capture line and column numbers here. */
  628. long line = SCM_LINUM (port);
  629. int column = SCM_COL (port) - 1;
  630. scm_ungetc_unlocked (chr, port);
  631. buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
  632. &bytes_read);
  633. str = scm_from_port_stringn (buffer, bytes_read, port);
  634. result = scm_string_to_number (str, SCM_UNDEFINED);
  635. if (scm_is_false (result))
  636. {
  637. /* Return a symbol instead of a number */
  638. if (opts->case_insensitive_p)
  639. str = scm_string_downcase_x (str);
  640. result = scm_string_to_symbol (str);
  641. }
  642. else if (SCM_NIMP (result))
  643. result = maybe_annotate_source (result, port, opts, line, column);
  644. SCM_COL (port) += scm_i_string_length (str);
  645. return result;
  646. }
  647. static SCM
  648. scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
  649. {
  650. SCM result;
  651. int ends_with_colon = 0;
  652. size_t bytes_read;
  653. int postfix = (opts->keyword_style == KEYWORD_STYLE_POSTFIX);
  654. char local_buffer[READER_BUFFER_SIZE], *buffer;
  655. SCM str;
  656. scm_ungetc_unlocked (chr, port);
  657. buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
  658. &bytes_read);
  659. if (bytes_read > 0)
  660. ends_with_colon = buffer[bytes_read - 1] == ':';
  661. if (postfix && ends_with_colon && (bytes_read > 1))
  662. {
  663. str = scm_from_port_stringn (buffer, bytes_read - 1, port);
  664. if (opts->case_insensitive_p)
  665. str = scm_string_downcase_x (str);
  666. result = scm_symbol_to_keyword (scm_string_to_symbol (str));
  667. }
  668. else
  669. {
  670. str = scm_from_port_stringn (buffer, bytes_read, port);
  671. if (opts->case_insensitive_p)
  672. str = scm_string_downcase_x (str);
  673. result = scm_string_to_symbol (str);
  674. }
  675. SCM_COL (port) += scm_i_string_length (str);
  676. return result;
  677. }
  678. static SCM
  679. scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
  680. #define FUNC_NAME "scm_lreadr"
  681. {
  682. SCM result;
  683. size_t read;
  684. char local_buffer[READER_BUFFER_SIZE], *buffer;
  685. unsigned int radix;
  686. SCM str;
  687. switch (chr)
  688. {
  689. case 'B':
  690. case 'b':
  691. radix = 2;
  692. break;
  693. case 'o':
  694. case 'O':
  695. radix = 8;
  696. break;
  697. case 'd':
  698. case 'D':
  699. radix = 10;
  700. break;
  701. case 'x':
  702. case 'X':
  703. radix = 16;
  704. break;
  705. default:
  706. scm_ungetc_unlocked (chr, port);
  707. scm_ungetc_unlocked ('#', port);
  708. radix = 10;
  709. }
  710. buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
  711. &read);
  712. str = scm_from_port_stringn (buffer, read, port);
  713. result = scm_string_to_number (str, scm_from_uint (radix));
  714. SCM_COL (port) += scm_i_string_length (str);
  715. if (scm_is_true (result))
  716. return result;
  717. scm_i_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL);
  718. return SCM_BOOL_F;
  719. }
  720. #undef FUNC_NAME
  721. static SCM
  722. scm_read_quote (int chr, SCM port, scm_t_read_opts *opts)
  723. {
  724. SCM p;
  725. long line = SCM_LINUM (port);
  726. int column = SCM_COL (port) - 1;
  727. switch (chr)
  728. {
  729. case '`':
  730. p = scm_sym_quasiquote;
  731. break;
  732. case '\'':
  733. p = scm_sym_quote;
  734. break;
  735. case ',':
  736. {
  737. scm_t_wchar c;
  738. c = scm_getc_unlocked (port);
  739. if ('@' == c)
  740. p = scm_sym_uq_splicing;
  741. else
  742. {
  743. scm_ungetc_unlocked (c, port);
  744. p = scm_sym_unquote;
  745. }
  746. break;
  747. }
  748. default:
  749. fprintf (stderr, "%s: unhandled quote character (%i)\n",
  750. "scm_read_quote", chr);
  751. abort ();
  752. }
  753. p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL);
  754. return maybe_annotate_source (p, port, opts, line, column);
  755. }
  756. SCM_SYMBOL (sym_syntax, "syntax");
  757. SCM_SYMBOL (sym_quasisyntax, "quasisyntax");
  758. SCM_SYMBOL (sym_unsyntax, "unsyntax");
  759. SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing");
  760. static SCM
  761. scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts)
  762. {
  763. SCM p;
  764. long line = SCM_LINUM (port);
  765. int column = SCM_COL (port) - 1;
  766. switch (chr)
  767. {
  768. case '`':
  769. p = sym_quasisyntax;
  770. break;
  771. case '\'':
  772. p = sym_syntax;
  773. break;
  774. case ',':
  775. {
  776. int c;
  777. c = scm_getc_unlocked (port);
  778. if ('@' == c)
  779. p = sym_unsyntax_splicing;
  780. else
  781. {
  782. scm_ungetc_unlocked (c, port);
  783. p = sym_unsyntax;
  784. }
  785. break;
  786. }
  787. default:
  788. fprintf (stderr, "%s: unhandled syntax character (%i)\n",
  789. "scm_read_syntax", chr);
  790. abort ();
  791. }
  792. p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL);
  793. return maybe_annotate_source (p, port, opts, line, column);
  794. }
  795. static SCM
  796. scm_read_nil (int chr, SCM port, scm_t_read_opts *opts)
  797. {
  798. SCM id = scm_read_mixed_case_symbol (chr, port, opts);
  799. if (!scm_is_eq (id, sym_nil))
  800. scm_i_input_error ("scm_read_nil", port,
  801. "unexpected input while reading #nil: ~a",
  802. scm_list_1 (id));
  803. return SCM_ELISP_NIL;
  804. }
  805. static SCM
  806. scm_read_semicolon_comment (int chr, SCM port)
  807. {
  808. int c;
  809. /* We use the get_byte here because there is no need to get the
  810. locale correct with comment input. This presumes that newline
  811. always represents itself no matter what the encoding is. */
  812. for (c = scm_get_byte_or_eof_unlocked (port);
  813. (c != EOF) && (c != '\n');
  814. c = scm_get_byte_or_eof_unlocked (port));
  815. return SCM_UNSPECIFIED;
  816. }
  817. /* If the EXPECTED_CHARS are the next ones available from PORT, then
  818. consume them and return 1. Otherwise leave the port position where
  819. it was and return 0. EXPECTED_CHARS should be all lowercase, and
  820. will be matched case-insensitively against the characters read from
  821. PORT. */
  822. static int
  823. try_read_ci_chars (SCM port, const char *expected_chars)
  824. {
  825. int num_chars_wanted = strlen (expected_chars);
  826. int num_chars_read = 0;
  827. char *chars_read = alloca (num_chars_wanted);
  828. int c;
  829. while (num_chars_read < num_chars_wanted)
  830. {
  831. c = scm_getc_unlocked (port);
  832. if (c == EOF)
  833. break;
  834. else if (c_tolower (c) != expected_chars[num_chars_read])
  835. {
  836. scm_ungetc_unlocked (c, port);
  837. break;
  838. }
  839. else
  840. chars_read[num_chars_read++] = c;
  841. }
  842. if (num_chars_read == num_chars_wanted)
  843. return 1;
  844. else
  845. {
  846. while (num_chars_read > 0)
  847. scm_ungetc_unlocked (chars_read[--num_chars_read], port);
  848. return 0;
  849. }
  850. }
  851. /* Sharp readers, i.e. readers called after a `#' sign has been read. */
  852. static SCM
  853. scm_read_boolean (int chr, SCM port)
  854. {
  855. switch (chr)
  856. {
  857. case 't':
  858. case 'T':
  859. try_read_ci_chars (port, "rue");
  860. return SCM_BOOL_T;
  861. case 'f':
  862. case 'F':
  863. try_read_ci_chars (port, "alse");
  864. return SCM_BOOL_F;
  865. }
  866. return SCM_UNSPECIFIED;
  867. }
  868. static SCM
  869. scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
  870. #define FUNC_NAME "scm_lreadr"
  871. {
  872. char buffer[READER_CHAR_NAME_MAX_SIZE];
  873. SCM charname;
  874. size_t charname_len, bytes_read;
  875. scm_t_wchar cp;
  876. int overflow;
  877. scm_t_port_internal *pti;
  878. overflow = read_token (port, opts, buffer, READER_CHAR_NAME_MAX_SIZE,
  879. &bytes_read);
  880. if (overflow)
  881. scm_i_input_error (FUNC_NAME, port, "character name too long", SCM_EOL);
  882. if (bytes_read == 0)
  883. {
  884. chr = scm_getc_unlocked (port);
  885. if (chr == EOF)
  886. scm_i_input_error (FUNC_NAME, port, "unexpected end of file "
  887. "while reading character", SCM_EOL);
  888. /* CHR must be a token delimiter, like a whitespace. */
  889. return (SCM_MAKE_CHAR (chr));
  890. }
  891. pti = SCM_PORT_GET_INTERNAL (port);
  892. /* Simple ASCII characters can be processed immediately. Also, simple
  893. ISO-8859-1 characters can be processed immediately if the encoding for this
  894. port is ISO-8859-1. */
  895. if (bytes_read == 1 &&
  896. ((unsigned char) buffer[0] <= 127
  897. || pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1))
  898. {
  899. SCM_COL (port) += 1;
  900. return SCM_MAKE_CHAR (buffer[0]);
  901. }
  902. /* Otherwise, convert the buffer into a proper scheme string for
  903. processing. */
  904. charname = scm_from_port_stringn (buffer, bytes_read, port);
  905. charname_len = scm_i_string_length (charname);
  906. SCM_COL (port) += charname_len;
  907. cp = scm_i_string_ref (charname, 0);
  908. if (charname_len == 1)
  909. return SCM_MAKE_CHAR (cp);
  910. /* Ignore dotted circles, which may be used to keep combining characters from
  911. combining with the backslash in #\charname. */
  912. if (cp == SCM_CODEPOINT_DOTTED_CIRCLE && charname_len == 2)
  913. return SCM_MAKE_CHAR (scm_i_string_ref (charname, 1));
  914. if (cp >= '0' && cp < '8')
  915. {
  916. /* Dirk:FIXME:: This type of character syntax is not R5RS
  917. * compliant. Further, it should be verified that the constant
  918. * does only consist of octal digits. */
  919. SCM p = scm_string_to_number (charname, scm_from_uint (8));
  920. if (SCM_I_INUMP (p))
  921. {
  922. scm_t_wchar c = scm_to_uint32 (p);
  923. if (SCM_IS_UNICODE_CHAR (c))
  924. return SCM_MAKE_CHAR (c);
  925. else
  926. scm_i_input_error (FUNC_NAME, port,
  927. "out-of-range octal character escape: ~a",
  928. scm_list_1 (charname));
  929. }
  930. }
  931. if (cp == 'x' && (charname_len > 1))
  932. {
  933. SCM p;
  934. /* Convert from hex, skipping the initial 'x' character in CHARNAME */
  935. p = scm_string_to_number (scm_c_substring (charname, 1, charname_len),
  936. scm_from_uint (16));
  937. if (SCM_I_INUMP (p))
  938. {
  939. scm_t_wchar c = scm_to_uint32 (p);
  940. if (SCM_IS_UNICODE_CHAR (c))
  941. return SCM_MAKE_CHAR (c);
  942. else
  943. scm_i_input_error (FUNC_NAME, port,
  944. "out-of-range hex character escape: ~a",
  945. scm_list_1 (charname));
  946. }
  947. }
  948. /* The names of characters should never have non-Latin1
  949. characters. */
  950. if (scm_i_is_narrow_string (charname)
  951. || scm_i_try_narrow_string (charname))
  952. { SCM ch = scm_i_charname_to_char (scm_i_string_chars (charname),
  953. charname_len);
  954. if (scm_is_true (ch))
  955. return ch;
  956. }
  957. scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
  958. scm_list_1 (charname));
  959. return SCM_UNSPECIFIED;
  960. }
  961. #undef FUNC_NAME
  962. static SCM
  963. scm_read_keyword (int chr, SCM port, scm_t_read_opts *opts)
  964. {
  965. SCM symbol;
  966. /* Read the symbol that comprises the keyword. Doing this instead of
  967. invoking a specific symbol reader function allows `scm_read_keyword ()'
  968. to adapt to the delimiters currently valid of symbols.
  969. XXX: This implementation allows sloppy syntaxes like `#: key'. */
  970. symbol = scm_read_expression (port, opts);
  971. if (!scm_is_symbol (symbol))
  972. scm_i_input_error ("scm_read_keyword", port,
  973. "keyword prefix `~a' not followed by a symbol: ~s",
  974. scm_list_2 (SCM_MAKE_CHAR (chr), symbol));
  975. return (scm_symbol_to_keyword (symbol));
  976. }
  977. static SCM
  978. scm_read_vector (int chr, SCM port, scm_t_read_opts *opts,
  979. long line, int column)
  980. {
  981. /* Note: We call `scm_read_sexp ()' rather than READER here in order to
  982. guarantee that it's going to do what we want. After all, this is an
  983. implementation detail of `scm_read_vector ()', not a desirable
  984. property. */
  985. return maybe_annotate_source (scm_vector (scm_read_sexp (chr, port, opts)),
  986. port, opts, line, column);
  987. }
  988. /* Helper used by scm_read_array */
  989. static int
  990. read_decimal_integer (SCM port, int c, ssize_t *resp)
  991. {
  992. ssize_t sign = 1;
  993. ssize_t res = 0;
  994. int got_it = 0;
  995. if (c == '-')
  996. {
  997. sign = -1;
  998. c = scm_getc_unlocked (port);
  999. }
  1000. while ('0' <= c && c <= '9')
  1001. {
  1002. if (((SSIZE_MAX - (c-'0')) / 10) <= res)
  1003. scm_i_input_error ("read_decimal_integer", port,
  1004. "number too large", SCM_EOL);
  1005. res = 10*res + c-'0';
  1006. got_it = 1;
  1007. c = scm_getc_unlocked (port);
  1008. }
  1009. if (got_it)
  1010. *resp = sign * res;
  1011. return c;
  1012. }
  1013. /* Read an array. This function can also read vectors and uniform
  1014. vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
  1015. handled here.
  1016. C is the first character read after the '#'. */
  1017. static SCM
  1018. scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column)
  1019. {
  1020. ssize_t rank;
  1021. scm_t_wchar tag_buf[8];
  1022. int tag_len;
  1023. SCM tag, shape = SCM_BOOL_F, elements, array;
  1024. /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
  1025. the array code can not deal with zero-length dimensions yet, and
  1026. we want to allow zero-length vectors, of course. */
  1027. if (c == '(')
  1028. return scm_read_vector (c, port, opts, line, column);
  1029. /* Disambiguate between '#f' and uniform floating point vectors. */
  1030. if (c == 'f')
  1031. {
  1032. c = scm_getc_unlocked (port);
  1033. if (c != '3' && c != '6')
  1034. {
  1035. if (c == 'a' && try_read_ci_chars (port, "lse"))
  1036. return SCM_BOOL_F;
  1037. else if (c != EOF)
  1038. scm_ungetc_unlocked (c, port);
  1039. return SCM_BOOL_F;
  1040. }
  1041. rank = 1;
  1042. tag_buf[0] = 'f';
  1043. tag_len = 1;
  1044. goto continue_reading_tag;
  1045. }
  1046. /* Read rank. */
  1047. rank = 1;
  1048. c = read_decimal_integer (port, c, &rank);
  1049. if (rank < 0)
  1050. scm_i_input_error (NULL, port, "array rank must be non-negative",
  1051. SCM_EOL);
  1052. /* Read tag. */
  1053. tag_len = 0;
  1054. continue_reading_tag:
  1055. while (c != EOF && c != '(' && c != '@' && c != ':'
  1056. && tag_len < sizeof tag_buf / sizeof tag_buf[0])
  1057. {
  1058. tag_buf[tag_len++] = c;
  1059. c = scm_getc_unlocked (port);
  1060. }
  1061. if (tag_len == 0)
  1062. tag = SCM_BOOL_T;
  1063. else
  1064. {
  1065. tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len));
  1066. if (tag_len == sizeof tag_buf / sizeof tag_buf[0])
  1067. scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a",
  1068. scm_list_1 (tag));
  1069. }
  1070. /* Read shape. */
  1071. if (c == '@' || c == ':')
  1072. {
  1073. shape = SCM_EOL;
  1074. do
  1075. {
  1076. ssize_t lbnd = 0, len = 0;
  1077. SCM s;
  1078. if (c == '@')
  1079. {
  1080. c = scm_getc_unlocked (port);
  1081. c = read_decimal_integer (port, c, &lbnd);
  1082. }
  1083. s = scm_from_ssize_t (lbnd);
  1084. if (c == ':')
  1085. {
  1086. c = scm_getc_unlocked (port);
  1087. c = read_decimal_integer (port, c, &len);
  1088. if (len < 0)
  1089. scm_i_input_error (NULL, port,
  1090. "array length must be non-negative",
  1091. SCM_EOL);
  1092. s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
  1093. }
  1094. shape = scm_cons (s, shape);
  1095. } while (c == '@' || c == ':');
  1096. shape = scm_reverse_x (shape, SCM_EOL);
  1097. }
  1098. /* Read nested lists of elements. */
  1099. if (c != '(')
  1100. scm_i_input_error (NULL, port,
  1101. "missing '(' in vector or array literal",
  1102. SCM_EOL);
  1103. elements = scm_read_sexp (c, port, opts);
  1104. if (scm_is_false (shape))
  1105. shape = scm_from_ssize_t (rank);
  1106. else if (scm_ilength (shape) != rank)
  1107. scm_i_input_error
  1108. (NULL, port,
  1109. "the number of shape specifications must match the array rank",
  1110. SCM_EOL);
  1111. /* Handle special print syntax of rank zero arrays; see
  1112. scm_i_print_array for a rationale. */
  1113. if (rank == 0)
  1114. {
  1115. if (!scm_is_pair (elements))
  1116. scm_i_input_error (NULL, port,
  1117. "too few elements in array literal, need 1",
  1118. SCM_EOL);
  1119. if (!scm_is_null (SCM_CDR (elements)))
  1120. scm_i_input_error (NULL, port,
  1121. "too many elements in array literal, want 1",
  1122. SCM_EOL);
  1123. elements = SCM_CAR (elements);
  1124. }
  1125. /* Construct array, annotate with source location, and return. */
  1126. array = scm_list_to_typed_array (tag, shape, elements);
  1127. return maybe_annotate_source (array, port, opts, line, column);
  1128. }
  1129. static SCM
  1130. scm_read_srfi4_vector (int chr, SCM port, scm_t_read_opts *opts,
  1131. long line, int column)
  1132. {
  1133. return scm_read_array (chr, port, opts, line, column);
  1134. }
  1135. static SCM
  1136. scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
  1137. long line, int column)
  1138. {
  1139. chr = scm_getc_unlocked (port);
  1140. if (chr != 'u')
  1141. goto syntax;
  1142. chr = scm_getc_unlocked (port);
  1143. if (chr != '8')
  1144. goto syntax;
  1145. chr = scm_getc_unlocked (port);
  1146. if (chr != '(')
  1147. goto syntax;
  1148. return maybe_annotate_source
  1149. (scm_u8_list_to_bytevector (scm_read_sexp (chr, port, opts)),
  1150. port, opts, line, column);
  1151. syntax:
  1152. scm_i_input_error ("read_bytevector", port,
  1153. "invalid bytevector prefix",
  1154. SCM_MAKE_CHAR (chr));
  1155. return SCM_UNSPECIFIED;
  1156. }
  1157. static SCM
  1158. scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
  1159. long line, int column)
  1160. {
  1161. /* Read the `#*10101'-style read syntax for bit vectors in Guile. This is
  1162. terribly inefficient but who cares? */
  1163. SCM s_bits = SCM_EOL;
  1164. for (chr = scm_getc_unlocked (port);
  1165. (chr != EOF) && ((chr == '0') || (chr == '1'));
  1166. chr = scm_getc_unlocked (port))
  1167. {
  1168. s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits);
  1169. }
  1170. if (chr != EOF)
  1171. scm_ungetc_unlocked (chr, port);
  1172. return maybe_annotate_source
  1173. (scm_bitvector (scm_reverse_x (s_bits, SCM_EOL)),
  1174. port, opts, line, column);
  1175. }
  1176. static SCM
  1177. scm_read_scsh_block_comment (scm_t_wchar chr, SCM port)
  1178. {
  1179. int bang_seen = 0;
  1180. for (;;)
  1181. {
  1182. int c = scm_getc_unlocked (port);
  1183. if (c == EOF)
  1184. scm_i_input_error ("skip_block_comment", port,
  1185. "unterminated `#! ... !#' comment", SCM_EOL);
  1186. if (c == '!')
  1187. bang_seen = 1;
  1188. else if (c == '#' && bang_seen)
  1189. break;
  1190. else
  1191. bang_seen = 0;
  1192. }
  1193. return SCM_UNSPECIFIED;
  1194. }
  1195. static void set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts,
  1196. int value);
  1197. static void set_port_square_brackets_p (SCM port, scm_t_read_opts *opts,
  1198. int value);
  1199. static void set_port_curly_infix_p (SCM port, scm_t_read_opts *opts,
  1200. int value);
  1201. static SCM
  1202. scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
  1203. {
  1204. char name[READER_DIRECTIVE_NAME_MAX_SIZE + 1];
  1205. int c;
  1206. int i = 0;
  1207. while (i <= READER_DIRECTIVE_NAME_MAX_SIZE)
  1208. {
  1209. c = scm_getc_unlocked (port);
  1210. if (c == EOF)
  1211. scm_i_input_error ("skip_block_comment", port,
  1212. "unterminated `#! ... !#' comment", SCM_EOL);
  1213. else if (('a' <= c && c <= 'z') || ('0' <= c && c <= '9') || c == '-')
  1214. name[i++] = c;
  1215. else if (CHAR_IS_DELIMITER (c))
  1216. {
  1217. scm_ungetc_unlocked (c, port);
  1218. name[i] = '\0';
  1219. if (0 == strcmp ("r6rs", name))
  1220. ; /* Silently ignore */
  1221. else if (0 == strcmp ("fold-case", name))
  1222. set_port_case_insensitive_p (port, opts, 1);
  1223. else if (0 == strcmp ("no-fold-case", name))
  1224. set_port_case_insensitive_p (port, opts, 0);
  1225. else if (0 == strcmp ("curly-infix", name))
  1226. set_port_curly_infix_p (port, opts, 1);
  1227. else if (0 == strcmp ("curly-infix-and-bracket-lists", name))
  1228. {
  1229. set_port_curly_infix_p (port, opts, 1);
  1230. set_port_square_brackets_p (port, opts, 0);
  1231. }
  1232. else
  1233. break;
  1234. return SCM_UNSPECIFIED;
  1235. }
  1236. else
  1237. {
  1238. scm_ungetc_unlocked (c, port);
  1239. break;
  1240. }
  1241. }
  1242. while (i > 0)
  1243. scm_ungetc_unlocked (name[--i], port);
  1244. return scm_read_scsh_block_comment (chr, port);
  1245. }
  1246. static SCM
  1247. scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port)
  1248. {
  1249. /* Unlike SCSH-style block comments, SRFI-30/R6RS block comments may be
  1250. nested. So care must be taken. */
  1251. int nesting_level = 1;
  1252. int a = scm_getc_unlocked (port);
  1253. if (a == EOF)
  1254. scm_i_input_error ("scm_read_r6rs_block_comment", port,
  1255. "unterminated `#| ... |#' comment", SCM_EOL);
  1256. while (nesting_level > 0)
  1257. {
  1258. int b = scm_getc_unlocked (port);
  1259. if (b == EOF)
  1260. scm_i_input_error ("scm_read_r6rs_block_comment", port,
  1261. "unterminated `#| ... |#' comment", SCM_EOL);
  1262. if (a == '|' && b == '#')
  1263. {
  1264. nesting_level--;
  1265. b = EOF;
  1266. }
  1267. else if (a == '#' && b == '|')
  1268. {
  1269. nesting_level++;
  1270. b = EOF;
  1271. }
  1272. a = b;
  1273. }
  1274. return SCM_UNSPECIFIED;
  1275. }
  1276. static SCM
  1277. scm_read_commented_expression (scm_t_wchar chr, SCM port,
  1278. scm_t_read_opts *opts)
  1279. {
  1280. scm_t_wchar c;
  1281. c = flush_ws (port, opts, (char *) NULL);
  1282. if (EOF == c)
  1283. scm_i_input_error ("read_commented_expression", port,
  1284. "no expression after #; comment", SCM_EOL);
  1285. scm_ungetc_unlocked (c, port);
  1286. scm_read_expression (port, opts);
  1287. return SCM_UNSPECIFIED;
  1288. }
  1289. static SCM
  1290. scm_read_extended_symbol (scm_t_wchar chr, SCM port)
  1291. {
  1292. /* Guile's extended symbol read syntax looks like this:
  1293. #{This is all a symbol name}#
  1294. So here, CHR is expected to be `{'. */
  1295. int saw_brace = 0;
  1296. size_t len = 0;
  1297. SCM buf = scm_i_make_string (1024, NULL, 0);
  1298. buf = scm_i_string_start_writing (buf);
  1299. while ((chr = scm_getc_unlocked (port)) != EOF)
  1300. {
  1301. if (saw_brace)
  1302. {
  1303. if (chr == '#')
  1304. {
  1305. break;
  1306. }
  1307. else
  1308. {
  1309. saw_brace = 0;
  1310. scm_i_string_set_x (buf, len++, '}');
  1311. }
  1312. }
  1313. if (chr == '}')
  1314. saw_brace = 1;
  1315. else if (chr == '\\')
  1316. {
  1317. /* It used to be that print.c would print extended-read-syntax
  1318. symbols with backslashes before "non-standard" chars, but
  1319. this routine wouldn't do anything with those escapes.
  1320. Bummer. What we've done is to change print.c to output
  1321. R6RS hex escapes for those characters, relying on the fact
  1322. that the extended read syntax would never put a `\' before
  1323. an `x'. For now, we just ignore other instances of
  1324. backslash in the string. */
  1325. switch ((chr = scm_getc_unlocked (port)))
  1326. {
  1327. case EOF:
  1328. goto done;
  1329. case 'x':
  1330. {
  1331. scm_t_wchar c;
  1332. SCM_READ_HEX_ESCAPE (10, ';');
  1333. scm_i_string_set_x (buf, len++, c);
  1334. break;
  1335. str_eof:
  1336. chr = EOF;
  1337. goto done;
  1338. bad_escaped:
  1339. scm_i_string_stop_writing ();
  1340. scm_i_input_error ("scm_read_extended_symbol", port,
  1341. "illegal character in escape sequence: ~S",
  1342. scm_list_1 (SCM_MAKE_CHAR (c)));
  1343. break;
  1344. }
  1345. default:
  1346. scm_i_string_set_x (buf, len++, chr);
  1347. break;
  1348. }
  1349. }
  1350. else
  1351. scm_i_string_set_x (buf, len++, chr);
  1352. if (len >= scm_i_string_length (buf) - 2)
  1353. {
  1354. SCM addy;
  1355. scm_i_string_stop_writing ();
  1356. addy = scm_i_make_string (1024, NULL, 0);
  1357. buf = scm_string_append (scm_list_2 (buf, addy));
  1358. len = 0;
  1359. buf = scm_i_string_start_writing (buf);
  1360. }
  1361. }
  1362. done:
  1363. scm_i_string_stop_writing ();
  1364. if (chr == EOF)
  1365. scm_i_input_error ("scm_read_extended_symbol", port,
  1366. "end of file while reading symbol", SCM_EOL);
  1367. return (scm_string_to_symbol (scm_c_substring (buf, 0, len)));
  1368. }
  1369. /* Top-level token readers, i.e., dispatchers. */
  1370. static SCM
  1371. scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts)
  1372. {
  1373. SCM proc;
  1374. proc = scm_get_hash_procedure (chr);
  1375. if (scm_is_true (scm_procedure_p (proc)))
  1376. {
  1377. long line = SCM_LINUM (port);
  1378. int column = SCM_COL (port) - 2;
  1379. SCM got;
  1380. got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
  1381. if (opts->record_positions_p && SCM_NIMP (got)
  1382. && !scm_i_has_source_properties (got))
  1383. scm_i_set_source_properties_x (got, line, column, SCM_FILENAME (port));
  1384. return got;
  1385. }
  1386. return SCM_UNSPECIFIED;
  1387. }
  1388. /* The reader for the sharp `#' character. It basically dispatches reads
  1389. among the above token readers. */
  1390. static SCM
  1391. scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
  1392. long line, int column)
  1393. #define FUNC_NAME "scm_lreadr"
  1394. {
  1395. SCM result;
  1396. chr = scm_getc_unlocked (port);
  1397. result = scm_read_sharp_extension (chr, port, opts);
  1398. if (!scm_is_eq (result, SCM_UNSPECIFIED))
  1399. return result;
  1400. switch (chr)
  1401. {
  1402. case '\\':
  1403. return (scm_read_character (chr, port, opts));
  1404. case '(':
  1405. return (scm_read_vector (chr, port, opts, line, column));
  1406. case 's':
  1407. case 'u':
  1408. case 'f':
  1409. case 'c':
  1410. /* This one may return either a boolean or an SRFI-4 vector. */
  1411. return (scm_read_srfi4_vector (chr, port, opts, line, column));
  1412. case 'v':
  1413. return (scm_read_bytevector (chr, port, opts, line, column));
  1414. case '*':
  1415. return (scm_read_guile_bit_vector (chr, port, opts, line, column));
  1416. case 't':
  1417. case 'T':
  1418. case 'F':
  1419. return (scm_read_boolean (chr, port));
  1420. case ':':
  1421. return (scm_read_keyword (chr, port, opts));
  1422. case '0': case '1': case '2': case '3': case '4':
  1423. case '5': case '6': case '7': case '8': case '9':
  1424. case '@':
  1425. return (scm_read_array (chr, port, opts, line, column));
  1426. case 'i':
  1427. case 'e':
  1428. case 'b':
  1429. case 'B':
  1430. case 'o':
  1431. case 'O':
  1432. case 'd':
  1433. case 'D':
  1434. case 'x':
  1435. case 'X':
  1436. case 'I':
  1437. case 'E':
  1438. return (scm_read_number_and_radix (chr, port, opts));
  1439. case '{':
  1440. return (scm_read_extended_symbol (chr, port));
  1441. case '!':
  1442. return (scm_read_shebang (chr, port, opts));
  1443. case ';':
  1444. return (scm_read_commented_expression (chr, port, opts));
  1445. case '`':
  1446. case '\'':
  1447. case ',':
  1448. return (scm_read_syntax (chr, port, opts));
  1449. case 'n':
  1450. return (scm_read_nil (chr, port, opts));
  1451. default:
  1452. result = scm_read_sharp_extension (chr, port, opts);
  1453. if (scm_is_eq (result, SCM_UNSPECIFIED))
  1454. {
  1455. /* To remain compatible with 1.8 and earlier, the following
  1456. characters have lower precedence than `read-hash-extend'
  1457. characters. */
  1458. switch (chr)
  1459. {
  1460. case '|':
  1461. return scm_read_r6rs_block_comment (chr, port);
  1462. default:
  1463. scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
  1464. scm_list_1 (SCM_MAKE_CHAR (chr)));
  1465. }
  1466. }
  1467. else
  1468. return result;
  1469. }
  1470. return SCM_UNSPECIFIED;
  1471. }
  1472. #undef FUNC_NAME
  1473. static SCM
  1474. read_inner_expression (SCM port, scm_t_read_opts *opts)
  1475. #define FUNC_NAME "read_inner_expression"
  1476. {
  1477. while (1)
  1478. {
  1479. scm_t_wchar chr;
  1480. chr = scm_getc_unlocked (port);
  1481. switch (chr)
  1482. {
  1483. case SCM_WHITE_SPACES:
  1484. case SCM_LINE_INCREMENTORS:
  1485. break;
  1486. case ';':
  1487. (void) scm_read_semicolon_comment (chr, port);
  1488. break;
  1489. case '{':
  1490. if (opts->curly_infix_p)
  1491. {
  1492. if (opts->neoteric_p)
  1493. return scm_read_sexp (chr, port, opts);
  1494. else
  1495. {
  1496. SCM expr;
  1497. /* Enable neoteric expressions within curly braces */
  1498. opts->neoteric_p = 1;
  1499. expr = scm_read_sexp (chr, port, opts);
  1500. opts->neoteric_p = 0;
  1501. return expr;
  1502. }
  1503. }
  1504. else
  1505. return scm_read_mixed_case_symbol (chr, port, opts);
  1506. case '[':
  1507. if (opts->square_brackets_p)
  1508. return scm_read_sexp (chr, port, opts);
  1509. else if (opts->curly_infix_p)
  1510. {
  1511. /* The syntax of neoteric expressions requires that '[' be
  1512. a delimiter when curly-infix is enabled, so it cannot
  1513. be part of an unescaped symbol. We might as well do
  1514. something useful with it, so we adopt Kawa's convention:
  1515. [...] => ($bracket-list$ ...) */
  1516. long line = SCM_LINUM (port);
  1517. int column = SCM_COL (port) - 1;
  1518. return maybe_annotate_source
  1519. (scm_cons (sym_bracket_list, scm_read_sexp (chr, port, opts)),
  1520. port, opts, line, column);
  1521. }
  1522. else
  1523. return scm_read_mixed_case_symbol (chr, port, opts);
  1524. case '(':
  1525. return (scm_read_sexp (chr, port, opts));
  1526. case '"':
  1527. return (scm_read_string (chr, port, opts));
  1528. case '|':
  1529. if (opts->r7rs_symbols_p)
  1530. return scm_read_r7rs_symbol (chr, port, opts);
  1531. else
  1532. return scm_read_mixed_case_symbol (chr, port, opts);
  1533. case '\'':
  1534. case '`':
  1535. case ',':
  1536. return (scm_read_quote (chr, port, opts));
  1537. case '#':
  1538. {
  1539. long line = SCM_LINUM (port);
  1540. int column = SCM_COL (port) - 1;
  1541. SCM result = scm_read_sharp (chr, port, opts, line, column);
  1542. if (scm_is_eq (result, SCM_UNSPECIFIED))
  1543. /* We read a comment or some such. */
  1544. break;
  1545. else
  1546. return result;
  1547. }
  1548. case ')':
  1549. scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL);
  1550. break;
  1551. case '}':
  1552. if (opts->curly_infix_p)
  1553. scm_i_input_error (FUNC_NAME, port, "unexpected \"}\"", SCM_EOL);
  1554. else
  1555. return scm_read_mixed_case_symbol (chr, port, opts);
  1556. case ']':
  1557. if (opts->square_brackets_p)
  1558. scm_i_input_error (FUNC_NAME, port, "unexpected \"]\"", SCM_EOL);
  1559. /* otherwise fall through */
  1560. case EOF:
  1561. return SCM_EOF_VAL;
  1562. case ':':
  1563. if (opts->keyword_style == KEYWORD_STYLE_PREFIX)
  1564. return scm_symbol_to_keyword (scm_read_expression (port, opts));
  1565. /* Fall through. */
  1566. default:
  1567. {
  1568. if (((chr >= '0') && (chr <= '9'))
  1569. || (strchr ("+-.", chr)))
  1570. return (scm_read_number (chr, port, opts));
  1571. else
  1572. return (scm_read_mixed_case_symbol (chr, port, opts));
  1573. }
  1574. }
  1575. }
  1576. }
  1577. #undef FUNC_NAME
  1578. static SCM
  1579. scm_read_expression (SCM port, scm_t_read_opts *opts)
  1580. #define FUNC_NAME "scm_read_expression"
  1581. {
  1582. if (!opts->neoteric_p)
  1583. return read_inner_expression (port, opts);
  1584. else
  1585. {
  1586. long line = 0;
  1587. int column = 0;
  1588. SCM expr;
  1589. if (opts->record_positions_p)
  1590. {
  1591. /* We need to get the position of the first non-whitespace
  1592. character in order to correctly annotate neoteric
  1593. expressions. For example, for the expression 'f(x)', the
  1594. first call to 'read_inner_expression' reads the 'f' (which
  1595. cannot be annotated), and then we later read the '(x)' and
  1596. use it to construct the new list (f x). */
  1597. int c = flush_ws (port, opts, (char *) NULL);
  1598. if (c == EOF)
  1599. return SCM_EOF_VAL;
  1600. scm_ungetc_unlocked (c, port);
  1601. line = SCM_LINUM (port);
  1602. column = SCM_COL (port);
  1603. }
  1604. expr = read_inner_expression (port, opts);
  1605. /* 'expr' is the first component of the neoteric expression. Now
  1606. we loop, and as long as the next character is '(', '[', or '{',
  1607. (without any intervening whitespace), we use it to construct a
  1608. new expression. For example, f{n - 1}(x) => ((f (- n 1)) x). */
  1609. for (;;)
  1610. {
  1611. int chr = scm_getc_unlocked (port);
  1612. if (chr == '(')
  1613. /* e(...) => (e ...) */
  1614. expr = scm_cons (expr, scm_read_sexp (chr, port, opts));
  1615. else if (chr == '[')
  1616. /* e[...] => ($bracket-apply$ e ...) */
  1617. expr = scm_cons (sym_bracket_apply,
  1618. scm_cons (expr,
  1619. scm_read_sexp (chr, port, opts)));
  1620. else if (chr == '{')
  1621. {
  1622. SCM arg = scm_read_sexp (chr, port, opts);
  1623. if (scm_is_null (arg))
  1624. expr = scm_list_1 (expr); /* e{} => (e) */
  1625. else
  1626. expr = scm_list_2 (expr, arg); /* e{...} => (e {...}) */
  1627. }
  1628. else
  1629. {
  1630. if (chr != EOF)
  1631. scm_ungetc_unlocked (chr, port);
  1632. break;
  1633. }
  1634. maybe_annotate_source (expr, port, opts, line, column);
  1635. }
  1636. return expr;
  1637. }
  1638. }
  1639. #undef FUNC_NAME
  1640. /* Actual reader. */
  1641. static void init_read_options (SCM port, scm_t_read_opts *opts);
  1642. SCM_DEFINE (scm_read, "read", 0, 1, 0,
  1643. (SCM port),
  1644. "Read an s-expression from the input port @var{port}, or from\n"
  1645. "the current input port if @var{port} is not specified.\n"
  1646. "Any whitespace before the next token is discarded.")
  1647. #define FUNC_NAME s_scm_read
  1648. {
  1649. scm_t_read_opts opts;
  1650. int c;
  1651. if (SCM_UNBNDP (port))
  1652. port = scm_current_input_port ();
  1653. SCM_VALIDATE_OPINPORT (1, port);
  1654. init_read_options (port, &opts);
  1655. c = flush_ws (port, &opts, (char *) NULL);
  1656. if (EOF == c)
  1657. return SCM_EOF_VAL;
  1658. scm_ungetc_unlocked (c, port);
  1659. return (scm_read_expression (port, &opts));
  1660. }
  1661. #undef FUNC_NAME
  1662. /* Manipulate the read-hash-procedures alist. This could be written in
  1663. Scheme, but maybe it will also be used by C code during initialisation. */
  1664. SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
  1665. (SCM chr, SCM proc),
  1666. "Install the procedure @var{proc} for reading expressions\n"
  1667. "starting with the character sequence @code{#} and @var{chr}.\n"
  1668. "@var{proc} will be called with two arguments: the character\n"
  1669. "@var{chr} and the port to read further data from. The object\n"
  1670. "returned will be the return value of @code{read}. \n"
  1671. "Passing @code{#f} for @var{proc} will remove a previous setting. \n"
  1672. )
  1673. #define FUNC_NAME s_scm_read_hash_extend
  1674. {
  1675. SCM this;
  1676. SCM prev;
  1677. SCM_VALIDATE_CHAR (1, chr);
  1678. SCM_ASSERT (scm_is_false (proc)
  1679. || scm_is_eq (scm_procedure_p (proc), SCM_BOOL_T),
  1680. proc, SCM_ARG2, FUNC_NAME);
  1681. /* Check if chr is already in the alist. */
  1682. this = scm_i_read_hash_procedures_ref ();
  1683. prev = SCM_BOOL_F;
  1684. while (1)
  1685. {
  1686. if (scm_is_null (this))
  1687. {
  1688. /* not found, so add it to the beginning. */
  1689. if (scm_is_true (proc))
  1690. {
  1691. SCM new = scm_cons (scm_cons (chr, proc),
  1692. scm_i_read_hash_procedures_ref ());
  1693. scm_i_read_hash_procedures_set_x (new);
  1694. }
  1695. break;
  1696. }
  1697. if (scm_is_eq (chr, SCM_CAAR (this)))
  1698. {
  1699. /* already in the alist. */
  1700. if (scm_is_false (proc))
  1701. {
  1702. /* remove it. */
  1703. if (scm_is_false (prev))
  1704. {
  1705. SCM rest = SCM_CDR (scm_i_read_hash_procedures_ref ());
  1706. scm_i_read_hash_procedures_set_x (rest);
  1707. }
  1708. else
  1709. scm_set_cdr_x (prev, SCM_CDR (this));
  1710. }
  1711. else
  1712. {
  1713. /* replace it. */
  1714. scm_set_cdr_x (SCM_CAR (this), proc);
  1715. }
  1716. break;
  1717. }
  1718. prev = this;
  1719. this = SCM_CDR (this);
  1720. }
  1721. return SCM_UNSPECIFIED;
  1722. }
  1723. #undef FUNC_NAME
  1724. /* Recover the read-hash procedure corresponding to char c. */
  1725. static SCM
  1726. scm_get_hash_procedure (int c)
  1727. {
  1728. SCM rest = scm_i_read_hash_procedures_ref ();
  1729. while (1)
  1730. {
  1731. if (scm_is_null (rest))
  1732. return SCM_BOOL_F;
  1733. if (SCM_CHAR (SCM_CAAR (rest)) == c)
  1734. return SCM_CDAR (rest);
  1735. rest = SCM_CDR (rest);
  1736. }
  1737. }
  1738. static int
  1739. is_encoding_char (char c)
  1740. {
  1741. if (c >= 'a' && c <= 'z') return 1;
  1742. if (c >= 'A' && c <= 'Z') return 1;
  1743. if (c >= '0' && c <= '9') return 1;
  1744. return strchr ("_-.:/,+=()", c) != NULL;
  1745. }
  1746. /* Maximum size of an encoding name. This is a bit more than the
  1747. longest name listed at
  1748. <http://www.iana.org/assignments/character-sets> ("ISO-2022-JP-2", 13
  1749. characters.) */
  1750. #define ENCODING_NAME_MAX_SIZE 20
  1751. /* Number of bytes at the beginning or end of a file that are scanned
  1752. for a "coding:" declaration. */
  1753. #define SCM_ENCODING_SEARCH_SIZE (500 + ENCODING_NAME_MAX_SIZE)
  1754. /* Search the SCM_ENCODING_SEARCH_SIZE bytes of a file for an Emacs-like
  1755. coding declaration. Returns either NULL or a string whose storage
  1756. has been allocated with `scm_gc_malloc'. */
  1757. char *
  1758. scm_i_scan_for_encoding (SCM port)
  1759. {
  1760. scm_t_port *pt;
  1761. char header[SCM_ENCODING_SEARCH_SIZE+1];
  1762. size_t bytes_read, encoding_length, i;
  1763. char *encoding = NULL;
  1764. char *pos, *encoding_start;
  1765. int in_comment;
  1766. pt = SCM_PTAB_ENTRY (port);
  1767. if (pt->rw_active == SCM_PORT_WRITE)
  1768. scm_flush_unlocked (port);
  1769. if (pt->rw_random)
  1770. pt->rw_active = SCM_PORT_READ;
  1771. if (pt->read_pos == pt->read_end)
  1772. {
  1773. /* We can use the read buffer, and thus avoid a seek. */
  1774. if (scm_fill_input_unlocked (port) == EOF)
  1775. return NULL;
  1776. bytes_read = pt->read_end - pt->read_pos;
  1777. if (bytes_read > SCM_ENCODING_SEARCH_SIZE)
  1778. bytes_read = SCM_ENCODING_SEARCH_SIZE;
  1779. if (bytes_read <= 1)
  1780. /* An unbuffered port -- don't scan. */
  1781. return NULL;
  1782. memcpy (header, pt->read_pos, bytes_read);
  1783. header[bytes_read] = '\0';
  1784. }
  1785. else
  1786. {
  1787. /* Try to read some bytes and then seek back. Not all ports
  1788. support seeking back; and indeed some file ports (like
  1789. /dev/urandom) will succeed on an lseek (fd, 0, SEEK_CUR)---the
  1790. check performed by SCM_FPORT_FDES---but fail to seek
  1791. backwards. Hence this block comes second. We prefer to use
  1792. the read buffer in-place. */
  1793. if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port)))
  1794. return NULL;
  1795. bytes_read = scm_c_read_unlocked (port, header, SCM_ENCODING_SEARCH_SIZE);
  1796. header[bytes_read] = '\0';
  1797. scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
  1798. }
  1799. /* search past "coding[:=]" */
  1800. pos = header;
  1801. while (1)
  1802. {
  1803. if ((pos = strstr(pos, "coding")) == NULL)
  1804. return NULL;
  1805. pos += strlen ("coding");
  1806. if (pos - header >= SCM_ENCODING_SEARCH_SIZE ||
  1807. (*pos == ':' || *pos == '='))
  1808. {
  1809. pos ++;
  1810. break;
  1811. }
  1812. }
  1813. /* skip spaces */
  1814. while (pos - header <= SCM_ENCODING_SEARCH_SIZE &&
  1815. (*pos == ' ' || *pos == '\t'))
  1816. pos ++;
  1817. if (pos - header >= SCM_ENCODING_SEARCH_SIZE - ENCODING_NAME_MAX_SIZE)
  1818. /* We found the "coding:" string, but there is probably not enough
  1819. room to store an encoding name in its entirety, so ignore it.
  1820. This makes sure we do not end up returning a truncated encoding
  1821. name. */
  1822. return NULL;
  1823. /* grab the next token */
  1824. encoding_start = pos;
  1825. i = 0;
  1826. while (encoding_start + i - header <= SCM_ENCODING_SEARCH_SIZE
  1827. && encoding_start + i - header < bytes_read
  1828. && is_encoding_char (encoding_start[i]))
  1829. i++;
  1830. encoding_length = i;
  1831. if (encoding_length == 0)
  1832. return NULL;
  1833. encoding = scm_gc_strndup (encoding_start, encoding_length, "encoding");
  1834. /* push backwards to make sure we were in a comment */
  1835. in_comment = 0;
  1836. pos = encoding_start;
  1837. while (pos >= header)
  1838. {
  1839. if (*pos == ';')
  1840. {
  1841. in_comment = 1;
  1842. break;
  1843. }
  1844. else if (*pos == '\n' || pos == header)
  1845. {
  1846. /* This wasn't in a semicolon comment. Check for a
  1847. hash-bang comment. */
  1848. char *beg = strstr (header, "#!");
  1849. char *end = strstr (header, "!#");
  1850. if (beg < encoding_start && encoding_start + encoding_length <= end)
  1851. in_comment = 1;
  1852. break;
  1853. }
  1854. else
  1855. {
  1856. pos --;
  1857. continue;
  1858. }
  1859. }
  1860. if (!in_comment)
  1861. /* This wasn't in a comment */
  1862. return NULL;
  1863. return encoding;
  1864. }
  1865. SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
  1866. (SCM port),
  1867. "Scans the port for an Emacs-like character coding declaration\n"
  1868. "near the top of the contents of a port with random-accessible contents.\n"
  1869. "The coding declaration is of the form\n"
  1870. "@code{coding: XXXXX} and must appear in a scheme comment.\n"
  1871. "\n"
  1872. "Returns a string containing the character encoding of the file\n"
  1873. "if a declaration was found, or @code{#f} otherwise.\n")
  1874. #define FUNC_NAME s_scm_file_encoding
  1875. {
  1876. char *enc;
  1877. SCM s_enc;
  1878. SCM_VALIDATE_OPINPORT (SCM_ARG1, port);
  1879. enc = scm_i_scan_for_encoding (port);
  1880. if (enc == NULL)
  1881. return SCM_BOOL_F;
  1882. else
  1883. {
  1884. s_enc = scm_string_upcase (scm_from_locale_string (enc));
  1885. return s_enc;
  1886. }
  1887. return SCM_BOOL_F;
  1888. }
  1889. #undef FUNC_NAME
  1890. /* Per-port read options.
  1891. We store per-port read options in the 'port-read-options' port
  1892. property, which is stored in the internal port structure. The value
  1893. stored is a single integer that contains a two-bit field for each
  1894. read option.
  1895. If a bit field contains READ_OPTION_INHERIT (3), that indicates that
  1896. the applicable value should be inherited from the corresponding
  1897. global read option. Otherwise, the bit field contains the value of
  1898. the read option. For boolean read options that have been set
  1899. per-port, the possible values are 0 or 1. If the 'keyword_style'
  1900. read option has been set per-port, its possible values are those in
  1901. 'enum t_keyword_style'. */
  1902. /* Key to read options in port properties. */
  1903. SCM_SYMBOL (sym_port_read_options, "port-read-options");
  1904. /* Offsets of bit fields for each per-port override */
  1905. #define READ_OPTION_COPY_SOURCE_P 0
  1906. #define READ_OPTION_RECORD_POSITIONS_P 2
  1907. #define READ_OPTION_CASE_INSENSITIVE_P 4
  1908. #define READ_OPTION_KEYWORD_STYLE 6
  1909. #define READ_OPTION_R6RS_ESCAPES_P 8
  1910. #define READ_OPTION_SQUARE_BRACKETS_P 10
  1911. #define READ_OPTION_HUNGRY_EOL_ESCAPES_P 12
  1912. #define READ_OPTION_CURLY_INFIX_P 14
  1913. #define READ_OPTION_R7RS_SYMBOLS_P 16
  1914. /* The total width in bits of the per-port overrides */
  1915. #define READ_OPTIONS_NUM_BITS 18
  1916. #define READ_OPTIONS_INHERIT_ALL ((1UL << READ_OPTIONS_NUM_BITS) - 1)
  1917. #define READ_OPTIONS_MAX_VALUE READ_OPTIONS_INHERIT_ALL
  1918. #define READ_OPTION_MASK 3
  1919. #define READ_OPTION_INHERIT 3
  1920. static void
  1921. set_port_read_option (SCM port, int option, int new_value)
  1922. {
  1923. SCM scm_read_options;
  1924. unsigned int read_options;
  1925. new_value &= READ_OPTION_MASK;
  1926. scm_dynwind_begin (0);
  1927. scm_dynwind_lock_port (port);
  1928. scm_read_options = scm_i_port_property (port, sym_port_read_options);
  1929. if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
  1930. read_options = scm_to_uint (scm_read_options);
  1931. else
  1932. read_options = READ_OPTIONS_INHERIT_ALL;
  1933. read_options &= ~(READ_OPTION_MASK << option);
  1934. read_options |= new_value << option;
  1935. scm_read_options = scm_from_uint (read_options);
  1936. scm_i_set_port_property_x (port, sym_port_read_options, scm_read_options);
  1937. scm_dynwind_end ();
  1938. }
  1939. /* Set OPTS and PORT's case-insensitivity according to VALUE. */
  1940. static void
  1941. set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, int value)
  1942. {
  1943. value = !!value;
  1944. opts->case_insensitive_p = value;
  1945. set_port_read_option (port, READ_OPTION_CASE_INSENSITIVE_P, value);
  1946. }
  1947. /* Set OPTS and PORT's square_brackets_p option according to VALUE. */
  1948. static void
  1949. set_port_square_brackets_p (SCM port, scm_t_read_opts *opts, int value)
  1950. {
  1951. value = !!value;
  1952. opts->square_brackets_p = value;
  1953. set_port_read_option (port, READ_OPTION_SQUARE_BRACKETS_P, value);
  1954. }
  1955. /* Set OPTS and PORT's curly_infix_p option according to VALUE. */
  1956. static void
  1957. set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value)
  1958. {
  1959. value = !!value;
  1960. opts->curly_infix_p = value;
  1961. set_port_read_option (port, READ_OPTION_CURLY_INFIX_P, value);
  1962. }
  1963. /* Initialize OPTS based on PORT's read options and the global read
  1964. options. */
  1965. static void
  1966. init_read_options (SCM port, scm_t_read_opts *opts)
  1967. {
  1968. SCM val, scm_read_options;
  1969. unsigned int read_options, x;
  1970. scm_read_options = scm_i_port_property (port, sym_port_read_options);
  1971. if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
  1972. read_options = scm_to_uint (scm_read_options);
  1973. else
  1974. read_options = READ_OPTIONS_INHERIT_ALL;
  1975. x = READ_OPTION_MASK & (read_options >> READ_OPTION_KEYWORD_STYLE);
  1976. if (x == READ_OPTION_INHERIT)
  1977. {
  1978. val = SCM_PACK (SCM_KEYWORD_STYLE);
  1979. if (scm_is_eq (val, scm_keyword_prefix))
  1980. x = KEYWORD_STYLE_PREFIX;
  1981. else if (scm_is_eq (val, scm_keyword_postfix))
  1982. x = KEYWORD_STYLE_POSTFIX;
  1983. else
  1984. x = KEYWORD_STYLE_HASH_PREFIX;
  1985. }
  1986. opts->keyword_style = x;
  1987. #define RESOLVE_BOOLEAN_OPTION(NAME, name) \
  1988. do \
  1989. { \
  1990. x = READ_OPTION_MASK & (read_options >> READ_OPTION_ ## NAME); \
  1991. if (x == READ_OPTION_INHERIT) \
  1992. x = !!SCM_ ## NAME; \
  1993. opts->name = x; \
  1994. } \
  1995. while (0)
  1996. RESOLVE_BOOLEAN_OPTION (COPY_SOURCE_P, copy_source_p);
  1997. RESOLVE_BOOLEAN_OPTION (RECORD_POSITIONS_P, record_positions_p);
  1998. RESOLVE_BOOLEAN_OPTION (CASE_INSENSITIVE_P, case_insensitive_p);
  1999. RESOLVE_BOOLEAN_OPTION (R6RS_ESCAPES_P, r6rs_escapes_p);
  2000. RESOLVE_BOOLEAN_OPTION (SQUARE_BRACKETS_P, square_brackets_p);
  2001. RESOLVE_BOOLEAN_OPTION (HUNGRY_EOL_ESCAPES_P, hungry_eol_escapes_p);
  2002. RESOLVE_BOOLEAN_OPTION (CURLY_INFIX_P, curly_infix_p);
  2003. RESOLVE_BOOLEAN_OPTION (R7RS_SYMBOLS_P, r7rs_symbols_p);
  2004. #undef RESOLVE_BOOLEAN_OPTION
  2005. opts->neoteric_p = 0;
  2006. }
  2007. void
  2008. scm_init_read ()
  2009. {
  2010. SCM read_hash_procs;
  2011. read_hash_procs = scm_make_fluid_with_default (SCM_EOL);
  2012. scm_i_read_hash_procedures =
  2013. SCM_VARIABLE_LOC (scm_c_define ("%read-hash-procedures", read_hash_procs));
  2014. scm_init_opts (scm_read_options, scm_read_opts);
  2015. #include "libguile/read.x"
  2016. }
  2017. /*
  2018. Local Variables:
  2019. c-file-style: "gnu"
  2020. End:
  2021. */