| 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 | #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 ("#<primitive-syntax-transformer ", port); |
| 53 | else |
| 54 | scm_puts ("#<syntax-transformer ", port); |
| 55 | scm_iprin1 (scm_macro_name (macro), port, pstate); |
| 56 | scm_putc ('>', 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_DATA_N (z, 2, scm_from_locale_symbol (name)); |
| 68 | SCM_SET_SMOB_DATA_N (z, 3, SCM_BOOL_F); |
| 69 | SCM_SET_SMOB_DATA_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 | existing_var = scm_sym2var (name, scm_current_module_lookup_closure (), |
| 96 | SCM_BOOL_F); |
| 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_DATA_N (z, 2, name); |
| 108 | SCM_SET_SMOB_DATA_N (z, 3, type); |
| 109 | SCM_SET_SMOB_DATA_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_pair (SCM_MACRO_BINDING (m)) |
| 161 | && scm_is_true (scm_procedure_p (scm_car (SCM_MACRO_BINDING (m))))) |
| 162 | return scm_car (SCM_MACRO_BINDING (m)); |
| 163 | else |
| 164 | return SCM_BOOL_F; |
| 165 | } |
| 166 | #undef FUNC_NAME |
| 167 | |
| 168 | SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0, |
| 169 | (SCM m), |
| 170 | "Return the binding of the syntax transformer @var{m}, as passed to\n" |
| 171 | "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n" |
| 172 | "transformer, @code{#f} will be returned.") |
| 173 | #define FUNC_NAME s_scm_macro_transformer |
| 174 | { |
| 175 | SCM_VALIDATE_MACRO (1, m); |
| 176 | return SCM_MACRO_BINDING (m); |
| 177 | } |
| 178 | #undef FUNC_NAME |
| 179 | |
| 180 | |
| 181 | void |
| 182 | scm_init_macros () |
| 183 | { |
| 184 | scm_tc16_macro = scm_make_smob_type ("macro", 0); |
| 185 | scm_set_smob_print (scm_tc16_macro, macro_print); |
| 186 | #include "libguile/macros.x" |
| 187 | } |
| 188 | |
| 189 | /* |
| 190 | Local Variables: |
| 191 | c-file-style: "gnu" |
| 192 | End: |
| 193 | */ |