Permalink
Browse files

Fix #221

The culprit was the sloppy definition of define-library.
  • Loading branch information...
shirok committed May 2, 2017
1 parent abd37d1 commit a1056121900e6dacf8fc0340843c3291ad8bcc12
Showing with 80 additions and 38 deletions.
  1. +10 −0 ChangeLog
  2. +30 −25 lib/r7rs.scm
  3. +40 −13 test/r7rs-tests.scm
View
@@ -1,5 +1,15 @@
2017-05-01 Shiro Kawai <shiro@acm.org>
* lib/r7rs.scm (define-library): Fix a mysterious bug that internal
definitions inserted by a macro defined in an r7rs library
wasn't recognized as internal definitions. Initially we suspected
a bug that broke hygiene of 'define'. It turned out that the
bug was in the sloppy definition of 'define-library': The expansion
redefined 'begin'. And because hygienic expansion is working as
expected, the compiler didn't recognize 'begin' as the original
meaning, and skipped splicing internal defines.
Fix https://github.com/shirok/Gauche/issues/221
* src/class.c (Scm_ShortClassName): Unofficial API change: Previously
called Scm__InternalClassName. It's just a C function that strips
'<' and '>' from the class name, but its handy and used from
View
@@ -93,38 +93,43 @@
(export define-library)
;; A trick - must be replaced once we have explicit-renaming macro.
(define define-module. ((with-module gauche.internal make-identifier)
'define-module (find-module 'gauche) '()))
(define with-module. ((with-module gauche.internal make-identifier)
'with-module (find-module 'gauche) '()))
(define define-syntax. ((with-module gauche.internal make-identifier)
'define-syntax (find-module 'gauche) '()))
(define extend. ((with-module gauche.internal make-identifier)
'extend (find-module 'gauche) '()))
(define (global-id sym) ((with-module gauche.internal make-identifier)
sym (find-module 'gauche) '()))
(define define-module. (global-id 'define-module))
(define with-module. (global-id 'with-module))
(define define-syntax. (global-id 'define-syntax.))
(define extend. (global-id 'extend))
(define export. (global-id 'export))
(define begin. (global-id 'begin))
(define include. (global-id 'include))
(define include-ci. (global-id 'include-ci))
(define cond-expand. (global-id 'cond-expand))
(define r7rs-import. ((with-module gauche.internal make-identifier)
'r7rs-import (find-module 'r7rs.import) '()))
(define-macro (define-library name . decls)
`(,define-module. ,(library-name->module-name name)
(,define-syntax. export (,with-module. gauche export))
(,define-syntax. begin (,with-module. gauche begin))
(,define-syntax. include (,with-module. gauche include))
(,define-syntax. include-ci (,with-module. gauche include-ci))
(,define-syntax. cond-expand (,with-module. gauche cond-expand))
(,define-syntax. import (,with-module. r7rs.import r7rs-import))
(,extend.)
,@(map transform-decl decls)))
(define (transform-decl decl)
(cond [(eq? (car decl) 'include-library-declarations)
;; TODO: This is too permissive---this allows the files
;; to have not only library decls but also ordinary scheme
;; expressions. But this can delegate file searching business
;; to 'include' syntax so it's an easy path.
`(include ,@(cdr decl))]
[(memq (car decl)
'(export import include include-ci begin cond-expand))
decl]
[else
(error "Invalid library declaration:" decl)]))
;; Since define-library can't be an output of macro, we can just
;; compare symbols literally.
(case (car decl)
[(include-library-declarations)
;; TODO: This is too permissive---this allows the files
;; to have not only library decls but also ordinary scheme
;; expressions. But this can delegate file searching business
;; to 'include' syntax so it's an easy path.
`(,include. ,@(cdr decl))]
[(export) `(,export. ,@(cdr decl))]
[(import) `(,r7rs-import. ,@(cdr decl))]
[(begin) `(,begin. ,@(cdr decl))]
[(include) `(,include. ,@(cdr decl))]
[(include-ci) `(,include-ci. ,@(cdr decl))]
[(cond-expand) `(,cond-expand. ,@(cdr decl))]
[else (error "Invalid library declaration:" decl)]))
)
;;
View
@@ -2,6 +2,8 @@
;; This defines a compatibility module, then include Chibi's r7rs-tests to run.
;;
(use gauche.test)
;; fake (chibi test) used in r7rs-tests
(define-module chibi.test
(use gauche.test)
@@ -10,16 +12,8 @@
(define *nest-count* 0)
(define (test-begin msg)
(if (zero? *nest-count*)
(test-start msg)
(test-section msg))
(inc! *nest-count*))
(define (test-end)
(dec! *nest-count*)
(when (zero? *nest-count*)
(with-module gauche.test (test-end))))
(define (test-begin msg) (test-section msg))
(define (test-end) #f)
(define-syntax x:test
(syntax-rules ()
@@ -51,7 +45,40 @@
(define-syntax include (with-module gauche include)))
(provide "adaptor")
(test-start "r7rs-tests")
(require "r7rs")
(select-module r7rs.user)
(import (adaptor))
(include "include/r7rs-tests.scm")
(with-module r7rs.user
(import (adaptor))
(include "include/r7rs-tests.scm"))
;;
;; Some extra tests
;;
(test-section "Extra tests")
;;
;; https://github.com/shirok/Gauche/issues/221
;;
;; In 0.9.5 and before, expansion of insert-internal-define raises
;; syntax-error, since the binding of 'begin' is replaced by
;; define-library implementation.
(define-library (insert-internal-define)
(import (scheme base))
(export insert-internal-define)
(begin (define-syntax insert-internal-define
(syntax-rules ()
((_ x) (begin (define x 'yo!) x))))))
(define-module insert-internal-define.user
(import insert-internal-define))
(test* "insert internal define with r7rs library" 'yo!
(eval '(let ((a 'duh!)) (insert-internal-define a))
(find-module 'insert-internal-define.user)))
(test-end)

0 comments on commit a105612

Please sign in to comment.