| 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008 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/alist.h" /* for SCM_EXTEND_ENV (well...) */ |
| 27 | #include "libguile/eval.h" |
| 28 | #include "libguile/ports.h" |
| 29 | #include "libguile/print.h" |
| 30 | #include "libguile/root.h" |
| 31 | #include "libguile/smob.h" |
| 32 | #include "libguile/deprecation.h" |
| 33 | |
| 34 | #include "libguile/validate.h" |
| 35 | #include "libguile/programs.h" |
| 36 | #include "libguile/macros.h" |
| 37 | |
| 38 | #include "libguile/private-options.h" |
| 39 | |
| 40 | scm_t_bits scm_tc16_macro; |
| 41 | |
| 42 | |
| 43 | static int |
| 44 | macro_print (SCM macro, SCM port, scm_print_state *pstate) |
| 45 | { |
| 46 | SCM code = SCM_MACRO_CODE (macro); |
| 47 | if (!SCM_CLOSUREP (code) |
| 48 | || scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE)) |
| 49 | || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE, |
| 50 | macro, port, pstate))) |
| 51 | { |
| 52 | scm_puts ("#<", port); |
| 53 | |
| 54 | if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro)) |
| 55 | scm_puts ("extended-", port); |
| 56 | |
| 57 | if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code)) |
| 58 | scm_puts ("primitive-", port); |
| 59 | |
| 60 | if (SCM_MACRO_TYPE (macro) == 0) |
| 61 | scm_puts ("syntax", port); |
| 62 | #if SCM_ENABLE_DEPRECATED == 1 |
| 63 | if (SCM_MACRO_TYPE (macro) == 1) |
| 64 | scm_puts ("macro", port); |
| 65 | #endif |
| 66 | if (SCM_MACRO_TYPE (macro) == 2) |
| 67 | scm_puts ("macro!", port); |
| 68 | if (SCM_MACRO_TYPE (macro) == 3) |
| 69 | scm_puts ("builtin-macro!", port); |
| 70 | if (SCM_MACRO_TYPE (macro) == 4) |
| 71 | scm_puts ("syncase-macro", port); |
| 72 | |
| 73 | scm_putc (' ', port); |
| 74 | scm_iprin1 (scm_macro_name (macro), port, pstate); |
| 75 | |
| 76 | if (SCM_CLOSUREP (code) && SCM_PRINT_SOURCE_P) |
| 77 | { |
| 78 | SCM formals = SCM_CLOSURE_FORMALS (code); |
| 79 | SCM env = SCM_ENV (code); |
| 80 | SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env); |
| 81 | SCM src = scm_i_unmemocopy_body (SCM_CODE (code), xenv); |
| 82 | scm_putc (' ', port); |
| 83 | scm_iprin1 (src, port, pstate); |
| 84 | } |
| 85 | |
| 86 | if (SCM_MACRO_IS_EXTENDED (macro)) |
| 87 | { |
| 88 | scm_putc (' ', port); |
| 89 | scm_write (SCM_SMOB_OBJECT_2 (macro), port); |
| 90 | scm_putc (' ', port); |
| 91 | scm_write (SCM_SMOB_OBJECT_3 (macro), port); |
| 92 | } |
| 93 | |
| 94 | scm_putc ('>', port); |
| 95 | } |
| 96 | |
| 97 | return 1; |
| 98 | } |
| 99 | |
| 100 | static SCM |
| 101 | macro_mark (SCM macro) |
| 102 | { |
| 103 | if (SCM_MACRO_IS_EXTENDED (macro)) |
| 104 | { scm_gc_mark (SCM_SMOB_OBJECT_2 (macro)); |
| 105 | scm_gc_mark (SCM_SMOB_OBJECT_3 (macro)); |
| 106 | } |
| 107 | return SCM_SMOB_OBJECT (macro); |
| 108 | } |
| 109 | |
| 110 | static SCM |
| 111 | makmac (SCM code, scm_t_bits flags) |
| 112 | { |
| 113 | SCM z; |
| 114 | SCM_NEWSMOB (z, scm_tc16_macro, SCM_UNPACK (code)); |
| 115 | SCM_SET_SMOB_FLAGS (z, flags); |
| 116 | return z; |
| 117 | } |
| 118 | |
| 119 | /* Return a mmacro that is known to be one of guile's built in macros. */ |
| 120 | SCM |
| 121 | scm_i_makbimacro (SCM code) |
| 122 | #define FUNC_NAME "scm_i_makbimacro" |
| 123 | { |
| 124 | SCM_VALIDATE_PROC (1, code); |
| 125 | return makmac (code, 3); |
| 126 | } |
| 127 | #undef FUNC_NAME |
| 128 | |
| 129 | |
| 130 | SCM_DEFINE (scm_makmmacro, "procedure->memoizing-macro", 1, 0, 0, |
| 131 | (SCM code), |
| 132 | "Return a @dfn{macro} which, when a symbol defined to this value\n" |
| 133 | "appears as the first symbol in an expression, evaluates the\n" |
| 134 | "result of applying @var{code} to the expression and the\n" |
| 135 | "environment.\n\n" |
| 136 | "@code{procedure->memoizing-macro} is the same as\n" |
| 137 | "@code{procedure->macro}, except that the expression returned by\n" |
| 138 | "@var{code} replaces the original macro expression in the memoized\n" |
| 139 | "form of the containing code.") |
| 140 | #define FUNC_NAME s_scm_makmmacro |
| 141 | { |
| 142 | SCM_VALIDATE_PROC (1, code); |
| 143 | return makmac (code, 2); |
| 144 | } |
| 145 | #undef FUNC_NAME |
| 146 | |
| 147 | |
| 148 | SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0, |
| 149 | (SCM code), |
| 150 | "Return a @dfn{macro} which, when a symbol defined to this value\n" |
| 151 | "appears as the first symbol in an expression, returns the\n" |
| 152 | "result of applying @var{code} to the expression and the\n" |
| 153 | "environment.") |
| 154 | #define FUNC_NAME s_scm_makacro |
| 155 | { |
| 156 | SCM_VALIDATE_PROC (1, code); |
| 157 | return makmac (code, 0); |
| 158 | } |
| 159 | #undef FUNC_NAME |
| 160 | |
| 161 | |
| 162 | #if SCM_ENABLE_DEPRECATED == 1 |
| 163 | |
| 164 | SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0, |
| 165 | (SCM code), |
| 166 | "Return a @dfn{macro} which, when a symbol defined to this value\n" |
| 167 | "appears as the first symbol in an expression, evaluates the\n" |
| 168 | "result of applying @var{code} to the expression and the\n" |
| 169 | "environment. For example:\n" |
| 170 | "\n" |
| 171 | "@lisp\n" |
| 172 | "(define trace\n" |
| 173 | " (procedure->macro\n" |
| 174 | " (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))\n\n" |
| 175 | "(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).\n" |
| 176 | "@end lisp") |
| 177 | #define FUNC_NAME s_scm_makmacro |
| 178 | { |
| 179 | scm_c_issue_deprecation_warning |
| 180 | ("The function procedure->macro is deprecated, and so are" |
| 181 | " non-memoizing macros in general. Use memoizing macros" |
| 182 | " or r5rs macros instead."); |
| 183 | |
| 184 | SCM_VALIDATE_PROC (1, code); |
| 185 | return makmac (code, 1); |
| 186 | } |
| 187 | #undef FUNC_NAME |
| 188 | |
| 189 | #endif |
| 190 | |
| 191 | SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0, |
| 192 | (SCM type, SCM binding), |
| 193 | "Return a @dfn{macro} that requires expansion by syntax-case.\n" |
| 194 | "While users should not call this function, it is useful to know\n" |
| 195 | "that syntax-case macros are represented as Guile primitive macros.") |
| 196 | #define FUNC_NAME s_scm_make_syncase_macro |
| 197 | { |
| 198 | SCM z; |
| 199 | SCM_VALIDATE_SYMBOL (1, type); |
| 200 | |
| 201 | SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type), |
| 202 | SCM_UNPACK (binding)); |
| 203 | SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED); |
| 204 | return z; |
| 205 | } |
| 206 | #undef FUNC_NAME |
| 207 | |
| 208 | SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3, 0, 0, |
| 209 | (SCM m, SCM type, SCM binding), |
| 210 | "Extend a core macro @var{m} with a syntax-case binding.") |
| 211 | #define FUNC_NAME s_scm_make_extended_syncase_macro |
| 212 | { |
| 213 | SCM z; |
| 214 | SCM_VALIDATE_SMOB (1, m, macro); |
| 215 | SCM_VALIDATE_SYMBOL (2, type); |
| 216 | |
| 217 | SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type), |
| 218 | SCM_UNPACK (binding)); |
| 219 | SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED); |
| 220 | return z; |
| 221 | } |
| 222 | #undef FUNC_NAME |
| 223 | |
| 224 | |
| 225 | |
| 226 | SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, |
| 227 | (SCM obj), |
| 228 | "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro, a\n" |
| 229 | "syntax transformer, or a syntax-case macro.") |
| 230 | #define FUNC_NAME s_scm_macro_p |
| 231 | { |
| 232 | return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj)); |
| 233 | } |
| 234 | #undef FUNC_NAME |
| 235 | |
| 236 | |
| 237 | SCM_SYMBOL (scm_sym_syntax, "syntax"); |
| 238 | #if SCM_ENABLE_DEPRECATED == 1 |
| 239 | SCM_SYMBOL (scm_sym_macro, "macro"); |
| 240 | #endif |
| 241 | SCM_SYMBOL (scm_sym_mmacro, "macro!"); |
| 242 | SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!"); |
| 243 | SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro"); |
| 244 | |
| 245 | SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, |
| 246 | (SCM m), |
| 247 | "Return one of the symbols @code{syntax}, @code{macro},\n" |
| 248 | "@code{macro!}, or @code{syntax-case}, depending on whether\n" |
| 249 | "@var{m} is a syntax transformer, a regular macro, a memoizing\n" |
| 250 | "macro, or a syntax-case macro, respectively. If @var{m} is\n" |
| 251 | "not a macro, @code{#f} is returned.") |
| 252 | #define FUNC_NAME s_scm_macro_type |
| 253 | { |
| 254 | if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m)) |
| 255 | return SCM_BOOL_F; |
| 256 | switch (SCM_MACRO_TYPE (m)) |
| 257 | { |
| 258 | case 0: return scm_sym_syntax; |
| 259 | #if SCM_ENABLE_DEPRECATED == 1 |
| 260 | case 1: return scm_sym_macro; |
| 261 | #endif |
| 262 | case 2: return scm_sym_mmacro; |
| 263 | case 3: return scm_sym_bimacro; |
| 264 | case 4: return scm_sym_syncase_macro; |
| 265 | default: scm_wrong_type_arg (FUNC_NAME, 1, m); |
| 266 | } |
| 267 | } |
| 268 | #undef FUNC_NAME |
| 269 | |
| 270 | |
| 271 | SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0, |
| 272 | (SCM m), |
| 273 | "Return the name of the macro @var{m}.") |
| 274 | #define FUNC_NAME s_scm_macro_name |
| 275 | { |
| 276 | SCM_VALIDATE_SMOB (1, m, macro); |
| 277 | if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m)))) |
| 278 | return scm_procedure_name (SCM_SMOB_OBJECT (m)); |
| 279 | return SCM_BOOL_F; |
| 280 | } |
| 281 | #undef FUNC_NAME |
| 282 | |
| 283 | |
| 284 | SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, |
| 285 | (SCM m), |
| 286 | "Return the transformer of the macro @var{m}.") |
| 287 | #define FUNC_NAME s_scm_macro_transformer |
| 288 | { |
| 289 | SCM data; |
| 290 | |
| 291 | SCM_VALIDATE_SMOB (1, m, macro); |
| 292 | data = SCM_PACK (SCM_SMOB_DATA (m)); |
| 293 | |
| 294 | if (SCM_CLOSUREP (data) || SCM_PROGRAM_P (data)) |
| 295 | return data; |
| 296 | else |
| 297 | return SCM_BOOL_F; |
| 298 | } |
| 299 | #undef FUNC_NAME |
| 300 | |
| 301 | SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0, |
| 302 | (SCM m), |
| 303 | "Return the type of the macro @var{m}.") |
| 304 | #define FUNC_NAME s_scm_syncase_macro_type |
| 305 | { |
| 306 | SCM_VALIDATE_SMOB (1, m, macro); |
| 307 | |
| 308 | if (SCM_MACRO_IS_EXTENDED (m)) |
| 309 | return SCM_SMOB_OBJECT_2 (m); |
| 310 | else |
| 311 | return SCM_BOOL_F; |
| 312 | } |
| 313 | #undef FUNC_NAME |
| 314 | |
| 315 | SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0, |
| 316 | (SCM m), |
| 317 | "Return the binding of the macro @var{m}.") |
| 318 | #define FUNC_NAME s_scm_syncase_macro_binding |
| 319 | { |
| 320 | SCM_VALIDATE_SMOB (1, m, macro); |
| 321 | |
| 322 | if (SCM_MACRO_IS_EXTENDED (m)) |
| 323 | return SCM_SMOB_OBJECT_3 (m); |
| 324 | else |
| 325 | return SCM_BOOL_F; |
| 326 | } |
| 327 | #undef FUNC_NAME |
| 328 | |
| 329 | SCM |
| 330 | scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) |
| 331 | { |
| 332 | SCM var = scm_c_define (name, SCM_UNDEFINED); |
| 333 | SCM transformer = scm_c_make_subr (name, scm_tc7_subr_2, fcn); |
| 334 | SCM_VARIABLE_SET (var, macroizer (transformer)); |
| 335 | return SCM_UNSPECIFIED; |
| 336 | } |
| 337 | |
| 338 | void |
| 339 | scm_init_macros () |
| 340 | { |
| 341 | scm_tc16_macro = scm_make_smob_type ("macro", 0); |
| 342 | scm_set_smob_mark (scm_tc16_macro, macro_mark); |
| 343 | scm_set_smob_print (scm_tc16_macro, macro_print); |
| 344 | #include "libguile/macros.x" |
| 345 | } |
| 346 | |
| 347 | /* |
| 348 | Local Variables: |
| 349 | c-file-style: "gnu" |
| 350 | End: |
| 351 | */ |