print.c 47 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746
  1. /* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008,
  2. * 2009, 2010, 2011, 2012, 2013, 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 <errno.h>
  23. #include <iconv.h>
  24. #include <stdio.h>
  25. #include <assert.h>
  26. #include <uniconv.h>
  27. #include <unictype.h>
  28. #include "libguile/_scm.h"
  29. #include "libguile/chars.h"
  30. #include "libguile/continuations.h"
  31. #include "libguile/smob.h"
  32. #include "libguile/control.h"
  33. #include "libguile/eval.h"
  34. #include "libguile/macros.h"
  35. #include "libguile/procprop.h"
  36. #include "libguile/read.h"
  37. #include "libguile/programs.h"
  38. #include "libguile/alist.h"
  39. #include "libguile/struct.h"
  40. #include "libguile/ports.h"
  41. #include "libguile/ports-internal.h"
  42. #include "libguile/root.h"
  43. #include "libguile/strings.h"
  44. #include "libguile/strports.h"
  45. #include "libguile/vectors.h"
  46. #include "libguile/numbers.h"
  47. #include "libguile/vm.h"
  48. #include "libguile/validate.h"
  49. #include "libguile/print.h"
  50. #include "libguile/private-options.h"
  51. /* Character printers. */
  52. #define PORT_CONVERSION_HANDLER(port) \
  53. SCM_PTAB_ENTRY (port)->ilseq_handler
  54. static size_t display_string (const void *, int, size_t, SCM,
  55. scm_t_string_failed_conversion_handler);
  56. static int display_character (scm_t_wchar, SCM,
  57. scm_t_string_failed_conversion_handler);
  58. static void write_character (scm_t_wchar, SCM, int);
  59. static void write_character_escaped (scm_t_wchar, int, SCM);
  60. /* {Names of immediate symbols}
  61. *
  62. * This table must agree with the declarations in scm.h: {Immediate Symbols}.
  63. */
  64. /* This table must agree with the list of flags in tags.h. */
  65. static const char *iflagnames[] =
  66. {
  67. "#f",
  68. "#nil", /* Elisp nil value. Should print from elisp as symbol `nil'. */
  69. "#<XXX UNUSED LISP FALSE -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
  70. "()",
  71. "#t",
  72. "#<XXX UNUSED BOOLEAN 0 -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
  73. "#<XXX UNUSED BOOLEAN 1 -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
  74. "#<XXX UNUSED BOOLEAN 2 -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
  75. "#<unspecified>",
  76. "#<undefined>",
  77. "#<eof>",
  78. /* Unbound slot marker for GOOPS. For internal use in GOOPS only. */
  79. "#<unbound>",
  80. };
  81. SCM_SYMBOL (sym_reader, "reader");
  82. scm_t_option scm_print_opts[] = {
  83. { SCM_OPTION_SCM, "highlight-prefix", (scm_t_bits)SCM_BOOL_F_BITS,
  84. "The string to print before highlighted values." },
  85. { SCM_OPTION_SCM, "highlight-suffix", (scm_t_bits)SCM_BOOL_F_BITS,
  86. "The string to print after highlighted values." },
  87. { SCM_OPTION_SCM, "quote-keywordish-symbols", (scm_t_bits)SCM_BOOL_F_BITS,
  88. "How to print symbols that have a colon as their first or last character. "
  89. "The value '#f' does not quote the colons; '#t' quotes them; "
  90. "'reader' quotes them when the reader option 'keywords' is not '#f'." },
  91. { SCM_OPTION_BOOLEAN, "escape-newlines", 1,
  92. "Render newlines as \\n when printing using `write'." },
  93. { SCM_OPTION_BOOLEAN, "r7rs-symbols", 0,
  94. "Escape symbols using R7RS |...| symbol notation." },
  95. { 0 },
  96. };
  97. SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0,
  98. (SCM setting),
  99. "Option interface for the print options. Instead of using\n"
  100. "this procedure directly, use the procedures\n"
  101. "@code{print-enable}, @code{print-disable}, @code{print-set!}\n"
  102. "and @code{print-options}.")
  103. #define FUNC_NAME s_scm_print_options
  104. {
  105. SCM ans = scm_options (setting,
  106. scm_print_opts,
  107. FUNC_NAME);
  108. return ans;
  109. }
  110. #undef FUNC_NAME
  111. /* {Printing of Scheme Objects}
  112. */
  113. /* Detection of circular references.
  114. *
  115. * Due to other constraints in the implementation, this code has bad
  116. * time complexity (O (depth * N)), The printer code can be
  117. * rewritten to be O(N).
  118. */
  119. #define PUSH_REF(pstate, obj) \
  120. do \
  121. { \
  122. PSTATE_STACK_SET (pstate, pstate->top, obj); \
  123. pstate->top++; \
  124. if (pstate->top == pstate->ceiling) \
  125. grow_ref_stack (pstate); \
  126. } while(0)
  127. #define ENTER_NESTED_DATA(pstate, obj, label) \
  128. do \
  129. { \
  130. register unsigned long i; \
  131. for (i = 0; i < pstate->top; ++i) \
  132. if (scm_is_eq (PSTATE_STACK_REF (pstate, i), (obj))) \
  133. goto label; \
  134. if (pstate->fancyp) \
  135. { \
  136. if (pstate->top - pstate->list_offset >= pstate->level) \
  137. { \
  138. scm_putc_unlocked ('#', port); \
  139. return; \
  140. } \
  141. } \
  142. PUSH_REF(pstate, obj); \
  143. } while(0)
  144. #define EXIT_NESTED_DATA(pstate) \
  145. do \
  146. { \
  147. --pstate->top; \
  148. PSTATE_STACK_SET (pstate, pstate->top, SCM_UNDEFINED); \
  149. } \
  150. while (0)
  151. SCM scm_print_state_vtable = SCM_BOOL_F;
  152. static SCM print_state_pool = SCM_EOL;
  153. scm_i_pthread_mutex_t print_state_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
  154. #ifdef GUILE_DEBUG /* Used for debugging purposes */
  155. SCM_DEFINE (scm_current_pstate, "current-pstate", 0, 0, 0,
  156. (),
  157. "Return the current-pstate -- the car of the\n"
  158. "@code{print_state_pool}. @code{current-pstate} is only\n"
  159. "included in @code{--enable-guile-debug} builds.")
  160. #define FUNC_NAME s_scm_current_pstate
  161. {
  162. if (!scm_is_null (print_state_pool))
  163. return SCM_CAR (print_state_pool);
  164. else
  165. return SCM_BOOL_F;
  166. }
  167. #undef FUNC_NAME
  168. #endif
  169. #define PSTATE_SIZE 50L
  170. static SCM
  171. make_print_state (void)
  172. {
  173. SCM print_state
  174. = scm_make_struct (scm_print_state_vtable, SCM_INUM0, SCM_EOL);
  175. scm_print_state *pstate = SCM_PRINT_STATE (print_state);
  176. pstate->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED);
  177. pstate->ceiling = SCM_SIMPLE_VECTOR_LENGTH (pstate->ref_vect);
  178. pstate->highlight_objects = SCM_EOL;
  179. return print_state;
  180. }
  181. SCM
  182. scm_make_print_state ()
  183. {
  184. SCM answer = SCM_BOOL_F;
  185. /* First try to allocate a print state from the pool */
  186. scm_i_pthread_mutex_lock (&print_state_mutex);
  187. if (!scm_is_null (print_state_pool))
  188. {
  189. answer = SCM_CAR (print_state_pool);
  190. print_state_pool = SCM_CDR (print_state_pool);
  191. }
  192. scm_i_pthread_mutex_unlock (&print_state_mutex);
  193. return scm_is_false (answer) ? make_print_state () : answer;
  194. }
  195. void
  196. scm_free_print_state (SCM print_state)
  197. {
  198. SCM handle;
  199. scm_print_state *pstate = SCM_PRINT_STATE (print_state);
  200. /* Cleanup before returning print state to pool.
  201. * It is better to do it here. Doing it in scm_prin1
  202. * would cost more since that function is called much more
  203. * often.
  204. */
  205. pstate->fancyp = 0;
  206. pstate->revealed = 0;
  207. pstate->highlight_objects = SCM_EOL;
  208. scm_i_pthread_mutex_lock (&print_state_mutex);
  209. handle = scm_cons (print_state, print_state_pool);
  210. print_state_pool = handle;
  211. scm_i_pthread_mutex_unlock (&print_state_mutex);
  212. }
  213. SCM
  214. scm_i_port_with_print_state (SCM port, SCM print_state)
  215. {
  216. if (SCM_UNBNDP (print_state))
  217. {
  218. if (SCM_PORT_WITH_PS_P (port))
  219. return port;
  220. else
  221. print_state = scm_make_print_state ();
  222. /* port does not need to be coerced since it doesn't have ps */
  223. }
  224. else
  225. port = SCM_COERCE_OUTPORT (port);
  226. SCM_RETURN_NEWSMOB (scm_tc16_port_with_ps,
  227. SCM_UNPACK (scm_cons (port, print_state)));
  228. }
  229. static void
  230. grow_ref_stack (scm_print_state *pstate)
  231. {
  232. SCM old_vect = pstate->ref_vect;
  233. size_t old_size = SCM_SIMPLE_VECTOR_LENGTH (old_vect);
  234. size_t new_size = 2 * pstate->ceiling;
  235. SCM new_vect = scm_c_make_vector (new_size, SCM_UNDEFINED);
  236. unsigned long int i;
  237. for (i = 0; i != old_size; ++i)
  238. SCM_SIMPLE_VECTOR_SET (new_vect, i, SCM_SIMPLE_VECTOR_REF (old_vect, i));
  239. pstate->ref_vect = new_vect;
  240. pstate->ceiling = new_size;
  241. }
  242. #define PSTATE_STACK_REF(p,i) SCM_SIMPLE_VECTOR_REF((p)->ref_vect, (i))
  243. #define PSTATE_STACK_SET(p,i,v) SCM_SIMPLE_VECTOR_SET((p)->ref_vect, (i), (v))
  244. static void
  245. print_circref (SCM port, scm_print_state *pstate, SCM ref)
  246. {
  247. register long i;
  248. long self = pstate->top - 1;
  249. i = pstate->top - 1;
  250. if (scm_is_pair (PSTATE_STACK_REF (pstate, i)))
  251. {
  252. while (i > 0)
  253. {
  254. if (!scm_is_pair (PSTATE_STACK_REF (pstate, i-1))
  255. || !scm_is_eq (SCM_CDR (PSTATE_STACK_REF (pstate, i-1)),
  256. SCM_CDR (PSTATE_STACK_REF (pstate, i))))
  257. break;
  258. --i;
  259. }
  260. self = i;
  261. }
  262. for (i = pstate->top - 1; 1; --i)
  263. if (scm_is_eq (PSTATE_STACK_REF(pstate, i), ref))
  264. break;
  265. scm_putc_unlocked ('#', port);
  266. scm_intprint (i - self, 10, port);
  267. scm_putc_unlocked ('#', port);
  268. }
  269. /* Print the name of a symbol. */
  270. static int
  271. quote_keywordish_symbols (void)
  272. {
  273. SCM option = SCM_PRINT_KEYWORD_STYLE;
  274. if (scm_is_false (option))
  275. return 0;
  276. if (scm_is_eq (option, sym_reader))
  277. return scm_is_true (SCM_PACK (SCM_KEYWORD_STYLE));
  278. return 1;
  279. }
  280. #define INITIAL_IDENTIFIER_MASK \
  281. (UC_CATEGORY_MASK_Lu | UC_CATEGORY_MASK_Ll | UC_CATEGORY_MASK_Lt \
  282. | UC_CATEGORY_MASK_Lm | UC_CATEGORY_MASK_Lo | UC_CATEGORY_MASK_Mn \
  283. | UC_CATEGORY_MASK_Nl | UC_CATEGORY_MASK_No | UC_CATEGORY_MASK_Pd \
  284. | UC_CATEGORY_MASK_Pc | UC_CATEGORY_MASK_Po | UC_CATEGORY_MASK_Sc \
  285. | UC_CATEGORY_MASK_Sm | UC_CATEGORY_MASK_Sk | UC_CATEGORY_MASK_So \
  286. | UC_CATEGORY_MASK_Co)
  287. #define SUBSEQUENT_IDENTIFIER_MASK \
  288. (INITIAL_IDENTIFIER_MASK \
  289. | UC_CATEGORY_MASK_Nd | UC_CATEGORY_MASK_Mc | UC_CATEGORY_MASK_Me)
  290. /* FIXME: Cache this information on the symbol, somehow. */
  291. static int
  292. symbol_has_extended_read_syntax (SCM sym)
  293. {
  294. size_t pos, len = scm_i_symbol_length (sym);
  295. scm_t_wchar c;
  296. /* The empty symbol. */
  297. if (len == 0)
  298. return 1;
  299. c = scm_i_symbol_ref (sym, 0);
  300. switch (c)
  301. {
  302. case '\'':
  303. case '`':
  304. case ',':
  305. case '"':
  306. case ';':
  307. case '#':
  308. /* Some initial-character constraints. */
  309. return 1;
  310. case '|':
  311. case '\\':
  312. /* R7RS allows neither '|' nor '\' in bare symbols. */
  313. if (SCM_PRINT_R7RS_SYMBOLS_P)
  314. return 1;
  315. break;
  316. case ':':
  317. /* Symbols that look like keywords. */
  318. return quote_keywordish_symbols ();
  319. case '.':
  320. /* Single dot conflicts with dotted-pair notation. */
  321. if (len == 1)
  322. return 1;
  323. /* Fall through to check numbers. */
  324. case '+':
  325. case '-':
  326. case '0':
  327. case '1':
  328. case '2':
  329. case '3':
  330. case '4':
  331. case '5':
  332. case '6':
  333. case '7':
  334. case '8':
  335. case '9':
  336. /* Number-ish symbols. Numbers with radixes already caught be #
  337. above. */
  338. if (scm_is_true (scm_i_string_to_number (scm_symbol_to_string (sym), 10)))
  339. return 1;
  340. break;
  341. default:
  342. break;
  343. }
  344. /* Other disallowed first characters. */
  345. if (!uc_is_general_category_withtable (c, INITIAL_IDENTIFIER_MASK))
  346. return 1;
  347. /* Keywords can be identified by trailing colons too. */
  348. if (scm_i_symbol_ref (sym, len - 1) == ':')
  349. return quote_keywordish_symbols ();
  350. /* Otherwise, any character that's in the identifier category mask is
  351. fine to pass through as-is, provided it's not one of the ASCII
  352. delimiters like `;'. */
  353. for (pos = 1; pos < len; pos++)
  354. {
  355. c = scm_i_symbol_ref (sym, pos);
  356. if (!uc_is_general_category_withtable (c, SUBSEQUENT_IDENTIFIER_MASK))
  357. return 1;
  358. else if (c == '"' || c == ';' || c == '#')
  359. return 1;
  360. else if ((c == '|' || c == '\\') && SCM_PRINT_R7RS_SYMBOLS_P)
  361. /* R7RS allows neither '|' nor '\' in bare symbols. */
  362. return 1;
  363. }
  364. return 0;
  365. }
  366. static void
  367. print_normal_symbol (SCM sym, SCM port)
  368. {
  369. size_t len;
  370. scm_t_string_failed_conversion_handler strategy;
  371. len = scm_i_symbol_length (sym);
  372. strategy = SCM_PTAB_ENTRY (port)->ilseq_handler;
  373. if (scm_i_is_narrow_symbol (sym))
  374. display_string (scm_i_symbol_chars (sym), 1, len, port, strategy);
  375. else
  376. display_string (scm_i_symbol_wide_chars (sym), 0, len, port, strategy);
  377. }
  378. static void
  379. print_extended_symbol (SCM sym, SCM port)
  380. {
  381. size_t pos, len;
  382. scm_t_string_failed_conversion_handler strategy;
  383. len = scm_i_symbol_length (sym);
  384. strategy = PORT_CONVERSION_HANDLER (port);
  385. scm_lfwrite_unlocked ("#{", 2, port);
  386. for (pos = 0; pos < len; pos++)
  387. {
  388. scm_t_wchar c = scm_i_symbol_ref (sym, pos);
  389. if (uc_is_general_category_withtable (c,
  390. SUBSEQUENT_IDENTIFIER_MASK
  391. | UC_CATEGORY_MASK_Zs))
  392. {
  393. if (!display_character (c, port, strategy)
  394. || (c == '\\' && !display_character (c, port, strategy)))
  395. scm_encoding_error ("print_extended_symbol", errno,
  396. "cannot convert to output locale",
  397. port, SCM_MAKE_CHAR (c));
  398. }
  399. else
  400. {
  401. scm_lfwrite_unlocked ("\\x", 2, port);
  402. scm_intprint (c, 16, port);
  403. scm_putc_unlocked (';', port);
  404. }
  405. }
  406. scm_lfwrite_unlocked ("}#", 2, port);
  407. }
  408. static void
  409. print_r7rs_extended_symbol (SCM sym, SCM port)
  410. {
  411. size_t pos, len;
  412. scm_t_string_failed_conversion_handler strategy;
  413. len = scm_i_symbol_length (sym);
  414. strategy = PORT_CONVERSION_HANDLER (port);
  415. scm_putc_unlocked ('|', port);
  416. for (pos = 0; pos < len; pos++)
  417. {
  418. scm_t_wchar c = scm_i_symbol_ref (sym, pos);
  419. switch (c)
  420. {
  421. case '\a': scm_lfwrite_unlocked ("\\a", 2, port); break;
  422. case '\b': scm_lfwrite_unlocked ("\\b", 2, port); break;
  423. case '\t': scm_lfwrite_unlocked ("\\t", 2, port); break;
  424. case '\n': scm_lfwrite_unlocked ("\\n", 2, port); break;
  425. case '\r': scm_lfwrite_unlocked ("\\r", 2, port); break;
  426. case '|': scm_lfwrite_unlocked ("\\|", 2, port); break;
  427. case '\\': scm_lfwrite_unlocked ("\\x5c;", 5, port); break;
  428. default:
  429. if (uc_is_general_category_withtable (c,
  430. UC_CATEGORY_MASK_L
  431. | UC_CATEGORY_MASK_M
  432. | UC_CATEGORY_MASK_N
  433. | UC_CATEGORY_MASK_P
  434. | UC_CATEGORY_MASK_S)
  435. || (c == ' '))
  436. {
  437. if (!display_character (c, port, strategy))
  438. scm_encoding_error ("print_r7rs_extended_symbol", errno,
  439. "cannot convert to output locale",
  440. port, SCM_MAKE_CHAR (c));
  441. }
  442. else
  443. {
  444. scm_lfwrite_unlocked ("\\x", 2, port);
  445. scm_intprint (c, 16, port);
  446. scm_putc_unlocked (';', port);
  447. }
  448. break;
  449. }
  450. }
  451. scm_putc_unlocked ('|', port);
  452. }
  453. /* FIXME: allow R6RS hex escapes instead of #{...}# or |...|. */
  454. static void
  455. print_symbol (SCM sym, SCM port)
  456. {
  457. if (!symbol_has_extended_read_syntax (sym))
  458. print_normal_symbol (sym, port);
  459. else if (SCM_PRINT_R7RS_SYMBOLS_P)
  460. print_r7rs_extended_symbol (sym, port);
  461. else
  462. print_extended_symbol (sym, port);
  463. }
  464. void
  465. scm_print_symbol_name (const char *str, size_t len, SCM port)
  466. {
  467. SCM symbol = scm_from_utf8_symboln (str, len);
  468. print_symbol (symbol, port);
  469. }
  470. /* Print generally. Handles both write and display according to PSTATE.
  471. */
  472. SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write);
  473. SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display);
  474. static void iprin1 (SCM exp, SCM port, scm_print_state *pstate);
  475. /* Print a character as an octal or hex escape. */
  476. #define PRINT_CHAR_ESCAPE(i, port) \
  477. do \
  478. { \
  479. if (!SCM_R6RS_ESCAPES_P) \
  480. scm_intprint (i, 8, port); \
  481. else \
  482. { \
  483. scm_puts_unlocked ("x", port); \
  484. scm_intprint (i, 16, port); \
  485. } \
  486. } \
  487. while (0)
  488. void
  489. scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
  490. {
  491. if (pstate->fancyp
  492. && scm_is_true (scm_memq (exp, pstate->highlight_objects)))
  493. {
  494. scm_display (SCM_PRINT_HIGHLIGHT_PREFIX, port);
  495. iprin1 (exp, port, pstate);
  496. scm_display (SCM_PRINT_HIGHLIGHT_SUFFIX, port);
  497. }
  498. else
  499. iprin1 (exp, port, pstate);
  500. }
  501. static void
  502. iprin1 (SCM exp, SCM port, scm_print_state *pstate)
  503. {
  504. switch (SCM_ITAG3 (exp))
  505. {
  506. case scm_tc3_tc7_1:
  507. case scm_tc3_tc7_2:
  508. /* These tc3 tags should never occur in an immediate value. They are
  509. * only used in cell types of non-immediates, i. e. the value returned
  510. * by SCM_CELL_TYPE (exp) can use these tags.
  511. */
  512. scm_ipruk ("immediate", exp, port);
  513. break;
  514. case scm_tc3_int_1:
  515. case scm_tc3_int_2:
  516. scm_intprint (SCM_I_INUM (exp), 10, port);
  517. break;
  518. case scm_tc3_imm24:
  519. if (SCM_CHARP (exp))
  520. {
  521. if (SCM_WRITINGP (pstate))
  522. write_character (SCM_CHAR (exp), port, 0);
  523. else
  524. {
  525. if (!display_character (SCM_CHAR (exp), port,
  526. PORT_CONVERSION_HANDLER (port)))
  527. scm_encoding_error (__func__, errno,
  528. "cannot convert to output locale",
  529. port, exp);
  530. }
  531. }
  532. else if (SCM_IFLAGP (exp)
  533. && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *))))
  534. {
  535. scm_puts_unlocked (iflagnames [SCM_IFLAGNUM (exp)], port);
  536. }
  537. else
  538. {
  539. /* unknown immediate value */
  540. scm_ipruk ("immediate", exp, port);
  541. }
  542. break;
  543. case scm_tc3_cons:
  544. switch (SCM_TYP7 (exp))
  545. {
  546. case scm_tcs_struct:
  547. {
  548. ENTER_NESTED_DATA (pstate, exp, circref);
  549. if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
  550. {
  551. SCM pwps, print = pstate->writingp ? g_write : g_display;
  552. if (SCM_UNPACK (print) == 0)
  553. goto print_struct;
  554. pwps = scm_i_port_with_print_state (port, pstate->handle);
  555. pstate->revealed = 1;
  556. scm_call_2 (print, exp, pwps);
  557. }
  558. else
  559. {
  560. print_struct:
  561. scm_print_struct (exp, port, pstate);
  562. }
  563. EXIT_NESTED_DATA (pstate);
  564. }
  565. break;
  566. case scm_tcs_cons_imcar:
  567. case scm_tcs_cons_nimcar:
  568. ENTER_NESTED_DATA (pstate, exp, circref);
  569. scm_iprlist ("(", exp, ')', port, pstate);
  570. EXIT_NESTED_DATA (pstate);
  571. break;
  572. circref:
  573. print_circref (port, pstate, exp);
  574. break;
  575. case scm_tc7_number:
  576. switch SCM_TYP16 (exp) {
  577. case scm_tc16_big:
  578. scm_bigprint (exp, port, pstate);
  579. break;
  580. case scm_tc16_real:
  581. scm_print_real (exp, port, pstate);
  582. break;
  583. case scm_tc16_complex:
  584. scm_print_complex (exp, port, pstate);
  585. break;
  586. case scm_tc16_fraction:
  587. scm_i_print_fraction (exp, port, pstate);
  588. break;
  589. }
  590. break;
  591. case scm_tc7_stringbuf:
  592. scm_i_print_stringbuf (exp, port, pstate);
  593. break;
  594. case scm_tc7_string:
  595. if (SCM_WRITINGP (pstate))
  596. {
  597. size_t len, i;
  598. display_character ('"', port, iconveh_question_mark);
  599. len = scm_i_string_length (exp);
  600. for (i = 0; i < len; ++i)
  601. write_character (scm_i_string_ref (exp, i), port, 1);
  602. display_character ('"', port, iconveh_question_mark);
  603. scm_remember_upto_here_1 (exp);
  604. }
  605. else
  606. {
  607. size_t len, printed;
  608. len = scm_i_string_length (exp);
  609. printed = display_string (scm_i_string_data (exp),
  610. scm_i_is_narrow_string (exp),
  611. len, port,
  612. PORT_CONVERSION_HANDLER (port));
  613. if (SCM_UNLIKELY (printed < len))
  614. scm_encoding_error (__func__, errno,
  615. "cannot convert to output locale",
  616. port, scm_c_string_ref (exp, printed));
  617. }
  618. scm_remember_upto_here_1 (exp);
  619. break;
  620. case scm_tc7_symbol:
  621. if (scm_i_symbol_is_interned (exp))
  622. {
  623. print_symbol (exp, port);
  624. scm_remember_upto_here_1 (exp);
  625. }
  626. else
  627. {
  628. scm_puts_unlocked ("#<uninterned-symbol ", port);
  629. print_symbol (exp, port);
  630. scm_putc_unlocked (' ', port);
  631. scm_uintprint (SCM_UNPACK (exp), 16, port);
  632. scm_putc_unlocked ('>', port);
  633. }
  634. break;
  635. case scm_tc7_variable:
  636. scm_i_variable_print (exp, port, pstate);
  637. break;
  638. case scm_tc7_program:
  639. scm_i_program_print (exp, port, pstate);
  640. break;
  641. case scm_tc7_pointer:
  642. scm_i_pointer_print (exp, port, pstate);
  643. break;
  644. case scm_tc7_hashtable:
  645. scm_i_hashtable_print (exp, port, pstate);
  646. break;
  647. case scm_tc7_weak_set:
  648. scm_i_weak_set_print (exp, port, pstate);
  649. break;
  650. case scm_tc7_weak_table:
  651. scm_i_weak_table_print (exp, port, pstate);
  652. break;
  653. case scm_tc7_fluid:
  654. scm_i_fluid_print (exp, port, pstate);
  655. break;
  656. case scm_tc7_dynamic_state:
  657. scm_i_dynamic_state_print (exp, port, pstate);
  658. break;
  659. case scm_tc7_frame:
  660. scm_i_frame_print (exp, port, pstate);
  661. break;
  662. case scm_tc7_vm_cont:
  663. scm_i_vm_cont_print (exp, port, pstate);
  664. break;
  665. case scm_tc7_array:
  666. ENTER_NESTED_DATA (pstate, exp, circref);
  667. scm_i_print_array (exp, port, pstate);
  668. EXIT_NESTED_DATA (pstate);
  669. break;
  670. case scm_tc7_bytevector:
  671. scm_i_print_bytevector (exp, port, pstate);
  672. break;
  673. case scm_tc7_bitvector:
  674. scm_i_print_bitvector (exp, port, pstate);
  675. break;
  676. case scm_tc7_wvect:
  677. ENTER_NESTED_DATA (pstate, exp, circref);
  678. scm_puts_unlocked ("#w(", port);
  679. goto common_vector_printer;
  680. case scm_tc7_vector:
  681. ENTER_NESTED_DATA (pstate, exp, circref);
  682. scm_puts_unlocked ("#(", port);
  683. common_vector_printer:
  684. {
  685. register long i;
  686. long last = SCM_SIMPLE_VECTOR_LENGTH (exp) - 1;
  687. int cutp = 0;
  688. if (pstate->fancyp
  689. && SCM_SIMPLE_VECTOR_LENGTH (exp) > pstate->length)
  690. {
  691. last = pstate->length - 1;
  692. cutp = 1;
  693. }
  694. for (i = 0; i < last; ++i)
  695. {
  696. scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
  697. scm_putc_unlocked (' ', port);
  698. }
  699. if (i == last)
  700. {
  701. /* CHECK_INTS; */
  702. scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
  703. }
  704. if (cutp)
  705. scm_puts_unlocked (" ...", port);
  706. scm_putc_unlocked (')', port);
  707. }
  708. EXIT_NESTED_DATA (pstate);
  709. break;
  710. case scm_tc7_port:
  711. {
  712. scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (exp);
  713. if (ptob->print && ptob->print (exp, port, pstate))
  714. break;
  715. goto punk;
  716. }
  717. case scm_tc7_smob:
  718. ENTER_NESTED_DATA (pstate, exp, circref);
  719. SCM_SMOB_DESCRIPTOR (exp).print (exp, port, pstate);
  720. EXIT_NESTED_DATA (pstate);
  721. break;
  722. default:
  723. /* case scm_tcs_closures: */
  724. punk:
  725. scm_ipruk ("type", exp, port);
  726. }
  727. }
  728. }
  729. /* Print states are necessary for circular reference safe printing.
  730. * They are also expensive to allocate. Therefore print states are
  731. * kept in a pool so that they can be reused.
  732. */
  733. /* The PORT argument can also be a print-state/port pair, which will
  734. * then be used instead of allocating a new print state. This is
  735. * useful for continuing a chain of print calls from Scheme. */
  736. void
  737. scm_prin1 (SCM exp, SCM port, int writingp)
  738. {
  739. SCM handle = SCM_BOOL_F; /* Will GC protect the handle whilst unlinked */
  740. SCM pstate_scm;
  741. scm_print_state *pstate;
  742. int old_writingp;
  743. /* If PORT is a print-state/port pair, use that. Else create a new
  744. print-state. */
  745. if (SCM_PORT_WITH_PS_P (port))
  746. {
  747. pstate_scm = SCM_PORT_WITH_PS_PS (port);
  748. port = SCM_PORT_WITH_PS_PORT (port);
  749. }
  750. else
  751. {
  752. /* First try to allocate a print state from the pool */
  753. scm_i_pthread_mutex_lock (&print_state_mutex);
  754. if (!scm_is_null (print_state_pool))
  755. {
  756. handle = print_state_pool;
  757. print_state_pool = SCM_CDR (print_state_pool);
  758. }
  759. scm_i_pthread_mutex_unlock (&print_state_mutex);
  760. if (scm_is_false (handle))
  761. handle = scm_list_1 (make_print_state ());
  762. pstate_scm = SCM_CAR (handle);
  763. }
  764. pstate = SCM_PRINT_STATE (pstate_scm);
  765. old_writingp = pstate->writingp;
  766. pstate->writingp = writingp;
  767. scm_iprin1 (exp, port, pstate);
  768. pstate->writingp = old_writingp;
  769. /* Return print state to pool if it has been created above and
  770. hasn't escaped to Scheme. */
  771. if (scm_is_true (handle) && !pstate->revealed)
  772. {
  773. scm_i_pthread_mutex_lock (&print_state_mutex);
  774. SCM_SETCDR (handle, print_state_pool);
  775. print_state_pool = handle;
  776. scm_i_pthread_mutex_unlock (&print_state_mutex);
  777. }
  778. }
  779. /* Convert codepoint CH to UTF-8 and store the result in UTF8. Return
  780. the number of bytes of the UTF-8-encoded string. */
  781. static size_t
  782. codepoint_to_utf8 (scm_t_wchar ch, scm_t_uint8 utf8[4])
  783. {
  784. size_t len;
  785. scm_t_uint32 codepoint;
  786. codepoint = (scm_t_uint32) ch;
  787. if (codepoint <= 0x7f)
  788. {
  789. len = 1;
  790. utf8[0] = (scm_t_uint8) codepoint;
  791. }
  792. else if (codepoint <= 0x7ffUL)
  793. {
  794. len = 2;
  795. utf8[0] = 0xc0 | (codepoint >> 6);
  796. utf8[1] = 0x80 | (codepoint & 0x3f);
  797. }
  798. else if (codepoint <= 0xffffUL)
  799. {
  800. len = 3;
  801. utf8[0] = 0xe0 | (codepoint >> 12);
  802. utf8[1] = 0x80 | ((codepoint >> 6) & 0x3f);
  803. utf8[2] = 0x80 | (codepoint & 0x3f);
  804. }
  805. else
  806. {
  807. len = 4;
  808. utf8[0] = 0xf0 | (codepoint >> 18);
  809. utf8[1] = 0x80 | ((codepoint >> 12) & 0x3f);
  810. utf8[2] = 0x80 | ((codepoint >> 6) & 0x3f);
  811. utf8[3] = 0x80 | (codepoint & 0x3f);
  812. }
  813. return len;
  814. }
  815. #define STR_REF(s, x) \
  816. (narrow_p \
  817. ? (scm_t_wchar) ((unsigned char *) (s))[x] \
  818. : ((scm_t_wchar *) (s))[x])
  819. /* Write STR to PORT as UTF-8. STR is a LEN-codepoint string; it is
  820. narrow if NARROW_P is true, wide otherwise. Return LEN. */
  821. static size_t
  822. display_string_as_utf8 (const void *str, int narrow_p, size_t len,
  823. SCM port)
  824. {
  825. size_t printed = 0;
  826. while (len > printed)
  827. {
  828. size_t utf8_len, i;
  829. char *input, utf8_buf[256];
  830. /* Convert STR to UTF-8. */
  831. for (i = printed, utf8_len = 0, input = utf8_buf;
  832. i < len && utf8_len + 4 < sizeof (utf8_buf);
  833. i++)
  834. {
  835. utf8_len += codepoint_to_utf8 (STR_REF (str, i),
  836. (scm_t_uint8 *) input);
  837. input = utf8_buf + utf8_len;
  838. }
  839. /* INPUT was successfully converted, entirely; print the
  840. result. */
  841. scm_lfwrite_unlocked (utf8_buf, utf8_len, port);
  842. printed += i - printed;
  843. }
  844. assert (printed == len);
  845. return len;
  846. }
  847. /* Write STR to PORT as ISO-8859-1. STR is a LEN-codepoint string; it
  848. is narrow if NARROW_P is true, wide otherwise. Return LEN. */
  849. static size_t
  850. display_string_as_latin1 (const void *str, int narrow_p, size_t len,
  851. SCM port,
  852. scm_t_string_failed_conversion_handler strategy)
  853. {
  854. size_t printed = 0;
  855. if (narrow_p)
  856. {
  857. scm_lfwrite_unlocked (str, len, port);
  858. return len;
  859. }
  860. while (printed < len)
  861. {
  862. char buf[256];
  863. size_t i;
  864. for (i = 0; i < sizeof(buf) && printed < len; i++, printed++)
  865. {
  866. scm_t_wchar c = STR_REF (str, printed);
  867. if (c < 256)
  868. buf[i] = c;
  869. else
  870. break;
  871. }
  872. scm_lfwrite_unlocked (buf, i, port);
  873. if (i < sizeof(buf) && printed < len)
  874. {
  875. if (strategy == SCM_FAILED_CONVERSION_ERROR)
  876. break;
  877. else if (strategy == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
  878. write_character_escaped (STR_REF (str, printed), 1, port);
  879. else
  880. /* STRATEGY is `SCM_FAILED_CONVERSION_QUESTION_MARK'. */
  881. display_string ("?", 1, 1, port, strategy);
  882. printed++;
  883. }
  884. }
  885. return printed;
  886. }
  887. /* Convert STR through PORT's output conversion descriptor and write the
  888. output to PORT. Return the number of codepoints written. */
  889. static size_t
  890. display_string_using_iconv (const void *str, int narrow_p, size_t len,
  891. SCM port,
  892. scm_t_string_failed_conversion_handler strategy)
  893. {
  894. size_t printed;
  895. scm_t_iconv_descriptors *id;
  896. scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
  897. id = scm_i_port_iconv_descriptors (port, SCM_PORT_WRITE);
  898. if (SCM_UNLIKELY (pti->at_stream_start_for_bom_write && len > 0))
  899. {
  900. scm_t_port *pt = SCM_PTAB_ENTRY (port);
  901. /* Record that we're no longer at stream start. */
  902. pti->at_stream_start_for_bom_write = 0;
  903. if (pt->rw_random)
  904. pti->at_stream_start_for_bom_read = 0;
  905. /* Write a BOM if appropriate. */
  906. if (SCM_UNLIKELY (strcmp(pt->encoding, "UTF-16") == 0
  907. || strcmp(pt->encoding, "UTF-32") == 0))
  908. display_character (SCM_UNICODE_BOM, port, iconveh_error);
  909. }
  910. printed = 0;
  911. while (len > printed)
  912. {
  913. size_t done, utf8_len, input_left, output_left, i;
  914. size_t codepoints_read, output_len;
  915. char *input, *output;
  916. char utf8_buf[256], encoded_output[256];
  917. size_t offsets[256];
  918. /* Convert STR to UTF-8. */
  919. for (i = printed, utf8_len = 0, input = utf8_buf;
  920. i < len && utf8_len + 4 < sizeof (utf8_buf);
  921. i++)
  922. {
  923. offsets[utf8_len] = i;
  924. utf8_len += codepoint_to_utf8 (STR_REF (str, i),
  925. (scm_t_uint8 *) input);
  926. input = utf8_buf + utf8_len;
  927. }
  928. input = utf8_buf;
  929. input_left = utf8_len;
  930. output = encoded_output;
  931. output_left = sizeof (encoded_output);
  932. done = iconv (id->output_cd, &input, &input_left,
  933. &output, &output_left);
  934. output_len = sizeof (encoded_output) - output_left;
  935. if (SCM_UNLIKELY (done == (size_t) -1))
  936. {
  937. int errno_save = errno;
  938. /* Reset the `iconv' state. */
  939. iconv (id->output_cd, NULL, NULL, NULL, NULL);
  940. /* Print the OUTPUT_LEN bytes successfully converted. */
  941. scm_lfwrite_unlocked (encoded_output, output_len, port);
  942. /* See how many input codepoints these OUTPUT_LEN bytes
  943. corresponds to. */
  944. codepoints_read = offsets[input - utf8_buf] - printed;
  945. printed += codepoints_read;
  946. if (errno_save == EILSEQ &&
  947. strategy != SCM_FAILED_CONVERSION_ERROR)
  948. {
  949. /* Conversion failed somewhere in INPUT and we want to
  950. escape or substitute the offending input character. */
  951. if (strategy == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
  952. {
  953. scm_t_wchar ch;
  954. /* Find CH, the offending codepoint, and escape it. */
  955. ch = STR_REF (str, offsets[input - utf8_buf]);
  956. write_character_escaped (ch, 1, port);
  957. }
  958. else
  959. /* STRATEGY is `SCM_FAILED_CONVERSION_QUESTION_MARK'. */
  960. display_string ("?", 1, 1, port, strategy);
  961. printed++;
  962. }
  963. else
  964. /* Something bad happened that we can't handle: bail out. */
  965. break;
  966. }
  967. else
  968. {
  969. /* INPUT was successfully converted, entirely; print the
  970. result. */
  971. scm_lfwrite_unlocked (encoded_output, output_len, port);
  972. codepoints_read = i - printed;
  973. printed += codepoints_read;
  974. }
  975. }
  976. return printed;
  977. }
  978. #undef STR_REF
  979. /* Display the LEN codepoints in STR to PORT according to STRATEGY;
  980. return the number of codepoints successfully displayed. If NARROW_P,
  981. then STR is interpreted as a sequence of `char', denoting a Latin-1
  982. string; otherwise it's interpreted as a sequence of
  983. `scm_t_wchar'. */
  984. static size_t
  985. display_string (const void *str, int narrow_p,
  986. size_t len, SCM port,
  987. scm_t_string_failed_conversion_handler strategy)
  988. {
  989. scm_t_port_internal *pti;
  990. pti = SCM_PORT_GET_INTERNAL (port);
  991. if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
  992. return display_string_as_utf8 (str, narrow_p, len, port);
  993. else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
  994. return display_string_as_latin1 (str, narrow_p, len, port, strategy);
  995. else
  996. return display_string_using_iconv (str, narrow_p, len, port, strategy);
  997. }
  998. /* Attempt to display CH to PORT according to STRATEGY. Return non-zero
  999. if CH was successfully displayed, zero otherwise (e.g., if it was not
  1000. representable in PORT's encoding.) */
  1001. static int
  1002. display_character (scm_t_wchar ch, SCM port,
  1003. scm_t_string_failed_conversion_handler strategy)
  1004. {
  1005. return display_string (&ch, 0, 1, port, strategy) == 1;
  1006. }
  1007. /* Attempt to pretty-print CH, a combining character, to PORT. Return
  1008. zero upon failure, non-zero otherwise. The idea is to print CH above
  1009. a dotted circle to make it more visible. */
  1010. static int
  1011. write_combining_character (scm_t_wchar ch, SCM port)
  1012. {
  1013. scm_t_wchar str[2];
  1014. str[0] = SCM_CODEPOINT_DOTTED_CIRCLE;
  1015. str[1] = ch;
  1016. return display_string (str, 0, 2, port, iconveh_error) == 2;
  1017. }
  1018. /* Write CH to PORT in its escaped form, using the string escape syntax
  1019. if STRING_ESCAPES_P is non-zero. */
  1020. static void
  1021. write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port)
  1022. {
  1023. if (string_escapes_p)
  1024. {
  1025. /* Represent CH using the in-string escape syntax. */
  1026. static const char hex[] = "0123456789abcdef";
  1027. static const char escapes[7] = "abtnvfr";
  1028. char buf[9];
  1029. if (ch >= 0x07 && ch <= 0x0D && ch != 0x0A)
  1030. {
  1031. /* Use special escapes for some C0 controls. */
  1032. buf[0] = '\\';
  1033. buf[1] = escapes[ch - 0x07];
  1034. scm_lfwrite_unlocked (buf, 2, port);
  1035. }
  1036. else if (!SCM_R6RS_ESCAPES_P)
  1037. {
  1038. if (ch <= 0xFF)
  1039. {
  1040. buf[0] = '\\';
  1041. buf[1] = 'x';
  1042. buf[2] = hex[ch / 16];
  1043. buf[3] = hex[ch % 16];
  1044. scm_lfwrite_unlocked (buf, 4, port);
  1045. }
  1046. else if (ch <= 0xFFFF)
  1047. {
  1048. buf[0] = '\\';
  1049. buf[1] = 'u';
  1050. buf[2] = hex[(ch & 0xF000) >> 12];
  1051. buf[3] = hex[(ch & 0xF00) >> 8];
  1052. buf[4] = hex[(ch & 0xF0) >> 4];
  1053. buf[5] = hex[(ch & 0xF)];
  1054. scm_lfwrite_unlocked (buf, 6, port);
  1055. }
  1056. else if (ch > 0xFFFF)
  1057. {
  1058. buf[0] = '\\';
  1059. buf[1] = 'U';
  1060. buf[2] = hex[(ch & 0xF00000) >> 20];
  1061. buf[3] = hex[(ch & 0xF0000) >> 16];
  1062. buf[4] = hex[(ch & 0xF000) >> 12];
  1063. buf[5] = hex[(ch & 0xF00) >> 8];
  1064. buf[6] = hex[(ch & 0xF0) >> 4];
  1065. buf[7] = hex[(ch & 0xF)];
  1066. scm_lfwrite_unlocked (buf, 8, port);
  1067. }
  1068. }
  1069. else
  1070. {
  1071. /* Print an R6RS variable-length hex escape: "\xNNNN;". */
  1072. scm_t_wchar ch2 = ch;
  1073. int i = 8;
  1074. buf[i] = ';';
  1075. i --;
  1076. if (ch == 0)
  1077. buf[i--] = '0';
  1078. else
  1079. while (ch2 > 0)
  1080. {
  1081. buf[i] = hex[ch2 & 0xF];
  1082. ch2 >>= 4;
  1083. i --;
  1084. }
  1085. buf[i] = 'x';
  1086. i --;
  1087. buf[i] = '\\';
  1088. scm_lfwrite_unlocked (buf + i, 9 - i, port);
  1089. }
  1090. }
  1091. else
  1092. {
  1093. /* Represent CH using the character escape syntax. */
  1094. const char *name;
  1095. name = scm_i_charname (SCM_MAKE_CHAR (ch));
  1096. if (name != NULL)
  1097. scm_puts_unlocked (name, port);
  1098. else
  1099. PRINT_CHAR_ESCAPE (ch, port);
  1100. }
  1101. }
  1102. /* Write CH to PORT, escaping it if it's non-graphic or not
  1103. representable in PORT's encoding. If STRING_ESCAPES_P is true and CH
  1104. needs to be escaped, it is escaped using the in-string escape syntax;
  1105. otherwise the character escape syntax is used. */
  1106. static void
  1107. write_character (scm_t_wchar ch, SCM port, int string_escapes_p)
  1108. {
  1109. int printed = 0;
  1110. scm_t_string_failed_conversion_handler strategy;
  1111. strategy = PORT_CONVERSION_HANDLER (port);
  1112. if (string_escapes_p)
  1113. {
  1114. /* Check if CH deserves special treatment. */
  1115. if (ch == '"' || ch == '\\')
  1116. {
  1117. display_character ('\\', port, iconveh_question_mark);
  1118. display_character (ch, port, strategy);
  1119. printed = 1;
  1120. }
  1121. else if (ch == '\n' && SCM_PRINT_ESCAPE_NEWLINES_P)
  1122. {
  1123. display_character ('\\', port, iconveh_question_mark);
  1124. display_character ('n', port, strategy);
  1125. printed = 1;
  1126. }
  1127. else if (ch == ' ' || ch == '\n')
  1128. {
  1129. display_character (ch, port, strategy);
  1130. printed = 1;
  1131. }
  1132. }
  1133. else
  1134. {
  1135. display_string ("#\\", 1, 2, port, iconveh_question_mark);
  1136. if (uc_combining_class (ch) != UC_CCC_NR)
  1137. /* Character is a combining character, so attempt to
  1138. pretty-print it. */
  1139. printed = write_combining_character (ch, port);
  1140. }
  1141. if (!printed
  1142. && uc_is_general_category_withtable (ch,
  1143. UC_CATEGORY_MASK_L |
  1144. UC_CATEGORY_MASK_M |
  1145. UC_CATEGORY_MASK_N |
  1146. UC_CATEGORY_MASK_P |
  1147. UC_CATEGORY_MASK_S))
  1148. /* CH is graphic; attempt to display it. */
  1149. printed = display_character (ch, port, iconveh_error);
  1150. if (!printed)
  1151. /* CH isn't graphic or cannot be represented in PORT's encoding. */
  1152. write_character_escaped (ch, string_escapes_p, port);
  1153. }
  1154. /* Display STR to PORT from START inclusive to END exclusive. */
  1155. void
  1156. scm_i_display_substring (SCM str, size_t start, size_t end, SCM port)
  1157. {
  1158. int narrow_p;
  1159. const char *buf;
  1160. size_t len, printed;
  1161. buf = scm_i_string_data (str);
  1162. len = end - start;
  1163. narrow_p = scm_i_is_narrow_string (str);
  1164. buf += start * (narrow_p ? sizeof (char) : sizeof (scm_t_wchar));
  1165. printed = display_string (buf, narrow_p, end - start, port,
  1166. PORT_CONVERSION_HANDLER (port));
  1167. if (SCM_UNLIKELY (printed < len))
  1168. scm_encoding_error (__func__, errno,
  1169. "cannot convert to output locale",
  1170. port, scm_c_string_ref (str, printed + start));
  1171. }
  1172. /* Print an integer.
  1173. */
  1174. void
  1175. scm_intprint (scm_t_intmax n, int radix, SCM port)
  1176. {
  1177. char num_buf[SCM_INTBUFLEN];
  1178. scm_lfwrite_unlocked (num_buf, scm_iint2str (n, radix, num_buf), port);
  1179. }
  1180. void
  1181. scm_uintprint (scm_t_uintmax n, int radix, SCM port)
  1182. {
  1183. char num_buf[SCM_INTBUFLEN];
  1184. scm_lfwrite_unlocked (num_buf, scm_iuint2str (n, radix, num_buf), port);
  1185. }
  1186. /* Print an object of unrecognized type.
  1187. */
  1188. void
  1189. scm_ipruk (char *hdr, SCM ptr, SCM port)
  1190. {
  1191. scm_puts_unlocked ("#<unknown-", port);
  1192. scm_puts_unlocked (hdr, port);
  1193. if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */
  1194. {
  1195. scm_puts_unlocked (" (0x", port);
  1196. scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
  1197. scm_puts_unlocked (" . 0x", port);
  1198. scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port);
  1199. scm_puts_unlocked (") @", port);
  1200. }
  1201. scm_puts_unlocked (" 0x", port);
  1202. scm_uintprint (SCM_UNPACK (ptr), 16, port);
  1203. scm_putc_unlocked ('>', port);
  1204. }
  1205. /* Print a list.
  1206. */
  1207. void
  1208. scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate)
  1209. {
  1210. register SCM hare, tortoise;
  1211. long floor = pstate->top - 2;
  1212. scm_puts_unlocked (hdr, port);
  1213. /* CHECK_INTS; */
  1214. if (pstate->fancyp)
  1215. goto fancy_printing;
  1216. /* Run a hare and tortoise so that total time complexity will be
  1217. O(depth * N) instead of O(N^2). */
  1218. hare = SCM_CDR (exp);
  1219. tortoise = exp;
  1220. while (scm_is_pair (hare))
  1221. {
  1222. if (scm_is_eq (hare, tortoise))
  1223. goto fancy_printing;
  1224. hare = SCM_CDR (hare);
  1225. if (!scm_is_pair (hare))
  1226. break;
  1227. hare = SCM_CDR (hare);
  1228. tortoise = SCM_CDR (tortoise);
  1229. }
  1230. /* No cdr cycles intrinsic to this list */
  1231. scm_iprin1 (SCM_CAR (exp), port, pstate);
  1232. for (exp = SCM_CDR (exp); scm_is_pair (exp); exp = SCM_CDR (exp))
  1233. {
  1234. register long i;
  1235. for (i = floor; i >= 0; --i)
  1236. if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
  1237. goto circref;
  1238. PUSH_REF (pstate, exp);
  1239. scm_putc_unlocked (' ', port);
  1240. /* CHECK_INTS; */
  1241. scm_iprin1 (SCM_CAR (exp), port, pstate);
  1242. }
  1243. if (!SCM_NULL_OR_NIL_P (exp))
  1244. {
  1245. scm_puts_unlocked (" . ", port);
  1246. scm_iprin1 (exp, port, pstate);
  1247. }
  1248. end:
  1249. scm_putc_unlocked (tlr, port);
  1250. pstate->top = floor + 2;
  1251. return;
  1252. fancy_printing:
  1253. {
  1254. long n = pstate->length;
  1255. scm_iprin1 (SCM_CAR (exp), port, pstate);
  1256. exp = SCM_CDR (exp); --n;
  1257. for (; scm_is_pair (exp); exp = SCM_CDR (exp))
  1258. {
  1259. register unsigned long i;
  1260. for (i = 0; i < pstate->top; ++i)
  1261. if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
  1262. goto fancy_circref;
  1263. if (pstate->fancyp)
  1264. {
  1265. if (n == 0)
  1266. {
  1267. scm_puts_unlocked (" ...", port);
  1268. goto skip_tail;
  1269. }
  1270. else
  1271. --n;
  1272. }
  1273. PUSH_REF(pstate, exp);
  1274. ++pstate->list_offset;
  1275. scm_putc_unlocked (' ', port);
  1276. /* CHECK_INTS; */
  1277. scm_iprin1 (SCM_CAR (exp), port, pstate);
  1278. }
  1279. }
  1280. if (!SCM_NULL_OR_NIL_P (exp))
  1281. {
  1282. scm_puts_unlocked (" . ", port);
  1283. scm_iprin1 (exp, port, pstate);
  1284. }
  1285. skip_tail:
  1286. pstate->list_offset -= pstate->top - floor - 2;
  1287. goto end;
  1288. fancy_circref:
  1289. pstate->list_offset -= pstate->top - floor - 2;
  1290. circref:
  1291. scm_puts_unlocked (" . ", port);
  1292. print_circref (port, pstate, exp);
  1293. goto end;
  1294. }
  1295. int
  1296. scm_valid_oport_value_p (SCM val)
  1297. {
  1298. return (SCM_OPOUTPORTP (val)
  1299. || (SCM_PORT_WITH_PS_P (val)
  1300. && SCM_OPOUTPORTP (SCM_PORT_WITH_PS_PORT (val))));
  1301. }
  1302. /* SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); */
  1303. SCM
  1304. scm_write (SCM obj, SCM port)
  1305. {
  1306. if (SCM_UNBNDP (port))
  1307. port = scm_current_output_port ();
  1308. SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
  1309. scm_dynwind_begin (0);
  1310. scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port));
  1311. scm_prin1 (obj, port, 1);
  1312. scm_dynwind_end ();
  1313. return SCM_UNSPECIFIED;
  1314. }
  1315. /* SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); */
  1316. SCM
  1317. scm_display (SCM obj, SCM port)
  1318. {
  1319. if (SCM_UNBNDP (port))
  1320. port = scm_current_output_port ();
  1321. SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
  1322. scm_dynwind_begin (0);
  1323. scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port));
  1324. scm_prin1 (obj, port, 0);
  1325. scm_dynwind_end ();
  1326. return SCM_UNSPECIFIED;
  1327. }
  1328. SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
  1329. (SCM destination, SCM message, SCM args),
  1330. "Write @var{message} to @var{destination}, defaulting to\n"
  1331. "the current output port.\n"
  1332. "@var{message} can contain @code{~A} (was @code{%s}) and\n"
  1333. "@code{~S} (was @code{%S}) escapes. When printed,\n"
  1334. "the escapes are replaced with corresponding members of\n"
  1335. "@var{args}:\n"
  1336. "@code{~A} formats using @code{display} and @code{~S} formats\n"
  1337. "using @code{write}.\n"
  1338. "If @var{destination} is @code{#t}, then use the current output\n"
  1339. "port, if @var{destination} is @code{#f}, then return a string\n"
  1340. "containing the formatted text. Does not add a trailing newline.")
  1341. #define FUNC_NAME s_scm_simple_format
  1342. {
  1343. SCM port, answer = SCM_UNSPECIFIED;
  1344. int fReturnString = 0;
  1345. int writingp;
  1346. size_t start, p, end;
  1347. if (scm_is_eq (destination, SCM_BOOL_T))
  1348. {
  1349. destination = port = scm_current_output_port ();
  1350. }
  1351. else if (scm_is_false (destination))
  1352. {
  1353. fReturnString = 1;
  1354. port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
  1355. SCM_OPN | SCM_WRTNG,
  1356. FUNC_NAME);
  1357. destination = port;
  1358. }
  1359. else
  1360. {
  1361. SCM_VALIDATE_OPORT_VALUE (1, destination);
  1362. port = SCM_COERCE_OUTPORT (destination);
  1363. }
  1364. SCM_VALIDATE_STRING (2, message);
  1365. SCM_VALIDATE_REST_ARGUMENT (args);
  1366. p = 0;
  1367. start = 0;
  1368. end = scm_i_string_length (message);
  1369. for (p = start; p != end; ++p)
  1370. if (scm_i_string_ref (message, p) == '~')
  1371. {
  1372. if (++p == end)
  1373. break;
  1374. switch (scm_i_string_ref (message, p))
  1375. {
  1376. case 'A': case 'a':
  1377. writingp = 0;
  1378. break;
  1379. case 'S': case 's':
  1380. writingp = 1;
  1381. break;
  1382. case '~':
  1383. scm_lfwrite_substr (message, start, p, port);
  1384. start = p + 1;
  1385. continue;
  1386. case '%':
  1387. scm_lfwrite_substr (message, start, p - 1, port);
  1388. scm_newline (port);
  1389. start = p + 1;
  1390. continue;
  1391. default:
  1392. SCM_MISC_ERROR ("FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead",
  1393. scm_list_1 (SCM_MAKE_CHAR (scm_i_string_ref (message, p))));
  1394. }
  1395. if (!scm_is_pair (args))
  1396. SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A",
  1397. scm_list_1 (SCM_MAKE_CHAR (scm_i_string_ref (message, p))));
  1398. scm_lfwrite_substr (message, start, p - 1, port);
  1399. /* we pass destination here */
  1400. scm_prin1 (SCM_CAR (args), destination, writingp);
  1401. args = SCM_CDR (args);
  1402. start = p + 1;
  1403. }
  1404. scm_lfwrite_substr (message, start, p, port);
  1405. if (!scm_is_eq (args, SCM_EOL))
  1406. SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments",
  1407. scm_list_1 (scm_length (args)));
  1408. if (fReturnString)
  1409. answer = scm_strport_to_string (destination);
  1410. return scm_return_first (answer, message);
  1411. }
  1412. #undef FUNC_NAME
  1413. SCM_DEFINE (scm_newline, "newline", 0, 1, 0,
  1414. (SCM port),
  1415. "Send a newline to @var{port}.\n"
  1416. "If @var{port} is omitted, send to the current output port.")
  1417. #define FUNC_NAME s_scm_newline
  1418. {
  1419. if (SCM_UNBNDP (port))
  1420. port = scm_current_output_port ();
  1421. SCM_VALIDATE_OPORT_VALUE (1, port);
  1422. scm_putc_unlocked ('\n', SCM_COERCE_OUTPORT (port));
  1423. return SCM_UNSPECIFIED;
  1424. }
  1425. #undef FUNC_NAME
  1426. SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
  1427. (SCM chr, SCM port),
  1428. "Send character @var{chr} to @var{port}.")
  1429. #define FUNC_NAME s_scm_write_char
  1430. {
  1431. if (SCM_UNBNDP (port))
  1432. port = scm_current_output_port ();
  1433. SCM_VALIDATE_CHAR (1, chr);
  1434. SCM_VALIDATE_OPORT_VALUE (2, port);
  1435. port = SCM_COERCE_OUTPORT (port);
  1436. if (!display_character (SCM_CHAR (chr), port,
  1437. PORT_CONVERSION_HANDLER (port)))
  1438. scm_encoding_error (__func__, errno,
  1439. "cannot convert to output locale",
  1440. port, chr);
  1441. return SCM_UNSPECIFIED;
  1442. }
  1443. #undef FUNC_NAME
  1444. /* Call back to Scheme code to do the printing of special objects
  1445. * (like structs). SCM_PRINTER_APPLY applies PROC to EXP and a smob
  1446. * containing PORT and PSTATE. This object can be used as the port for
  1447. * display/write etc to continue the current print chain. The REVEALED
  1448. * field of PSTATE is set to true to indicate that the print state has
  1449. * escaped to Scheme and thus has to be freed by the GC.
  1450. */
  1451. scm_t_bits scm_tc16_port_with_ps;
  1452. /* Print exactly as the port itself would */
  1453. static int
  1454. port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate)
  1455. {
  1456. obj = SCM_PORT_WITH_PS_PORT (obj);
  1457. return SCM_PORT_DESCRIPTOR (obj)->print (obj, port, pstate);
  1458. }
  1459. SCM
  1460. scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate)
  1461. {
  1462. pstate->revealed = 1;
  1463. return scm_call_2 (proc, exp,
  1464. scm_i_port_with_print_state (port, pstate->handle));
  1465. }
  1466. SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 1, 1, 0,
  1467. (SCM port, SCM pstate),
  1468. "Create a new port which behaves like @var{port}, but with an\n"
  1469. "included print state @var{pstate}. @var{pstate} is optional.\n"
  1470. "If @var{pstate} isn't supplied and @var{port} already has\n"
  1471. "a print state, the old print state is reused.")
  1472. #define FUNC_NAME s_scm_port_with_print_state
  1473. {
  1474. SCM_VALIDATE_OPORT_VALUE (1, port);
  1475. if (!SCM_UNBNDP (pstate))
  1476. SCM_VALIDATE_PRINTSTATE (2, pstate);
  1477. return scm_i_port_with_print_state (port, pstate);
  1478. }
  1479. #undef FUNC_NAME
  1480. SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0,
  1481. (SCM port),
  1482. "Return the print state of the port @var{port}. If @var{port}\n"
  1483. "has no associated print state, @code{#f} is returned.")
  1484. #define FUNC_NAME s_scm_get_print_state
  1485. {
  1486. if (SCM_PORT_WITH_PS_P (port))
  1487. return SCM_PORT_WITH_PS_PS (port);
  1488. if (SCM_OUTPUT_PORT_P (port))
  1489. return SCM_BOOL_F;
  1490. SCM_WRONG_TYPE_ARG (1, port);
  1491. }
  1492. #undef FUNC_NAME
  1493. void
  1494. scm_init_print ()
  1495. {
  1496. SCM type;
  1497. type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT),
  1498. SCM_BOOL_F);
  1499. scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state"));
  1500. scm_print_state_vtable = type;
  1501. /* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */
  1502. scm_tc16_port_with_ps = scm_make_smob_type (0, 0);
  1503. scm_set_smob_print (scm_tc16_port_with_ps, port_with_ps_print);
  1504. #include "libguile/print.x"
  1505. scm_init_opts (scm_print_options, scm_print_opts);
  1506. scm_print_opts[SCM_PRINT_HIGHLIGHT_PREFIX_I].val =
  1507. SCM_UNPACK (scm_from_locale_string ("{"));
  1508. scm_print_opts[SCM_PRINT_HIGHLIGHT_SUFFIX_I].val =
  1509. SCM_UNPACK (scm_from_locale_string ("}"));
  1510. scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader);
  1511. }
  1512. /*
  1513. Local Variables:
  1514. c-file-style: "gnu"
  1515. End:
  1516. */