~ chicken-core (chicken-5) 7f9f4545d8a6519076749a8dedc046e387eb50c5
commit 7f9f4545d8a6519076749a8dedc046e387eb50c5
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Aug 13 04:03:15 2010 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Aug 13 04:03:15 2010 -0400
import accepts (srfi N) as module name (suggested by Kon Lovett)
diff --git a/distribution/manifest b/distribution/manifest
index affd61e9..158c4385 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -137,6 +137,7 @@ tests/reexport-tests.scm
tests/ec.scm
tests/ec-tests.scm
tests/test-chained-modules.scm
+tests/import-tests.scm
tests/import-library-test1.scm
tests/import-library-test2.scm
tests/match-test.scm
diff --git a/eval.scm b/eval.scm
index ff35cfaf..0d8bb4fb 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1209,6 +1209,11 @@
,@(if (and imp? (or (not builtin?) (##sys#current-module)))
`((import ,id)) ;XXX make hygienic
'())))
+ (define (srfi-id n)
+ (if (fixnum? n)
+ (##sys#intern-symbol
+ (##sys#string-append "srfi-" (##sys#number->string n)))
+ (##sys#syntax-error 'require-extension "invalid SRFI number" n)))
(define (doit id impid)
(cond ((or (memq id builtin-features)
(if comp?
@@ -1273,21 +1278,19 @@
(exp
`(##core#begin
,@(map (lambda (n)
- (unless (fixnum? n)
- (##sys#syntax-error 'require-extension "invalid SRFI number" n))
- (let ((rid (string->symbol (string-append "srfi-" (number->string n)))))
+ (let ((rid (srfi-id n)))
(let-values (((exp f2) (doit rid rid)))
(set! f (or f f2))
exp)))
(cdr id)))))
(values exp f)))
((rename except only prefix)
- (doit
- (let follow ((id2 id))
- (if (and (pair? id2) (pair? (cdr id2)))
- (follow (cadr id2))
- id2))
- id))
+ (let follow ((id2 id))
+ (if (and (pair? id2) (pair? (cdr id2)))
+ (if (and (eq? 'srfi (car id2)) (null? (cddr id2))) ; only allow one number
+ (doit (srfi-id (cadr id2)) id)
+ (follow (cadr id2)))
+ (doit id2 id))))
(else (##sys#error "invalid extension specifier" id) ) ) )
((symbol? id)
(doit id id))
diff --git a/expand.scm b/expand.scm
index 3ca63b71..ad6fb9c1 100644
--- a/expand.scm
+++ b/expand.scm
@@ -838,7 +838,8 @@
(let ((%only (r 'only))
(%rename (r 'rename))
(%except (r 'except))
- (%prefix (r 'prefix)))
+ (%prefix (r 'prefix))
+ (%srfi (r 'srfi)))
(define (resolve sym)
(or (lookup sym '()) sym)) ;*** empty se?
(define (tostr x)
@@ -871,12 +872,16 @@
(cond ((symbol? spec) (import-name spec))
((or (not (list? spec)) (< (length spec) 2))
(syntax-error loc "invalid import specification" spec))
+ ((and (c %srfi (car spec)) (fixnum? (cadr spec)) (null? (cddr spec))) ; only one number
+ (import-name
+ (##sys#intern-symbol
+ (##sys#string-append "srfi-" (##sys#number->string (cadr spec))))))
(else
(let* ((s (car spec))
(imp (import-spec (cadr spec)))
(impv (car imp))
(imps (cdr imp)))
- (cond ((c %only (car spec))
+ (cond ((c %only s)
(##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
(let ((ids (map resolve (cddr spec))))
(let loop ((ids ids) (v '()) (s '()))
@@ -888,7 +893,7 @@
(lambda (a)
(loop (cdr ids) v (cons a s))))
(else (loop (cdr ids) v s))))))
- ((c %except (car spec))
+ ((c %except s)
(##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
(let ((ids (map resolve (cddr spec))))
(let loop ((impv impv) (v '()))
@@ -899,7 +904,7 @@
(else (loop (cdr imps) (cons (car imps) s))))))
((memq (caar impv) ids) (loop (cdr impv) v))
(else (loop (cdr impv) (cons (car impv) v)))))))
- ((c %rename (car spec))
+ ((c %rename s)
(##sys#check-syntax loc spec '(_ _ . #((symbol symbol) 0)))
(let loop ((impv impv) (imps imps) (v '()) (s '()) (ids (cddr spec)))
(cond ((null? impv)
@@ -925,7 +930,7 @@
(else (loop (cdr impv) imps
(cons (car impv) v)
s ids)))))
- ((c %prefix (car spec))
+ ((c %prefix s)
(##sys#check-syntax loc spec '(_ _ _))
(let ((pref (tostr (caddr spec))))
(define (ren imp)
diff --git a/manual/Modules b/manual/Modules
index 766bfd3e..510e548c 100644
--- a/manual/Modules
+++ b/manual/Modules
@@ -105,7 +105,8 @@ compilation unit, if compiled and used outside of a module.
Importing a module does not load or link it - this is a separate
operation from importing its bindings.
-{{IMPORT}} may be a module name, or an ''import specifier''.
+{{IMPORT}} may be a module name or an ''import specifier'', where a
+module name is either a symbol or a list of the form {{(srfi N)}}.
An {{IMPORT}} defines a set of bindings that are to be made visible
in the current scope.
diff --git a/tests/import-tests.scm b/tests/import-tests.scm
new file mode 100644
index 00000000..f6fd9949
--- /dev/null
+++ b/tests/import-tests.scm
@@ -0,0 +1,23 @@
+;;;; import-tests.scm
+
+
+(require-library (srfi 4))
+
+(module m1 ()
+(import scheme (only srfi-4 u8vector?)) u8vector?)
+
+(assert
+ (handle-exceptions ex #t
+ (eval '
+(module m2 ()
+(import scheme chicken (only (srfi 4) u8vector?))
+s8vector?)) #f))
+
+(module m3 ()
+(import scheme (rename (srfi 4) (u8vector? u8v?)))
+u8v?)
+
+(module m4 ()
+(import scheme chicken)
+(require-extension (prefix (srfi 4) s4:))
+s4:f32vector)
diff --git a/tests/runtests.sh b/tests/runtests.sh
index d75607f6..804edb17 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -125,6 +125,9 @@ echo "======================================== compiler syntax tests ..."
$compile compiler-syntax-tests.scm
./a.out
+echo "======================================== import tests ..."
+$interpret import-tests.scm
+
echo "======================================== import library tests ..."
rm -f ../foo.import.* foo.import.*
$compile import-library-test1.scm -emit-import-library foo
Trap