Merge branch 'syncase'

libguile/debug.c

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

libguile/debug.h

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

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

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

libguile/modules.c

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

libguile/modules.h

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

libguile/vm-i-system.c

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

module/ice-9/Makefile.am

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

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}

module/ice-9/compile-psyntax.scm

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

module/ice-9/expand-support.scm

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

module/ice-9/syncase.scm

@@ -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)))
+      (save-module-excursion
-        (sc-expand exp)))))
+       (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))
+		(let* ((mod (resolve-module mod))
-		       (m (variable-ref (eval-closure (car e) #f))))
+                       (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
+				(strip-expansion-structures e)
-				(append r (list eval-closure)))))
+				(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)
+                  (debug-disable 'debug 'procnames)
-		  (read-disable 'positions)
+                  (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)
+		     (strip-expansion-structures (cadr x))
-		     (sc-expand 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
+  (strip-expansion-structures (sc-expand exp)))
-		 (module-eval-closure (current-module))))
-    (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)

module/language/scheme/compile-ghil.scm

@@ -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)
+               ((symbol? head) (module-ref/safe mod 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)))))
                ;; 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))
+      (let ((sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
-             (sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
         (lambda (env loc exp)
           (retrans
-           (with-fluids ((eec (module-eval-closure mod)))
+           (strip-expansion-structures
-             (sc-expand3 exp 'c '(compile load eval)))))))
+            (sc-expand3 exp 'c '(compile load eval)))))))
 
      ((primitive-macro? val)
       (syntax-error #f "unhandled primitive macro" head))

module/language/scheme/expand.scm

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

module/system/base/pmatch.scm

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