mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Merge branch 'master' into boehm-demers-weiser-gc

Browse source 
Conflicts:
	lib/Makefile.am
	libguile/Makefile.am
	libguile/frames.c
	libguile/gc-card.c
	libguile/gc-freelist.c
	libguile/gc-mark.c
	libguile/gc-segment.c
	libguile/gc_os_dep.c
	libguile/load.c
	libguile/macros.c
	libguile/objcodes.c
	libguile/programs.c
	libguile/strings.c
	libguile/vm.c
	m4/gnulib-cache.m4
	m4/gnulib-comp.m4
	m4/inline.m4
This commit is contained in:
Ludovic Courtès 2009-08-17 23:39:56 +02:00
commit fbb857a472
823 changed files with 61674 additions and 14111 deletions
Download patch file Download diff file Expand all files Collapse all files

116
libguile/macros.c
View file

@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008, 2009 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 2.1 of the License, or (at your option) any later version.
* 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
* 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
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
@ -48,10 +49,13 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
|| 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);
else
scm_puts ("#<", port);
scm_puts ("primitive-", port);
if (SCM_MACRO_TYPE (macro) == 0)
scm_puts ("syntax", port);
@ -63,6 +67,8 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
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);
@ -77,6 +83,14 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
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);
}
@ -164,11 +178,45 @@ SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0,
#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 or a\n"
"syntax transformer.")
"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));
@ -182,14 +230,15 @@ 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} or\n"
"@code{macro!}, depending on whether @var{m} is a syntax\n"
"transformer, a regular macro, or a memoizing macro,\n"
"respectively. If @var{m} is not a macro, @code{#f} is\n"
"returned.")
"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))
@ -202,6 +251,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
#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);
}
}
@ -214,7 +264,9 @@ SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0,
#define FUNC_NAME s_scm_macro_name
{
SCM_VALIDATE_SMOB (1, m, macro);
return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m)));
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
@ -236,6 +288,34 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0,
}
#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)() )
{