dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

clean up macros.[ch]

Browse source 
There are some incompatible changes here, but only to interfaces that
were introduced earlier in 1.9, or interfaces which have been broken
since early in 1.9.

* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump, as the macro
  changes affect the interface that is called by psyntax-generated macro
  definitions.

* libguile/inline.h (scm_words): New function, allocates a variable
  number of contiguous scm_t_bits locations, with a given value in the
  0th word, and 0 in the rest of the words.

* libguile/macros.h: Rework interface to correspond more closely, and
  minimally, to the needs of memoize.c and psyntax.
  (SCM_ASSYNT, SCM_MACRO_TYPE_BITS, SCM_MACRO_TYPE_MASK)
  (SCM_F_MACRO_EXTENDED, SCM_MACROP, SCM_MACRO_TYPE)
  (SCM_MACRO_IS_EXTENDED, SCM_BUILTIN_MACRO_P, SCM_SYNCASE_MACRO_P)
  (SCM_MACRO_CODE, scm_tc16_macro): Remove CPP macros related to the
  representation of Scheme macros.
  (scm_i_make_primitive_macro): Renamed from scm_i_makbimacro.
  (scm_i_macro_primitive): New accessor so that memoize.c can get to the
  primitive syntax transformer.
  (scm_make_syncase_macro, scm_make_extended_syncase_macro)
  (scm_syncase_macro_type, scm_syncase_macro_binding): Removed these
  functions, replaced by make-syntax-transformer and its accessors.
  (scm_macro_binding): New accessor, the same as what
  scm_syncase_macro_binding was.

* libguile/macros.c: All representation details of syntax transformers
  are private to this file now.
  (macro_print): Print macros as #<syntax-transformer ...>, or
  #<primitive-syntax-transformer ...> if psyntax has not attached a
  transformer of its own.
  (scm_i_make_primitive_macro): Represent macros as 5-word smobs.
  (scm_make_syntax_transformer): New constructor for syntax transformers
  (macros), exported to scheme. Takes a name, and looks it up in the
  current module to determine the previous primitive transformer, if
  any.
  (scm_macro_type): Instead of returning 'builtin-macro!, etc, return
  the type as set by psyntax, or #f if it's a primitive.
  (scm_macro_name): Return the stored macro name.
  (scm_macro_transformer): Return the psyntax-set syntax transformer.
  Hacky, but should help introspection somewhat.

* libguile/memoize.c (memoize_env_ref_transformer): Use the new
  scm_i_macro_primitive, and adapt to other macro API changes.

* module/ice-9/psyntax.scm (put-global-definition-hook)
  (get-global-definition-hook, chi-install-global): Call (and generate
  calls to) the new macro constructors and accessors.

* module/ice-9/psyntax-pp.scm: Doubly regenerated.

* module/ice-9/debugging/traps.scm (trap-here): Comment out this
  definition and export, while it's not working.
This commit is contained in:
Andy Wingo 2010-01-05 15:20:47 +01:00
commit e809758a7e
8 changed files with 7984 additions and 7982 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/_scm.h
View file

@ -3,7 +3,7 @@
#ifndef SCM__SCM_H
#define SCM__SCM_H
/* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008, 2009, 2010 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
@ -176,7 +176,7 @@
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0
#define SCM_OBJCODE_MINOR_VERSION M
#define SCM_OBJCODE_MINOR_VERSION N
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \

41
libguile/inline.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_INLINE_H
#define SCM_INLINE_H
/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010 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
@ -87,6 +87,9 @@ SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
scm_t_bits ccr, scm_t_bits cdr);
SCM_API SCM scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
scm_t_bits ccr, scm_t_bits cdr);
SCM_API SCM scm_words (scm_t_bits car, scm_t_uint16 n_words);
/* no immutable words for now, would require initialization at the same time as
allocation */
SCM_API SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
SCM_API void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val);
@ -237,6 +240,42 @@ scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
return z;
}
#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
SCM
scm_words (scm_t_bits car, scm_t_uint16 n_words)
{
SCM z;
z = SCM_PACK ((scm_t_bits) (GC_MALLOC (sizeof (scm_t_bits) * n_words)));
SCM_GC_SET_CELL_WORD (z, 0, car);
/* FIXME: is the following concern even relevant with BDW-GC? */
/* When this function is inlined, it's possible that the last
SCM_GC_SET_CELL_WORD above will be adjacent to a following
initialization of z. E.g., it occurred in scm_make_real. GCC
from around version 3 (e.g., certainly 3.2) began taking
advantage of strict C aliasing rules which say that it's OK to
interchange the initialization above and the one below when the
pointer types appear to differ sufficiently. We don't want that,
of course. GCC allows this behaviour to be disabled with the
-fno-strict-aliasing option, but would also need to be supplied
by Guile users. Instead, the following statements prevent the
reordering.
*/
#ifdef __GNUC__
__asm__ volatile ("" : : : "memory");
#else
/* portable version, just in case any other compiler does the same
thing. */
scm_remember_upto_here_1 (z);
#endif
return z;
}
#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif

