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

Merge branch 'syncase'

Browse source
This commit is contained in:
Andy Wingo 2009-04-20 22:26:02 +02:00
commit 71d903c881
17 changed files with 553 additions and 363 deletions
Download patch file Download diff file Expand all files Collapse all files

15
libguile/debug.c
View file

@ -400,6 +400,21 @@ SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0,
(SCM proc),
"Return the module that was current when @var{proc} was defined.")
#define FUNC_NAME s_scm_procedure_module
{
SCM_VALIDATE_PROC (SCM_ARG1, proc);
if (scm_is_true (scm_program_p (proc)))
return scm_program_module (proc);
else
return scm_env_module (scm_procedure_environment (proc));
}
#undef FUNC_NAME
/* Eval in a local environment. We would like to have the ability to

1
libguile/debug.h
View file

@ -140,6 +140,7 @@ SCM_API SCM scm_local_eval (SCM exp, SCM env);
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
SCM_API SCM scm_procedure_environment (SCM proc);
SCM_API SCM scm_procedure_module (SCM proc);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_memoized_environment (SCM m);

48
libguile/eval.c
View file

@ -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,48 @@ 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);
ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), 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);
ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), 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 +2707,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

4
libguile/eval.h
View file

@ -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

15
libguile/modules.c
View file

@ -544,6 +544,21 @@ SCM_DEFINE (scm_standard_interface_eval_closure,
}
#undef FUNC_NAME
SCM_DEFINE (scm_eval_closure_module,
"eval-closure-module", 1, 0, 0,
(SCM eval_closure),
"Return the module associated with this eval closure.")
/* the idea is that eval closures are really not the way to do things, they're
superfluous given our module system. this function lets mmacros migrate away
from eval closures. */
#define FUNC_NAME s_scm_eval_closure_module
{
SCM_MAKE_VALIDATE_MSG (SCM_ARG1, eval_closure, EVAL_CLOSURE_P,
"eval-closure");
return SCM_SMOB_OBJECT (eval_closure);
}
#undef FUNC_NAME
SCM
scm_module_lookup_closure (SCM module)
{

1
libguile/modules.h
View file

@ -109,6 +109,7 @@ SCM_API SCM scm_current_module_transformer (void);
SCM_API SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep);
SCM_API SCM scm_standard_eval_closure (SCM module);
SCM_API SCM scm_standard_interface_eval_closure (SCM module);
SCM_API SCM scm_eval_closure_module (SCM eval_closure); /* deprecated already */
SCM_API SCM scm_get_pre_modules_obarray (void);
SCM_API SCM scm_lookup_closure_module (SCM proc);

16
libguile/vm-i-system.c
View file

@ -284,7 +284,13 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
/* might longjmp */
what = scm_module_lookup (mod, what);
else
what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
{
SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
if (scm_is_false (v))
SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (what));
else
what = v;
}
}
else
{
@ -367,7 +373,13 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
/* might longjmp */
what = scm_module_lookup (mod, what);
else
what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
{
SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
if (scm_is_false (v))
SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (what));
else
what = v;
}
}
else
{

2
module/ice-9/Makefile.am
View file

@ -30,7 +30,7 @@ modpath = ice-9
# and forth between interpreted and compiled code, we end up using more
# of the C stack than the interpreter would have; so avoid that by
# putting these core modules first.
SOURCES = psyntax-pp.scm annotate.scm boot-9.scm \
SOURCES = psyntax-pp.scm expand-support.scm boot-9.scm \
and-let-star.scm calling.scm common-list.scm \
debug.scm debugger.scm documentation.scm emacs.scm expect.scm \
format.scm getopt-long.scm hcons.scm i18n.scm \

25
module/ice-9/boot-9.scm
View file

@ -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}

22
module/ice-9/compile-psyntax.scm
View file

