wingo pushed a commit to branch wip-whippet
in repository guile.
commit 383b67c9f1ca4539cb33b566c330fbe689037326
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Mon Jun 16 13:35:34 2025 +0200
Give syntax transformers a static tc16
* libguile/scm.h: Allocate a tc16 for syntax transformers.
* libguile/expand.c: Adapt to renamings.
* libguile/eq.c:
* libguile/goops.c:
* libguile/print.c: Add tc16 cases.
* libguile/macros.h:
* libguile/macros.c (scm_i_make_primitive_syntax_transformer):
(scm_i_primitive_syntax_transformer): Rename internal functions from
scm_i_make_primitive_macro, etc. Use new representation.
(scm_make_syntax_transformer): Update for new representation.
---
libguile/eq.c | 1 +
libguile/expand.c | 5 ++-
libguile/goops.c | 3 +-
libguile/macros.c | 124 +++++++++++++++++++++++++++++++++---------------------
libguile/macros.h | 9 ++--
libguile/print.c | 3 ++
libguile/scm.h | 3 +-
7 files changed, 92 insertions(+), 56 deletions(-)
diff --git a/libguile/eq.c b/libguile/eq.c
index 5e559848f..f85ad43d7 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -392,6 +392,7 @@ scm_equal_p (SCM x, SCM y)
case scm_tc16_mutex:
case scm_tc16_continuation:
case scm_tc16_directory:
+ case scm_tc16_syntax_transformer:
return SCM_BOOL_F;
default:
abort ();
diff --git a/libguile/expand.c b/libguile/expand.c
index be95578e3..7b28cb6d2 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -148,7 +148,8 @@ SCM_SYMBOL (syntax_error_key, "syntax-error");
#define SCM_SYNTAX(STR, CFN) \
SCM_SNARF_HERE(static SCM CFN (SCM xorig, SCM env)) \
-SCM_SNARF_INIT(scm_c_define (STR, scm_i_make_primitive_macro (STR, CFN)))
+SCM_SNARF_INIT(scm_c_define \
+ (STR, scm_i_make_primitive_syntax_transformer (STR, CFN)))
/* True primitive syntax */
@@ -296,7 +297,7 @@ expand (SCM exp, SCM env)
macro = expand_env_ref_macro (env, car);
if (scm_is_true (macro))
- trans = scm_i_macro_primitive (macro);
+ trans = scm_i_primitive_syntax_transformer (macro);
if (trans)
return trans (exp, env);
diff --git a/libguile/goops.c b/libguile/goops.c
index db71dc8d8..e21a504e4 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -41,7 +41,6 @@
#include "gsubr-internal.h"
#include "hashtab.h"
#include "keywords.h"
-#include "macros.h"
#include "modules.h"
#include "numbers.h"
#include "pairs.h"
@@ -357,6 +356,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return class_continuation;
case scm_tc16_directory:
return class_directory;
+ case scm_tc16_syntax_transformer:
+ return class_unknown;
default:
abort ();
}
diff --git a/libguile/macros.c b/libguile/macros.c
index e26ed651c..15478c7cd 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-1998,2000-2003,2006,2008-2012,2018-2019
+/* Copyright 1995-1998,2000-2003,2006,2008-2012,2018-2019,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -38,27 +38,49 @@
#include "macros.h"
-static scm_t_bits scm_tc16_macro;
+struct scm_syntax_transformer
+{
+ scm_t_bits tag;
+ scm_t_macro_primitive primitive;
+ SCM name;
+ SCM type;
+ SCM binding;
+};
+
+static inline int
+scm_is_syntax_transformer (SCM x)
+{
+ return SCM_HAS_TYP16 (x, scm_tc16_syntax_transformer);
+}
-#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)
+static inline struct scm_syntax_transformer*
+scm_to_syntax_transformer (SCM x)
+{
+ if (!scm_is_syntax_transformer (x))
+ abort ();
+ return (struct scm_syntax_transformer *)SCM_UNPACK_POINTER (x);
+}
+static inline SCM
+scm_from_syntax_transformer (struct scm_syntax_transformer *m)
+{
+ return SCM_PACK_POINTER (m);
+}
-SCM_API scm_t_bits scm_tc16_macro;
+#define SCM_MACROP(x) scm_is_syntax_transformer (x)
+#define SCM_VALIDATE_MACRO(p,v) SCM_MAKE_VALIDATE ((p), (v), MACROP)
-static int
-macro_print (SCM macro, SCM port, scm_print_state *pstate)
+int
+scm_i_print_syntax_transformer (SCM macro, SCM port, scm_print_state *pstate)
{
- if (scm_is_false (SCM_MACRO_TYPE (macro)))
+ struct scm_syntax_transformer *tx = scm_to_syntax_transformer (macro);
+
+ if (scm_is_false (tx->type))
scm_puts ("#<primitive-syntax-transformer ", port);
else
scm_puts ("#<syntax-transformer ", port);
- scm_iprin1 (scm_macro_name (macro), port, pstate);
+ scm_iprin1 (tx->name, port, pstate);
scm_putc ('>', port);
return 1;
@@ -68,20 +90,24 @@ SCM_SYMBOL (sym_primitive_macro, "primitive-macro");
/* 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_utf8_symbol (name));
- SCM_SET_SMOB_OBJECT_N (z, 3, sym_primitive_macro);
- SCM_SET_SMOB_OBJECT_N (z, 4, SCM_BOOL_F);
- return z;
+scm_i_make_primitive_syntax_transformer (const char *name,
+ scm_t_macro_primitive fn)
+{
+ struct scm_syntax_transformer *tx = scm_gc_malloc (sizeof (*tx),
+ "syntax transformer");
+ tx->tag = scm_tc16_syntax_transformer;
+ tx->primitive = fn;
+ tx->name = scm_from_utf8_symbol (name);
+ tx->type = sym_primitive_macro;
+ tx->binding = SCM_BOOL_F;
+
+ return scm_from_syntax_transformer (tx);
}
scm_t_macro_primitive
-scm_i_macro_primitive (SCM macro)
+scm_i_primitive_syntax_transformer (SCM macro)
{
- return SCM_MACRO_PRIMITIVE (macro);
+ return scm_to_syntax_transformer (macro)->primitive;
}
@@ -92,30 +118,34 @@ SCM_DEFINE (scm_make_syntax_transformer,
"make-syntax-transformer", 3, 0, 0,
"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_VALIDATE_SYMBOL (1, name);
+
+ SCM_VALIDATE_SYMBOL (2, type);
+
+ struct scm_syntax_transformer *tx = scm_gc_malloc (sizeof (*tx),
+ "syntax transformer");
+ tx->tag = scm_tc16_syntax_transformer;
+ tx->primitive = NULL;
+ tx->name = name;
+ tx->type = type;
+ tx->binding = binding;
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_is_true (scm_variable_bound_p (existing_var)))
+ {
+ SCM val = SCM_VARIABLE_REF (existing_var);
+ if (scm_is_syntax_transformer (val))
+ tx->primitive = scm_to_syntax_transformer (val)->primitive;
+ }
}
- 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;
+ return scm_from_syntax_transformer (tx);
}
#undef FUNC_NAME
@@ -127,7 +157,7 @@ SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0,
"procedure has its name due to historical reasons.")
#define FUNC_NAME s_scm_macro_p
{
- return scm_from_bool (SCM_MACROP (obj));
+ return scm_from_bool (scm_is_syntax_transformer (obj));
}
#undef FUNC_NAME
@@ -139,7 +169,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
#define FUNC_NAME s_scm_macro_type
{
SCM_VALIDATE_MACRO (1, m);
- return SCM_MACRO_TYPE (m);
+ return scm_to_syntax_transformer (m)->type;
}
#undef FUNC_NAME
@@ -149,7 +179,7 @@ SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0,
#define FUNC_NAME s_scm_macro_name
{
SCM_VALIDATE_MACRO (1, m);
- return SCM_MACRO_NAME (m);
+ return scm_to_syntax_transformer (m)->name;
}
#undef FUNC_NAME
@@ -162,13 +192,13 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer",
1, 0, 0,
#define FUNC_NAME s_scm_macro_transformer
{
SCM_VALIDATE_MACRO (1, m);
+ SCM binding = scm_macro_binding (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;
+ if (scm_is_true (scm_procedure_p (binding)))
+ return binding;
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -180,7 +210,7 @@ SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0,
#define FUNC_NAME s_scm_macro_binding
{
SCM_VALIDATE_MACRO (1, m);
- return SCM_MACRO_BINDING (m);
+ return scm_to_syntax_transformer (m)->binding;
}
#undef FUNC_NAME
@@ -219,8 +249,6 @@ scm_syntax_session_id (void)
void
scm_init_macros ()
{
- scm_tc16_macro = scm_make_smob_type ("macro", 0);
- scm_set_smob_print (scm_tc16_macro, macro_print);
#include "macros.x"
syntax_session_id = fresh_syntax_session_id();
diff --git a/libguile/macros.h b/libguile/macros.h
index fda7191b8..3227d0680 100644
--- a/libguile/macros.h
+++ b/libguile/macros.h
@@ -1,7 +1,7 @@
#ifndef SCM_MACROS_H
#define SCM_MACROS_H
-/* Copyright 1998,2000-2003,2006,2008-2010,2018
+/* Copyright 1998,2000-2003,2006,2008-2010,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -36,9 +36,12 @@ 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_INTERNAL SCM scm_i_make_primitive_macro (const char *name,
+SCM_INTERNAL int scm_i_print_syntax_transformer (SCM macro, SCM port,
+ scm_print_state *pstate);
+SCM_INTERNAL
+SCM scm_i_make_primitive_syntax_transformer (const char *name,
scm_t_macro_primitive fn);
-SCM_INTERNAL scm_t_macro_primitive scm_i_macro_primitive (SCM m);
+SCM_INTERNAL scm_t_macro_primitive scm_i_primitive_syntax_transformer (SCM m);
SCM_INTERNAL void scm_init_macros (void);
diff --git a/libguile/print.c b/libguile/print.c
index 0395bfede..256fd8a2a 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -805,6 +805,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc16_directory:
scm_i_print_directory (exp, port, pstate);
break;
+ case scm_tc16_syntax_transformer:
+ scm_i_print_syntax_transformer (exp, port, pstate);
+ break;
default:
abort ();
}
diff --git a/libguile/scm.h b/libguile/scm.h
index cff85c669..e9d24bed1 100644
--- a/libguile/scm.h
+++ b/libguile/scm.h
@@ -513,9 +513,8 @@ typedef uintptr_t scm_t_bits;
#define scm_tc16_mutex 0x027f
#define scm_tc16_continuation 0x037f
#define scm_tc16_directory 0x047f
+#define scm_tc16_syntax_transformer 0x057f
/*
-#define scm_tc16_hook 0x097f
-#define scm_tc16_macro 0x0a7f
#define scm_tc16_malloc 0x0b7f
#define scm_tc16_port_with_print_state 0x0d7f
#define scm_tc16_promise 0x0e7f