216
libguile/macros.c
View file

@ -22,205 +22,161 @@
# include <config.h>
#endif
#define SCM_BUILDING_DEPRECATED_CODE
#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 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)
{
SCM code = SCM_MACRO_CODE (macro);
scm_puts ("#<", port);
if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
scm_puts ("extended-", port);
/* FIXME: doesn't catch boot closures; but do we care? */
if (!SCM_PROGRAM_P (code))
scm_puts ("primitive-", 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);
if (scm_is_false (SCM_MACRO_TYPE (macro)))
scm_puts ("#<primitive-syntax-transformer ", port);
else
scm_puts ("#<syntax-transformer ", port);
scm_iprin1 (scm_macro_name (macro), 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
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 (const char *name, SCM (*fn)(SCM, SCM))
scm_i_make_primitive_macro (const char *name, scm_t_macro_primitive fn)
{
return makmac (scm_c_make_gsubr (name, 2, 0, 0, fn), 3);
}
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);
SCM z = scm_words (scm_tc16_macro, 5);
SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)fn);
SCM_SET_SMOB_DATA_N (z, 2, scm_from_locale_symbol (name));
SCM_SET_SMOB_DATA_N (z, 3, SCM_BOOL_F);
SCM_SET_SMOB_DATA_N (z, 4, SCM_BOOL_F);
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_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_VALIDATE_SMOB (1, m, macro);
SCM (*prim)(SCM,SCM) = NULL;
if (scm_is_true (name))
{
SCM existing_var;
SCM_VALIDATE_SYMBOL (1, name);
existing_var = scm_sym2var (name, scm_current_module_lookup_closure (),
SCM_BOOL_F);
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);
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);
z = scm_words (scm_tc16_macro, 5);
SCM_SET_SMOB_DATA_N (z, 1, prim);
SCM_SET_SMOB_DATA_N (z, 2, name);
SCM_SET_SMOB_DATA_N (z, 3, type);
SCM_SET_SMOB_DATA_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 regular macro, a memoizing macro, a\n"
"syntax transformer, or a syntax-case macro.")
"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_SMOB_PREDICATE (scm_tc16_macro, obj));
return scm_from_bool (SCM_MACROP (obj));
}
#undef FUNC_NAME
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.")
"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
{
if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m))
return SCM_BOOL_F;
switch (SCM_MACRO_TYPE (m))
{
case 3: return scm_sym_bimacro;
case 4: return scm_sym_syncase_macro;
default: scm_wrong_type_arg (FUNC_NAME, 1, m);
}
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 macro @var{m}.")
"Return the name of the syntax transformer @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;
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 of the macro @var{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 data;
SCM_VALIDATE_SMOB (1, m, macro);
data = SCM_PACK (SCM_SMOB_DATA (m));
if (scm_is_true (scm_procedure_p (data)))
return data;
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_pair (SCM_MACRO_BINDING (m))
&& scm_is_true (scm_procedure_p (scm_car (SCM_MACRO_BINDING (m)))))
return scm_car (SCM_MACRO_BINDING (m));
else
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0,
SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0,
(SCM m),
"Return the type of the macro @var{m}.")
#define FUNC_NAME s_scm_syncase_macro_type
"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_transformer
{
SCM_VALIDATE_SMOB (1, m, macro);
if (SCM_MACRO_IS_EXTENDED (m))
return SCM_SMOB_OBJECT_2 (m);
else
return SCM_BOOL_F;
SCM_VALIDATE_MACRO (1, m);
return SCM_MACRO_BINDING (m);
}
#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
void
scm_init_macros ()