@ -12,16 +12,16 @@
(let ((in (open-input-file source))
(out (open-output-file (string-append target ".tmp"))))
(with-fluids ((expansion-eval-closure
(module-eval-closure (current-module))))
(let loop ((x (read in)))
(if (eof-object? x)
(begin
(close-port out)
(close-port in))
(begin
(write (sc-expand3 x 'c '(compile load eval)) out)
(newline out)
(loop (read in)))))))
(let loop ((x (read in)))
(if (eof-object? x)
(begin
(close-port out)
(close-port in))
(begin
(write (strip-expansion-structures
(sc-expand3 x 'c '(compile load eval)))
out)
(newline out)
(loop (read in))))))
(system (format #f "mv -f ~s.tmp ~s" target target))

87
module/ice-9/annotate.scm → module/ice-9/expand-support.scm
View file

@ -16,11 +16,19 @@
;;;;
(define-module (ice-9 annotate)
(define-module (ice-9 expand-support)
:export (<annotation> annotation? annotate deannotate make-annotation
annotation-expression annotation-source annotation-stripped
set-annotation-stripped!
deannotate/source-properties))
deannotate/source-properties
<module-ref> make-module-ref
module-ref-symbol module-ref-modname module-ref-public?
<lexical> make-lexical
lexical-name lexical-gensym
strip-expansion-structures))
(define <annotation>
(make-vtable "prprpw"
@ -78,3 +86,78 @@
(set-source-properties! e source))
e))
(else e)))
(define <module-ref>
(make-vtable "prprpr"
(lambda (struct port)
(display "#<" port)
(display (if (module-ref-public? struct) "@ " "@@ ") port)
(display (module-ref-modname struct) port)
(display " " port)
(display (module-ref-symbol struct) port)
(display ">" port))))
(define (module-ref? x)
(and (struct? x) (eq? (struct-vtable x) <module-ref>)))
(define (make-module-ref modname symbol public?)
(make-struct <module-ref> 0 modname symbol public?))
(define (module-ref-modname a)
(struct-ref a 0))
(define (module-ref-symbol a)
(struct-ref a 1))
(define (module-ref-public? a)
(struct-ref a 2))
(define <lexical>
(make-vtable "prpr"
(lambda (struct port)
(display "#<lexical " port)
(display (lexical-name struct) port)
(display "/" port)
(display (lexical-gensym struct) port)
(display ">" port))))
(define (lexical? x)
(and (struct? x) (eq? (struct-vtable x) <lexical>)))
(define (make-lexical name gensym)
(make-struct <lexical> 0 name gensym))
(define (lexical-name a)
(struct-ref a 0))
(define (lexical-gensym a)
(struct-ref a 1))
(define (strip-expansion-structures e)
(cond ((list? e)
(map strip-expansion-structures e))
((pair? e)
(cons (strip-expansion-structures (car e))
(strip-expansion-structures (cdr e))))
((annotation? e)
(let ((e (strip-expansion-structures (annotation-expression e)))
(source (annotation-source e)))
(if (pair? e)
(set-source-properties! e source))
e))
((module-ref? e)
(if (and (module-ref-modname e)
(not (eq? (module-ref-modname e)
(module-name (current-module)))))
`(,(if (module-ref-public? e) '@ '@@)
,(module-ref-modname e)
,(module-ref-symbol e))
(module-ref-symbol e)))
((lexical? e)
(lexical-gensym e))
((record? e)
(error "unexpected record in expansion" e))
(else e)))

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

File diff suppressed because one or more lines are too long

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

File diff suppressed because it is too large Load diff

79
module/ice-9/syncase.scm
View file

@ -17,10 +17,11 @@
(define-module (ice-9 syncase)
:use-module (ice-9 expand-support)
:use-module (ice-9 debug)
:use-module (ice-9 threads)
:export-syntax (sc-macro define-syntax define-syntax-public
eval-when fluid-let-syntax
fluid-let-syntax
identifier-syntax let-syntax
letrec-syntax syntax syntax-case syntax-rules
with-syntax
@ -30,25 +31,21 @@
datum->syntax-object free-identifier=?
generate-temporaries identifier? syntax-object->datum
void syncase)
:replace (eval))
:replace (eval eval-when))
(define expansion-eval-closure (make-fluid))
(define (current-eval-closure)
(or (fluid-ref expansion-eval-closure)
(module-eval-closure (current-module))))
(define (env->eval-closure env)
(and env (car (last-pair env))))
(define (annotation? x) #f)
(define sc-macro
(procedure->memoizing-macro
(lambda (exp env)
(with-fluids ((expansion-eval-closure (env->eval-closure env)))
(sc-expand exp)))))
(save-module-excursion
(lambda ()
;; Because memoization happens lazily, env's module isn't
;; necessarily the current module.
(set-current-module (eval-closure-module (car (last-pair env))))
(strip-expansion-structures (sc-expand exp)))))))
;;; Exported variables
@ -105,55 +102,28 @@
'())))
(define the-syncase-module (current-module))
(define the-syncase-eval-closure (module-eval-closure the-syncase-module))
(fluid-set! expansion-eval-closure the-syncase-eval-closure)
(define (putprop symbol key binding)
(let* ((eval-closure (current-eval-closure))
;; Why not simply do (eval-closure symbol #t)?
;; Answer: That would overwrite imported bindings
(v (or (eval-closure symbol #f) ;lookup
(eval-closure symbol #t) ;create it locally
)))
;; Don't destroy Guile macros corresponding to
;; primitive syntax when syncase boots.
(if (not (and (symbol-property symbol 'primitive-syntax)
(eq? eval-closure the-syncase-eval-closure)))
(variable-set! v sc-macro))
;; Properties are tied to variable objects
(set-object-property! v key binding)))
(define (getprop symbol key)
(let* ((v ((current-eval-closure) symbol #f)))
(and v
(or (object-property v key)
(and (variable-bound? v)
(macro? (variable-ref v))
(macro-transformer (variable-ref v)) ;non-primitive
guile-macro)))))
(define guile-macro
(cons 'external-macro
(lambda (e r w s)
(lambda (e r w s mod)
(let ((e (syntax-object->datum e)))
(if (symbol? e)
;; pass the expression through
e
(let* ((eval-closure (current-eval-closure))
(m (variable-ref (eval-closure (car e) #f))))
(let* ((mod (resolve-module mod))
(m (module-ref mod (car e))))
(if (eq? (macro-type m) 'syntax)
;; pass the expression through
e
;; perform Guile macro transform
(let ((e ((macro-transformer m)
e
(append r (list eval-closure)))))
(strip-expansion-structures e)
(append r (list (module-eval-closure mod))))))
(if (variable? e)
e
(if (null? r)
(sc-expand e)
(sc-chi e r w)))))))))))
(sc-chi e r w (module-name mod))))))))))))
(define generated-symbols (make-weak-key-hash-table 1019))
@ -207,25 +177,20 @@
(set! old-debug (debug-options))
(set! old-read (read-options)))
(lambda ()
(debug-disable 'debug 'procnames)
(read-disable 'positions)
(debug-disable 'debug 'procnames)
(read-disable 'positions)
(load-from-path "ice-9/psyntax-pp"))
(lambda ()
(debug-options old-debug)
(read-options old-read))))
;;; The following lines are necessary only if we start making changes
;; (use-syntax sc-expand)
;; (load-from-path "ice-9/psyntax")
(define internal-eval (nested-ref the-scm-module '(%app modules guile eval)))
(define (eval x environment)
(internal-eval (if (and (pair? x)
(equal? (car x) "noexpand"))
(cadr x)
(sc-expand x))
(strip-expansion-structures (cadr x))
(strip-expansion-structures (sc-expand x)))
environment))
;;; Hack to make syncase macros work in the slib module
@ -236,9 +201,7 @@
'(define))))
(define (syncase exp)
(with-fluids ((expansion-eval-closure
(module-eval-closure (current-module))))
(sc-expand exp)))
(strip-expansion-structures (sc-expand exp)))
(set-module-transformer! the-syncase-module syncase)
@ -248,5 +211,3 @@
(begin
;(eval-case ((load-toplevel) (export-syntax name)))
(define-syntax name rules ...)))))
(fluid-set! expansion-eval-closure #f)

28
module/language/scheme/compile-ghil.scm
View file

@ -27,6 +27,7 @@
#:use-module (system vm objcode)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
#:use-module (ice-9 expand-support)
#:use-module ((ice-9 syncase) #:select (sc-macro))
#:use-module ((system base compile) #:select (syntax-error))
#:export (compile-ghil translate-1
@ -93,17 +94,25 @@
;;
;; FIXME shadowing lexicals?
(define (lookup-transformer head retrans)
(define (module-ref/safe mod sym)
(and mod
(and=> (module-variable mod sym)
(lambda (var)
;; unbound vars can happen if the module
;; definition forward-declared them
(and (variable-bound? var) (variable-ref var))))))
(let* ((mod (current-module))
(val (cond
((symbol? head)
(and=> (module-variable mod head)
(lambda (var)
;; unbound vars can happen if the module
;; definition forward-declared them
(and (variable-bound? var) (variable-ref var)))))
((symbol? head) (module-ref/safe mod head))
;; allow macros to be unquoted into the output of a macro
;; expansion
((macro? head) head)
((pmatch head
((@ ,modname ,sym)
(module-ref/safe (resolve-interface modname) sym))
((@@ ,modname ,sym)
(module-ref/safe (resolve-module modname) sym))
(else #f)))
(else #f))))
(cond
((hashq-ref *translate-table* val))
@ -114,12 +123,11 @@
((eq? val sc-macro)
;; syncase!
(let* ((eec (@@ (ice-9 syncase) expansion-eval-closure))
(sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
(let ((sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
(lambda (env loc exp)
(retrans
(with-fluids ((eec (module-eval-closure mod)))
(sc-expand3 exp 'c '(compile load eval)))))))
(strip-expansion-structures
(sc-expand3 exp 'c '(compile load eval)))))))
((primitive-macro? val)
(syntax-error #f "unhandled primitive macro" head))

2
module/language/scheme/expand.scm
View file

@ -21,7 +21,7 @@
(define-module (language scheme expand)
#:use-module (language scheme amatch)
#:use-module (ice-9 annotate)
#:use-module (ice-9 expand-support)
#:use-module (ice-9 optargs)
#:use-module ((ice-9 syncase) #:select (sc-macro))
#:use-module ((system base compile) #:select (syntax-error))

2
module/system/base/pmatch.scm
View file

@ -1,6 +1,6 @@
(define-module (system base pmatch)
#:use-module (ice-9 syncase)
#:export (pmatch ppat))
#:export (pmatch))
;; FIXME: shouldn't have to export ppat...
;; Originally written by Oleg Kiselyov. Taken from: