| 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008, 2009, 2010 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 | #define SCM_BUILDING_DEPRECATED_CODE |
| 26 | |
| 27 | #include "libguile/_scm.h" |
| 28 | #include "libguile/alist.h" /* for SCM_EXTEND_ENV (well...) */ |
| 29 | #include "libguile/eval.h" |
| 30 | #include "libguile/ports.h" |
| 31 | #include "libguile/print.h" |
| 32 | #include "libguile/root.h" |
| 33 | #include "libguile/smob.h" |
| 34 | #include "libguile/deprecation.h" |
| 35 | |
| 36 | #include "libguile/validate.h" |
| 37 | #include "libguile/programs.h" |
| 38 | #include "libguile/macros.h" |
| 39 | |
| 40 | #include "libguile/private-options.h" |
| 41 | |
| 42 | scm_t_bits scm_tc16_macro; |
| 43 | |
| 44 | |
| 45 | static int |
| 46 | macro_print (SCM macro, SCM port, scm_print_state *pstate) |
| 47 | { |
| 48 | SCM code = SCM_MACRO_CODE (macro); |
| 49 | |
| 50 | scm_puts ("#<", port); |
| 51 | |
| 52 | if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro)) |
| 53 | scm_puts ("extended-", port); |
| 54 | |
| 55 | /* FIXME: doesn't catch boot closures; but do we care? */ |
| 56 | if (!SCM_PROGRAM_P (code)) |
| 57 | scm_puts ("primitive-", port); |
| 58 | |
| 59 | if (SCM_MACRO_TYPE (macro) == 3) |
| 60 | scm_puts ("builtin-macro!", port); |
| 61 | if (SCM_MACRO_TYPE (macro) == 4) |
| 62 | scm_puts ("syncase-macro", port); |
| 63 | |
| 64 | scm_putc (' ', port); |
| 65 | scm_iprin1 (scm_macro_name (macro), port, pstate); |
| 66 | |
| 67 | if (SCM_MACRO_IS_EXTENDED (macro)) |
| 68 | { |
| 69 | scm_putc (' ', port); |
| 70 | scm_write (SCM_SMOB_OBJECT_2 (macro), port); |
| 71 | scm_putc (' ', port); |
| 72 | scm_write (SCM_SMOB_OBJECT_3 (macro), port); |
| 73 | } |
| 74 | |
| 75 | scm_putc ('>', port); |
| 76 | |
| 77 | return 1; |
| 78 | } |
| 79 | |
| 80 | static SCM |
| 81 | makmac (SCM code, scm_t_bits flags) |
| 82 | { |
| 83 | SCM z; |
| 84 | SCM_NEWSMOB (z, scm_tc16_macro, SCM_UNPACK (code)); |
| 85 | SCM_SET_SMOB_FLAGS (z, flags); |
| 86 | return z; |
| 87 | } |
| 88 | |
| 89 | /* Return a mmacro that is known to be one of guile's built in macros. */ |
| 90 | SCM |
| 91 | scm_i_makbimacro (const char *name, SCM (*fn)(SCM, SCM)) |
| 92 | { |
| 93 | return makmac (scm_c_make_gsubr (name, 2, 0, 0, fn), 3); |
| 94 | } |
| 95 | |
| 96 | |
| 97 | SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0, |
| 98 | (SCM type, SCM binding), |
| 99 | "Return a @dfn{macro} that requires expansion by syntax-case.\n" |
| 100 | "While users should not call this function, it is useful to know\n" |
| 101 | "that syntax-case macros are represented as Guile primitive macros.") |
| 102 | #define FUNC_NAME s_scm_make_syncase_macro |
| 103 | { |
| 104 | SCM z; |
| 105 | SCM_VALIDATE_SYMBOL (1, type); |
| 106 | |
| 107 | SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type), |
| 108 | SCM_UNPACK (binding)); |
| 109 | SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED); |
| 110 | return z; |
| 111 | } |
| 112 | #undef FUNC_NAME |
| 113 | |
| 114 | SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3, 0, 0, |
| 115 | (SCM m, SCM type, SCM binding), |
| 116 | "Extend a core macro @var{m} with a syntax-case binding.") |
| 117 | #define FUNC_NAME s_scm_make_extended_syncase_macro |
| 118 | { |
| 119 | SCM z; |
| 120 | SCM_VALIDATE_SMOB (1, m, macro); |
| 121 | SCM_VALIDATE_SYMBOL (2, type); |
| 122 | |
| 123 | SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type), |
| 124 | SCM_UNPACK (binding)); |
| 125 | SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED); |
| 126 | return z; |
| 127 | } |
| 128 | #undef FUNC_NAME |
| 129 | |
| 130 | |
| 131 | |
| 132 | SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, |
| 133 | (SCM obj), |
| 134 | "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro, a\n" |
| 135 | "syntax transformer, or a syntax-case macro.") |
| 136 | #define FUNC_NAME s_scm_macro_p |
| 137 | { |
| 138 | return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj)); |
| 139 | } |
| 140 | #undef FUNC_NAME |
| 141 | |
| 142 | |
| 143 | SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!"); |
| 144 | SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro"); |
| 145 | |
| 146 | SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, |
| 147 | (SCM m), |
| 148 | "Return one of the symbols @code{syntax}, @code{macro},\n" |
| 149 | "@code{macro!}, or @code{syntax-case}, depending on whether\n" |
| 150 | "@var{m} is a syntax transformer, a regular macro, a memoizing\n" |
| 151 | "macro, or a syntax-case macro, respectively. If @var{m} is\n" |
| 152 | "not a macro, @code{#f} is returned.") |
| 153 | #define FUNC_NAME s_scm_macro_type |
| 154 | { |
| 155 | if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m)) |
| 156 | return SCM_BOOL_F; |
| 157 | switch (SCM_MACRO_TYPE (m)) |
| 158 | { |
| 159 | case 3: return scm_sym_bimacro; |
| 160 | case 4: return scm_sym_syncase_macro; |
| 161 | default: scm_wrong_type_arg (FUNC_NAME, 1, m); |
| 162 | } |
| 163 | } |
| 164 | #undef FUNC_NAME |
| 165 | |
| 166 | |
| 167 | SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0, |
| 168 | (SCM m), |
| 169 | "Return the name of the macro @var{m}.") |
| 170 | #define FUNC_NAME s_scm_macro_name |
| 171 | { |
| 172 | SCM_VALIDATE_SMOB (1, m, macro); |
| 173 | if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m)))) |
| 174 | return scm_procedure_name (SCM_SMOB_OBJECT (m)); |
| 175 | return SCM_BOOL_F; |
| 176 | } |
| 177 | #undef FUNC_NAME |
| 178 | |
| 179 | |
| 180 | SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, |
| 181 | (SCM m), |
| 182 | "Return the transformer of the macro @var{m}.") |
| 183 | #define FUNC_NAME s_scm_macro_transformer |
| 184 | { |
| 185 | SCM data; |
| 186 | |
| 187 | SCM_VALIDATE_SMOB (1, m, macro); |
| 188 | data = SCM_PACK (SCM_SMOB_DATA (m)); |
| 189 | |
| 190 | if (scm_is_true (scm_procedure_p (data))) |
| 191 | return data; |
| 192 | else |
| 193 | return SCM_BOOL_F; |
| 194 | } |
| 195 | #undef FUNC_NAME |
| 196 | |
| 197 | SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0, |
| 198 | (SCM m), |
| 199 | "Return the type of the macro @var{m}.") |
| 200 | #define FUNC_NAME s_scm_syncase_macro_type |
| 201 | { |
| 202 | SCM_VALIDATE_SMOB (1, m, macro); |
| 203 | |
| 204 | if (SCM_MACRO_IS_EXTENDED (m)) |
| 205 | return SCM_SMOB_OBJECT_2 (m); |
| 206 | else |
| 207 | return SCM_BOOL_F; |
| 208 | } |
| 209 | #undef FUNC_NAME |
| 210 | |
| 211 | SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0, |
| 212 | (SCM m), |
| 213 | "Return the binding of the macro @var{m}.") |
| 214 | #define FUNC_NAME s_scm_syncase_macro_binding |
| 215 | { |
| 216 | SCM_VALIDATE_SMOB (1, m, macro); |
| 217 | |
| 218 | if (SCM_MACRO_IS_EXTENDED (m)) |
| 219 | return SCM_SMOB_OBJECT_3 (m); |
| 220 | else |
| 221 | return SCM_BOOL_F; |
| 222 | } |
| 223 | #undef FUNC_NAME |
| 224 | |
| 225 | void |
| 226 | scm_init_macros () |
| 227 | { |
| 228 | scm_tc16_macro = scm_make_smob_type ("macro", 0); |
| 229 | scm_set_smob_print (scm_tc16_macro, macro_print); |
| 230 | #include "libguile/macros.x" |
| 231 | } |
| 232 | |
| 233 | /* |
| 234 | Local Variables: |
| 235 | c-file-style: "gnu" |
| 236 | End: |
| 237 | */ |