macros.c 6.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229
  1. /* Copyright 1995-1998,2000-2003,2006,2008-2012,2018-2019
  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 "boolean.h"
  19. #include "gsubr.h"
  20. #include "modules.h"
  21. #include "ports.h"
  22. #include "print.h"
  23. #include "private-options.h"
  24. #include "procs.h"
  25. #include "random.h"
  26. #include "smob.h"
  27. #include "symbols.h"
  28. #include "variable.h"
  29. #include "macros.h"
  30. static scm_t_bits scm_tc16_macro;
  31. #define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
  32. #define SCM_MACRO_PRIMITIVE(m) ((scm_t_macro_primitive)SCM_SMOB_DATA (m))
  33. #define SCM_MACRO_NAME(m) (SCM_SMOB_OBJECT_2 (m))
  34. #define SCM_MACRO_TYPE(m) (SCM_SMOB_OBJECT_3 (m))
  35. #define SCM_MACRO_BINDING(m) (SCM_CELL_OBJECT ((m), 4))
  36. #define SCM_VALIDATE_MACRO(p,v) SCM_MAKE_VALIDATE ((p), (v), MACROP)
  37. SCM_API scm_t_bits scm_tc16_macro;
  38. static int
  39. macro_print (SCM macro, SCM port, scm_print_state *pstate)
  40. {
  41. if (scm_is_false (SCM_MACRO_TYPE (macro)))
  42. scm_puts ("#<primitive-syntax-transformer ", port);
  43. else
  44. scm_puts ("#<syntax-transformer ", port);
  45. scm_iprin1 (scm_macro_name (macro), port, pstate);
  46. scm_putc ('>', port);
  47. return 1;
  48. }
  49. SCM_SYMBOL (sym_primitive_macro, "primitive-macro");
  50. /* Return a mmacro that is known to be one of guile's built in macros. */
  51. SCM
  52. scm_i_make_primitive_macro (const char *name, scm_t_macro_primitive fn)
  53. {
  54. SCM z = scm_words (scm_tc16_macro, 5);
  55. SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)fn);
  56. SCM_SET_SMOB_OBJECT_N (z, 2, scm_from_utf8_symbol (name));
  57. SCM_SET_SMOB_OBJECT_N (z, 3, sym_primitive_macro);
  58. SCM_SET_SMOB_OBJECT_N (z, 4, SCM_BOOL_F);
  59. return z;
  60. }
  61. scm_t_macro_primitive
  62. scm_i_macro_primitive (SCM macro)
  63. {
  64. return SCM_MACRO_PRIMITIVE (macro);
  65. }
  66. SCM_DEFINE (scm_make_syntax_transformer, "make-syntax-transformer", 3, 0, 0,
  67. (SCM name, SCM type, SCM binding),
  68. "Construct a @dfn{syntax transformer}.\n\n"
  69. "This function is part of Guile's low-level support for the psyntax\n"
  70. "syntax expander. Users should not call this function.")
  71. #define FUNC_NAME s_scm_make_syntax_transformer
  72. {
  73. SCM z;
  74. SCM (*prim)(SCM,SCM) = NULL;
  75. if (scm_is_true (name))
  76. {
  77. SCM existing_var;
  78. SCM_VALIDATE_SYMBOL (1, name);
  79. existing_var = scm_module_variable (scm_current_module (), name);
  80. if (scm_is_true (existing_var)
  81. && scm_is_true (scm_variable_bound_p (existing_var))
  82. && SCM_MACROP (SCM_VARIABLE_REF (existing_var)))
  83. prim = SCM_MACRO_PRIMITIVE (SCM_VARIABLE_REF (existing_var));
  84. }
  85. SCM_VALIDATE_SYMBOL (2, type);
  86. z = scm_words (scm_tc16_macro, 5);
  87. SCM_SET_SMOB_DATA_N (z, 1, prim);
  88. SCM_SET_SMOB_OBJECT_N (z, 2, name);
  89. SCM_SET_SMOB_OBJECT_N (z, 3, type);
  90. SCM_SET_SMOB_OBJECT_N (z, 4, binding);
  91. return z;
  92. }
  93. #undef FUNC_NAME
  94. SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0,
  95. (SCM obj),
  96. "Return @code{#t} if @var{obj} is a syntax transformer (an object that "
  97. "transforms Scheme expressions at expansion-time).\n\n"
  98. "Macros are actually just one kind of syntax transformer; this\n"
  99. "procedure has its name due to historical reasons.")
  100. #define FUNC_NAME s_scm_macro_p
  101. {
  102. return scm_from_bool (SCM_MACROP (obj));
  103. }
  104. #undef FUNC_NAME
  105. SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
  106. (SCM m),
  107. "Return the type of the syntax transformer @var{m}, as passed to\n"
  108. "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n"
  109. "transformer, @code{#f} will be returned.")
  110. #define FUNC_NAME s_scm_macro_type
  111. {
  112. SCM_VALIDATE_MACRO (1, m);
  113. return SCM_MACRO_TYPE (m);
  114. }
  115. #undef FUNC_NAME
  116. SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0,
  117. (SCM m),
  118. "Return the name of the syntax transformer @var{m}.")
  119. #define FUNC_NAME s_scm_macro_name
  120. {
  121. SCM_VALIDATE_MACRO (1, m);
  122. return SCM_MACRO_NAME (m);
  123. }
  124. #undef FUNC_NAME
  125. SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0,
  126. (SCM m),
  127. "Return the transformer procedure of the macro @var{m}.\n\n"
  128. "If @var{m} is a syntax transformer but not a macro, @code{#f}\n"
  129. "will be returned. (This can happen, for example, with primitive\n"
  130. "syntax transformers).")
  131. #define FUNC_NAME s_scm_macro_transformer
  132. {
  133. SCM_VALIDATE_MACRO (1, m);
  134. /* here we rely on knowledge of how psyntax represents macro bindings, but
  135. hey, there is code out there that calls this function, and expects to get
  136. a procedure in return... */
  137. if (scm_is_true (scm_procedure_p (SCM_MACRO_BINDING (m))))
  138. return SCM_MACRO_BINDING (m);
  139. else
  140. return SCM_BOOL_F;
  141. }
  142. #undef FUNC_NAME
  143. SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0,
  144. (SCM m),
  145. "Return the binding of the syntax transformer @var{m}, as passed to\n"
  146. "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n"
  147. "transformer, @code{#f} will be returned.")
  148. #define FUNC_NAME s_scm_macro_binding
  149. {
  150. SCM_VALIDATE_MACRO (1, m);
  151. return SCM_MACRO_BINDING (m);
  152. }
  153. #undef FUNC_NAME
  154. static SCM syntax_session_id;
  155. #define SESSION_ID_LENGTH 22 /* bytes */
  156. #define BASE64_RADIX_BITS 6
  157. #define BASE64_RADIX (1 << (BASE64_RADIX_BITS))
  158. #define BASE64_MASK (BASE64_RADIX - 1)
  159. static SCM
  160. fresh_syntax_session_id (void)
  161. {
  162. static const char base64[BASE64_RADIX] =
  163. "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@";
  164. unsigned char digit_buf[SESSION_ID_LENGTH];
  165. char char_buf[SESSION_ID_LENGTH];
  166. size_t i;
  167. scm_i_random_bytes_from_platform (digit_buf, SESSION_ID_LENGTH);
  168. for (i = 0; i < SESSION_ID_LENGTH; ++i)
  169. char_buf[i] = base64[digit_buf[i] & BASE64_MASK];
  170. return scm_from_latin1_stringn (char_buf, SESSION_ID_LENGTH);
  171. }
  172. static SCM
  173. scm_syntax_session_id (void)
  174. {
  175. return syntax_session_id;
  176. }
  177. void
  178. scm_init_macros ()
  179. {
  180. scm_tc16_macro = scm_make_smob_type ("macro", 0);
  181. scm_set_smob_print (scm_tc16_macro, macro_print);
  182. #include "macros.x"
  183. syntax_session_id = fresh_syntax_session_id();
  184. scm_c_define_gsubr ("syntax-session-id", 0, 0, 0, scm_syntax_session_id);
  185. }