~ chicken-core (chicken-5) e15ef2ef871046567bfd285534ff207c1e44773d
commit e15ef2ef871046567bfd285534ff207c1e44773d
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Fri Jan 1 12:11:59 2016 +1300
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Tue Mar 8 22:52:32 2016 +1300
Make import load, add unit info to import libraries, track unit execution
Adds a load flag to import expansion, to indicate whether to a module's
code should be loaded when its identifiers are imported.
Tracks library loading with a new "unit hook". This requires pulling
build-version into library.scm so that library (which provides the hook)
is always the first unit loaded.
diff --git a/batch-driver.scm b/batch-driver.scm
index fc78c4dd..040858c5 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -580,16 +580,17 @@
,@forms))))))
(exps (append
(map (lambda (ic) `(set! ,(cdr ic) ',(car ic))) immutable-constants)
- (map (lambda (n) `(##core#callunit ,n)) used-units)
+ (map (lambda (uu) `(##core#callunit ,uu)) used-units)
(if emit-profile
(profiling-prelude-exps (and (not unit-name)
(or profile-name #t)))
'() )
exps0
- (if (and (not unit-name) (not dynamic))
- cleanup-forms
- '() )
- '((##core#undefined))) ) )
+ (cond
+ (unit-name `((##sys#unit-hook ',unit-name)))
+ (dynamic '())
+ (else cleanup-forms))
+ '((##core#undefined)))))
(unless (null? import-libraries)
(quit-compiling
diff --git a/c-backend.scm b/c-backend.scm
index 2940dfdf..1061043a 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -67,6 +67,7 @@
;; Hacky procedures to make certain names more suitable for use in C.
(define (backslashify s) (string-translate (->string s) "\\" "\\\\"))
(define (uncommentify s) (string-translate* (->string s) '(("*/" . "*_/"))))
+(define (c-identifier s) (string->c-identifier (->string s)))
;;; Generate target code:
@@ -391,7 +392,7 @@
(nf (+ n 1)) )
(gen #\{)
(push-args subs i "C_SCHEME_UNDEFINED")
- (gen #t "C_" (first params) "_toplevel(" nf ",av2);}")))
+ (gen #t "C_" (c-identifier (first params)) "_toplevel(" nf ",av2);}")))
((##core#return)
(gen #t "return(")
@@ -532,10 +533,12 @@
" command line: ")
(gen-list user-supplied-options)
(gen #t)
- (cond [unit-name (gen " unit: " unit-name)]
- [else
- (gen " used units: ")
- (gen-list used-units) ] )
+ (cond
+ (unit-name
+ (gen " unit: " unit-name))
+ (else
+ (gen " used units: ")
+ (gen-list used-units)))
(gen #t "*/" #t #t "#include \"" target-include-file "\"")
(when external-protos-first
(generate-foreign-callback-stub-prototypes foreign-callback-stubs) )
@@ -557,10 +560,10 @@
(let ((n (length literals)))
(gen #t #t "static C_PTABLE_ENTRY *create_ptable(void);")
(for-each
- (lambda (uu)
+ (lambda (uu)
(gen #t "C_noret_decl(C_" uu "_toplevel)"
#t "C_externimport void C_ccall C_" uu "_toplevel(C_word c,C_word *av) C_noret;"))
- used-units)
+ (map c-identifier used-units))
(unless (zero? n)
(gen #t #t "static C_TLS C_word lf[" n "];") )
(gen #t "static double C_possibly_force_alignment;")
@@ -604,7 +607,7 @@
(gen "C_ccall ") )
(gen id) )
(else
- (let ((uname (if unit-name (string-append unit-name "_toplevel") "toplevel")))
+ (let ((uname (if unit-name (string-append (c-identifier unit-name) "_toplevel") "toplevel")))
(gen "C_noret_decl(C_" uname ")" #t) ;XXX what's this for?
(gen "C_externexport void C_ccall ")
(gen "C_" uname) ) ) )
@@ -760,7 +763,7 @@
(temps (lambda-literal-temporaries ll))
(ubtemps (lambda-literal-unboxed-temporaries ll))
(topname (if unit-name
- (string-append unit-name "_toplevel")
+ (string-append (c-identifier unit-name) "_toplevel")
"toplevel") ) )
(when empty-closure (debugging 'o "dropping unused closure argument" id))
(gen #t #t)
@@ -930,7 +933,7 @@
(gen #t "{\"" id #\: (string->c-identifier sf) "\",(void*)")
(if (eq? 'toplevel id)
(if unit-name
- (gen "C_" unit-name "_toplevel},")
+ (gen "C_" (c-identifier unit-name) "_toplevel},")
(gen "C_toplevel},") )
(gen id "},") ) )
lambda-table)
diff --git a/core.scm b/core.scm
index 252313fc..2617d7ed 100644
--- a/core.scm
+++ b/core.scm
@@ -955,7 +955,7 @@
'module "modules may not be nested" name))
(let-values (((body mreg)
(parameterize ((##sys#current-module
- (##sys#register-module name exports) )
+ (##sys#register-module name unit-name exports))
(##sys#current-environment '())
(##sys#macro-environment
##sys#initial-macro-environment)
@@ -1456,15 +1456,14 @@
file-requirements 'static
(cut lset-union/eq? us <>)
(lambda () us))
- (let ((units (map (lambda (u) (string->c-identifier (stringify u))) us)))
- (set! used-units (append used-units units)) ) ) ) )
+ (set! used-units
+ (append used-units us)))))
((unit)
(check-decl spec 1 1)
- (let* ([u (stripu (cadr spec))]
- [un (string->c-identifier (stringify u))] )
- (when (and unit-name (not (string=? unit-name un)))
- (warning "unit was already given a name (new name is ignored)") )
- (set! unit-name un) ) )
+ (let ((u (stripu (cadr spec))))
+ (when (and unit-name (not (eq? unit-name u)))
+ (warning "unit was already given a name (new name is ignored)"))
+ (set! unit-name u)))
((standard-bindings)
(if (null? (cdr spec))
(set! standard-bindings default-standard-bindings)
diff --git a/eval.scm b/eval.scm
index c841af47..d30a6504 100644
--- a/eval.scm
+++ b/eval.scm
@@ -114,8 +114,10 @@
; srfi-98 partially in unit posix
(define-constant builtin-features
- '(chicken srfi-2 srfi-6 srfi-10 srfi-12 srfi-23 srfi-28 srfi-30 srfi-39
- srfi-55 srfi-88 srfi-98) )
+ '(scheme chicken
+ srfi-2 srfi-6 srfi-10 srfi-12
+ srfi-23 srfi-28 srfi-30 srfi-39
+ srfi-55 srfi-88 srfi-98))
(define-constant builtin-features/compiled
'(srfi-8 srfi-9 srfi-11 srfi-15 srfi-16 srfi-17 srfi-26) )
@@ -667,7 +669,7 @@
(when (##sys#current-module)
(##sys#syntax-error-hook 'module "modules may not be nested" name))
(parameterize ((##sys#current-module
- (##sys#register-module name exports))
+ (##sys#register-module name #f exports))
(##sys#current-environment '())
(##sys#macro-environment
##sys#initial-macro-environment)
@@ -1085,7 +1087,7 @@
[display display] )
(lambda (uname lib)
(let ([id (##sys#->feature-id uname)])
- (or (memq id ##sys#features)
+ (or (##sys#get uname '##core#unit)
(let ([libs
(if lib
(##sys#list lib)
@@ -1101,13 +1103,10 @@
(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)
- (unless (memq id ##sys#features)
- (set! ##sys#features (cons id ##sys#features)))
- #t]
- [else (loop (##sys#slot libs 1))] ) ) ) ) ) ) ) )
+ (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)))))))))))
(define load-library
(lambda (uname . lib)
@@ -1407,16 +1406,17 @@
(lambda (s r)
(if (memq (car s)
'(import
- require-extension
- require-extension-for-syntax
- require-library
- begin-for-syntax
- export
- module
- cond-expand
- syntax
- reexport
- import-for-syntax))
+ import-syntax
+ require-extension
+ require-extension-for-syntax
+ require-library
+ begin-for-syntax
+ export
+ module
+ cond-expand
+ syntax
+ reexport
+ import-for-syntax))
r
(cons s r)))
'()
diff --git a/expand.scm b/expand.scm
index e8702ef9..f18866f3 100644
--- a/expand.scm
+++ b/expand.scm
@@ -58,8 +58,7 @@
?se))))
(set! ##sys#features
- (append '(#:hygienic-macros
- #:syntax-rules
+ (append '(#:expand #:hygienic-macros #:syntax-rules
#:srfi-0 #:srfi-2 #:srfi-6 #:srfi-9 #:srfi-46 #:srfi-55 #:srfi-61)
##sys#features))
@@ -924,25 +923,34 @@
;;; Macro definitions:
(##sys#extend-macro-environment
- 'import '()
- (##sys#er-transformer
- (cut ##sys#expand-import <> <> <> ##sys#current-environment ##sys#macro-environment
- #f #f 'import) ) )
+ 'import-syntax '()
+ (##sys#er-transformer
+ (cut ##sys#expand-import <> <> <>
+ ##sys#current-environment ##sys#macro-environment
+ #f #f #f 'import-syntax)))
+
+(##sys#extend-macro-environment
+ 'import '()
+ (##sys#er-transformer
+ (cut ##sys#expand-import <> <> <>
+ ##sys#current-environment ##sys#macro-environment
+ #f #f #t 'import)))
(##sys#extend-macro-environment
- 'import-for-syntax '()
- (##sys#er-transformer
- (cut ##sys#expand-import <> <> <> ##sys#current-meta-environment
- ##sys#meta-macro-environment
- #t #f 'import-for-syntax) ) )
+ 'import-for-syntax '()
+ (##sys#er-transformer
+ (cut ##sys#expand-import <> <> <>
+ ##sys#current-meta-environment ##sys#meta-macro-environment
+ #t #f #t 'import-for-syntax)))
(##sys#extend-macro-environment
- 'reexport '()
- (##sys#er-transformer
- (cut ##sys#expand-import <> <> <> ##sys#current-environment ##sys#macro-environment
- #f #t 'reexport) ) )
+ 'reexport '()
+ (##sys#er-transformer
+ (cut ##sys#expand-import <> <> <>
+ ##sys#current-environment ##sys#macro-environment
+ #f #t #t 'reexport)))
-;; contains only "import[-for-syntax]" and "reexport"
+;; contains only "import" and "reexport" forms
(define ##sys#initial-macro-environment (##sys#macro-environment))
(##sys#extend-macro-environment
diff --git a/library.scm b/library.scm
index a72e889d..643d0d47 100644
--- a/library.scm
+++ b/library.scm
@@ -41,7 +41,7 @@
##sys#string->compnum ##sys#internal-gcd)
(not inline ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook ##sys#schedule
##sys#default-read-info-hook ##sys#infix-list-hook ##sys#sharp-number-hook
- ##sys#user-print-hook ##sys#user-interrupt-hook ##sys#step-hook)
+ ##sys#user-print-hook ##sys#user-interrupt-hook ##sys#unit-hook)
(foreign-declare #<<EOF
#include <errno.h>
#include <float.h>
@@ -154,7 +154,6 @@ signal_debug_event(C_word mode, C_word msg, C_word args)
EOF
) )
-
(include "common-declarations.scm")
(include "banner.scm")
@@ -4491,6 +4490,10 @@ EOF
(when (##sys#fudge 39) (set! ##sys#features (cons #:cross-chicken ##sys#features)))
(when (##sys#fudge 3) (set! ##sys#features (cons #:64bit ##sys#features)))
+(define ##sys#unit-hook
+ (lambda (id)
+ (##sys#put! id '##core#unit #t)))
+
(set! ##sys#features
(let ((major (##sys#string-append "chicken-" (##sys#number->string (##sys#fudge 41)))))
(cons (##sys#->feature-id major)
diff --git a/modules.scm b/modules.scm
index 275939e8..b30753d9 100644
--- a/modules.scm
+++ b/modules.scm
@@ -65,7 +65,8 @@
(declare
(hide make-module module? %make-module
- module-name module-vexports module-sexports
+ module-name module-unit
+ module-vexports module-sexports
set-module-vexports! set-module-sexports!
module-export-list set-module-export-list!
module-defined-list set-module-defined-list!
@@ -78,11 +79,12 @@
module-iexports set-module-iexports!))
(define-record-type module
- (%make-module name export-list defined-list exist-list defined-syntax-list
+ (%make-module name unit 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
(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
@@ -105,8 +107,8 @@
(module-vexports m)
(module-sexports m)))
-(define (make-module name explist vexports sexports iexports)
- (%make-module name explist '() '() '() '() '() '() '() vexports sexports iexports #f))
+(define (make-module name unit explist vexports sexports iexports)
+ (%make-module name unit explist '() '() '() '() '() '() '() vexports sexports iexports #f))
(define (##sys#register-module-alias alias name)
(##sys#module-alias-environment
@@ -227,8 +229,8 @@
mod
(cons (cons sym (if where (list where) '())) ul)))))))
-(define (##sys#register-module name explist #!optional (vexports '()) (sexports '()))
- (let ((mod (make-module name explist vexports sexports '())))
+(define (##sys#register-module name unit explist #!optional (vexports '()) (sexports '()))
+ (let ((mod (make-module name unit explist vexports sexports '())))
(set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
mod) )
@@ -305,6 +307,7 @@
,@(##sys#fast-reverse (map chicken.expand#strip-syntax (module-meta-expressions mod)))
(##sys#register-compiled-module
',(module-name mod)
+ ',(module-unit mod)
(list
,@(map (lambda (ie)
(if (symbol? (cdr ie))
@@ -333,7 +336,7 @@
(cons `(cons ',(caar sd) ,(chicken.expand#strip-syntax (cdar sd)))
(loop (cdr sd)))))))))))))
-(define (##sys#register-compiled-module name iexports vexports sexports #!optional
+(define (##sys#register-compiled-module name unit iexports vexports sexports #!optional
(sdefs '()))
(define (find-reexport name)
(let ((a (assq name (##sys#macro-environment))))
@@ -358,7 +361,7 @@
(map (lambda (ne)
(list (car ne) #f (##sys#ensure-transformer (cdr ne) (car ne))))
sdefs))
- (mod (make-module name '() vexports sexps iexps))
+ (mod (make-module name unit '() vexports sexps iexps))
(senv (merge-se
(##sys#macro-environment)
(##sys#current-environment)
@@ -393,8 +396,8 @@
(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
(let* ((me (##sys#macro-environment))
- (mod (make-module
- name '()
+ (mod (make-module
+ name #f '()
(map (lambda (ve)
(if (symbol? ve)
(cons ve (##sys#primitive-alias ve))
@@ -572,7 +575,7 @@
mname)))))
mod))
-(define (##sys#expand-import x r c import-env macro-env meta? reexp? loc)
+(define (##sys#expand-import x r c import-env macro-env meta? reexp? load? loc)
(let ((%only (r 'only))
(%rename (r 'rename))
(%except (r 'except))
@@ -591,7 +594,7 @@
(sexp (module-sexports mod))
(iexp (module-iexports mod))
(name (module-name mod)))
- (values name name vexp sexp iexp)))
+ (values mod name name vexp sexp iexp)))
(define (import-spec spec)
(cond ((symbol? spec)
(import-name (chicken.expand#strip-syntax spec)))
@@ -601,7 +604,7 @@
(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-values (((mod 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)
@@ -609,7 +612,7 @@
(lambda (id)
(warn "imported identifier doesn't exist" name id))
missing)
- (values name `(,head ,form ,@imports) v s impi))
+ (values mod name `(,head ,form ,@imports) v s impi))
((assq (car ids) impv) =>
(lambda (a)
(loop (cdr ids) (cons a v) s missing)))
@@ -620,7 +623,7 @@
(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-values (((mod 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)
@@ -630,7 +633,7 @@
(lambda (id)
(warn "excluded identifier doesn't exist" name id))
ids)
- (values name `(,head ,form ,@imports) v s impi))
+ (values mod name `(,head ,form ,@imports) v s impi))
((memq (caar imps) ids) =>
(lambda (id)
(loop (cdr imps) s (delete (car id) ids eq?))))
@@ -643,7 +646,7 @@
(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-values (((mod 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)
@@ -653,7 +656,7 @@
(lambda (id)
(warn "renamed identifier doesn't exist" name id))
(map car ids))
- (values name `(,head ,form ,@renames) v s impi))
+ (values mod name `(,head ,form ,@renames) v s impi))
((assq (caar imps) ids) =>
(lambda (a)
(loop (cdr imps)
@@ -670,74 +673,78 @@
(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-values (((mod 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)))
+ (values mod name `(,head ,form ,prefix) (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)))
- (for-each
- (lambda (spec)
- (let-values (((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)
+ `(##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))))
- (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))))
+ (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)))
+ (let ((unit (module-unit mod)))
+ (if (and unit load?)
+ `(##core#require-extension (,unit) #f)
+ '(##core#undefined)))))
+ (cdr x))))))
(define (module-rename sym prefix)
(##sys#string->symbol
Trap