~ chicken-core (chicken-5) 9a42090d173ab29fa57de23af835a54c1aa92f6c
commit 9a42090d173ab29fa57de23af835a54c1aa92f6c
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sun Oct 11 17:56:24 2015 +1300
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Mon Nov 2 21:29:01 2015 +0100
Some refactoring to simplify import handling
Introduces a mapping from modules to unit names in eval.scm, for loading
code when a core module is required (with e.g. `use`).
Cleans up library list handling in eval.scm and modules.scm.
Standardizes syntax stripping behaviour across all of the four complex
import types ("prefix", "rename" et al.).
diff --git a/chicken-install.scm b/chicken-install.scm
index eb1b2fb3..0798dcc0 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -222,8 +222,8 @@
(cond ((or (eq? x 'chicken)
(equal? x "chicken")
(let ((xs (->string x)))
- (or (member xs ##sys#core-library-modules)
- (member xs ##sys#core-syntax-modules))))
+ (or (member xs ##sys#core-library-units)
+ (member xs ##sys#core-syntax-units))))
(chicken-version) )
((extension-information x) =>
(lambda (info)
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 6464808c..03f67fca 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1155,10 +1155,7 @@
(and (list? argname)
(= 2 (length argname))
(symbol? (car argname))
- (let ((param (cadr argname)))
- (or (symbol? param)
- (and (list? param)
- (every symbol? param))))))
+ (chicken.internal#valid-library-specifier? (cadr argname))))
(##sys#syntax-error-hook "invalid functor argument" name arg))
(cons argname exps)))
args)
diff --git a/eval.scm b/eval.scm
index 1db97c09..5ff73fa1 100644
--- a/eval.scm
+++ b/eval.scm
@@ -78,15 +78,22 @@
(define-foreign-variable uses-soname? bool "C_USES_SONAME")
(define-foreign-variable install-lib-name c-string "C_INSTALL_LIB_NAME")
-;; Core units under the "chicken" module namespace.
-(define ##sys#core-chicken-modules
- '(eval extras lolevel utils files tcp irregex posix data-structures ports))
-
-;; Core units outside the "chicken" module namespace.
-(define ##sys#core-library-modules
- `(srfi-4 . ,##sys#core-chicken-modules))
-
-(define ##sys#core-syntax-modules
+(define-constant core-chicken-modules
+ '((chicken.data-structures . data-structures)
+ (chicken.eval . eval)
+ (chicken.extras . extras)
+ (chicken.files . files)
+ (chicken.irregex . irregex)
+ (chicken.lolevel . lolevel)
+ (chicken.ports . ports)
+ (chicken.posix . posix)
+ (chicken.tcp . tcp)
+ (chicken.utils . utils)))
+
+(define ##sys#core-library-units
+ `(srfi-4 . ,(map cdr core-chicken-modules)))
+
+(define ##sys#core-syntax-units
'(chicken-syntax chicken-ffi-syntax))
(define ##sys#explicit-library-modules '())
@@ -1231,8 +1238,8 @@
(else (##sys#check-symbol id loc)) )
(let ([p (##sys#canonicalize-extension-path id loc)])
(cond ((member p ##sys#loaded-extensions))
- ((or (memq id ##sys#core-library-modules)
- (memq id ##sys#core-syntax-modules))
+ ((or (memq id ##sys#core-library-units)
+ (memq id ##sys#core-syntax-units))
(or (##sys#load-library-0 id #f)
(and err?
(##sys#error loc "cannot load core library" id))))
@@ -1297,7 +1304,7 @@
(define ##sys#do-the-right-thing
(let ((vector->list vector->list))
- (lambda (id comp? imp? #!optional (add-req void))
+ (lambda (spec comp? imp? #!optional (add-req void))
(define (impform x id builtin?)
`(##core#begin
,x
@@ -1310,7 +1317,7 @@
(values (impform '(##core#undefined) impid #t) #t id))
((and (not comp?) (##sys#feature? id))
(values (impform '(##core#undefined) impid #f) #t id))
- ((memq id ##sys#core-library-modules)
+ ((memq id ##sys#core-library-units)
(values
(impform
(if comp?
@@ -1318,7 +1325,7 @@
`(##sys#load-library ',id #f) )
impid #f)
#t id) )
- ((memq id ##sys#core-syntax-modules)
+ ((memq id ##sys#core-syntax-units)
(values
(impform
(if comp?
@@ -1369,36 +1376,21 @@
`(##sys#require ',id)
impid #f)
#f id)))))))
- (cond ((and (pair? id) (symbol? (car id)))
- (case (car id)
- ((srfi)
- (let* ((f #f)
- (exp
- `(##core#begin
- ,@(map (lambda (n)
- (let ((rid (srfi-id n)))
- (let-values (((exp f2 _) (doit rid)))
- (set! f (or f f2))
- exp)))
- (cdr id)))))
- (values exp f id))) ;XXX `id' not fully correct
- ((rename except only prefix)
- (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))))
- ((chicken)
- (if (memq (cadr id) ##sys#core-chicken-modules)
- (doit (cadr id) (library-id id))
- (doit (library-id id))))
- (else
- (doit (library-id id)))))
- ((symbol? id)
- (doit id))
- (else
- (##sys#error "invalid extension specifier" id))))))
+ (let loop ((id spec))
+ (cond ((assq id core-chicken-modules) =>
+ (lambda (lib) (doit (cdr lib) spec)))
+ ((symbol? id)
+ (doit (library-id id) spec))
+ ((pair? id)
+ (case (car id)
+ ((rename except only prefix)
+ (if (pair? (cdr id))
+ (loop (cadr id))
+ (loop (library-id id))))
+ (else
+ (loop (library-id id)))))
+ (else
+ (##sys#error "invalid extension specifier" id)))))))
;;; Convert string into valid C-identifier:
diff --git a/expand.scm b/expand.scm
index 257214d9..e8702ef9 100644
--- a/expand.scm
+++ b/expand.scm
@@ -106,7 +106,6 @@
alias) ) )
(define (strip-syntax exp)
- ;; if se is given, retain bound vars
(let ((seen '()))
(let walk ((x exp))
(cond ((assq x seen) => cdr)
diff --git a/internal.scm b/internal.scm
index 76f75af7..eda1fc48 100644
--- a/internal.scm
+++ b/internal.scm
@@ -30,28 +30,41 @@
(fixnum))
(module chicken.internal
- (srfi-id library-id)
+ (library-id valid-library-specifier?)
(import scheme chicken)
-(define (srfi-id n)
- (if (fixnum? n)
- (##sys#intern-symbol
- (##sys#string-append "srfi-" (##sys#number->string n)))
- (##sys#error "invalid SRFI number" n)))
+(include "mini-srfi-1.scm")
+
+(define (valid-library-specifier? x)
+ (or (symbol? x)
+ (and (list? x)
+ (not (null? x))
+ (every (lambda (x) (or (symbol? x) (fixnum? x))) x))))
(define (library-id lib)
- (define (library-part->string id)
- (cond ((symbol? id) (##sys#symbol->string id))
- ((number? id) (##sys#number->string id))
- (else (##sys#error "invalid library specifier" lib))))
+ (define (fail)
+ (##sys#error "invalid library specifier" lib))
+ (define (srfi? x)
+ (and (pair? (cdr x))
+ (null? (cddr x))
+ (eq? 'srfi (car x))
+ (fixnum? (cadr x))))
+ (define (library-part->string x)
+ (cond ((symbol? x) (##sys#symbol->string x))
+ ((fixnum? x) (##sys#number->string x))
+ (else (fail))))
(cond
((symbol? lib) lib)
- ((list? lib)
- (do ((lib (cdr lib) (cdr lib))
+ ((not (pair? lib)) (fail))
+ ((srfi? lib)
+ (##sys#intern-symbol
+ (##sys#string-append "srfi-" (##sys#number->string (cadr lib)))))
+ (else
+ (do ((lst (cdr lib) (cdr lst))
(str (library-part->string (car lib))
- (string-append str "." (library-part->string (car lib)))))
- ((null? lib) (##sys#intern-symbol str))))
- (else (##sys#error "invalid library specifier" lib))))
+ (string-append str "." (library-part->string (car lst)))))
+ ((null? lst)
+ (##sys#intern-symbol str))))))
) ; chicken.internal
diff --git a/modules.scm b/modules.scm
index ae4452ae..d7f1cc55 100644
--- a/modules.scm
+++ b/modules.scm
@@ -29,7 +29,7 @@
(uses eval expand internal)
(disable-interrupts)
(fixnum)
- (hide lookup merge-se module-indirect-exports)
+ (hide merge-se module-indirect-exports)
(not inline ##sys#alias-global-hook))
(include "common-declarations.scm")
@@ -56,13 +56,6 @@
;;; Support definitions
-;; duplicates code in the hope of being inlined
-(define (lookup id se)
- (cond ((##core#inline "C_u_i_assq" id se) => cdr)
- ((getp id '##core#macro-alias))
- (else #f)))
-
-
;;; low-level module support
(define ##sys#current-module (make-parameter #f))
@@ -555,8 +548,8 @@
;;; Import-expansion
-(define (##sys#find-module/import-library mname loc)
- (let* ((mname (##sys#resolve-module-name mname loc))
+(define (##sys#find-module/import-library lib loc)
+ (let* ((mname (##sys#resolve-module-name lib loc))
(mod (##sys#find-module mname #f loc)))
(unless mod
(let* ((il (##sys#find-extension
@@ -581,10 +574,7 @@
(let ((%only (r 'only))
(%rename (r 'rename))
(%except (r 'except))
- (%prefix (r 'prefix))
- (%srfi (r 'srfi)))
- (define (resolve sym)
- (or (lookup sym '()) sym)) ;XXX really empty se?
+ (%prefix (r 'prefix)))
(define (warn msg mod id)
(##sys#warn (string-append msg " in module `" (symbol->string mod) "'") id))
(define (tostr x)
@@ -594,66 +584,66 @@
((number? x) (number->string x))
(else (##sys#syntax-error-hook loc "invalid prefix" ))))
(define (import-name spec)
- (let* ((mod (##sys#find-module/import-library (chicken.expand#strip-syntax spec) 'import))
+ (let* ((mod (##sys#find-module/import-library spec 'import))
(vexp (module-vexports mod))
(sexp (module-sexports mod))
(iexp (module-iexports mod))
(name (module-name mod)))
(values name name vexp sexp iexp)))
(define (import-spec spec)
- (cond ((symbol? spec) (import-name spec))
- ((null? (cdr spec)) (import-name (car spec))) ; single library component
- ((and (c %srfi (car spec)) (fixnum? (cadr spec)) (null? (cddr spec))) ; only one number
- (import-name (chicken.internal#srfi-id (cadr spec))))
- (else
- (let ((head (car spec))
- (imports (cddr spec)))
+ (cond ((symbol? spec)
+ (import-name (chicken.expand#strip-syntax spec)))
+ ((not (pair? spec))
+ (##sys#syntax-error-hook loc "invalid import specification" spec))
+ (else
+ (let ((head (car spec)))
(cond ((c %only head)
(##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
- (let-values (((name form impv imps impi) (import-spec (cadr spec))))
- (let ((ids (map resolve imports)))
- (let loop ((ids ids) (v '()) (s '()) (missing '()))
- (cond ((null? ids)
- (for-each
- (lambda (id)
- (warn "imported identifier doesn't exist" name id))
- missing)
- (values name `(,head ,form ,@imports) v s impi))
- ((assq (car ids) impv) =>
- (lambda (a)
- (loop (cdr ids) (cons a v) s missing)))
- ((assq (car ids) imps) =>
- (lambda (a)
- (loop (cdr ids) v (cons a s) missing)))
- (else
- (loop (cdr ids) v s (cons (car ids) missing))))))))
+ (let-values (((name form impv imps impi) (import-spec (cadr spec)))
+ ((imports) (chicken.expand#strip-syntax (cddr spec))))
+ (let loop ((ids imports) (v '()) (s '()) (missing '()))
+ (cond ((null? ids)
+ (for-each
+ (lambda (id)
+ (warn "imported identifier doesn't exist" name id))
+ missing)
+ (values name `(,head ,form ,@imports) v s impi))
+ ((assq (car ids) impv) =>
+ (lambda (a)
+ (loop (cdr ids) (cons a v) s missing)))
+ ((assq (car ids) imps) =>
+ (lambda (a)
+ (loop (cdr ids) v (cons a s) missing)))
+ (else
+ (loop (cdr ids) v s (cons (car ids) missing)))))))
((c %except head)
(##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
- (let-values (((name form impv imps impi) (import-spec (cadr spec))))
- (let ((ids (map resolve imports)))
- (let loop ((impv impv) (v '()) (ids imports))
- (cond ((null? impv)
- (let loop ((imps imps) (s '()) (ids ids))
- (cond ((null? imps)
- (for-each
- (lambda (id)
- (warn "excluded identifier doesn't exist" name id))
- ids)
- (values name `(,head ,form ,@imports) v s impi))
- ((memq (caar imps) ids) =>
- (lambda (id)
- (loop (cdr imps) s (delete (car id) ids eq?))))
- (else
- (loop (cdr imps) (cons (car imps) s) ids)))))
- ((memq (caar impv) ids) =>
- (lambda (id)
- (loop (cdr impv) v (delete (car id) ids eq?))))
- (else
- (loop (cdr impv) (cons (car impv) v) ids)))))))
+ (let-values (((name form impv imps impi) (import-spec (cadr spec)))
+ ((imports) (chicken.expand#strip-syntax (cddr spec))))
+ (let loop ((impv impv) (v '()) (ids imports))
+ (cond ((null? impv)
+ (let loop ((imps imps) (s '()) (ids ids))
+ (cond ((null? imps)
+ (for-each
+ (lambda (id)
+ (warn "excluded identifier doesn't exist" name id))
+ ids)
+ (values name `(,head ,form ,@imports) v s impi))
+ ((memq (caar imps) ids) =>
+ (lambda (id)
+ (loop (cdr imps) s (delete (car id) ids eq?))))
+ (else
+ (loop (cdr imps) (cons (car imps) s) ids)))))
+ ((memq (caar impv) ids) =>
+ (lambda (id)
+ (loop (cdr impv) v (delete (car id) ids eq?))))
+ (else
+ (loop (cdr impv) (cons (car impv) v) ids))))))
((c %rename head)
(##sys#check-syntax loc spec '(_ _ . #((symbol symbol) 0)))
- (let-values (((name form impv imps impi) (import-spec (cadr spec))))
- (let loop ((impv impv) (v '()) (ids imports))
+ (let-values (((name form impv imps impi) (import-spec (cadr spec)))
+ ((renames) (chicken.expand#strip-syntax (cddr spec))))
+ (let loop ((impv impv) (v '()) (ids renames))
(cond ((null? impv)
(let loop ((imps imps) (s '()) (ids ids))
(cond ((null? imps)
@@ -661,7 +651,7 @@
(lambda (id)
(warn "renamed identifier doesn't exist" name id))
(map car ids))
- (values name `(,head ,form ,@imports) v s impi))
+ (values name `(,head ,form ,@renames) v s impi))
((assq (caar imps) ids) =>
(lambda (a)
(loop (cdr imps)
@@ -678,16 +668,16 @@
(loop (cdr impv) (cons (car impv) v) ids))))))
((c %prefix head)
(##sys#check-syntax loc spec '(_ _ _))
- (let-values (((name form impv imps impi) (import-spec (cadr spec))))
- (let ((pref (caddr spec)))
- (define (ren imp)
- (cons
- (##sys#string->symbol
- (##sys#string-append (tostr pref) (##sys#symbol->string (car imp))))
- (cdr imp) ) )
- (values name `(,head ,form ,pref) (map ren impv) (map ren imps) impi))))
+ (let-values (((name form impv imps impi) (import-spec (cadr spec)))
+ ((prefix) (chicken.expand#strip-syntax (caddr spec))))
+ (define (rename imp)
+ (cons
+ (##sys#string->symbol
+ (##sys#string-append (tostr prefix) (##sys#symbol->string (car imp))))
+ (cdr imp)))
+ (values name `(,head ,form ,prefix) (map rename impv) (map rename imps) impi)))
(else
- (import-name (chicken.internal#library-id spec))))))))
+ (import-name (chicken.expand#strip-syntax spec))))))))
(##sys#check-syntax loc x '(_ . #(_ 1)))
(let ((cm (##sys#current-module)))
(for-each
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 350d948a..70f732a0 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -42,17 +42,17 @@ Warning: at toplevel:
(scrutiny-tests.scm:29) in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a200) (procedure car ((pair a200 *)) a200))'
+ assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a196) (procedure car ((pair a196 *)) a196))'
Warning: at toplevel:
- expected in `let' binding of `g20' a single result, but were given 2 results
+ expected in `let' binding of `g18' a single result, but were given 2 results
Warning: at toplevel:
- in procedure call to `g20', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
+ in procedure call to `g18', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
Note: in toplevel procedure `foo':
expected value of type boolean in conditional but were given a value of type
- `(procedure bar42 () *)' which is always true:
+ `(procedure bar40 () *)' which is always true:
(if bar 3 (##core#undefined))
Trap