X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/639bf3e507959ca53fef713306eb33f1074f1588..62e15979b5d773dda79c4f44c07e919b5d0f6e18:/libguile/macros.c diff --git a/libguile/macros.c b/libguile/macros.c dissimilarity index 77% index a6a4c3eb6..fe33e7e48 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -1,351 +1,226 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - - - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include "libguile/_scm.h" -#include "libguile/alist.h" /* for SCM_EXTEND_ENV (well...) */ -#include "libguile/eval.h" -#include "libguile/ports.h" -#include "libguile/print.h" -#include "libguile/root.h" -#include "libguile/smob.h" -#include "libguile/deprecation.h" - -#include "libguile/validate.h" -#include "libguile/programs.h" -#include "libguile/macros.h" - -#include "libguile/private-options.h" - -scm_t_bits scm_tc16_macro; - - -static int -macro_print (SCM macro, SCM port, scm_print_state *pstate) -{ - SCM code = SCM_MACRO_CODE (macro); - if (!SCM_CLOSUREP (code) - || scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE)) - || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE, - macro, port, pstate))) - { - scm_puts ("#<", port); - - if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro)) - scm_puts ("extended-", port); - - if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code)) - scm_puts ("primitive-", port); - - if (SCM_MACRO_TYPE (macro) == 0) - scm_puts ("syntax", port); -#if SCM_ENABLE_DEPRECATED == 1 - if (SCM_MACRO_TYPE (macro) == 1) - scm_puts ("macro", port); -#endif - if (SCM_MACRO_TYPE (macro) == 2) - scm_puts ("macro!", port); - if (SCM_MACRO_TYPE (macro) == 3) - scm_puts ("builtin-macro!", port); - if (SCM_MACRO_TYPE (macro) == 4) - scm_puts ("syncase-macro", port); - - scm_putc (' ', port); - scm_iprin1 (scm_macro_name (macro), port, pstate); - - if (SCM_CLOSUREP (code) && SCM_PRINT_SOURCE_P) - { - SCM formals = SCM_CLOSURE_FORMALS (code); - SCM env = SCM_ENV (code); - SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env); - SCM src = scm_i_unmemocopy_body (SCM_CODE (code), xenv); - scm_putc (' ', port); - scm_iprin1 (src, port, pstate); - } - - if (SCM_MACRO_IS_EXTENDED (macro)) - { - scm_putc (' ', port); - scm_write (SCM_SMOB_OBJECT_2 (macro), port); - scm_putc (' ', port); - scm_write (SCM_SMOB_OBJECT_3 (macro), port); - } - - scm_putc ('>', port); - } - - return 1; -} - -static SCM -macro_mark (SCM macro) -{ - if (SCM_MACRO_IS_EXTENDED (macro)) - { scm_gc_mark (SCM_SMOB_OBJECT_2 (macro)); - scm_gc_mark (SCM_SMOB_OBJECT_3 (macro)); - } - return SCM_SMOB_OBJECT (macro); -} - -static SCM -makmac (SCM code, scm_t_bits flags) -{ - SCM z; - SCM_NEWSMOB (z, scm_tc16_macro, SCM_UNPACK (code)); - SCM_SET_SMOB_FLAGS (z, flags); - return z; -} - -/* Return a mmacro that is known to be one of guile's built in macros. */ -SCM -scm_i_makbimacro (SCM code) -#define FUNC_NAME "scm_i_makbimacro" -{ - SCM_VALIDATE_PROC (1, code); - return makmac (code, 3); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_makmmacro, "procedure->memoizing-macro", 1, 0, 0, - (SCM code), - "Return a @dfn{macro} which, when a symbol defined to this value\n" - "appears as the first symbol in an expression, evaluates the\n" - "result of applying @var{code} to the expression and the\n" - "environment.\n\n" - "@code{procedure->memoizing-macro} is the same as\n" - "@code{procedure->macro}, except that the expression returned by\n" - "@var{code} replaces the original macro expression in the memoized\n" - "form of the containing code.") -#define FUNC_NAME s_scm_makmmacro -{ - SCM_VALIDATE_PROC (1, code); - return makmac (code, 2); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0, - (SCM code), - "Return a @dfn{macro} which, when a symbol defined to this value\n" - "appears as the first symbol in an expression, returns the\n" - "result of applying @var{code} to the expression and the\n" - "environment.") -#define FUNC_NAME s_scm_makacro -{ - SCM_VALIDATE_PROC (1, code); - return makmac (code, 0); -} -#undef FUNC_NAME - - -#if SCM_ENABLE_DEPRECATED == 1 - -SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0, - (SCM code), - "Return a @dfn{macro} which, when a symbol defined to this value\n" - "appears as the first symbol in an expression, evaluates the\n" - "result of applying @var{code} to the expression and the\n" - "environment. For example:\n" - "\n" - "@lisp\n" - "(define trace\n" - " (procedure->macro\n" - " (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))\n\n" - "(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).\n" - "@end lisp") -#define FUNC_NAME s_scm_makmacro -{ - scm_c_issue_deprecation_warning - ("The function procedure->macro is deprecated, and so are" - " non-memoizing macros in general. Use memoizing macros" - " or r5rs macros instead."); - - SCM_VALIDATE_PROC (1, code); - return makmac (code, 1); -} -#undef FUNC_NAME - -#endif - -SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0, - (SCM type, SCM binding), - "Return a @dfn{macro} that requires expansion by syntax-case.\n" - "While users should not call this function, it is useful to know\n" - "that syntax-case macros are represented as Guile primitive macros.") -#define FUNC_NAME s_scm_make_syncase_macro -{ - SCM z; - SCM_VALIDATE_SYMBOL (1, type); - - SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type), - SCM_UNPACK (binding)); - SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED); - return z; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3, 0, 0, - (SCM m, SCM type, SCM binding), - "Extend a core macro @var{m} with a syntax-case binding.") -#define FUNC_NAME s_scm_make_extended_syncase_macro -{ - SCM z; - SCM_VALIDATE_SMOB (1, m, macro); - SCM_VALIDATE_SYMBOL (2, type); - - SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type), - SCM_UNPACK (binding)); - SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED); - return z; -} -#undef FUNC_NAME - - - -SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro, a\n" - "syntax transformer, or a syntax-case macro.") -#define FUNC_NAME s_scm_macro_p -{ - return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj)); -} -#undef FUNC_NAME - - -SCM_SYMBOL (scm_sym_syntax, "syntax"); -#if SCM_ENABLE_DEPRECATED == 1 -SCM_SYMBOL (scm_sym_macro, "macro"); -#endif -SCM_SYMBOL (scm_sym_mmacro, "macro!"); -SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!"); -SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro"); - -SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, - (SCM m), - "Return one of the symbols @code{syntax}, @code{macro},\n" - "@code{macro!}, or @code{syntax-case}, depending on whether\n" - "@var{m} is a syntax transformer, a regular macro, a memoizing\n" - "macro, or a syntax-case macro, respectively. If @var{m} is\n" - "not a macro, @code{#f} is returned.") -#define FUNC_NAME s_scm_macro_type -{ - if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m)) - return SCM_BOOL_F; - switch (SCM_MACRO_TYPE (m)) - { - case 0: return scm_sym_syntax; -#if SCM_ENABLE_DEPRECATED == 1 - case 1: return scm_sym_macro; -#endif - case 2: return scm_sym_mmacro; - case 3: return scm_sym_bimacro; - case 4: return scm_sym_syncase_macro; - default: scm_wrong_type_arg (FUNC_NAME, 1, m); - } -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0, - (SCM m), - "Return the name of the macro @var{m}.") -#define FUNC_NAME s_scm_macro_name -{ - SCM_VALIDATE_SMOB (1, m, macro); - if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m)))) - return scm_procedure_name (SCM_SMOB_OBJECT (m)); - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, - (SCM m), - "Return the transformer of the macro @var{m}.") -#define FUNC_NAME s_scm_macro_transformer -{ - SCM data; - - SCM_VALIDATE_SMOB (1, m, macro); - data = SCM_PACK (SCM_SMOB_DATA (m)); - - if (SCM_CLOSUREP (data) || SCM_PROGRAM_P (data)) - return data; - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0, - (SCM m), - "Return the type of the macro @var{m}.") -#define FUNC_NAME s_scm_syncase_macro_type -{ - SCM_VALIDATE_SMOB (1, m, macro); - - if (SCM_MACRO_IS_EXTENDED (m)) - return SCM_SMOB_OBJECT_2 (m); - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0, - (SCM m), - "Return the binding of the macro @var{m}.") -#define FUNC_NAME s_scm_syncase_macro_binding -{ - SCM_VALIDATE_SMOB (1, m, macro); - - if (SCM_MACRO_IS_EXTENDED (m)) - return SCM_SMOB_OBJECT_3 (m); - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM -scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) -{ - SCM var = scm_c_define (name, SCM_UNDEFINED); - SCM transformer = scm_c_make_subr (name, scm_tc7_subr_2, fcn); - SCM_VARIABLE_SET (var, macroizer (transformer)); - return SCM_UNSPECIFIED; -} - -void -scm_init_macros () -{ - scm_tc16_macro = scm_make_smob_type ("macro", 0); - scm_set_smob_mark (scm_tc16_macro, macro_mark); - scm_set_smob_print (scm_tc16_macro, macro_print); -#include "libguile/macros.x" -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include "libguile/_scm.h" +#include "libguile/ports.h" +#include "libguile/print.h" +#include "libguile/smob.h" +#include "libguile/validate.h" +#include "libguile/macros.h" + +#include "libguile/private-options.h" + + +static scm_t_bits scm_tc16_macro; + +#define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x)) +#define SCM_MACRO_PRIMITIVE(m) ((scm_t_macro_primitive)SCM_SMOB_DATA (m)) +#define SCM_MACRO_NAME(m) (SCM_SMOB_OBJECT_2 (m)) +#define SCM_MACRO_TYPE(m) (SCM_SMOB_OBJECT_3 (m)) +#define SCM_MACRO_BINDING(m) (SCM_CELL_OBJECT ((m), 4)) +#define SCM_VALIDATE_MACRO(p,v) SCM_MAKE_VALIDATE ((p), (v), MACROP) + + +SCM_API scm_t_bits scm_tc16_macro; + + +static int +macro_print (SCM macro, SCM port, scm_print_state *pstate) +{ + if (scm_is_false (SCM_MACRO_TYPE (macro))) + scm_puts ("#', port); + + return 1; +} + +/* Return a mmacro that is known to be one of guile's built in macros. */ +SCM +scm_i_make_primitive_macro (const char *name, scm_t_macro_primitive fn) +{ + SCM z = scm_words (scm_tc16_macro, 5); + SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)fn); + SCM_SET_SMOB_OBJECT_N (z, 2, scm_from_locale_symbol (name)); + SCM_SET_SMOB_OBJECT_N (z, 3, SCM_BOOL_F); + SCM_SET_SMOB_OBJECT_N (z, 4, SCM_BOOL_F); + return z; +} + +scm_t_macro_primitive +scm_i_macro_primitive (SCM macro) +{ + return SCM_MACRO_PRIMITIVE (macro); +} + + +SCM_DEFINE (scm_make_syntax_transformer, "make-syntax-transformer", 3, 0, 0, + (SCM name, SCM type, SCM binding), + "Construct a @dfn{syntax transformer}.\n\n" + "This function is part of Guile's low-level support for the psyntax\n" + "syntax expander. Users should not call this function.") +#define FUNC_NAME s_scm_make_syntax_transformer +{ + SCM z; + SCM (*prim)(SCM,SCM) = NULL; + + if (scm_is_true (name)) + { + SCM existing_var; + + SCM_VALIDATE_SYMBOL (1, name); + + existing_var = scm_module_variable (scm_current_module (), name); + if (scm_is_true (existing_var) + && scm_is_true (scm_variable_bound_p (existing_var)) + && SCM_MACROP (SCM_VARIABLE_REF (existing_var))) + prim = SCM_MACRO_PRIMITIVE (SCM_VARIABLE_REF (existing_var)); + } + + SCM_VALIDATE_SYMBOL (2, type); + + z = scm_words (scm_tc16_macro, 5); + SCM_SET_SMOB_DATA_N (z, 1, prim); + SCM_SET_SMOB_OBJECT_N (z, 2, name); + SCM_SET_SMOB_OBJECT_N (z, 3, type); + SCM_SET_SMOB_OBJECT_N (z, 4, binding); + return z; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a syntax transformer (an object that " + "transforms Scheme expressions at expansion-time).\n\n" + "Macros are actually just one kind of syntax transformer; this\n" + "procedure has its name due to historical reasons.") +#define FUNC_NAME s_scm_macro_p +{ + return scm_from_bool (SCM_MACROP (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, + (SCM m), + "Return the type of the syntax transformer @var{m}, as passed to\n" + "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n" + "transformer, @code{#f} will be returned.") +#define FUNC_NAME s_scm_macro_type +{ + SCM_VALIDATE_MACRO (1, m); + return SCM_MACRO_TYPE (m); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0, + (SCM m), + "Return the name of the syntax transformer @var{m}.") +#define FUNC_NAME s_scm_macro_name +{ + SCM_VALIDATE_MACRO (1, m); + return SCM_MACRO_NAME (m); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, + (SCM m), + "Return the transformer procedure of the macro @var{m}.\n\n" + "If @var{m} is a syntax transformer but not a macro, @code{#f}\n" + "will be returned. (This can happen, for example, with primitive\n" + "syntax transformers).") +#define FUNC_NAME s_scm_macro_transformer +{ + SCM_VALIDATE_MACRO (1, m); + /* here we rely on knowledge of how psyntax represents macro bindings, but + hey, there is code out there that calls this function, and expects to get + a procedure in return... */ + if (scm_is_true (scm_procedure_p (SCM_MACRO_BINDING (m)))) + return SCM_MACRO_BINDING (m); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0, + (SCM m), + "Return the binding of the syntax transformer @var{m}, as passed to\n" + "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n" + "transformer, @code{#f} will be returned.") +#define FUNC_NAME s_scm_macro_binding +{ + SCM_VALIDATE_MACRO (1, m); + return SCM_MACRO_BINDING (m); +} +#undef FUNC_NAME + + +static SCM syntax_session_id; + +#define SESSION_ID_LENGTH 22 /* bytes */ +#define BASE64_RADIX_BITS 6 +#define BASE64_RADIX (1 << (BASE64_RADIX_BITS)) +#define BASE64_MASK (BASE64_RADIX - 1) + +static SCM +fresh_syntax_session_id (void) +{ + static const char base64[BASE64_RADIX] = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@"; + + unsigned char digit_buf[SESSION_ID_LENGTH]; + char char_buf[SESSION_ID_LENGTH]; + size_t i; + + scm_i_random_bytes_from_platform (digit_buf, SESSION_ID_LENGTH); + for (i = 0; i < SESSION_ID_LENGTH; ++i) + char_buf[i] = base64[digit_buf[i] & BASE64_MASK]; + + return scm_from_latin1_stringn (char_buf, SESSION_ID_LENGTH); +} + +static SCM +scm_syntax_session_id (void) +{ + return syntax_session_id; +} + + +void +scm_init_macros () +{ + scm_tc16_macro = scm_make_smob_type ("macro", 0); + scm_set_smob_print (scm_tc16_macro, macro_print); +#include "libguile/macros.x" + + syntax_session_id = fresh_syntax_session_id(); + scm_c_define_gsubr ("syntax-session-id", 0, 0, 0, scm_syntax_session_id); +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/