print.c 42 KB

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