syntax.c 5.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211
  1. /* Copyright 2017-2018,2021
  2. Free Software Foundation, Inc.
  3. This file is part of Guile.
  4. Guile is free software: you can redistribute it and/or modify it
  5. under the terms of the GNU Lesser General Public License as published
  6. by the Free Software Foundation, either version 3 of the License, or
  7. (at your option) any later version.
  8. Guile is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  11. License for more details.
  12. You should have received a copy of the GNU Lesser General Public
  13. License along with Guile. If not, see
  14. <https://www.gnu.org/licenses/>. */
  15. #ifdef HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include "alist.h"
  19. #include "eval.h"
  20. #include "gsubr.h"
  21. #include "keywords.h"
  22. #include "modules.h"
  23. #include "pairs.h"
  24. #include "ports.h"
  25. #include "srcprop.h"
  26. #include "threads.h"
  27. #include "variable.h"
  28. #include "vectors.h"
  29. #include "syntax.h"
  30. /* The source field was added to syntax objects in Guile 3.0.6. However
  31. there can be older syntax objects present in compiled files that
  32. don't have the source field. If a syntax object has a source field,
  33. its tag will have HAS_SOURCE_WORD_FLAG set. */
  34. #define HAS_SOURCE_WORD_FLAG 0x100
  35. enum
  36. {
  37. TAG_WORD,
  38. EXPR_WORD,
  39. WRAP_WORD,
  40. MODULE_WORD,
  41. SOURCE_WORD,
  42. WORD_COUNT
  43. };
  44. static int
  45. scm_is_syntax (SCM x)
  46. {
  47. return SCM_HAS_TYP7 (x, scm_tc7_syntax);
  48. }
  49. #define SCM_VALIDATE_SYNTAX(pos, scm) \
  50. SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_syntax, "syntax object")
  51. SCM_DEFINE (scm_syntax_p, "syntax?", 1, 0, 0,
  52. (SCM obj),
  53. "Return @code{#t} if the argument @var{obj} is a syntax object,\n"
  54. "else @code{#f}.")
  55. #define FUNC_NAME s_scm_syntax_p
  56. {
  57. return scm_from_bool (scm_is_syntax (obj));
  58. }
  59. #undef FUNC_NAME
  60. static SCM
  61. sourcev_to_props (SCM v)
  62. {
  63. SCM props = scm_acons (scm_sym_line, scm_c_vector_ref (v, 1),
  64. scm_acons (scm_sym_column, scm_c_vector_ref (v, 2),
  65. SCM_EOL));
  66. if (scm_is_true (scm_c_vector_ref (v, 0)))
  67. props = scm_acons (scm_sym_filename, scm_c_vector_ref (v, 0), props);
  68. return props;
  69. }
  70. static SCM
  71. props_to_sourcev (SCM props)
  72. {
  73. SCM v = scm_c_make_vector (3, SCM_BOOL_F);
  74. scm_c_vector_set_x (v, 0, scm_assq_ref (props, scm_sym_filename));
  75. scm_c_vector_set_x (v, 1, scm_assq_ref (props, scm_sym_line));
  76. scm_c_vector_set_x (v, 2, scm_assq_ref (props, scm_sym_column));
  77. return v;
  78. }
  79. SCM_DEFINE (scm_make_syntax, "make-syntax", 3, 1, 0,
  80. (SCM exp, SCM wrap, SCM module, SCM source),
  81. "Make a new syntax object.")
  82. #define FUNC_NAME s_scm_make_syntax
  83. {
  84. if (SCM_UNBNDP (source))
  85. source = scm_source_properties (exp);
  86. if (scm_is_pair (source))
  87. source = props_to_sourcev (source);
  88. if (!scm_is_vector (source))
  89. source = SCM_BOOL_F;
  90. SCM ret = scm_words (scm_tc7_syntax | HAS_SOURCE_WORD_FLAG, WORD_COUNT);
  91. SCM_SET_CELL_OBJECT (ret, EXPR_WORD, exp);
  92. SCM_SET_CELL_OBJECT (ret, WRAP_WORD, wrap);
  93. SCM_SET_CELL_OBJECT (ret, MODULE_WORD, module);
  94. SCM_SET_CELL_OBJECT (ret, SOURCE_WORD, source);
  95. return ret;
  96. }
  97. #undef FUNC_NAME
  98. SCM_DEFINE (scm_syntax_expression, "syntax-expression", 1, 0, 0,
  99. (SCM obj),
  100. "Return the expression contained in the syntax object @var{obj}.")
  101. #define FUNC_NAME s_scm_syntax_expression
  102. {
  103. SCM_VALIDATE_SYNTAX (1, obj);
  104. return SCM_CELL_OBJECT (obj, EXPR_WORD);
  105. }
  106. #undef FUNC_NAME
  107. SCM_DEFINE (scm_syntax_wrap, "syntax-wrap", 1, 0, 0,
  108. (SCM obj),
  109. "Return the wrap contained in the syntax object @var{obj}.")
  110. #define FUNC_NAME s_scm_syntax_wrap
  111. {
  112. SCM_VALIDATE_SYNTAX (1, obj);
  113. return SCM_CELL_OBJECT (obj, WRAP_WORD);
  114. }
  115. #undef FUNC_NAME
  116. SCM_DEFINE (scm_syntax_module, "syntax-module", 1, 0, 0,
  117. (SCM obj),
  118. "Return the module info contained in the syntax object @var{obj}.")
  119. #define FUNC_NAME s_scm_syntax_module
  120. {
  121. SCM_VALIDATE_SYNTAX (1, obj);
  122. return SCM_CELL_OBJECT (obj, MODULE_WORD);
  123. }
  124. #undef FUNC_NAME
  125. SCM_DEFINE (scm_syntax_source, "syntax-source", 1, 0, 0,
  126. (SCM obj),
  127. "Return the source properties for syntax object @var{obj}, as\n"
  128. "an alist possibly containing the keys @code{filename},\n"
  129. "@code{line}, and @code{column}. Return @code{#f} if no\n"
  130. "source properties are available.")
  131. #define FUNC_NAME s_scm_syntax_source
  132. {
  133. SCM_VALIDATE_SYNTAX (1, obj);
  134. if (!(SCM_CELL_WORD (obj, TAG_WORD) & HAS_SOURCE_WORD_FLAG))
  135. return SCM_BOOL_F;
  136. SCM src = SCM_CELL_OBJECT (obj, SOURCE_WORD);
  137. if (scm_is_vector (src))
  138. src = sourcev_to_props (src);
  139. return src;
  140. }
  141. #undef FUNC_NAME
  142. SCM_DEFINE (scm_syntax_sourcev, "syntax-sourcev", 1, 0, 0,
  143. (SCM obj),
  144. "Return the source location information for syntax object\n"
  145. "@var{obj}, as a vector of @code{#(@var{filename} @var{line}\n"
  146. "@var{column})}, or @code{#f} if no source properties are\n"
  147. "available.")
  148. #define FUNC_NAME s_scm_syntax_sourcev
  149. {
  150. SCM_VALIDATE_SYNTAX (1, obj);
  151. if (!(SCM_CELL_WORD (obj, TAG_WORD) & HAS_SOURCE_WORD_FLAG))
  152. return SCM_BOOL_F;
  153. SCM src = SCM_CELL_OBJECT (obj, SOURCE_WORD);
  154. if (scm_is_null (src) || scm_is_pair (src))
  155. src = props_to_sourcev (src);
  156. return src;
  157. }
  158. #undef FUNC_NAME
  159. static SCM print_syntax_var;
  160. static void
  161. init_print_syntax_var (void)
  162. {
  163. print_syntax_var =
  164. scm_c_private_variable ("system syntax", "print-syntax");
  165. }
  166. void
  167. scm_i_syntax_print (SCM obj, SCM port, scm_print_state *pstate)
  168. {
  169. static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
  170. scm_i_pthread_once (&once, init_print_syntax_var);
  171. scm_call_2 (scm_variable_ref (print_syntax_var), obj, port);
  172. }
  173. void
  174. scm_init_syntax ()
  175. {
  176. #include "syntax.x"
  177. }