diff options
-rw-r--r-- | libguile/eval.c | 46 | ||||
-rw-r--r-- | libguile/eval.h | 4 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 25 |
3 files changed, 47 insertions, 28 deletions
diff --git a/libguile/eval.c b/libguile/eval.c index 48b229903..12888c2fe 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -306,6 +306,9 @@ syntax_error (const char* const msg, const SCM form, const SCM expr) { if (SCM_UNLIKELY (!(cond))) \ syntax_error (message, form, expr); } +static void error_unbound_variable (SCM symbol) SCM_NORETURN; +static void error_defined_variable (SCM symbol) SCM_NORETURN; + /* {Ilocs} @@ -1976,6 +1979,46 @@ unmemoize_set_x (const SCM expr, const SCM env) /* Start of the memoizers for non-R5RS builtin macros. */ +SCM_SYNTAX (s_at, "@", scm_makmmacro, scm_m_at); +SCM_GLOBAL_SYMBOL (scm_sym_at, s_at); + +SCM +scm_m_at (SCM expr, SCM env SCM_UNUSED) +{ + SCM mod, var; + ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); + + mod = scm_resolve_module (scm_cadr (expr)); + if (scm_is_false (mod)) + error_unbound_variable (expr); + var = scm_module_variable (scm_module_public_interface (mod), scm_caddr (expr)); + if (scm_is_false (var)) + error_unbound_variable (expr); + + return var; +} + +SCM_SYNTAX (s_atat, "@@", scm_makmmacro, scm_m_atat); +SCM_GLOBAL_SYMBOL (scm_sym_atat, s_atat); + +SCM +scm_m_atat (SCM expr, SCM env SCM_UNUSED) +{ + SCM mod, var; + ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); + + mod = scm_resolve_module (scm_cadr (expr)); + if (scm_is_false (mod)) + error_unbound_variable (expr); + var = scm_module_variable (mod, scm_caddr (expr)); + if (scm_is_false (var)) + error_unbound_variable (expr); + + return var; +} + SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply); SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply); SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); @@ -2662,9 +2705,6 @@ scm_ilookup (SCM iloc, SCM env) SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); -static void error_unbound_variable (SCM symbol) SCM_NORETURN; -static void error_defined_variable (SCM symbol) SCM_NORETURN; - /* Call this for variables that are unfound. */ static void diff --git a/libguile/eval.h b/libguile/eval.h index 333265263..f3ec2e19c 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -94,6 +94,8 @@ SCM_API SCM scm_sym_quasiquote; SCM_API SCM scm_sym_unquote; SCM_API SCM scm_sym_uq_splicing; +SCM_API SCM scm_sym_at; +SCM_API SCM scm_sym_atat; SCM_API SCM scm_sym_atapply; SCM_API SCM scm_sym_atcall_cc; SCM_API SCM scm_sym_at_call_with_values; @@ -131,6 +133,8 @@ SCM_API SCM scm_m_future (SCM xorig, SCM env); SCM_API SCM scm_m_define (SCM x, SCM env); SCM_API SCM scm_m_letrec (SCM xorig, SCM env); SCM_API SCM scm_m_let (SCM xorig, SCM env); +SCM_API SCM scm_m_at (SCM xorig, SCM env); +SCM_API SCM scm_m_atat (SCM xorig, SCM env); SCM_API SCM scm_m_apply (SCM xorig, SCM env); SCM_API SCM scm_m_cont (SCM xorig, SCM env); #if SCM_ENABLE_ELISP diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 29c89b1f9..03d876907 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2936,31 +2936,6 @@ module '(ice-9 q) '(make-q q-length))}." (define load load-module) -;; The following macro allows one to write, for example, -;; -;; (@ (ice-9 pretty-print) pretty-print) -;; -;; to refer directly to the pretty-print variable in module (ice-9 -;; pretty-print). It works by looking up the variable and inserting -;; it directly into the code. This is understood by the evaluator. -;; Indeed, all references to global variables are memoized into such -;; variable objects. - -(define-macro (@ mod-name var-name) - (let ((var (module-variable (resolve-interface mod-name) var-name))) - (if (not var) - (error "no such public variable" (list '@ mod-name var-name))) - var)) - -;; The '@@' macro is like '@' but it can also access bindings that -;; have not been explicitely exported. - -(define-macro (@@ mod-name var-name) - (let ((var (module-variable (resolve-module mod-name) var-name))) - (if (not var) - (error "no such variable" (list '@@ mod-name var-name))) - var)) - ;;; {Compiler interface} |