~ chicken-core (chicken-5) 09ae443c12cb7ec9b4e411d419dbb2f2e51d5eb3
commit 09ae443c12cb7ec9b4e411d419dbb2f2e51d5eb3
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Tue Jan 12 22:14:36 2016 +1300
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Tue Mar 8 22:52:33 2016 +1300
Rehaul library loading
Import libraries now include a library identifier that is consulted in
order to determine a module's presence. When loaded, a module provides
this identifier via `##sys#provide` from the eval unit.
When shared libraries are loaded with `##sys#require`, either via
`import` or some similar method, an attempt is made to enter a toplevel
corresponding to the required library's name before falling back to the
library's default, non-unit toplevel.
Units specified by the "-uses" flag are treated identically to those
declared used in-source.
The "-R" flags to csc(1) and csi(1) now use `import` to load the
requested libraries.
diff --git a/batch-driver.scm b/batch-driver.scm
index 46a327d0..a90601ce 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -217,8 +217,7 @@
(and-let* ((pn (memq 'profile-name options))) (cadr pn)))
(hsize (memq 'heap-size options))
(kwstyle (memq 'keyword-style options))
- (loop/dispatch (memq 'clustering options))
- (uses-units '())
+ (loop/dispatch (memq 'clustering options))
(unit (memq 'unit options))
(a-only (memq 'analyze-only options))
(dynamic (memq 'dynamic options))
@@ -405,10 +404,6 @@
ipath) )
(when (and outfile filename (string=? outfile filename))
(quit-compiling "source- and output-filename are the same") )
- (set! uses-units
- (append-map
- (lambda (u) (map string->symbol (string-split u ", ")))
- (collect-options 'uses)))
(when (memq 'keep-shadowed-macros options)
(set! undefine-shadowed-macros #f) )
(when (memq 'no-argc-checks options)
@@ -453,10 +448,18 @@
;; Append required extensions to initforms:
(set! initforms
- (append
- initforms
- (map (lambda (r) `(##core#require-extension (,(string->symbol r)) #t))
- (collect-options 'require-extension))))
+ (append
+ initforms
+ (map (lambda (r) `(import ,(string->symbol r)))
+ (collect-options 'require-extension))))
+
+ ;; Handle units added with the "-uses" flag.
+ (let ((uses (append-map
+ (lambda (u) (map string->symbol (string-split u ", ")))
+ (collect-options 'uses))))
+ (unless (null? uses)
+ (set! forms
+ (cons `(##core#declare (uses . ,uses)) forms))))
(when (memq 'compile-syntax options)
(set! ##sys#enable-runtime-macros #t) )
@@ -560,10 +563,6 @@
(print-expr "source" '|1| forms)
(begin-time)
- (unless (null? uses-units)
- (set! ##sys#explicit-library-modules
- (append ##sys#explicit-library-modules uses-units))
- (set! forms (cons `(declare (uses ,@uses-units)) forms)) )
;; Canonicalize s-expressions
(let* ((exps0 (map canonicalize-expression
(let ((forms (append initforms forms)))
@@ -580,10 +579,9 @@
(or profile-name #t)))
'() )
exps0
- (cond
- (unit-name `((##sys#unit-hook ',unit-name)))
- (dynamic '())
- (else cleanup-forms))
+ (if (or unit-name dynamic)
+ '()
+ cleanup-forms)
'((##core#undefined)))))
(unless (null? import-libraries)
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index b7c326a7..5761f855 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1083,7 +1083,7 @@
(##sys#er-transformer
(lambda (x r c)
(##sys#check-syntax 'use x '(_ . #(_ 0)))
- `(##core#require-extension ,(cdr x) #t))))
+ `(,(r 'require-extension) ,@(cdr x)))))
(##sys#extend-macro-environment
'use-for-syntax '()
diff --git a/core.scm b/core.scm
index f521bfa1..5faccf51 100644
--- a/core.scm
+++ b/core.scm
@@ -139,7 +139,7 @@
; (##core#define-external-variable <name> <type> <bool> [<symbol>])
; (##core#check <exp>)
; (##core#require-for-syntax <exp> ...)
-; (##core#require-extension (<id> ...) <bool>)
+; (##core#require <id> ...)
; (##core#app <exp> {<exp>})
; (##core#define-syntax <symbol> <expr>)
; (##core#define-compiler-syntax <symbol> <expr>)
@@ -668,36 +668,27 @@
(lambda () ids) )
'(##core#undefined) ) )
- ((##core#require-extension)
- (let ((imp? (caddr x)))
- (walk
- (let loop ([ids (strip-syntax (cadr x))])
- (if (null? ids)
- '(##core#undefined)
- (let ((id (car ids)))
- (let-values (((exp f realid)
- (##sys#do-the-right-thing
- id #t imp?
- (lambda (id* syntax?)
- (##sys#hash-table-update!
- ;; XXX FIXME: This is a bit of a hack. Why is it needed at all?
- file-requirements
- (if syntax? 'dynamic/syntax 'dynamic)
- (lambda (lst)
- (if (memq id* lst)
- lst
- (cons id* lst)))
- (lambda () (list id*)))))))
- (unless (or f
- (and (symbol? id)
- (##sys#find-extension
- (##sys#canonicalize-extension-path
- id 'require-extension)
- #f)))
+ ((##core#require)
+ (walk
+ (let loop ((ids (map strip-syntax (cdr x))))
+ (if (null? ids)
+ '(##core#undefined)
+ (let ((id (car ids)))
+ (let-values (((exp lib type)
+ (##sys#expand-require id #t used-units)))
+ (unless (not type)
+ (##sys#hash-table-update!
+ file-requirements
+ type
+ (cut lset-adjoin/eq? <> id)
+ (cut list id)))
+ (when (not lib)
+ (unless (##sys#find-extension
+ (##sys#canonicalize-extension-path id 'require) #f)
(warning
- (sprintf "extension `~A' is currently not installed" realid)))
- `(##core#begin ,exp ,(loop (cdr ids))) ) ) ) )
- e se dest ldest h ln) ) )
+ (sprintf "extension `~A' is currently not installed" id))))
+ `(##core#begin ,exp ,(loop (cdr ids)))))))
+ e se dest ldest h ln))
((##core#let)
(let* ((bindings (cadr x))
@@ -933,6 +924,7 @@
((##core#module)
(let* ((name (strip-syntax (cadr x)))
+ (unit (or unit-name name))
(exports
(or (eq? #t (caddr x))
(map (lambda (exp)
@@ -954,7 +946,7 @@
'module "modules may not be nested" name))
(let-values (((body module-registration)
(parameterize ((##sys#current-module
- (##sys#register-module name unit-name exports))
+ (##sys#register-module name unit exports))
(##sys#current-environment '())
(##sys#macro-environment
##sys#initial-macro-environment)
@@ -981,7 +973,7 @@
(delete il import-libraries)))
(values
(reverse xs)
- `((##sys#unit-hook ',name)))))
+ `((##sys#provide ',unit)))))
((not enable-module-registration)
(values
(reverse xs)
@@ -989,12 +981,12 @@
(else
(values
(reverse xs)
- `((##sys#unit-hook ',name)
+ `((##sys#provide ',unit)
.
,(if standalone-executable
- `()
- (##sys#compiled-module-registration
- (##sys#current-module))))))))
+ `()
+ (##sys#compiled-module-registration
+ (##sys#current-module))))))))
(else
(loop
(cdr body)
diff --git a/eval.scm b/eval.scm
index 33a6a9e8..2914afe9 100644
--- a/eval.scm
+++ b/eval.scm
@@ -95,8 +95,6 @@
(define-constant core-syntax-units
'(chicken-syntax chicken-ffi-syntax))
-(define ##sys#explicit-library-modules '())
-
(define-constant cygwin-default-dynamic-load-libraries '("cygchicken-0"))
(define-constant macosx-load-library-extension ".dylib")
(define-constant windows-load-library-extension ".dll")
@@ -667,8 +665,8 @@
(caddr x)))))
(when (##sys#current-module)
(##sys#syntax-error-hook 'module "modules may not be nested" name))
- (parameterize ((##sys#current-module
- (##sys#register-module name #f exports))
+ (parameterize ((##sys#current-module
+ (##sys#register-module name name exports))
(##sys#current-environment '())
(##sys#macro-environment
##sys#initial-macro-environment)
@@ -680,7 +678,7 @@
(if (null? body)
(let ((xs (reverse xs)))
(##sys#finalize-module (##sys#current-module))
- (##sys#unit-hook name)
+ (##sys#provide name)
(lambda (v)
(let loop2 ((xs xs))
(if (null? xs)
@@ -713,16 +711,14 @@
`(##sys#require ,@(map (lambda (x) `(##core#quote ,x)) rs)) )
e #f tf cntr se) ) ) ]
- [(##core#require-extension)
- (let ((imp? (caddr x)))
- (compile
- (let loop ((ids (strip-syntax (cadr x))))
- (if (null? ids)
- '(##core#undefined)
- (let-values (((exp f real-id)
- (##sys#do-the-right-thing (car ids) #f imp?)))
- `(##core#begin ,exp ,(loop (cdr ids))) ) ) )
- e #f tf cntr se) ) ]
+ [(##core#require)
+ (compile
+ (let loop ((ids (map strip-syntax (cdr x))))
+ (if (null? ids)
+ '(##core#undefined)
+ (let-values (((exp _ _) (##sys#expand-require (car ids))))
+ `(##core#begin ,exp ,(loop (cdr ids))))))
+ e #f tf cntr se)]
[(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
(##sys#eval/meta (cadr x))
@@ -954,6 +950,16 @@
(loop (##sys#slot mode 1)) ) )
(##sys#set-dlopen-flags! now global) ) )
+(define (toplevel name)
+ (if (not name)
+ "toplevel"
+ (##sys#string-append
+ (string->c-identifier (##sys#slot name 1))
+ "_toplevel")))
+
+(define (c-toplevel name loc)
+ (##sys#make-c-string (##sys#string-append "C_" (toplevel name)) loc))
+
(define load/internal
(let ((read read)
(write write)
@@ -961,56 +967,67 @@
(newline newline)
(eval eval)
(open-input-file open-input-file)
- (close-input-port close-input-port)
- (string-append string-append))
- (lambda (input evaluator #!optional pf timer printer)
+ (close-input-port close-input-port))
+ (lambda (input evaluator #!optional pf timer printer unit)
+
(define evalproc
(or evaluator eval))
- (define topentry
- (##sys#make-c-string "C_toplevel"))
- (define (has-sep? str)
- (let loop ([i (fx- (##sys#size str) 1)])
- (and (not (zero? i))
- (if (memq (##core#inline "C_subchar" str i) '(#\\ #\/))
- i
+
+ (define (has-slash? str)
+ (let loop ((i (fx- (##sys#size str) 1)))
+ (if (memq (##core#inline "C_subchar" str i) '(#\\ #\/))
+ i
+ (and (fx< 0 i)
(loop (fx- i 1))))))
+
+ ;; dload doesn't consider filenames without slashes to be paths,
+ ;; so we prepend a dot to force a relative pathname.
+ (define (dload-path path)
+ (if (has-slash? path)
+ path
+ (##sys#string-append "./" path)))
+
+ (define (dload path)
+ (let ((c-path (##sys#make-c-string (dload-path path) 'load)))
+ (or (##sys#dload c-path (c-toplevel unit 'load))
+ (and (symbol? unit)
+ (##sys#dload c-path (c-toplevel #f 'load))))))
+
+ (define dload?
+ (and (not ##sys#dload-disabled)
+ (##sys#fudge 24)))
+
(define fname
(cond ((port? input) #f)
((not (string? input))
(##sys#signal-hook #:type-error 'load "bad argument type - not a port or string" input))
((##sys#file-exists? input #t #f 'load) input)
(else
- (let ([fname2 (##sys#string-append input ##sys#load-dynamic-extension)])
- (if (and (not ##sys#dload-disabled)
- (##sys#fudge 24) ; dload?
- (##sys#file-exists? fname2 #t #f 'load))
+ (let ((fname2 (##sys#string-append input ##sys#load-dynamic-extension)))
+ (if (and dload? (##sys#file-exists? fname2 #t #f 'load))
fname2
- (let ([fname3 (##sys#string-append input source-file-extension)])
+ (let ((fname3 (##sys#string-append input source-file-extension)))
(if (##sys#file-exists? fname3 #t #f 'load)
fname3
input)))))))
+
(when (and (string? input) (not fname))
(##sys#signal-hook #:file-error 'load "cannot open file" input))
+
(when (and (load-verbose) fname)
(display "; loading ")
(display fname)
(display " ...\n")
(flush-output))
- (or (and fname
- (or (##sys#dload (##sys#make-c-string fname 'load) topentry)
- (and (not (has-sep? fname))
- (##sys#dload
- (##sys#make-c-string
- (##sys#string-append "./" fname)
- 'load)
- topentry))))
+
+ (or (and fname dload? (dload fname))
(call-with-current-continuation
(lambda (abrt)
(fluid-let ((##sys#read-error-with-line-number #t)
(##sys#current-source-filename fname)
(##sys#current-load-path
(and fname
- (let ((i (has-sep? fname)))
+ (let ((i (has-slash? fname)))
(if i (##sys#substring fname 0 (fx+ i 1)) "")))))
(let ((in (if fname (open-input-file fname) input)))
(##sys#dynamic-wind
@@ -1083,35 +1100,31 @@
x) ) ) )
(define load-library-0
- (let ([string-append string-append]
- [display display] )
+ (let ((display display))
(lambda (uname lib)
- (let ([id (##sys#->feature-id uname)])
- (or (##sys#get uname '##core#unit)
- (let ([libs
- (if lib
- (##sys#list lib)
- (cons (##sys#string-append (##sys#slot uname 1) load-library-extension)
- (dynamic-load-libraries) ) ) ]
- [top
- (##sys#make-c-string
- (string-append
- "C_"
- (##sys#string->c-identifier (##sys#slot uname 1))
- "_toplevel") 'load-library) ] )
- (when (load-verbose)
- (display "; loading library ")
- (display uname)
- (display " ...\n") )
- (let loop ((libs libs))
- (cond ((null? libs) #f)
- ((##sys#dload (##sys#make-c-string (##sys#slot libs 0) 'load-library) top) #t)
- (else (loop (##sys#slot libs 1)))))))))))
+ (or (##sys#provided? uname)
+ (let ((libs
+ (if lib
+ (##sys#list lib)
+ (cons (##sys#string-append (##sys#slot uname 1) load-library-extension)
+ (dynamic-load-libraries))))
+ (top
+ (c-toplevel uname 'load-library)))
+ (when (load-verbose)
+ (display "; loading library ")
+ (display uname)
+ (display " ...\n") )
+ (let loop ((libs libs))
+ (cond ((null? libs) #f)
+ ((##sys#dload (##sys#make-c-string (##sys#slot libs 0) 'load-library) top)
+ (##sys#provide uname))
+ (else (loop (##sys#slot libs 1))))))))))
(define load-library
- (lambda (uname . lib)
+ (lambda (uname #!optional lib)
(##sys#check-symbol uname 'load-library)
- (or (load-library-0 uname (and (pair? lib) (car lib)))
+ (unless (not lib) (##sys#check-string lib 'load-library))
+ (or (load-library-0 uname lib)
(##sys#error 'load-library "unable to load library" uname _dlerror) ) ) )
(define ##sys#load-library load-library)
@@ -1204,34 +1217,28 @@
(or (check pa)
(loop (##sys#slot paths 1)) ) ) ) ) ) ) ))
-(define loaded-extensions '())
-
-(define load-extension
- (let ((string->symbol string->symbol))
- (lambda (id loc #!optional (err? #t))
- (define (fail message)
- (and err? (##sys#error loc message id)))
- (cond ((string? id) (set! id (string->symbol id)))
- (else (##sys#check-symbol id loc)))
- (let ((p (##sys#canonicalize-extension-path id loc)))
- (cond ((##sys#get id '##core#unit))
- ((member p loaded-extensions))
- ((memq id core-syntax-units)
- (fail "cannot load core library"))
- ((memq id core-library-units)
- (or (load-library-0 id #f)
- (fail "cannot load core library")))
- (else
- (let ((id2 (##sys#find-extension p #f)))
- (cond (id2
- (load/internal id2 #f)
- (set! loaded-extensions (cons p loaded-extensions))
- #t)
- (else
- (fail "cannot load extension"))))))))))
+(define (load-extension id)
+ (define (fail message)
+ (##sys#error 'require message id))
+ (cond ((string? id) (set! id (string->symbol id)))
+ (else (##sys#check-symbol id 'require)))
+ (cond ((##sys#provided? id))
+ ((memq id core-syntax-units)
+ (fail "cannot load core library"))
+ ((memq id core-library-units)
+ (or (load-library-0 id #f)
+ (fail "cannot load core library")))
+ (else
+ (let* ((path (##sys#canonicalize-extension-path id 'require))
+ (ext (##sys#find-extension path #f)))
+ (cond (ext
+ (load/internal ext #f #f #f #f id)
+ (##sys#provide id))
+ (else
+ (fail "cannot load extension")))))))
(define (require . ids)
- (for-each (cut load-extension <> 'require) ids))
+ (for-each load-extension ids))
(define ##sys#require require)
@@ -1264,106 +1271,70 @@
'() )
(loop1 (cdr ids)) ) ) ) ) ) )
-(define ##sys#do-the-right-thing
- (let ((vector->list vector->list))
- (lambda (spec comp? imp? #!optional (add-req void))
- (define (impform x id builtin?)
- `(##core#begin
- ,x
- ,@(if (and imp? (or (not builtin?) (##sys#current-module)))
- `((import-syntax ,id)) ; XXX make hygienic
- '())))
- (define (doit id #!optional (impid id))
- (cond ((or (memq id builtin-features)
- (and comp? (memq id builtin-features/compiled)))
- (values (impform '(##core#undefined) impid #t) #t id))
- ((and (not comp?) (##sys#feature? id))
- (values (impform '(##core#undefined) impid #f) #t id))
- ((memq id core-syntax-units)
- (values (impform '(##core#undefined) impid #t) #t id))
- ((memq id core-library-units)
- (values
- (impform
- (if comp?
- `(##core#declare (uses ,id))
- `(##sys#load-library (##core#quote ,id) #f))
- impid #f)
- #t id) )
- ((memq id ##sys#explicit-library-modules)
- (let* ((info (extension-information/internal id 'require-extension))
- (nr (and info (assq 'import-only info)))
- (s (and info (assq 'syntax info))))
- (values
- `(##core#begin
- ,@(if s `((##core#require-for-syntax (##core#quote ,id))) '())
- ,(impform
- (if (not nr)
- (if comp?
- `(##core#declare (uses ,id))
- `(##sys#load-library (##core#quote ,id) #f))
- '(##core#undefined))
- impid #f))
- #t id) ) )
- (else
- (let ((info (extension-information/internal id 'require-extension)))
- (cond (info
- (let ((s (assq 'syntax info))
- (nr (assq 'import-only info))
- (rr (assq 'require-at-runtime info)) )
- (when s (add-req id #t))
- (values
- (impform
- `(##core#begin
- ,@(if s `((##core#require-for-syntax (##core#quote ,id))) '())
- ,@(if (or nr (and (not rr) s))
- '()
- (begin
- (add-req id #f)
- `((##sys#require
- ,@(map (lambda (id) `(##core#quote ,id))
- (cond (rr (cdr rr))
- (else (list id)) ) ) ) ) ) ) )
- impid #f)
- #t id) ) )
- (else
- (add-req id #f)
- (values
- (impform
- `(##sys#require (##core#quote ,id))
- impid #f)
- #f 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)))))))
+;;
+;; Given a library specification, returns three values:
+;;
+;; - an expression for loading the library, if required
+;; - a fixed-up library id if the library was found, #f otherwise
+;; - a requirement type (e.g. 'dynamic) or #f if provided statically
+;;
+(define (##sys#expand-require lib #!optional compiling? (static-units '()))
+ (let ((id (library-id lib)))
+ (cond
+ ((assq id core-chicken-modules) =>
+ (lambda (mod)
+ (##sys#expand-require (cdr mod) compiling? static-units)))
+ ((or (memq id builtin-features)
+ (and compiling? (memq id builtin-features/compiled)))
+ (values '(##core#undefined) id #f))
+ ((memq id static-units)
+ (values '(##core#undefined) id #f))
+ ((and (not compiling?) (##sys#feature? id))
+ (values '(##core#undefined) id #f))
+ ((memq id core-syntax-units)
+ (values '(##core#undefined) id #f))
+ ((memq id core-library-units)
+ (values
+ (if compiling?
+ `(##core#declare (uses ,id))
+ `(##sys#load-library (##core#quote ,id) #f))
+ id #f))
+ ((extension-information/internal id 'require) =>
+ (lambda (info)
+ (let ((s (assq 'syntax info))
+ (nr (assq 'import-only info))
+ (rr (assq 'require-at-runtime info)))
+ (values
+ `(##core#begin
+ ,@(if s `((##core#require-for-syntax (##core#quote ,id))) '())
+ ,@(if (or nr (and (not rr) s))
+ '()
+ (begin
+ `((##sys#require
+ ,@(map (lambda (id) `(##core#quote ,id))
+ (cond (rr (cdr rr))
+ (else (list id)))))))))
+ id
+ (if s 'dynamic/syntax 'dynamic)))))
+ (else
+ (values `(##sys#require (##core#quote ,id)) #f 'dynamic)))))
;;; Convert string into valid C-identifier:
(define (##sys#string->c-identifier str)
(let ((out (open-output-string))
- (n (string-length str)))
+ (n (string-length str)))
(do ((i 0 (fx+ i 1)))
- ((fx>= i n) (get-output-string out))
+ ((fx>= i n) (get-output-string out))
(let ((c (string-ref str i)))
- (if (and (not (char-alphabetic? c))
- (or (not (char-numeric? c)) (fx= i 0)))
- (let ((i (char->integer c)))
- (write-char #\_ out)
- (when (fx< i 16) (write-char #\0 out))
- (display (number->string i 16) out))
- (write-char c out))))))
+ (if (and (not (char-alphabetic? c))
+ (or (not (char-numeric? c)) (fx= i 0)))
+ (let ((i (char->integer c)))
+ (write-char #\_ out)
+ (when (fx< i 16) (write-char #\0 out))
+ (display (number->string i 16) out))
+ (write-char c out))))))
;;; Environments:
@@ -1388,8 +1359,10 @@
(foldr
(lambda (s r)
(if (memq (car s)
- '(import
+ '(import
import-syntax
+ import-for-syntax
+ import-syntax-for-syntax
require-extension
require-extension-for-syntax
require-library
@@ -1398,8 +1371,7 @@
module
cond-expand
syntax
- reexport
- import-for-syntax))
+ reexport))
r
(cons s r)))
'()
diff --git a/expand.scm b/expand.scm
index 2acc467a..1ac5f5b3 100644
--- a/expand.scm
+++ b/expand.scm
@@ -925,32 +925,51 @@
(##sys#extend-macro-environment
'import-syntax '()
(##sys#er-transformer
- (cut ##sys#expand-import <> <> <>
+ (cut ##sys#import <> <> <>
##sys#current-environment ##sys#macro-environment
- #f #f #f 'import-syntax)))
+ #f #f 'import-syntax)))
(##sys#extend-macro-environment
- 'import '()
+ 'import-syntax-for-syntax '()
+ (##sys#er-transformer
+ (cut ##sys#import <> <> <>
+ ##sys#current-meta-environment ##sys#meta-macro-environment
+ #t #f 'import-syntax-for-syntax)))
+
+(##sys#extend-macro-environment
+ 'reexport '()
(##sys#er-transformer
- (cut ##sys#expand-import <> <> <>
+ (cut ##sys#import <> <> <>
##sys#current-environment ##sys#macro-environment
- #f #f #t 'import)))
+ #f #t 'reexport)))
(##sys#extend-macro-environment
- 'import-for-syntax '()
+ 'import '()
(##sys#er-transformer
- (cut ##sys#expand-import <> <> <>
- ##sys#current-meta-environment ##sys#meta-macro-environment
- #t #f #t 'import-for-syntax)))
+ (lambda (x r c)
+ `(##core#begin
+ ,@(map (lambda (x)
+ (let-values (((mod lib _ _ _) (##sys#expand-import x r c 'import)))
+ `(##core#begin
+ (,(r 'import-syntax) ,mod)
+ (##core#require ,lib))))
+ (cdr x))))))
(##sys#extend-macro-environment
- 'reexport '()
+ 'begin-for-syntax '()
(##sys#er-transformer
- (cut ##sys#expand-import <> <> <>
- ##sys#current-environment ##sys#macro-environment
- #f #t #t 'reexport)))
+ (lambda (x r c)
+ (##sys#check-syntax 'begin-for-syntax x '(_ . #(_ 0)))
+ (##sys#register-meta-expression `(##core#begin ,@(cdr x)))
+ `(##core#elaborationtimeonly (##core#begin ,@(cdr x))))))
-;; contains only "import" and "reexport" forms
+(##sys#extend-macro-environment
+ 'import-for-syntax '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ `(,(r 'begin-for-syntax) (,(r 'import) ,@(cdr x))))))
+
+;; contains only syntax-related bindings
(define ##sys#initial-macro-environment (##sys#macro-environment))
(##sys#extend-macro-environment
@@ -1426,16 +1445,14 @@
'()
(##sys#er-transformer
(lambda (x r c)
- (let ((ids (cdr x)))
- `(##core#require-extension ,ids #f) ) ) ) )
+ `(##core#require ,@(cdr x)))))
(##sys#extend-macro-environment
'require-extension
'()
(##sys#er-transformer
(lambda (x r c)
- (let ((ids (cdr x)))
- `(##core#require-extension ,ids #t) ) ) ) )
+ `(,(r 'import) ,@(cdr x)))))
(##sys#extend-macro-environment
'require-extension-for-syntax
@@ -1501,15 +1518,6 @@
`((##core#include ,(car body)))
body))))))))))
-(##sys#extend-macro-environment
- 'begin-for-syntax
- '()
- (##sys#er-transformer
- (lambda (x r c)
- (##sys#check-syntax 'begin-for-syntax x '(_ . #(_ 0)))
- (##sys#register-meta-expression `(##core#begin ,@(cdr x)))
- `(##core#elaborationtimeonly (##core#begin ,@(cdr x))))))
-
(##sys#extend-macro-environment
'export
'()
diff --git a/internal.scm b/internal.scm
index e54669d3..96d77fa3 100644
--- a/internal.scm
+++ b/internal.scm
@@ -30,12 +30,32 @@
(fixnum))
(module chicken.internal
- (library-id valid-library-specifier?)
+ (library-id valid-library-specifier? string->c-identifier)
(import scheme chicken)
(include "mini-srfi-1.scm")
+
+;;; Convert string into valid C-identifier:
+
+(define (string->c-identifier str)
+ (let ((out (open-output-string))
+ (n (string-length str)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx>= i n) (get-output-string out))
+ (let ((c (string-ref str i)))
+ (if (and (not (char-alphabetic? c))
+ (or (not (char-numeric? c)) (fx= i 0)))
+ (let ((i (char->integer c)))
+ (write-char #\_ out)
+ (when (fx< i 16) (write-char #\0 out))
+ (display (number->string i 16) out))
+ (write-char c out))))))
+
+
+;;; Parse library specifications:
+
(define (valid-library-specifier? x)
(or (symbol? x)
(and (list? x)
diff --git a/modules.scm b/modules.scm
index d0acb944..22034f18 100644
--- a/modules.scm
+++ b/modules.scm
@@ -65,7 +65,7 @@
(declare
(hide make-module module? %make-module
- module-name module-unit
+ module-name module-library
module-vexports module-sexports
set-module-vexports! set-module-sexports!
module-export-list set-module-export-list!
@@ -79,12 +79,12 @@
module-iexports set-module-iexports!))
(define-record-type module
- (%make-module name unit export-list defined-list exist-list defined-syntax-list
+ (%make-module name library export-list defined-list exist-list defined-syntax-list
undefined-list import-forms meta-import-forms meta-expressions
vexports sexports iexports saved-environments)
module?
(name module-name) ; SYMBOL
- (unit module-unit) ; SYMBOL
+ (library module-library) ; SYMBOL
(export-list module-export-list set-module-export-list!) ; (SYMBOL | (SYMBOL ...) ...)
(defined-list module-defined-list set-module-defined-list!) ; ((SYMBOL . VALUE) ...) - *exported* value definitions
(exist-list module-exist-list set-module-exist-list!) ; (SYMBOL ...) - only for checking refs to undef'd
@@ -107,8 +107,8 @@
(module-vexports m)
(module-sexports m)))
-(define (make-module name unit explist vexports sexports iexports)
- (%make-module name unit explist '() '() '() '() '() '() '() vexports sexports iexports #f))
+(define (make-module name lib explist vexports sexports iexports)
+ (%make-module name lib explist '() '() '() '() '() '() '() vexports sexports iexports #f))
(define (##sys#register-module-alias alias name)
(##sys#module-alias-environment
@@ -229,8 +229,8 @@
mod
(cons (cons sym (if where (list where) '())) ul)))))))
-(define (##sys#register-module name unit explist #!optional (vexports '()) (sexports '()))
- (let ((mod (make-module name unit explist vexports sexports '())))
+(define (##sys#register-module name lib explist #!optional (vexports '()) (sexports '()))
+ (let ((mod (make-module name lib explist vexports sexports '())))
(set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
mod) )
@@ -302,12 +302,12 @@
(ifs (module-import-forms mod))
(sexports (module-sexports mod))
(mifs (module-meta-import-forms mod)))
- `(,@(if (pair? ifs) `((chicken.eval#eval '(import ,@(chicken.expand#strip-syntax ifs)))) '())
- ,@(if (pair? mifs) `((import ,@(chicken.expand#strip-syntax mifs))) '())
+ `(,@(if (pair? ifs) `((chicken.eval#eval '(import-syntax ,@(chicken.expand#strip-syntax ifs)))) '())
+ ,@(if (pair? mifs) `((import-syntax ,@(chicken.expand#strip-syntax mifs))) '())
,@(##sys#fast-reverse (map chicken.expand#strip-syntax (module-meta-expressions mod)))
(##sys#register-compiled-module
',(module-name mod)
- ',(module-unit mod)
+ ',(module-library mod)
(list
,@(map (lambda (ie)
(if (symbol? (cdr ie))
@@ -336,7 +336,7 @@
(cons `(cons ',(caar sd) ,(chicken.expand#strip-syntax (cdar sd)))
(loop (cdr sd)))))))))))))
-(define (##sys#register-compiled-module name unit iexports vexports sexports #!optional
+(define (##sys#register-compiled-module name lib iexports vexports sexports #!optional
(sdefs '()))
(define (find-reexport name)
(let ((a (assq name (##sys#macro-environment))))
@@ -361,7 +361,7 @@
(map (lambda (ne)
(list (car ne) #f (##sys#ensure-transformer (cdr ne) (car ne))))
sdefs))
- (mod (make-module name unit '() vexports sexps iexps))
+ (mod (make-module name lib '() vexports sexps iexps))
(senv (merge-se
(##sys#macro-environment)
(##sys#current-environment)
@@ -397,7 +397,7 @@
(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
(let* ((me (##sys#macro-environment))
(mod (make-module
- name #f '()
+ name name '()
(map (lambda (ve)
(if (symbol? ve)
(cons ve (##sys#primitive-alias ve))
@@ -575,7 +575,7 @@
mname)))))
mod))
-(define (##sys#expand-import x r c import-env macro-env meta? reexp? load? loc)
+(define (##sys#expand-import x r c loc)
(let ((%only (r 'only))
(%rename (r 'rename))
(%except (r 'except))
@@ -588,31 +588,31 @@
((symbol? x) (##sys#symbol->string x))
((number? x) (number->string x))
(else (##sys#syntax-error-hook loc "invalid prefix" ))))
- (define (import-name spec)
- (let* ((mod (find-module/import-library spec 'import))
- (vexp (module-vexports mod))
- (sexp (module-sexports mod))
- (iexp (module-iexports mod))
- (name (module-name mod)))
- (values mod name name vexp sexp iexp)))
- (define (import-spec spec)
- (cond ((symbol? spec)
- (import-name (chicken.expand#strip-syntax spec)))
- ((not (pair? spec))
- (##sys#syntax-error-hook loc "invalid import specification" spec))
+ (define (module-imports name)
+ (let ((mod (find-module/import-library name loc)))
+ (values (module-name mod)
+ (module-library mod)
+ (module-vexports mod)
+ (module-sexports mod)
+ (module-iexports mod))))
+ (let loop ((x x))
+ (cond ((symbol? x)
+ (module-imports (chicken.expand#strip-syntax x)))
+ ((not (pair? x))
+ (##sys#syntax-error-hook loc "invalid import specification" x))
(else
- (let ((head (car spec)))
+ (let ((head (car x)))
(cond ((c %only head)
- (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
- (let-values (((mod name form impv imps impi) (import-spec (cadr spec)))
- ((imports) (chicken.expand#strip-syntax (cddr spec))))
+ (##sys#check-syntax loc x '(_ _ . #(symbol 0)))
+ (let-values (((form name impv imps impi) (loop (cadr x)))
+ ((imports) (chicken.expand#strip-syntax (cddr x))))
(let loop ((ids imports) (v '()) (s '()) (missing '()))
(cond ((null? ids)
(for-each
(lambda (id)
(warn "imported identifier doesn't exist" name id))
missing)
- (values mod name `(,head ,form ,@imports) v s impi))
+ (values `(,head ,form ,@imports) name v s impi))
((assq (car ids) impv) =>
(lambda (a)
(loop (cdr ids) (cons a v) s missing)))
@@ -622,9 +622,9 @@
(else
(loop (cdr ids) v s (cons (car ids) missing)))))))
((c %except head)
- (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
- (let-values (((mod name form impv imps impi) (import-spec (cadr spec)))
- ((imports) (chicken.expand#strip-syntax (cddr spec))))
+ (##sys#check-syntax loc x '(_ _ . #(symbol 0)))
+ (let-values (((form name impv imps impi) (loop (cadr x)))
+ ((imports) (chicken.expand#strip-syntax (cddr x))))
(let loop ((impv impv) (v '()) (ids imports))
(cond ((null? impv)
(let loop ((imps imps) (s '()) (ids ids))
@@ -633,7 +633,7 @@
(lambda (id)
(warn "excluded identifier doesn't exist" name id))
ids)
- (values mod name `(,head ,form ,@imports) v s impi))
+ (values `(,head ,form ,@imports) name v s impi))
((memq (caar imps) ids) =>
(lambda (id)
(loop (cdr imps) s (delete (car id) ids eq?))))
@@ -645,9 +645,9 @@
(else
(loop (cdr impv) (cons (car impv) v) ids))))))
((c %rename head)
- (##sys#check-syntax loc spec '(_ _ . #((symbol symbol) 0)))
- (let-values (((mod name form impv imps impi) (import-spec (cadr spec)))
- ((renames) (chicken.expand#strip-syntax (cddr spec))))
+ (##sys#check-syntax loc x '(_ _ . #((symbol symbol) 0)))
+ (let-values (((form name impv imps impi) (loop (cadr x)))
+ ((renames) (chicken.expand#strip-syntax (cddr x))))
(let loop ((impv impv) (v '()) (ids renames))
(cond ((null? impv)
(let loop ((imps imps) (s '()) (ids ids))
@@ -656,7 +656,7 @@
(lambda (id)
(warn "renamed identifier doesn't exist" name id))
(map car ids))
- (values mod name `(,head ,form ,@renames) v s impi))
+ (values `(,head ,form ,@renames) name v s impi))
((assq (caar imps) ids) =>
(lambda (a)
(loop (cdr imps)
@@ -672,82 +672,77 @@
(else
(loop (cdr impv) (cons (car impv) v) ids))))))
((c %prefix head)
- (##sys#check-syntax loc spec '(_ _ _))
- (let-values (((mod name form impv imps impi) (import-spec (cadr spec)))
- ((prefix) (chicken.expand#strip-syntax (caddr spec))))
+ (##sys#check-syntax loc x '(_ _ _))
+ (let-values (((name lib impv imps impi) (loop (cadr x)))
+ ((prefix) (chicken.expand#strip-syntax (caddr x))))
(define (rename imp)
(cons
(##sys#string->symbol
(##sys#string-append (tostr prefix) (##sys#symbol->string (car imp))))
(cdr imp)))
- (values mod name `(,head ,form ,prefix) (map rename impv) (map rename imps) impi)))
+ (values `(,head ,name ,prefix) lib (map rename impv) (map rename imps) impi)))
(else
- (import-name (chicken.expand#strip-syntax spec))))))))
- (##sys#check-syntax loc x '(_ . #(_ 1)))
- (let ((cm (##sys#current-module)))
- `(##core#begin
- .
- ,(map (lambda (spec)
- (let-values (((mod name form vsv vss vsi) (import-spec spec)))
- (when cm ; save import form
- (if meta?
- (set-module-meta-import-forms!
- cm
- (append (module-meta-import-forms cm) (list form)))
- (set-module-import-forms!
- cm
- (append (module-import-forms cm) (list form)))))
- (dd `(IMPORT: ,loc))
- (dd `(V: ,(if cm (module-name cm) '<toplevel>) ,(map-se vsv)))
- (dd `(S: ,(if cm (module-name cm) '<toplevel>) ,(map-se vss)))
- (mark-imported-symbols vsv) ; mark imports as ##core#aliased
- (for-each
- (lambda (imp)
- (and-let* ((id (car imp))
- (a (assq id (import-env)))
- (aid (cdr imp))
- ((not (eq? aid (cdr a)))))
- (##sys#notice "re-importing already imported identifier" id)))
- vsv)
- (for-each
- (lambda (imp)
- (and-let* ((a (assq (car imp) (macro-env)))
- ((not (eq? (cdr imp) (cdr a)))))
- (##sys#notice "re-importing already imported syntax" (car imp))))
- vss)
- (when reexp?
- (unless cm
- (##sys#syntax-error-hook loc "`reexport' only valid inside a module"))
- (let ((el (module-export-list cm)))
- (cond ((eq? #t el)
- (set-module-sexports! cm (append vss (module-sexports cm)))
- (set-module-exist-list!
- cm
- (append (module-exist-list cm)
- (map car vsv)
- (map car vss))))
- (else
- (set-module-export-list!
- cm
- (append
- (let ((xl (module-export-list cm)))
- (if (eq? #t xl) '() xl))
- (map car vsv)
- (map car vss))))))
- (set-module-iexports!
+ (module-imports (chicken.expand#strip-syntax x))))))))))
+
+(define (##sys#import x r c import-env macro-env meta? reexp? loc)
+ (##sys#check-syntax loc x '(_ . #(_ 1)))
+ (let ((cm (##sys#current-module)))
+ (for-each
+ (lambda (spec)
+ (let-values (((name _ vsv vss vsi) (##sys#expand-import spec r c loc)))
+ (when cm ; save import form
+ (if meta?
+ (set-module-meta-import-forms!
+ cm
+ (append (module-meta-import-forms cm) (list name)))
+ (set-module-import-forms!
+ cm
+ (append (module-import-forms cm) (list name)))))
+ (dd `(IMPORT: ,loc))
+ (dd `(V: ,(if cm (module-name cm) '<toplevel>) ,(map-se vsv)))
+ (dd `(S: ,(if cm (module-name cm) '<toplevel>) ,(map-se vss)))
+ (mark-imported-symbols vsv) ; mark imports as ##core#aliased
+ (for-each
+ (lambda (imp)
+ (and-let* ((id (car imp))
+ (a (assq id (import-env)))
+ (aid (cdr imp))
+ ((not (eq? aid (cdr a)))))
+ (##sys#notice "re-importing already imported identifier" id)))
+ vsv)
+ (for-each
+ (lambda (imp)
+ (and-let* ((a (assq (car imp) (macro-env)))
+ ((not (eq? (cdr imp) (cdr a)))))
+ (##sys#notice "re-importing already imported syntax" (car imp))))
+ vss)
+ (when reexp?
+ (unless cm
+ (##sys#syntax-error-hook loc "`reexport' only valid inside a module"))
+ (let ((el (module-export-list cm)))
+ (cond ((eq? #t el)
+ (set-module-sexports! cm (append vss (module-sexports cm)))
+ (set-module-exist-list!
cm
- (merge-se (module-iexports cm) vsi))
- (dm "export-list: " (module-export-list cm)))
- (import-env (append vsv (import-env)))
- (macro-env (append vss (macro-env)))
- (let ((unit (module-unit mod)))
- (cond ((not load?)
- '(##core#undefined))
- ((symbol? unit)
- `(##core#require-extension (,unit) #f))
- (else
- `(##core#require-extension (,name) #f))))))
- (cdr x))))))
+ (append (module-exist-list cm)
+ (map car vsv)
+ (map car vss))))
+ (else
+ (set-module-export-list!
+ cm
+ (append
+ (let ((xl (module-export-list cm)))
+ (if (eq? #t xl) '() xl))
+ (map car vsv)
+ (map car vss))))))
+ (set-module-iexports!
+ cm
+ (merge-se (module-iexports cm) vsi))
+ (dm "export-list: " (module-export-list cm)))
+ (import-env (append vsv (import-env)))
+ (macro-env (append vss (macro-env)))))
+ (cdr x))
+ '(##core#undefined)))
(define (module-rename sym prefix)
(##sys#string->symbol
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 472ade0f..33f2d65c 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -1,9 +1,8 @@
;;;; compiler-tests.scm
-(import foreign)
-(use-for-syntax data-structures)
-(use srfi-4)
+(import (chicken foreign) srfi-4)
+(import-for-syntax data-structures (chicken expand))
;; test dropping of previous toplevel assignments
diff --git a/tests/meta-syntax-test.scm b/tests/meta-syntax-test.scm
index 1b05ee98..b53d7a3f 100755
--- a/tests/meta-syntax-test.scm
+++ b/tests/meta-syntax-test.scm
@@ -4,10 +4,10 @@
;; A module's syntax definitions should be accessible through either of
;; the following import forms:
;;
-;; (import-for-syntax (foo)) ; meta environment
+;; (import-syntax-for-syntax (foo)) ; meta environment
;;
-;; (begin-for-syntax ; compiler environment
-;; (import-syntax (foo))) ; note that `import` will not work here
+;; (begin-for-syntax ; compiler environment
+;; (import-syntax (foo))) ; note that `import` will not work here
;;
(module foo (bar listify)
@@ -29,15 +29,15 @@
(lambda (e r c)
(call-it-123 list)))))
-(module test-import-for-syntax (test)
+(module test-import-syntax-for-syntax (test)
(import chicken scheme)
- (import-for-syntax (prefix foo foo:))
- (define-syntax test-import-for-syntax
+ (import-syntax-for-syntax (prefix foo foo:))
+ (define-syntax test-import-syntax-for-syntax
(er-macro-transformer
(lambda (x r c)
`(,(r 'quote) ,@(foo:bar 1 2)))))
(define (test)
- (test-import-for-syntax)))
+ (test-import-syntax-for-syntax)))
(module test-begin-for-syntax (test)
(import chicken scheme)
diff --git a/tests/reexport-m2.scm b/tests/reexport-m2.scm
index 923491a9..f3b5ad25 100644
--- a/tests/reexport-m2.scm
+++ b/tests/reexport-m2.scm
@@ -1,6 +1,5 @@
;;;; module importing from module that reexports core binding
(module foo ()
- (import scheme chicken)
- (use reexport-m1)
+ (import scheme chicken reexport-m1)
(print (cons 1 2)))
diff --git a/tests/reexport-m4.scm b/tests/reexport-m4.scm
index 4ccea9ec..4f18ef68 100644
--- a/tests/reexport-m4.scm
+++ b/tests/reexport-m4.scm
@@ -2,8 +2,7 @@
(module
reexport-m4
(baz)
- (import chicken scheme)
- (use reexport-m3)
+ (import chicken scheme reexport-m3)
(reexport reexport-m3)
(define-syntax baz
(ir-macro-transformer
diff --git a/tests/reexport-tests-2.scm b/tests/reexport-tests-2.scm
index dadab728..14b51c5a 100644
--- a/tests/reexport-tests-2.scm
+++ b/tests/reexport-tests-2.scm
@@ -1,5 +1,5 @@
;;; export of syntax referring to reexported syntax binding
-(use reexport-m4)
+(import reexport-m4)
(print (baz))
;;; reexport of renamed syntax
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 88b58278..84fa95aa 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -200,10 +200,10 @@ $compile syntax-tests-2.scm
./a.out
echo "======================================== meta-syntax tests ..."
-$interpret -bnq meta-syntax-test.scm -e '(import foo)' -e "(assert (equal? '((1)) (bar 1 2)))" -e "(assert (equal? '(list 1 2 3) (listify)))" -e "(import test-import-for-syntax)" -e "(assert (equal? '(1) (test)))" -e "(import test-begin-for-syntax)" -e "(assert (equal? '(1) (test)))"
+$interpret -bnq meta-syntax-test.scm -e '(import foo)' -e "(assert (equal? '((1)) (bar 1 2)))" -e "(assert (equal? '(list 1 2 3) (listify)))" -e "(import test-import-syntax-for-syntax)" -e "(assert (equal? '(1) (test)))" -e "(import test-begin-for-syntax)" -e "(assert (equal? '(1) (test)))"
$compile_s meta-syntax-test.scm -j foo
$compile_s foo.import.scm
-$interpret -bnq meta-syntax-test.scm -e '(import foo)' -e "(assert (equal? '((1)) (bar 1 2)))" -e "(assert (equal? '(list 1 2 3) (listify)))" -e "(import test-import-for-syntax)" -e "(assert (equal? '(1) (test)))" -e "(import test-begin-for-syntax)" -e "(assert (equal? '(1) (test)))"
+$interpret -bnq meta-syntax-test.scm -e '(import foo)' -e "(assert (equal? '((1)) (bar 1 2)))" -e "(assert (equal? '(list 1 2 3) (listify)))" -e "(import test-import-syntax-for-syntax)" -e "(assert (equal? '(1) (test)))" -e "(import test-begin-for-syntax)" -e "(assert (equal? '(1) (test)))"
echo "======================================== reexport tests ..."
$interpret -bnq reexport-tests.scm
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index c444f353..490ece11 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -43,10 +43,10 @@ Warning: at toplevel:
assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a) (procedure car ((pair a *)) a))'
Warning: at toplevel:
- expected a single result in `let' binding of `g18', but received 2 results
+ expected in `let' binding of `g38' a single result, but were given 2 results
Warning: at toplevel:
- in procedure call to `g18', expected a value of type `(procedure () *)' but was given a value of type `fixnum'
+ in procedure call to `g38', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
Note: in toplevel procedure `foo':
expected a value of type boolean in conditional, but was given a value of type `(procedure bar () *)' which is always true:
Trap