30
libguile/macros.h
View file

@ -27,32 +27,20 @@
#define SCM_ASSYNT(_cond, _msg, _subr) \
if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL);
typedef SCM (*scm_t_macro_primitive) (SCM, SCM);
#define SCM_MACRO_TYPE_BITS (3)
#define SCM_MACRO_TYPE_MASK ((1<<SCM_MACRO_TYPE_BITS)-1)
#define SCM_F_MACRO_EXTENDED (1<<SCM_MACRO_TYPE_BITS)
#define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
#define SCM_MACRO_TYPE(m) (SCM_SMOB_FLAGS (m) & SCM_MACRO_TYPE_MASK)
#define SCM_MACRO_IS_EXTENDED(m) (SCM_SMOB_FLAGS (m) & SCM_F_MACRO_EXTENDED)
#define SCM_BUILTIN_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 3)
#define SCM_SYNCASE_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 4)
#define SCM_MACRO_CODE(m) SCM_SMOB_OBJECT (m)
SCM_API scm_t_bits scm_tc16_macro;
SCM_INTERNAL SCM scm_i_makbimacro (const char *name, SCM (*fn)(SCM,SCM));
SCM_API SCM scm_make_syncase_macro (SCM type, SCM binding);
SCM_API SCM scm_make_extended_syncase_macro (SCM builtin, SCM type,
SCM binding);
SCM_API SCM scm_make_syntax_transformer (SCM name_or_existing_definition,
SCM type, SCM binding);
SCM_API SCM scm_macro_p (SCM obj);
SCM_API SCM scm_macro_type (SCM m);
SCM_API SCM scm_macro_name (SCM m);
SCM_API SCM scm_macro_binding (SCM m);
SCM_API SCM scm_macro_transformer (SCM m);
SCM_API SCM scm_syncase_macro_type (SCM m);
SCM_API SCM scm_syncase_macro_binding (SCM m);
SCM_INTERNAL SCM scm_i_make_primitive_macro (const char *name,
scm_t_macro_primitive fn);
SCM_INTERNAL scm_t_macro_primitive scm_i_macro_primitive (SCM m);
SCM_INTERNAL void scm_init_macros (void);

22
libguile/memoize.c
View file

