From 16f451f308cd79168d2b1d1314b324dff96fde0d Mon Sep 17 00:00:00 2001
From: =?utf8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 12 Aug 2009 19:22:19 +0200
Subject: [PATCH] Allow fresh modules to be passed to `compile'.

* module/ice-9/boot-9.scm (module-name): When making MOD non-anonymous,
  bind it in the `(%app modules)' name space.

* test-suite/tests/compiler.test ("psyntax")["compile in current
  module", "compile in fresh module"]: New tests.

* test-suite/tests/modules.test ("foundations")["modules don't remain
  anonymous"]: New test.
---
 module/ice-9/boot-9.scm        |  9 +++++++--
 test-suite/tests/compiler.test | 22 +++++++++++++++++++---
 test-suite/tests/modules.test  |  9 ++++++++-
 3 files changed, 34 insertions(+), 6 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 36a463ad3..01569cbf9 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1982,8 +1982,13 @@
   (let ((accessor (record-accessor module-type 'name)))
     (lambda (mod)
       (or (accessor mod)
-          (begin
-            (set-module-name! mod (list (gensym)))
+          (let ((name (list (gensym))))
+            ;; Name MOD and bind it in THE-ROOT-MODULE so that it's visible
+            ;; to `resolve-module'.  This is important as `psyntax' stores
+            ;; module names and relies on being able to `resolve-module'
+            ;; them.
+            (set-module-name! mod name)
+            (nested-define! the-root-module `(%app modules ,@name) mod)
             (accessor mod))))))
 
 ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index fe9d7765f..9c84fd7b4 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
 ;;;; compiler.test --- tests for the compiler      -*- scheme -*-
-;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 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
@@ -19,8 +19,9 @@
   :use-module (test-suite lib)
   :use-module (test-suite guile-test)
   :use-module (system base compile))
-  
 
+
+
 (with-test-prefix "basic"
 
   (pass-if "compile to value"
@@ -34,4 +35,19 @@
     ;; imported `round'.  See the same test in `syntax.test' for details.
     (let ((o1 (compile '(define round round)))
           (o2 (compile '(eq? round (@@ (guile) round)))))
-      o2)))
+      o2))
+
+  (pass-if "compile in current module"
+    (let ((o1 (compile '(define-macro (foo) 'bar)))
+          (o2 (compile '(let ((bar 'ok)) (foo)))))
+      (and (module-ref (current-module) 'foo)
+           (eq? o2 'ok))))
+
+  (pass-if "compile in fresh module"
+    (let* ((m  (let ((m (make-module)))
+                 (beautify-user-module! m)
+                 m))
+           (o1 (compile '(define-macro (foo) 'bar) #:env m))
+           (o2 (compile '(let ((bar 'ok)) (foo)) #:env m)))
+      (and (module-ref m 'foo)
+           (eq? o2 'ok)))))
diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test
index 696c35ca2..f22cfe9c1 100644
--- a/test-suite/tests/modules.test
+++ b/test-suite/tests/modules.test
@@ -1,6 +1,6 @@
 ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
 
-;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 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
@@ -34,6 +34,13 @@
 
 (with-test-prefix "foundations"
 
+  (pass-if "modules don't remain anonymous"
+    ;; This is a requirement for `psyntax': it stores module names and relies
+    ;; on being able to `resolve-module' them.
+    (let ((m (make-module)))
+      (and (module-name m)
+           (eq? m (resolve-module (module-name m))))))
+
   (pass-if "module-add!"
     (let ((m (make-module))
           (value (cons 'x 'y)))
-- 
2.20.1