1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00

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.
This commit is contained in:
Ludovic Courtès 2009-08-12 19:22:19 +02:00
parent b9434165b6
commit 16f451f308
3 changed files with 34 additions and 6 deletions

View file

@ -1982,8 +1982,13 @@
(let ((accessor (record-accessor module-type 'name))) (let ((accessor (record-accessor module-type 'name)))
(lambda (mod) (lambda (mod)
(or (accessor mod) (or (accessor mod)
(begin (let ((name (list (gensym))))
(set-module-name! mod (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)))))) (accessor mod))))))
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module))) ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))

View file

@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -19,8 +19,9 @@
:use-module (test-suite lib) :use-module (test-suite lib)
:use-module (test-suite guile-test) :use-module (test-suite guile-test)
:use-module (system base compile)) :use-module (system base compile))
(with-test-prefix "basic" (with-test-prefix "basic"
(pass-if "compile to value" (pass-if "compile to value"
@ -34,4 +35,19 @@
;; imported `round'. See the same test in `syntax.test' for details. ;; imported `round'. See the same test in `syntax.test' for details.
(let ((o1 (compile '(define round round))) (let ((o1 (compile '(define round round)))
(o2 (compile '(eq? round (@@ (guile) 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)))))

View file

@ -1,6 +1,6 @@
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -34,6 +34,13 @@
(with-test-prefix "foundations" (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!" (pass-if "module-add!"
(let ((m (make-module)) (let ((m (make-module))
(value (cons 'x 'y))) (value (cons 'x 'y)))