| 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006 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 |
| 5 | * License as published by the Free Software Foundation; either |
| 6 | * version 2.1 of the License, or (at your option) any later version. |
| 7 | * |
| 8 | * This library is distributed in the hope that it will be useful, |
| 9 | * but 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 02110-1301 USA |
| 16 | */ |
| 17 | |
| 18 | |
| 19 | \f |
| 20 | |
| 21 | #include "libguile/_scm.h" |
| 22 | #include "libguile/alist.h" /* for SCM_EXTEND_ENV (well...) */ |
| 23 | #include "libguile/eval.h" |
| 24 | #include "libguile/ports.h" |
| 25 | #include "libguile/print.h" |
| 26 | #include "libguile/root.h" |
| 27 | #include "libguile/smob.h" |
| 28 | #include "libguile/deprecation.h" |
| 29 | |
| 30 | #include "libguile/validate.h" |
| 31 | #include "libguile/programs.h" |
| 32 | #include "libguile/macros.h" |
| 33 | |
| 34 | #include "libguile/private-options.h" |
| 35 | |
| 36 | scm_t_bits scm_tc16_macro; |
| 37 | |
| 38 | |
| 39 | static int |
| 40 | macro_print (SCM macro, SCM port, scm_print_state *pstate) |
| 41 | { |
| 42 | SCM code = SCM_MACRO_CODE (macro); |
| 43 | if (!SCM_CLOSUREP (code) |
| 44 | || scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE)) |
| 45 | || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE, |
| 46 | macro, port, pstate))) |
| 47 | { |
| 48 | if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code)) |
| 49 | scm_puts ("#<primitive-", port); |
| 50 | else |
| 51 | scm_puts ("#<", port); |
| 52 | |
| 53 | if (SCM_MACRO_TYPE (macro) == 0) |
| 54 | scm_puts ("syntax", port); |
| 55 | #if SCM_ENABLE_DEPRECATED == 1 |
| 56 | if (SCM_MACRO_TYPE (macro) == 1) |
| 57 | scm_puts ("macro", port); |
| 58 | #endif |
| 59 | if (SCM_MACRO_TYPE (macro) == 2) |
| 60 | scm_puts ("macro!", port); |
| 61 | if (SCM_MACRO_TYPE (macro) == 3) |
| 62 | scm_puts ("builtin-macro!", port); |
| 63 | |
| 64 | scm_putc (' ', port); |
| 65 | scm_iprin1 (scm_macro_name (macro), port, pstate); |
| 66 | |
| 67 | if (SCM_CLOSUREP (code) && SCM_PRINT_SOURCE_P) |
| 68 | { |
| 69 | SCM formals = SCM_CLOSURE_FORMALS (code); |
| 70 | SCM env = SCM_ENV (code); |
| 71 | SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env); |
| 72 | SCM src = scm_i_unmemocopy_body (SCM_CODE (code), xenv); |
| 73 | scm_putc (' ', port); |
| 74 | scm_iprin1 (src, port, pstate); |
| 75 | } |
| 76 | |
| 77 | scm_putc ('>', port); |
| 78 | } |
| 79 | |
| 80 | return 1; |
| 81 | } |
| 82 | |
| 83 | static SCM |
| 84 | makmac (SCM code, scm_t_bits flags) |
| 85 | { |
| 86 | SCM z; |
| 87 | SCM_NEWSMOB (z, scm_tc16_macro, SCM_UNPACK (code)); |
| 88 | SCM_SET_SMOB_FLAGS (z, flags); |
| 89 | return z; |
| 90 | } |
| 91 | |
| 92 | /* Return a mmacro that is known to be one of guile's built in macros. */ |
| 93 | SCM |
| 94 | scm_i_makbimacro (SCM code) |
| 95 | #define FUNC_NAME "scm_i_makbimacro" |
| 96 | { |
| 97 | SCM_VALIDATE_PROC (1, code); |
| 98 | return makmac (code, 3); |
| 99 | } |
| 100 | #undef FUNC_NAME |
| 101 | |
| 102 | |
| 103 | SCM_DEFINE (scm_makmmacro, "procedure->memoizing-macro", 1, 0, 0, |
| 104 | (SCM code), |
| 105 | "Return a @dfn{macro} which, when a symbol defined to this value\n" |
| 106 | "appears as the first symbol in an expression, evaluates the\n" |
| 107 | "result of applying @var{code} to the expression and the\n" |
| 108 | "environment.\n\n" |
| 109 | "@code{procedure->memoizing-macro} is the same as\n" |
| 110 | "@code{procedure->macro}, except that the expression returned by\n" |
| 111 | "@var{code} replaces the original macro expression in the memoized\n" |
| 112 | "form of the containing code.") |
| 113 | #define FUNC_NAME s_scm_makmmacro |
| 114 | { |
| 115 | SCM_VALIDATE_PROC (1, code); |
| 116 | return makmac (code, 2); |
| 117 | } |
| 118 | #undef FUNC_NAME |
| 119 | |
| 120 | |
| 121 | SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0, |
| 122 | (SCM code), |
| 123 | "Return a @dfn{macro} which, when a symbol defined to this value\n" |
| 124 | "appears as the first symbol in an expression, returns the\n" |
| 125 | "result of applying @var{code} to the expression and the\n" |
| 126 | "environment.") |
| 127 | #define FUNC_NAME s_scm_makacro |
| 128 | { |
| 129 | SCM_VALIDATE_PROC (1, code); |
| 130 | return makmac (code, 0); |
| 131 | } |
| 132 | #undef FUNC_NAME |
| 133 | |
| 134 | |
| 135 | #if SCM_ENABLE_DEPRECATED == 1 |
| 136 | |
| 137 | SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0, |
| 138 | (SCM code), |
| 139 | "Return a @dfn{macro} which, when a symbol defined to this value\n" |
| 140 | "appears as the first symbol in an expression, evaluates the\n" |
| 141 | "result of applying @var{code} to the expression and the\n" |
| 142 | "environment. For example:\n" |
| 143 | "\n" |
| 144 | "@lisp\n" |
| 145 | "(define trace\n" |
| 146 | " (procedure->macro\n" |
| 147 | " (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))\n\n" |
| 148 | "(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).\n" |
| 149 | "@end lisp") |
| 150 | #define FUNC_NAME s_scm_makmacro |
| 151 | { |
| 152 | scm_c_issue_deprecation_warning |
| 153 | ("The function procedure->macro is deprecated, and so are" |
| 154 | " non-memoizing macros in general. Use memoizing macros" |
| 155 | " or r5rs macros instead."); |
| 156 | |
| 157 | SCM_VALIDATE_PROC (1, code); |
| 158 | return makmac (code, 1); |
| 159 | } |
| 160 | #undef FUNC_NAME |
| 161 | |
| 162 | #endif |
| 163 | |
| 164 | |
| 165 | SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, |
| 166 | (SCM obj), |
| 167 | "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a\n" |
| 168 | "syntax transformer.") |
| 169 | #define FUNC_NAME s_scm_macro_p |
| 170 | { |
| 171 | return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj)); |
| 172 | } |
| 173 | #undef FUNC_NAME |
| 174 | |
| 175 | |
| 176 | SCM_SYMBOL (scm_sym_syntax, "syntax"); |
| 177 | #if SCM_ENABLE_DEPRECATED == 1 |
| 178 | SCM_SYMBOL (scm_sym_macro, "macro"); |
| 179 | #endif |
| 180 | SCM_SYMBOL (scm_sym_mmacro, "macro!"); |
| 181 | SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!"); |
| 182 | |
| 183 | SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, |
| 184 | (SCM m), |
| 185 | "Return one of the symbols @code{syntax}, @code{macro} or\n" |
| 186 | "@code{macro!}, depending on whether @var{m} is a syntax\n" |
| 187 | "transformer, a regular macro, or a memoizing macro,\n" |
| 188 | "respectively. If @var{m} is not a macro, @code{#f} is\n" |
| 189 | "returned.") |
| 190 | #define FUNC_NAME s_scm_macro_type |
| 191 | { |
| 192 | if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m)) |
| 193 | return SCM_BOOL_F; |
| 194 | switch (SCM_MACRO_TYPE (m)) |
| 195 | { |
| 196 | case 0: return scm_sym_syntax; |
| 197 | #if SCM_ENABLE_DEPRECATED == 1 |
| 198 | case 1: return scm_sym_macro; |
| 199 | #endif |
| 200 | case 2: return scm_sym_mmacro; |
| 201 | case 3: return scm_sym_bimacro; |
| 202 | default: scm_wrong_type_arg (FUNC_NAME, 1, m); |
| 203 | } |
| 204 | } |
| 205 | #undef FUNC_NAME |
| 206 | |
| 207 | |
| 208 | SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0, |
| 209 | (SCM m), |
| 210 | "Return the name of the macro @var{m}.") |
| 211 | #define FUNC_NAME s_scm_macro_name |
| 212 | { |
| 213 | SCM_VALIDATE_SMOB (1, m, macro); |
| 214 | return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m))); |
| 215 | } |
| 216 | #undef FUNC_NAME |
| 217 | |
| 218 | |
| 219 | SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, |
| 220 | (SCM m), |
| 221 | "Return the transformer of the macro @var{m}.") |
| 222 | #define FUNC_NAME s_scm_macro_transformer |
| 223 | { |
| 224 | SCM_VALIDATE_SMOB (1, m, macro); |
| 225 | return ((SCM_CLOSUREP (SCM_PACK (SCM_SMOB_DATA (m)))) ? |
| 226 | SCM_PACK(SCM_SMOB_DATA (m)) : SCM_BOOL_F); |
| 227 | } |
| 228 | #undef FUNC_NAME |
| 229 | |
| 230 | SCM |
| 231 | scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) |
| 232 | { |
| 233 | SCM var = scm_c_define (name, SCM_UNDEFINED); |
| 234 | SCM transformer = scm_c_make_subr (name, scm_tc7_subr_2, fcn); |
| 235 | SCM_VARIABLE_SET (var, macroizer (transformer)); |
| 236 | return SCM_UNSPECIFIED; |
| 237 | } |
| 238 | |
| 239 | void |
| 240 | scm_init_macros () |
| 241 | { |
| 242 | scm_tc16_macro = scm_make_smob_type ("macro", 0); |
| 243 | scm_set_smob_mark (scm_tc16_macro, scm_markcdr); |
| 244 | scm_set_smob_print (scm_tc16_macro, macro_print); |
| 245 | #include "libguile/macros.x" |
| 246 | } |
| 247 | |
| 248 | /* |
| 249 | Local Variables: |
| 250 | c-file-style: "gnu" |
| 251 | End: |
| 252 | */ |