@ -275,9 +275,7 @@ static SCM scm_m_set_x (SCM xorig, SCM env);
typedef SCM (*t_syntax_transformer) (SCM, SCM);
static t_syntax_transformer
static scm_t_macro_primitive
memoize_env_ref_transformer (SCM env, SCM x)
{
SCM var;
@ -287,15 +285,8 @@ memoize_env_ref_transformer (SCM env, SCM x)
var = scm_module_variable (env, x);
if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
&& SCM_MACROP (scm_variable_ref (var)))
{
SCM mac = scm_variable_ref (var);
if (SCM_IMP (SCM_MACRO_CODE (mac))
|| (SCM_TYP7 (SCM_MACRO_CODE (mac)) != scm_tc7_gsubr))
syntax_error ("bad macro", x, SCM_UNDEFINED);
else
return (t_syntax_transformer)SCM_SUBRF (SCM_MACRO_CODE (mac)); /* global macro */
}
&& scm_is_true (scm_macro_p (scm_variable_ref (var))))
return scm_i_macro_primitive (scm_variable_ref (var));
else
return NULL; /* anything else */
}
@ -331,7 +322,7 @@ memoize (SCM exp, SCM env)
if (scm_is_pair (exp))
{
SCM CAR;
t_syntax_transformer trans;
scm_t_macro_primitive trans;
CAR = CAR (exp);
if (scm_is_symbol (CAR))
@ -392,11 +383,8 @@ memoize_sequence (const SCM forms, const SCM env)
#define SCM_SYNTAX(RANAME, STR, CFN) \
SCM_SNARF_HERE(static const char RANAME[]=STR)\
SCM_SNARF_INIT(scm_c_define (RANAME, scm_i_makbimacro (RANAME, CFN)))
SCM_SNARF_INIT(scm_c_define (RANAME, scm_i_make_primitive_macro (RANAME, CFN)))
/* bimacros (built-in macros) have isym codes.
mmacros don't exist at runtime, they just expand out to more primitive
forms. */
SCM_SYNTAX (s_at, "@", scm_m_at);
SCM_SYNTAX (s_atat, "@@", scm_m_atat);
SCM_SYNTAX (s_and, "and", scm_m_and);

7
module/ice-9/debugging/traps.scm
View file

@ -1,6 +1,6 @@
;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface
;;; Copyright (C) 2002, 2004, 2009 Free Software Foundation, Inc.
;;; Copyright (C) 2002, 2004, 2009, 2010 Free Software Foundation, Inc.
;;; Copyright (C) 2005 Neil Jerram
;;;
;;;; This library is free software; you can redistribute it and/or
@ -81,7 +81,9 @@
without-traps
guile-trap-features)
#:re-export (make)
#:export-syntax (trap-here))
;; FIXME: see below
;; #:export-syntax (trap-here)
)
;; How to debug the debugging infrastructure, when needed. Grep for
;; "(trc " to find other symbols that can be passed to trc-add.
@ -888,6 +890,7 @@ it twice."
;; (trap-here EXPRESSION . OPTIONS)
;; FIXME: no longer working due to no mmacros, no local-eval
#;
(define trap-here
(procedure->memoizing-macro
(lambda (expr env)

15563
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

83
module/ice-9/psyntax.scm
View file

@ -1,6 +1,6 @@
;;;; -*-scheme-*-
;;;;
;;;; Copyright (C) 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010 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
@ -308,18 +308,10 @@
(define put-global-definition-hook
(lambda (symbol type val)
(let ((existing (let ((v (module-variable (current-module) symbol)))
(and v (variable-bound? v)
(let ((val (variable-ref v)))
(and (macro? val)
(not (syncase-macro-type val))
val))))))
(module-define! (current-module)
symbol
(if existing
(make-extended-syncase-macro existing type val)
(make-syncase-macro type val))))))
(module-define! (current-module)
symbol
(make-syntax-transformer symbol type val))))
(define get-global-definition-hook
(lambda (symbol module)
(if (and (not module) (current-module))
@ -330,9 +322,9 @@
symbol)))
(and v (variable-bound? v)
(let ((val (variable-ref v)))
(and (macro? val) (syncase-macro-type val)
(cons (syncase-macro-type val)
(syncase-macro-binding val))))))))
(and (macro? val) (macro-type val)
(cons (macro-type val)
(macro-binding val))))))))
)
@ -1036,49 +1028,22 @@
(build-global-definition
no-source
name
;; FIXME: seems nasty to call current-module here
(if (let ((v (module-variable (current-module) name)))
;; FIXME use primitive-macro?
(and v (variable-bound? v) (macro? (variable-ref v))
(not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
(build-application
no-source
(build-primref no-source 'make-extended-syncase-macro)
(list (build-application
no-source
(build-primref no-source 'module-ref)
(list (build-application
no-source
(build-primref no-source 'current-module)
'())
(build-data no-source name)))
(build-data no-source 'macro)
(build-application
no-source
(build-primref no-source 'cons)
(list e
(build-application
no-source
(build-primref no-source 'module-name)
(list (build-application
no-source
(build-primref no-source 'current-module)
'())))))))
(build-application
no-source
(build-primref no-source 'make-syncase-macro)
(list (build-data no-source 'macro)
(build-application
no-source
(build-primref no-source 'cons)
(list e
(build-application
no-source
(build-primref no-source 'module-name)
(list (build-application
no-source
(build-primref no-source 'current-module)
'())))))))))))
(build-application
no-source
(build-primref no-source 'make-syntax-transformer)
(list (build-data no-source name)
(build-data no-source 'macro)
(build-application
no-source
(build-primref no-source 'cons)
(list e
(build-application
no-source
(build-primref no-source 'module-name)
(list (build-application
no-source
(build-primref no-source 'current-module)
'()))))))))))
(define chi-when-list
(lambda (e when-list w)