| 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. |
| 2 | * |
| 3 | * This library is free software; you can redistribute it and/or |
| 4 | * modify it under the terms of the GNU Lesser General Public License |
| 5 | * as published by the Free Software Foundation; either version 3 of |
| 6 | * the License, or (at your option) any later version. |
| 7 | * |
| 8 | * This library is distributed in the hope that it will be useful, but |
| 9 | * WITHOUT ANY WARRANTY; without even the implied warranty of |
| 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 11 | * Lesser General Public License for more details. |
| 12 | * |
| 13 | * You should have received a copy of the GNU Lesser General Public |
| 14 | * License along with this library; if not, write to the Free Software |
| 15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
| 16 | * 02110-1301 USA |
| 17 | */ |
| 18 | |
| 19 | |
| 20 | \f |
| 21 | #ifdef HAVE_CONFIG_H |
| 22 | # include <config.h> |
| 23 | #endif |
| 24 | |
| 25 | #include "libguile/_scm.h" |
| 26 | #include "libguile/ports.h" |
| 27 | #include "libguile/print.h" |
| 28 | #include "libguile/smob.h" |
| 29 | #include "libguile/validate.h" |
| 30 | #include "libguile/macros.h" |
| 31 | |
| 32 | #include "libguile/private-options.h" |
| 33 | |
| 34 | |
| 35 | static scm_t_bits scm_tc16_macro; |
| 36 | |
| 37 | #define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x)) |
| 38 | #define SCM_MACRO_PRIMITIVE(m) ((scm_t_macro_primitive)SCM_SMOB_DATA (m)) |
| 39 | #define SCM_MACRO_NAME(m) (SCM_SMOB_OBJECT_2 (m)) |
| 40 | #define SCM_MACRO_TYPE(m) (SCM_SMOB_OBJECT_3 (m)) |
| 41 | #define SCM_MACRO_BINDING(m) (SCM_CELL_OBJECT ((m), 4)) |
| 42 | #define SCM_VALIDATE_MACRO(p,v) SCM_MAKE_VALIDATE ((p), (v), MACROP) |
| 43 | |
| 44 | |
| 45 | SCM_API scm_t_bits scm_tc16_macro; |
| 46 | |
| 47 | |
| 48 | static int |
| 49 | macro_print (SCM macro, SCM port, scm_print_state *pstate) |
| 50 | { |
| 51 | if (scm_is_false (SCM_MACRO_TYPE (macro))) |
| 52 | scm_puts_unlocked ("#<primitive-syntax-transformer ", port); |
| 53 | else |
| 54 | scm_puts_unlocked ("#<syntax-transformer ", port); |
| 55 | scm_iprin1 (scm_macro_name (macro), port, pstate); |
| 56 | scm_putc_unlocked ('>', port); |
| 57 | |
| 58 | return 1; |
| 59 | } |
| 60 | |
| 61 | /* Return a mmacro that is known to be one of guile's built in macros. */ |
| 62 | SCM |
| 63 | scm_i_make_primitive_macro (const char *name, scm_t_macro_primitive fn) |
| 64 | { |
| 65 | SCM z = scm_words (scm_tc16_macro, 5); |
| 66 | SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)fn); |
| 67 | SCM_SET_SMOB_OBJECT_N (z, 2, scm_from_utf8_symbol (name)); |
| 68 | SCM_SET_SMOB_OBJECT_N (z, 3, SCM_BOOL_F); |
| 69 | SCM_SET_SMOB_OBJECT_N (z, 4, SCM_BOOL_F); |
| 70 | return z; |
| 71 | } |
| 72 | |
| 73 | scm_t_macro_primitive |
| 74 | scm_i_macro_primitive (SCM macro) |
| 75 | { |
| 76 | return SCM_MACRO_PRIMITIVE (macro); |
| 77 | } |
| 78 | |
| 79 | |
| 80 | SCM_DEFINE (scm_make_syntax_transformer, "make-syntax-transformer", 3, 0, 0, |
| 81 | (SCM name, SCM type, SCM binding), |
| 82 | "Construct a @dfn{syntax transformer}.\n\n" |
| 83 | "This function is part of Guile's low-level support for the psyntax\n" |
| 84 | "syntax expander. Users should not call this function.") |
| 85 | #define FUNC_NAME s_scm_make_syntax_transformer |
| 86 | { |
| 87 | SCM z; |
| 88 | SCM (*prim)(SCM,SCM) = NULL; |
| 89 | |
| 90 | if (scm_is_true (name)) |
| 91 | { |
| 92 | SCM existing_var; |
| 93 | |
| 94 | SCM_VALIDATE_SYMBOL (1, name); |
| 95 | |
| 96 | existing_var = scm_module_variable (scm_current_module (), name); |
| 97 | if (scm_is_true (existing_var) |
| 98 | && scm_is_true (scm_variable_bound_p (existing_var)) |
| 99 | && SCM_MACROP (SCM_VARIABLE_REF (existing_var))) |
| 100 | prim = SCM_MACRO_PRIMITIVE (SCM_VARIABLE_REF (existing_var)); |
| 101 | } |
| 102 | |
| 103 | SCM_VALIDATE_SYMBOL (2, type); |
| 104 | |
| 105 | z = scm_words (scm_tc16_macro, 5); |
| 106 | SCM_SET_SMOB_DATA_N (z, 1, prim); |
| 107 | SCM_SET_SMOB_OBJECT_N (z, 2, name); |
| 108 | SCM_SET_SMOB_OBJECT_N (z, 3, type); |
| 109 | SCM_SET_SMOB_OBJECT_N (z, 4, binding); |
| 110 | return z; |
| 111 | } |
| 112 | #undef FUNC_NAME |
| 113 | |
| 114 | SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, |
| 115 | (SCM obj), |
| 116 | "Return @code{#t} if @var{obj} is a syntax transformer (an object that " |
| 117 | "transforms Scheme expressions at expansion-time).\n\n" |
| 118 | "Macros are actually just one kind of syntax transformer; this\n" |
| 119 | "procedure has its name due to historical reasons.") |
| 120 | #define FUNC_NAME s_scm_macro_p |
| 121 | { |
| 122 | return scm_from_bool (SCM_MACROP (obj)); |
| 123 | } |
| 124 | #undef FUNC_NAME |
| 125 | |
| 126 | SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, |
| 127 | (SCM m), |
| 128 | "Return the type of the syntax transformer @var{m}, as passed to\n" |
| 129 | "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n" |
| 130 | "transformer, @code{#f} will be returned.") |
| 131 | #define FUNC_NAME s_scm_macro_type |
| 132 | { |
| 133 | SCM_VALIDATE_MACRO (1, m); |
| 134 | return SCM_MACRO_TYPE (m); |
| 135 | } |
| 136 | #undef FUNC_NAME |
| 137 | |
| 138 | SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0, |
| 139 | (SCM m), |
| 140 | "Return the name of the syntax transformer @var{m}.") |
| 141 | #define FUNC_NAME s_scm_macro_name |
| 142 | { |
| 143 | SCM_VALIDATE_MACRO (1, m); |
| 144 | return SCM_MACRO_NAME (m); |
| 145 | } |
| 146 | #undef FUNC_NAME |
| 147 | |
| 148 | SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, |
| 149 | (SCM m), |
| 150 | "Return the transformer procedure of the macro @var{m}.\n\n" |
| 151 | "If @var{m} is a syntax transformer but not a macro, @code{#f}\n" |
| 152 | "will be returned. (This can happen, for example, with primitive\n" |
| 153 | "syntax transformers).") |
| 154 | #define FUNC_NAME s_scm_macro_transformer |
| 155 | { |
| 156 | SCM_VALIDATE_MACRO (1, m); |
| 157 | /* here we rely on knowledge of how psyntax represents macro bindings, but |
| 158 | hey, there is code out there that calls this function, and expects to get |
| 159 | a procedure in return... */ |
| 160 | if (scm_is_true (scm_procedure_p (SCM_MACRO_BINDING (m)))) |
| 161 | return SCM_MACRO_BINDING (m); |
| 162 | else |
| 163 | return SCM_BOOL_F; |
| 164 | } |
| 165 | #undef FUNC_NAME |
| 166 | |
| 167 | SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0, |
| 168 | (SCM m), |
| 169 | "Return the binding of the syntax transformer @var{m}, as passed to\n" |
| 170 | "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n" |
| 171 | "transformer, @code{#f} will be returned.") |
| 172 | #define FUNC_NAME s_scm_macro_binding |
| 173 | { |
| 174 | SCM_VALIDATE_MACRO (1, m); |
| 175 | return SCM_MACRO_BINDING (m); |
| 176 | } |
| 177 | #undef FUNC_NAME |
| 178 | |
| 179 | |
| 180 | static SCM syntax_session_id; |
| 181 | |
| 182 | #define SESSION_ID_LENGTH 22 /* bytes */ |
| 183 | #define BASE64_RADIX_BITS 6 |
| 184 | #define BASE64_RADIX (1 << (BASE64_RADIX_BITS)) |
| 185 | #define BASE64_MASK (BASE64_RADIX - 1) |
| 186 | |
| 187 | static SCM |
| 188 | fresh_syntax_session_id (void) |
| 189 | { |
| 190 | static const char base64[BASE64_RADIX] = |
| 191 | "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@"; |
| 192 | |
| 193 | unsigned char digit_buf[SESSION_ID_LENGTH]; |
| 194 | char char_buf[SESSION_ID_LENGTH]; |
| 195 | size_t i; |
| 196 | |
| 197 | scm_i_random_bytes_from_platform (digit_buf, SESSION_ID_LENGTH); |
| 198 | for (i = 0; i < SESSION_ID_LENGTH; ++i) |
| 199 | char_buf[i] = base64[digit_buf[i] & BASE64_MASK]; |
| 200 | |
| 201 | return scm_from_latin1_stringn (char_buf, SESSION_ID_LENGTH); |
| 202 | } |
| 203 | |
| 204 | static SCM |
| 205 | scm_syntax_session_id (void) |
| 206 | { |
| 207 | return syntax_session_id; |
| 208 | } |
| 209 | |
| 210 | |
| 211 | void |
| 212 | scm_init_macros () |
| 213 | { |
| 214 | scm_tc16_macro = scm_make_smob_type ("macro", 0); |
| 215 | scm_set_smob_print (scm_tc16_macro, macro_print); |
| 216 | #include "libguile/macros.x" |
| 217 | |
| 218 | syntax_session_id = fresh_syntax_session_id(); |
| 219 | scm_c_define_gsubr ("syntax-session-id", 0, 0, 0, scm_syntax_session_id); |
| 220 | } |
| 221 | |
| 222 | /* |
| 223 | Local Variables: |
| 224 | c-file-style: "gnu" |
| 225 | End: |
| 226 | */ |