~ chicken-core (chicken-5) 5c3923fbd40bcc786bc4c803d8d737231d18e4e7
commit 5c3923fbd40bcc786bc4c803d8d737231d18e4e7
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Mar 18 19:24:31 2011 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Mar 18 19:24:31 2011 +0100
moved module-specific code into modules.scm, added new core unit, added define-interface
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 20c9e822..2db03701 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1110,6 +1110,25 @@
(##core#let-compiler-syntax (binding ...) body ...)))))
+;;; interface definition
+
+(##sys#extend-macro-environment
+ 'define-interface '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'define-interface x '(_ symbol _))
+ (let ((name (##sys#strip-syntax (cadr x))))
+ `(,(r 'begin-for-syntax)
+ (##sys#register-interface
+ ',name
+ ',(let ((exps (##sys#strip-syntax (caddr x))))
+ (cond ((eq? '* exps) '*)
+ ((symbol? exps) `(#:interface ,exps))
+ ((list? exps) (##sys#validate-exports exps 'define-interface))
+ (else (##sys#syntax-error-hook
+ 'define-interface "invalid exports" (caddr x)))))))))))
+
+
(##sys#macro-subset me0 ##sys#default-macro-environment)))
;; register features
diff --git a/defaults.make b/defaults.make
index 64d91044..361d0310 100644
--- a/defaults.make
+++ b/defaults.make
@@ -303,7 +303,7 @@ CHICKEN_STATUS_PROGRAM = $(PROGRAM_PREFIX)chicken-status$(PROGRAM_SUFFIX)
CHICKEN_BUG_PROGRAM = $(PROGRAM_PREFIX)chicken-bug$(PROGRAM_SUFFIX)
IMPORT_LIBRARIES = chicken lolevel srfi-1 srfi-4 data-structures ports files posix srfi-13 srfi-69 extras srfi-14 tcp foreign scheme srfi-18 utils csi irregex
IMPORT_LIBRARIES += setup-api setup-download
-SCRUTINIZED_LIBRARIES = library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69 $(POSIXFILE) irregex scheduler profiler stub expand chicken-syntax chicken-ffi-syntax
+SCRUTINIZED_LIBRARIES = library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69 $(POSIXFILE) irregex scheduler profiler stub expand modules chicken-syntax chicken-ffi-syntax
ifdef STATICBUILD
CHICKEN_STATIC_EXECUTABLE = $(CHICKEN_PROGRAM)$(EXE)
diff --git a/distribution/manifest b/distribution/manifest
index abdc28fe..6f805100 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -200,6 +200,8 @@ compiler-namespace.scm
synrules.scm
expand.scm
expand.c
+modules.scm
+modules.c
chicken-syntax.scm
chicken-syntax.c
common-declarations.scm
diff --git a/expand.scm b/expand.scm
index e4387532..9b12f0ba 100644
--- a/expand.scm
+++ b/expand.scm
@@ -26,14 +26,15 @@
(declare
(unit expand)
+ (uses modules)
(disable-interrupts)
(fixnum)
(hide match-expression
- macro-alias module-indirect-exports
- d dd dm dx map-se merge-se
+ macro-alias
+ d dd dm dx map-se
lookup check-for-redef)
(not inline ##sys#syntax-error-hook ##sys#compiler-syntax-hook
- ##sys#alias-global-hook ##sys#toplevel-definition-hook))
+ ##sys#toplevel-definition-hook))
(include "common-declarations.scm")
@@ -267,37 +268,6 @@
(define ##sys#compiler-syntax-hook #f)
(define ##sys#enable-runtime-macros #f)
-(define (##sys#module-rename sym prefix)
- (##sys#string->symbol (string-append
- (##sys#slot prefix 1)
- "#"
- (##sys#slot sym 1) ) ) )
-
-(define (##sys#alias-global-hook sym assign where)
- (define (mrename sym)
- (cond ((##sys#current-module) =>
- (lambda (mod)
- (dm "(ALIAS) global alias " sym " in " (module-name mod))
- (unless assign
- (##sys#register-undefined sym mod where))
- (##sys#module-rename sym (module-name mod))))
- (else sym)))
- (cond ((##sys#qualified-symbol? sym) sym)
- ((getp sym '##core#primitive) =>
- (lambda (p)
- (dm "(ALIAS) primitive: " p)
- p))
- ((getp sym '##core#aliased)
- (dm "(ALIAS) marked: " sym)
- sym)
- ((assq sym (##sys#current-environment)) =>
- (lambda (a)
- (dm "(ALIAS) in current environment: " sym)
- (let ((sym2 (cdr a)))
- (if (pair? sym2) ; macro (*** can this be?)
- (mrename sym)
- (or (getp sym2 '##core#primitive) sym2)))))
- (else (mrename sym))))
;;; User-level macroexpansion
@@ -888,176 +858,8 @@
(define (er-macro-transformer x) x)
(define ir-macro-transformer ##sys#ir-transformer)
-;;; Macro definitions:
-(define (##sys#expand-import x r c import-env macro-env meta? reexp? loc)
- (let ((%only (r 'only))
- (%rename (r 'rename))
- (%except (r 'except))
- (%prefix (r 'prefix))
- (%srfi (r 'srfi)))
- (define (resolve sym)
- (or (lookup sym '()) sym)) ;*** empty se?
- (define (tostr x)
- (cond ((string? x) x)
- ((keyword? x) (##sys#string-append (##sys#symbol->string x) ":")) ; hack
- ((symbol? x) (##sys#symbol->string x))
- ((number? x) (number->string x))
- (else (syntax-error loc "invalid prefix" ))))
- (define (import-name spec)
- (let* ((mname (##sys#strip-syntax spec))
- (mod (##sys#find-module mname #f)))
- (unless mod
- (let ((il (##sys#find-extension
- (string-append (symbol->string mname) ".import")
- #t)))
- (cond (il (parameterize ((##sys#current-module #f)
- (##sys#current-environment '())
- (##sys#current-meta-environment
- (##sys#current-meta-environment))
- (##sys#macro-environment
- (##sys#meta-macro-environment)))
- (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
- (##sys#load il #f #f)))
- (set! mod (##sys#find-module mname)))
- (else
- (syntax-error
- loc "cannot import from undefined module"
- mname)))))
- (let ((vexp (module-vexports mod))
- (sexp (module-sexports mod)))
- (cons vexp sexp))))
- (define (import-spec spec)
- (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 s)
- (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
- (let ((ids (map resolve (cddr spec))))
- (let loop ((ids ids) (v '()) (s '()))
- (cond ((null? ids) (cons v s))
- ((assq (car ids) impv) =>
- (lambda (a)
- (loop (cdr ids) (cons a v) s)))
- ((assq (car ids) imps) =>
- (lambda (a)
- (loop (cdr ids) v (cons a s))))
- (else (loop (cdr ids) v s))))))
- ((c %except s)
- (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
- (let ((ids (map resolve (cddr spec))))
- (let loop ((impv impv) (v '()))
- (cond ((null? impv)
- (let loop ((imps imps) (s '()))
- (cond ((null? imps) (cons v s))
- ((memq (caar imps) ids) (loop (cdr imps) s))
- (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 s)
- (##sys#check-syntax loc spec '(_ _ . #((symbol symbol) 0)))
- (let loop ((impv impv) (imps imps) (v '()) (s '()) (ids (cddr spec)))
- (cond ((null? impv)
- (cond ((null? imps)
- (for-each
- (lambda (id)
- (##sys#warn "renamed identifier not imported" id) )
- ids)
- (cons v s))
- ((assq (caar imps) ids) =>
- (lambda (a)
- (loop impv (cdr imps)
- v
- (cons (cons (cadr a) (cdar imps)) s)
- (##sys#delq a ids))))
- (else (loop impv (cdr imps) v (cons (car imps) s) ids))))
- ((assq (caar impv) ids) =>
- (lambda (a)
- (loop (cdr impv) imps
- (cons (cons (cadr a) (cdar impv)) v)
- s
- (##sys#delq a ids))))
- (else (loop (cdr impv) imps
- (cons (car impv) v)
- s ids)))))
- ((c %prefix s)
- (##sys#check-syntax loc spec '(_ _ _))
- (let ((pref (tostr (caddr spec))))
- (define (ren imp)
- (cons
- (##sys#string->symbol
- (##sys#string-append pref (##sys#symbol->string (car imp))) )
- (cdr imp) ) )
- (cons (map ren impv) (map ren imps))))
- (else (syntax-error loc "invalid import specification" spec)))))))
- (##sys#check-syntax loc x '(_ . #(_ 1)))
- (let ((cm (##sys#current-module)))
- (when cm
- ;; save import form
- (if meta?
- (set-module-meta-import-forms!
- cm
- (append (module-meta-import-forms cm) (cdr x)))
- (set-module-import-forms!
- cm
- (append (module-import-forms cm) (cdr x)))))
- (for-each
- (lambda (spec)
- (let* ((vs (import-spec spec))
- (vsv (car vs))
- (vss (cdr vs))
- (prims '()))
- (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)))
- (##sys#mark-imported-symbols vsv) ; mark imports as ##core#aliased
- (for-each
- (lambda (imp)
- (let* ((id (car imp))
- (aid (cdr imp))
- (prim (getp aid '##core#primitive)))
- (when prim
- (set! prims (cons imp prims)))
- (and-let* ((a (assq id (import-env)))
- ((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
- (syntax-error loc "`reexport' only valid inside a module"))
- (set-module-export-list!
- cm
- (append
- (let ((xl (module-export-list cm) ))
- (if (eq? #t xl) '() xl))
- (map car vsv)
- (map car vss)))
- (when (pair? prims)
- (set-module-meta-expressions!
- cm
- (append
- (module-meta-expressions cm)
- `((##sys#mark-primitive ',prims)))))
- (dm "export-list: " (module-export-list cm)))
- (import-env (append vsv (import-env)))
- (macro-env (append vss (macro-env)))))
- (cdr x))
- '(##core#undefined))))
+;;; Macro definitions:
(define (##sys#mark-primitive prims)
(for-each
@@ -1548,7 +1350,7 @@
((not (pair? iexp)) #t)
((not (symbol? (car iexp))) #t)
(else (loop (cdr iexp))))))
- (syntax-error 'export "invalid export syntax" exp (module-name mod))))
+ (##sys#syntax-error-hook 'export "invalid export syntax" exp (module-name mod))))
exps)
(set-module-export-list!
mod
@@ -1590,421 +1392,6 @@
(##sys#fixup-macro-environment (##sys#macro-environment)))
-;;; low-level module support
-
-(define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment)))
-(define ##sys#current-module (make-parameter #f))
-
-(declare
- (hide make-module module? %make-module
- module-name module-vexports module-sexports
- set-module-vexports! set-module-sexports!
- module-export-list set-module-export-list!
- module-defined-list set-module-defined-list!
- module-import-forms set-module-import-forms!
- module-meta-import-forms set-module-meta-import-forms!
- module-exist-list set-module-exist-list!
- module-meta-expressions set-module-meta-expressions!
- module-defined-syntax-list set-module-defined-syntax-list!))
-
-(define-record-type module
- (%make-module name export-list defined-list exist-list defined-syntax-list
- undefined-list import-forms meta-import-forms meta-expressions
- vexports sexports)
- module?
- (name module-name) ; 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
- (defined-syntax-list module-defined-syntax-list set-module-defined-syntax-list!) ; ((SYMBOL . VALUE) ...)
- (undefined-list module-undefined-list set-module-undefined-list!) ; ((SYMBOL WHERE1 ...) ...)
- (import-forms module-import-forms set-module-import-forms!) ; (SPEC ...)
- (meta-import-forms module-meta-import-forms set-module-meta-import-forms!) ; (SPEC ...)
- (meta-expressions module-meta-expressions set-module-meta-expressions!) ; (EXP ...)
- (vexports module-vexports set-module-vexports!) ; ((SYMBOL . SYMBOL) ...)
- (sexports module-sexports set-module-sexports!) ) ; ((SYMBOL SE TRANSFORMER) ...)
-
-(define ##sys#module-name module-name)
-
-(define (##sys#module-exports m)
- (values
- (module-export-list m)
- (module-vexports m)
- (module-sexports m)))
-
-(define (make-module name explist vexports sexports)
- (%make-module name explist '() '() '() '() '() '() '() vexports sexports))
-
-(define (##sys#find-module name #!optional (err #t))
- (cond ((assq name ##sys#module-table) => cdr)
- (err (error 'import "module not found" name))
- (else #f)))
-
-(define (##sys#toplevel-definition-hook sym mod exp val) #f)
-
-(define (##sys#register-meta-expression exp)
- (and-let* ((mod (##sys#current-module)))
- (set-module-meta-expressions! mod (cons exp (module-meta-expressions mod)))))
-
-(define (check-for-redef sym env senv)
- (and-let* ((a (assq sym env)))
- (##sys#warn "redefinition of imported value binding" sym) )
- (and-let* ((a (assq sym senv)))
- (##sys#warn "redefinition of imported syntax binding" sym)))
-
-(define (##sys#register-export sym mod)
- (when mod
- (let ((exp (or (eq? #t (module-export-list mod))
- (##sys#find-export sym mod #t)))
- (ulist (module-undefined-list mod)))
- (##sys#toplevel-definition-hook ; in compiler, hides unexported bindings
- (##sys#module-rename sym (module-name mod))
- mod exp #f)
- (and-let* ((a (assq sym ulist)))
- (set-module-undefined-list! mod (##sys#delq a ulist)))
- (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
- (set-module-exist-list! mod (cons sym (module-exist-list mod)))
- (when exp
- (dm "defined: " sym)
- (set-module-defined-list!
- mod
- (cons (cons sym #f)
- (module-defined-list mod)))))) )
-
-(define (##sys#register-syntax-export sym mod val)
- (when mod
- (let ((exp (or (eq? #t (module-export-list mod))
- (##sys#find-export sym mod #t)))
- (ulist (module-undefined-list mod))
- (mname (module-name mod)))
- (when (assq sym ulist)
- (##sys#warn "use of syntax precedes definition" sym)) ;XXX could report locations
- (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
- (dm "defined syntax: " sym)
- (when exp
- (set-module-defined-list!
- mod
- (cons (cons sym val)
- (module-defined-list mod))) )
- (set-module-defined-syntax-list!
- mod
- (cons (cons sym val) (module-defined-syntax-list mod))))))
-
-(define (##sys#register-undefined sym mod where)
- (when mod
- (let ((ul (module-undefined-list mod)))
- (cond ((assq sym ul) =>
- (lambda (a)
- (when (and where (not (memq where (cdr a))))
- (set-cdr! a (cons where (cdr a))))))
- (else
- (set-module-undefined-list!
- 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)))
- (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
- mod) )
-
-(define (##sys#mark-imported-symbols se)
- (for-each
- (lambda (imp)
- (when (and (symbol? (cdr imp)) (not (eq? (car imp) (cdr imp))))
- (dm `(MARKING: ,(cdr imp)))
- (putp (cdr imp) '##core#aliased #t)))
- se))
-
-(define (module-indirect-exports mod)
- (let ((exports (module-export-list mod))
- (mname (module-name mod))
- (dlist (module-defined-list mod)))
- (define (indirect? id)
- (let loop ((exports exports))
- (and (not (null? exports))
- (or (and (pair? (car exports))
- (memq id (cdar exports)))
- (loop (cdr exports))))))
- (define (warn msg id)
- (##sys#warn
- (string-append msg " in module `" (symbol->string mname) "'")
- id))
- (if (eq? #t exports)
- '()
- (let loop ((exports exports)) ; walk export list
- (cond ((null? exports) '())
- ((symbol? (car exports)) (loop (cdr exports))) ; normal export
- (else
- (let loop2 ((iexports (cdar exports))) ; walk indirect exports for a given entry
- (cond ((null? iexports) (loop (cdr exports)))
- ((assq (car iexports) (##sys#macro-environment))
- (warn "indirect export of syntax binding" (car iexports))
- (loop2 (cdr iexports)))
- ((assq (car iexports) dlist) => ; defined in current module?
- (lambda (a)
- (cons
- (cons
- (car iexports)
- (or (cdr a) (##sys#module-rename (car iexports) mname)))
- (loop2 (cdr iexports)))))
- ((assq (car iexports) (##sys#current-environment)) =>
- (lambda (a) ; imported in current env.
- (cond ((symbol? (cdr a)) ; not syntax
- (cons (cons (car iexports) (cdr a)) (loop2 (cdr iexports))) )
- (else
- (warn "indirect reexport of syntax" (car iexports))
- (loop2 (cdr iexports))))))
- (else
- (warn "indirect export of unknown binding" (car iexports))
- (loop2 (cdr iexports)))))))))))
-
-(define (merge-se . ses) ; later occurrences take precedence to earlier ones
- (let ((se (apply append ses)))
- (dm "merging " (length ses) " se's with total length of " (length se))
- (let ((se2
- (let loop ((se se))
- (cond ((null? se) '())
- ((assq (caar se) (cdr se)) (loop (cdr se)))
- (else (cons (car se) (loop (cdr se))))))))
- (dm " merged has length " (length se2))
- se2)))
-
-(define (##sys#compiled-module-registration mod)
- (let ((dlist (module-defined-list mod))
- (mname (module-name mod))
- (ifs (module-import-forms mod))
- (sexports (module-sexports mod))
- (mifs (module-meta-import-forms mod)))
- `(,@(if (pair? ifs) `((eval '(import ,@(##sys#strip-syntax ifs)))) '())
- ,@(if (pair? mifs) `((import ,@(##sys#strip-syntax mifs))) '())
- ,@(reverse (map ##sys#strip-syntax (module-meta-expressions mod)))
- (##sys#register-compiled-module
- ',(module-name mod)
- (list
- ,@(map (lambda (ie)
- (if (symbol? (cdr ie))
- `'(,(car ie) . ,(cdr ie))
- `(list ',(car ie) '() ,(cdr ie))))
- (module-indirect-exports mod)))
- ',(module-vexports mod)
- (list
- ,@(map (lambda (sexport)
- (let* ((name (car sexport))
- (a (assq name dlist)))
- (cond ((pair? a)
- `(cons ',(car sexport) ,(##sys#strip-syntax (cdr a))))
- (else
- (dm "re-exported syntax" name mname)
- `',name))))
- sexports))
- (list
- ,@(if (null? sexports)
- '() ; no syntax exported - no more info needed
- (let loop ((sd (module-defined-syntax-list mod)))
- (cond ((null? sd) '())
- ((assq (caar sd) sexports) (loop (cdr sd)))
- (else
- (let ((name (caar sd)))
- (cons `(cons ',(caar sd) ,(##sys#strip-syntax (cdar sd)))
- (loop (cdr sd)))))))))))))
-
-(define (##sys#register-compiled-module name iexports vexports sexports #!optional
- (sdefs '()))
- (define (find-reexport name)
- (let ((a (assq name (##sys#macro-environment))))
- (if (and a (pair? (cdr a)))
- a
- (##sys#error
- 'import "cannot find implementation of re-exported syntax"
- name))))
- (let* ((sexps
- (map (lambda (se)
- (if (symbol? se)
- (find-reexport se)
- (list (car se) #f (##sys#er-transformer (cdr se)))))
- sexports))
- (iexps
- (map (lambda (ie)
- (if (pair? (cdr ie))
- (list (car ie) (cadr ie) (##sys#er-transformer (caddr ie)))
- ie))
- iexports))
- (nexps
- (map (lambda (ne)
- (list (car ne) #f (##sys#er-transformer (cdr ne))))
- sdefs))
- (mod (make-module name '() vexports sexps))
- (senv (merge-se
- (##sys#macro-environment)
- (##sys#current-environment)
- iexps vexports sexps nexps)))
- (##sys#mark-imported-symbols iexps)
- (for-each
- (lambda (sexp)
- (set-car! (cdr sexp) senv))
- sexps)
- (for-each
- (lambda (iexp)
- (when (pair? (cdr iexp))
- (set-car! (cdr iexp) senv)))
- iexps)
- (for-each
- (lambda (nexp)
- (set-car! (cdr nexp) senv))
- nexps)
- (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
- mod))
-
-(define (##sys#primitive-alias sym)
- (let ((palias
- (##sys#string->symbol
- (##sys#string-append "#%" (##sys#slot sym 1)))))
- (putp palias '##core#primitive sym)
- palias))
-
-(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
- (let* ((me (##sys#macro-environment))
- (mod (make-module
- name '()
- (map (lambda (ve)
- (if (symbol? ve)
- (cons ve (##sys#primitive-alias ve))
- ve))
- vexports)
- (map (lambda (se)
- (if (symbol? se)
- (or (assq se me)
- (##sys#error
- "unknown syntax referenced while registering module"
- se name))
- se))
- sexports))))
- (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
- mod))
-
-(define (##sys#find-export sym mod indirect)
- (let ((exports (module-export-list mod)))
- (let loop ((xl (if (eq? #t exports) (module-exists-list mod) exports)))
- (cond ((null? xl) #f)
- ((eq? sym (car xl)))
- ((pair? (car xl))
- (or (eq? sym (caar xl))
- (and indirect (memq sym (cdar xl)))
- (loop (cdr xl))))
- (else (loop (cdr xl)))))))
-
-(define ##sys#finalize-module
- (let ((display display)
- (write-char write-char))
- (lambda (mod)
- (let* ((explist (module-export-list mod))
- (name (module-name mod))
- (dlist (module-defined-list mod))
- (elist (module-exist-list mod))
- (missing #f)
- (sdlist (map (lambda (sym) (assq (car sym) (##sys#macro-environment)))
- (module-defined-syntax-list mod)))
- (sexports
- (if (eq? #t explist)
- sdlist
- (let loop ((me (##sys#macro-environment)))
- (cond ((null? me) '())
- ((##sys#find-export (caar me) mod #f)
- (cons (car me) (loop (cdr me))))
- (else (loop (cdr me)))))))
- (vexports
- (let loop ((xl (if (eq? #t explist) elist explist)))
- (if (null? xl)
- '()
- (let* ((h (car xl))
- (id (if (symbol? h) h (car h))))
- (if (assq id sexports)
- (loop (cdr xl))
- (cons
- (cons
- id
- (let ((def (assq id dlist)))
- (if (and def (symbol? (cdr def)))
- (cdr def)
- (let ((a (assq id (##sys#current-environment))))
- (cond ((and a (symbol? (cdr a)))
- (dm "reexporting: " id " -> " (cdr a))
- (cdr a))
- ((not def)
- (set! missing #t)
- (##sys#warn
- (string-append
- "exported identifier of module `"
- (symbol->string name)
- "' has not been defined")
- id)
- #f)
- (else (##sys#module-rename id name)))))))
- (loop (cdr xl)))))))))
- (for-each
- (lambda (u)
- (let* ((where (cdr u))
- (u (car u)))
- (unless (memq u elist)
- (let ((out (open-output-string)))
- (set! missing #t)
- (display "reference to possibly unbound identifier `" out)
- (display u out)
- (write-char #\' out)
- (when (pair? where)
- (display " in:" out)
- (for-each
- (lambda (sym)
- (display "\nWarning: " out)
- (display sym out))
- where))
- (and-let* ((a (getp u '##core#db)))
- (cond ((= 1 (length a))
- (display "\nWarning: suggesting: `(import " out)
- (display (cadar a) out)
- (display ")'" out))
- (else
- (display "\nWarning: suggesting one of:" out)
- (for-each
- (lambda (a)
- (display "\nWarning: (import " out)
- (display (cadr a) out)
- (write-char #\) out))
- a))))
- (##sys#warn (get-output-string out))))))
- (module-undefined-list mod))
- (when missing
- (##sys#error "module unresolved" name))
- (let* ((iexports
- (map (lambda (exp)
- (cond ((symbol? (cdr exp)) exp)
- ((assq (car exp) (##sys#macro-environment)))
- (else (##sys#error "(internal) indirect export not found" (car exp)))) )
- (module-indirect-exports mod)))
- (new-se (merge-se
- (##sys#macro-environment)
- (##sys#current-environment)
- iexports vexports sexports sdlist)))
- (##sys#mark-imported-symbols iexports)
- (for-each
- (lambda (m)
- (let ((se (merge-se (cadr m) new-se))) ;XXX needed?
- (dm `(FIXUP: ,(car m) ,@(map-se se)))
- (set-car! (cdr m) se)))
- sdlist)
- (dm `(EXPORTS:
- ,(module-name mod)
- (DLIST: ,@dlist)
- (SDLIST: ,@(map-se sdlist))
- (IEXPORTS: ,@(map-se iexports))
- (VEXPORTS: ,@(map-se vexports))
- (SEXPORTS: ,@(map-se sexports))))
- (set-module-vexports! mod vexports)
- (set-module-sexports! mod sexports))))))
-
-(define ##sys#module-table '())
-
-
;; Used by the syntax-rules implementation (and possibly handy elsewhere)
;; (kindly contributed by Peter Bex)
diff --git a/modules.scm b/modules.scm
new file mode 100644
index 00000000..a4db59f9
--- /dev/null
+++ b/modules.scm
@@ -0,0 +1,706 @@
+;;;; modules.scm - module-system support
+;
+; Copyright (c) 2011, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
+; disclaimer in the documentation and/or other materials provided with the distribution.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit modules)
+ (disable-interrupts)
+ (fixnum)
+ (hide lookup merge-se module-indirect-exports)
+ (not inline ##sys#alias-global-hook))
+
+(include "common-declarations.scm")
+
+(define-alias dd d)
+(define-alias dm d)
+(define-alias dx d)
+
+(define-inline (getp sym prop)
+ (##core#inline "C_i_getprop" sym prop #f))
+
+(define-inline (putp sym prop val)
+ (##core#inline_allocate ("C_a_i_putprop" 8) sym prop val))
+
+
+;;; Support definitions
+
+;; duoplicates 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#meta-macro-environment (make-parameter (##sys#macro-environment)))
+(define ##sys#current-module (make-parameter #f))
+
+(declare
+ (hide make-module module? %make-module
+ module-name module-vexports module-sexports
+ set-module-vexports! set-module-sexports!
+ module-export-list set-module-export-list!
+ module-defined-list set-module-defined-list!
+ module-import-forms set-module-import-forms!
+ module-meta-import-forms set-module-meta-import-forms!
+ module-exist-list set-module-exist-list!
+ module-meta-expressions set-module-meta-expressions!
+ module-defined-syntax-list set-module-defined-syntax-list!))
+
+(define-record-type module
+ (%make-module name export-list defined-list exist-list defined-syntax-list
+ undefined-list import-forms meta-import-forms meta-expressions
+ vexports sexports)
+ module?
+ (name module-name) ; 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
+ (defined-syntax-list module-defined-syntax-list set-module-defined-syntax-list!) ; ((SYMBOL . VALUE) ...)
+ (undefined-list module-undefined-list set-module-undefined-list!) ; ((SYMBOL WHERE1 ...) ...)
+ (import-forms module-import-forms set-module-import-forms!) ; (SPEC ...)
+ (meta-import-forms module-meta-import-forms set-module-meta-import-forms!) ; (SPEC ...)
+ (meta-expressions module-meta-expressions set-module-meta-expressions!) ; (EXP ...)
+ (vexports module-vexports set-module-vexports!) ; ((SYMBOL . SYMBOL) ...)
+ (sexports module-sexports set-module-sexports!) ) ; ((SYMBOL SE TRANSFORMER) ...)
+
+(define ##sys#module-name module-name)
+
+(define (##sys#module-exports m)
+ (values
+ (module-export-list m)
+ (module-vexports m)
+ (module-sexports m)))
+
+(define (make-module name explist vexports sexports)
+ (%make-module name explist '() '() '() '() '() '() '() vexports sexports))
+
+(define (##sys#find-module name #!optional (err #t))
+ (cond ((assq name ##sys#module-table) => cdr)
+ (err (error 'import "module not found" name))
+ (else #f)))
+
+(define (##sys#toplevel-definition-hook sym mod exp val) #f)
+
+(define (##sys#register-meta-expression exp)
+ (and-let* ((mod (##sys#current-module)))
+ (set-module-meta-expressions! mod (cons exp (module-meta-expressions mod)))))
+
+(define (check-for-redef sym env senv)
+ (and-let* ((a (assq sym env)))
+ (##sys#warn "redefinition of imported value binding" sym) )
+ (and-let* ((a (assq sym senv)))
+ (##sys#warn "redefinition of imported syntax binding" sym)))
+
+(define (##sys#register-export sym mod)
+ (when mod
+ (let ((exp (or (eq? #t (module-export-list mod))
+ (##sys#find-export sym mod #t)))
+ (ulist (module-undefined-list mod)))
+ (##sys#toplevel-definition-hook ; in compiler, hides unexported bindings
+ (##sys#module-rename sym (module-name mod))
+ mod exp #f)
+ (and-let* ((a (assq sym ulist)))
+ (set-module-undefined-list! mod (##sys#delq a ulist)))
+ (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
+ (set-module-exist-list! mod (cons sym (module-exist-list mod)))
+ (when exp
+ (dm "defined: " sym)
+ (set-module-defined-list!
+ mod
+ (cons (cons sym #f)
+ (module-defined-list mod)))))) )
+
+(define (##sys#register-syntax-export sym mod val)
+ (when mod
+ (let ((exp (or (eq? #t (module-export-list mod))
+ (##sys#find-export sym mod #t)))
+ (ulist (module-undefined-list mod))
+ (mname (module-name mod)))
+ (when (assq sym ulist)
+ (##sys#warn "use of syntax precedes definition" sym)) ;XXX could report locations
+ (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
+ (dm "defined syntax: " sym)
+ (when exp
+ (set-module-defined-list!
+ mod
+ (cons (cons sym val)
+ (module-defined-list mod))) )
+ (set-module-defined-syntax-list!
+ mod
+ (cons (cons sym val) (module-defined-syntax-list mod))))))
+
+(define (##sys#register-undefined sym mod where)
+ (when mod
+ (let ((ul (module-undefined-list mod)))
+ (cond ((assq sym ul) =>
+ (lambda (a)
+ (when (and where (not (memq where (cdr a))))
+ (set-cdr! a (cons where (cdr a))))))
+ (else
+ (set-module-undefined-list!
+ 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)))
+ (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
+ mod) )
+
+(define (##sys#mark-imported-symbols se)
+ (for-each
+ (lambda (imp)
+ (when (and (symbol? (cdr imp)) (not (eq? (car imp) (cdr imp))))
+ (dm `(MARKING: ,(cdr imp)))
+ (putp (cdr imp) '##core#aliased #t)))
+ se))
+
+(define (module-indirect-exports mod)
+ (let ((exports (module-export-list mod))
+ (mname (module-name mod))
+ (dlist (module-defined-list mod)))
+ (define (indirect? id)
+ (let loop ((exports exports))
+ (and (not (null? exports))
+ (or (and (pair? (car exports))
+ (memq id (cdar exports)))
+ (loop (cdr exports))))))
+ (define (warn msg id)
+ (##sys#warn
+ (string-append msg " in module `" (symbol->string mname) "'")
+ id))
+ (if (eq? #t exports)
+ '()
+ (let loop ((exports exports)) ; walk export list
+ (cond ((null? exports) '())
+ ((symbol? (car exports)) (loop (cdr exports))) ; normal export
+ (else
+ (let loop2 ((iexports (cdar exports))) ; walk indirect exports for a given entry
+ (cond ((null? iexports) (loop (cdr exports)))
+ ((assq (car iexports) (##sys#macro-environment))
+ (warn "indirect export of syntax binding" (car iexports))
+ (loop2 (cdr iexports)))
+ ((assq (car iexports) dlist) => ; defined in current module?
+ (lambda (a)
+ (cons
+ (cons
+ (car iexports)
+ (or (cdr a) (##sys#module-rename (car iexports) mname)))
+ (loop2 (cdr iexports)))))
+ ((assq (car iexports) (##sys#current-environment)) =>
+ (lambda (a) ; imported in current env.
+ (cond ((symbol? (cdr a)) ; not syntax
+ (cons (cons (car iexports) (cdr a)) (loop2 (cdr iexports))) )
+ (else
+ (warn "indirect reexport of syntax" (car iexports))
+ (loop2 (cdr iexports))))))
+ (else
+ (warn "indirect export of unknown binding" (car iexports))
+ (loop2 (cdr iexports)))))))))))
+
+(define (merge-se . ses) ; later occurrences take precedence to earlier ones
+ (let ((se (apply append ses)))
+ (dm "merging " (length ses) " se's with total length of " (length se))
+ (let ((se2
+ (let loop ((se se))
+ (cond ((null? se) '())
+ ((assq (caar se) (cdr se)) (loop (cdr se)))
+ (else (cons (car se) (loop (cdr se))))))))
+ (dm " merged has length " (length se2))
+ se2)))
+
+(define (##sys#compiled-module-registration mod)
+ (let ((dlist (module-defined-list mod))
+ (mname (module-name mod))
+ (ifs (module-import-forms mod))
+ (sexports (module-sexports mod))
+ (mifs (module-meta-import-forms mod)))
+ `(,@(if (pair? ifs) `((eval '(import ,@(##sys#strip-syntax ifs)))) '())
+ ,@(if (pair? mifs) `((import ,@(##sys#strip-syntax mifs))) '())
+ ,@(reverse (map ##sys#strip-syntax (module-meta-expressions mod)))
+ (##sys#register-compiled-module
+ ',(module-name mod)
+ (list
+ ,@(map (lambda (ie)
+ (if (symbol? (cdr ie))
+ `'(,(car ie) . ,(cdr ie))
+ `(list ',(car ie) '() ,(cdr ie))))
+ (module-indirect-exports mod)))
+ ',(module-vexports mod)
+ (list
+ ,@(map (lambda (sexport)
+ (let* ((name (car sexport))
+ (a (assq name dlist)))
+ (cond ((pair? a)
+ `(cons ',(car sexport) ,(##sys#strip-syntax (cdr a))))
+ (else
+ (dm "re-exported syntax" name mname)
+ `',name))))
+ sexports))
+ (list
+ ,@(if (null? sexports)
+ '() ; no syntax exported - no more info needed
+ (let loop ((sd (module-defined-syntax-list mod)))
+ (cond ((null? sd) '())
+ ((assq (caar sd) sexports) (loop (cdr sd)))
+ (else
+ (let ((name (caar sd)))
+ (cons `(cons ',(caar sd) ,(##sys#strip-syntax (cdar sd)))
+ (loop (cdr sd)))))))))))))
+
+(define (##sys#register-compiled-module name iexports vexports sexports #!optional
+ (sdefs '()))
+ (define (find-reexport name)
+ (let ((a (assq name (##sys#macro-environment))))
+ (if (and a (pair? (cdr a)))
+ a
+ (##sys#error
+ 'import "cannot find implementation of re-exported syntax"
+ name))))
+ (let* ((sexps
+ (map (lambda (se)
+ (if (symbol? se)
+ (find-reexport se)
+ (list (car se) #f (##sys#er-transformer (cdr se)))))
+ sexports))
+ (iexps
+ (map (lambda (ie)
+ (if (pair? (cdr ie))
+ (list (car ie) (cadr ie) (##sys#er-transformer (caddr ie)))
+ ie))
+ iexports))
+ (nexps
+ (map (lambda (ne)
+ (list (car ne) #f (##sys#er-transformer (cdr ne))))
+ sdefs))
+ (mod (make-module name '() vexports sexps))
+ (senv (merge-se
+ (##sys#macro-environment)
+ (##sys#current-environment)
+ iexps vexports sexps nexps)))
+ (##sys#mark-imported-symbols iexps)
+ (for-each
+ (lambda (sexp)
+ (set-car! (cdr sexp) senv))
+ sexps)
+ (for-each
+ (lambda (iexp)
+ (when (pair? (cdr iexp))
+ (set-car! (cdr iexp) senv)))
+ iexps)
+ (for-each
+ (lambda (nexp)
+ (set-car! (cdr nexp) senv))
+ nexps)
+ (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
+ mod))
+
+(define (##sys#primitive-alias sym)
+ (let ((palias
+ (##sys#string->symbol
+ (##sys#string-append "#%" (##sys#slot sym 1)))))
+ (putp palias '##core#primitive sym)
+ palias))
+
+(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
+ (let* ((me (##sys#macro-environment))
+ (mod (make-module
+ name '()
+ (map (lambda (ve)
+ (if (symbol? ve)
+ (cons ve (##sys#primitive-alias ve))
+ ve))
+ vexports)
+ (map (lambda (se)
+ (if (symbol? se)
+ (or (assq se me)
+ (##sys#error
+ "unknown syntax referenced while registering module"
+ se name))
+ se))
+ sexports))))
+ (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
+ mod))
+
+(define (##sys#find-export sym mod indirect)
+ (let ((exports (module-export-list mod)))
+ (let loop ((xl (if (eq? #t exports) (module-exists-list mod) exports)))
+ (cond ((null? xl) #f)
+ ((eq? sym (car xl)))
+ ((pair? (car xl))
+ (or (eq? sym (caar xl))
+ (and indirect (memq sym (cdar xl)))
+ (loop (cdr xl))))
+ (else (loop (cdr xl)))))))
+
+(define ##sys#finalize-module
+ (let ((display display)
+ (write-char write-char))
+ (lambda (mod)
+ (let* ((explist (module-export-list mod))
+ (name (module-name mod))
+ (dlist (module-defined-list mod))
+ (elist (module-exist-list mod))
+ (missing #f)
+ (sdlist (map (lambda (sym) (assq (car sym) (##sys#macro-environment)))
+ (module-defined-syntax-list mod)))
+ (sexports
+ (if (eq? #t explist)
+ sdlist
+ (let loop ((me (##sys#macro-environment)))
+ (cond ((null? me) '())
+ ((##sys#find-export (caar me) mod #f)
+ (cons (car me) (loop (cdr me))))
+ (else (loop (cdr me)))))))
+ (vexports
+ (let loop ((xl (if (eq? #t explist) elist explist)))
+ (if (null? xl)
+ '()
+ (let* ((h (car xl))
+ (id (if (symbol? h) h (car h))))
+ (if (assq id sexports)
+ (loop (cdr xl))
+ (cons
+ (cons
+ id
+ (let ((def (assq id dlist)))
+ (if (and def (symbol? (cdr def)))
+ (cdr def)
+ (let ((a (assq id (##sys#current-environment))))
+ (cond ((and a (symbol? (cdr a)))
+ (dm "reexporting: " id " -> " (cdr a))
+ (cdr a))
+ ((not def)
+ (set! missing #t)
+ (##sys#warn
+ (string-append
+ "exported identifier of module `"
+ (symbol->string name)
+ "' has not been defined")
+ id)
+ #f)
+ (else (##sys#module-rename id name)))))))
+ (loop (cdr xl)))))))))
+ (for-each
+ (lambda (u)
+ (let* ((where (cdr u))
+ (u (car u)))
+ (unless (memq u elist)
+ (let ((out (open-output-string)))
+ (set! missing #t)
+ (display "reference to possibly unbound identifier `" out)
+ (display u out)
+ (write-char #\' out)
+ (when (pair? where)
+ (display " in:" out)
+ (for-each
+ (lambda (sym)
+ (display "\nWarning: " out)
+ (display sym out))
+ where))
+ (and-let* ((a (getp u '##core#db)))
+ (cond ((= 1 (length a))
+ (display "\nWarning: suggesting: `(import " out)
+ (display (cadar a) out)
+ (display ")'" out))
+ (else
+ (display "\nWarning: suggesting one of:" out)
+ (for-each
+ (lambda (a)
+ (display "\nWarning: (import " out)
+ (display (cadr a) out)
+ (write-char #\) out))
+ a))))
+ (##sys#warn (get-output-string out))))))
+ (module-undefined-list mod))
+ (when missing
+ (##sys#error "module unresolved" name))
+ (let* ((iexports
+ (map (lambda (exp)
+ (cond ((symbol? (cdr exp)) exp)
+ ((assq (car exp) (##sys#macro-environment)))
+ (else (##sys#error "(internal) indirect export not found" (car exp)))) )
+ (module-indirect-exports mod)))
+ (new-se (merge-se
+ (##sys#macro-environment)
+ (##sys#current-environment)
+ iexports vexports sexports sdlist)))
+ (##sys#mark-imported-symbols iexports)
+ (for-each
+ (lambda (m)
+ (let ((se (merge-se (cadr m) new-se))) ;XXX needed?
+ (dm `(FIXUP: ,(car m) ,@(map-se se)))
+ (set-car! (cdr m) se)))
+ sdlist)
+ (dm `(EXPORTS:
+ ,(module-name mod)
+ (DLIST: ,@dlist)
+ (SDLIST: ,@(map-se sdlist))
+ (IEXPORTS: ,@(map-se iexports))
+ (VEXPORTS: ,@(map-se vexports))
+ (SEXPORTS: ,@(map-se sexports))))
+ (set-module-vexports! mod vexports)
+ (set-module-sexports! mod sexports))))))
+
+(define ##sys#module-table '())
+
+
+;;; Import-expansion
+
+(define (##sys#expand-import x r c import-env macro-env meta? reexp? loc)
+ (let ((%only (r 'only))
+ (%rename (r 'rename))
+ (%except (r 'except))
+ (%prefix (r 'prefix))
+ (%srfi (r 'srfi)))
+ (define (resolve sym)
+ (or (lookup sym '()) sym)) ;*** empty se?
+ (define (tostr x)
+ (cond ((string? x) x)
+ ((keyword? x) (##sys#string-append (##sys#symbol->string x) ":")) ; hack
+ ((symbol? x) (##sys#symbol->string x))
+ ((number? x) (number->string x))
+ (else (##sys#syntax-error-hook loc "invalid prefix" ))))
+ (define (import-name spec)
+ (let* ((mname (##sys#strip-syntax spec))
+ (mod (##sys#find-module mname #f)))
+ (unless mod
+ (let ((il (##sys#find-extension
+ (string-append (symbol->string mname) ".import")
+ #t)))
+ (cond (il (parameterize ((##sys#current-module #f)
+ (##sys#current-environment '())
+ (##sys#current-meta-environment
+ (##sys#current-meta-environment))
+ (##sys#macro-environment
+ (##sys#meta-macro-environment)))
+ (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
+ (##sys#load il #f #f)))
+ (set! mod (##sys#find-module mname)))
+ (else
+ (##sys#syntax-error-hook
+ loc "cannot import from undefined module"
+ mname)))))
+ (let ((vexp (module-vexports mod))
+ (sexp (module-sexports mod)))
+ (cons vexp sexp))))
+ (define (import-spec spec)
+ (cond ((symbol? spec) (import-name spec))
+ ((or (not (list? spec)) (< (length spec) 2))
+ (##sys#syntax-error-hook 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 s)
+ (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
+ (let ((ids (map resolve (cddr spec))))
+ (let loop ((ids ids) (v '()) (s '()))
+ (cond ((null? ids) (cons v s))
+ ((assq (car ids) impv) =>
+ (lambda (a)
+ (loop (cdr ids) (cons a v) s)))
+ ((assq (car ids) imps) =>
+ (lambda (a)
+ (loop (cdr ids) v (cons a s))))
+ (else (loop (cdr ids) v s))))))
+ ((c %except s)
+ (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
+ (let ((ids (map resolve (cddr spec))))
+ (let loop ((impv impv) (v '()))
+ (cond ((null? impv)
+ (let loop ((imps imps) (s '()))
+ (cond ((null? imps) (cons v s))
+ ((memq (caar imps) ids) (loop (cdr imps) s))
+ (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 s)
+ (##sys#check-syntax loc spec '(_ _ . #((symbol symbol) 0)))
+ (let loop ((impv impv) (imps imps) (v '()) (s '()) (ids (cddr spec)))
+ (cond ((null? impv)
+ (cond ((null? imps)
+ (for-each
+ (lambda (id)
+ (##sys#warn "renamed identifier not imported" id) )
+ ids)
+ (cons v s))
+ ((assq (caar imps) ids) =>
+ (lambda (a)
+ (loop impv (cdr imps)
+ v
+ (cons (cons (cadr a) (cdar imps)) s)
+ (##sys#delq a ids))))
+ (else (loop impv (cdr imps) v (cons (car imps) s) ids))))
+ ((assq (caar impv) ids) =>
+ (lambda (a)
+ (loop (cdr impv) imps
+ (cons (cons (cadr a) (cdar impv)) v)
+ s
+ (##sys#delq a ids))))
+ (else (loop (cdr impv) imps
+ (cons (car impv) v)
+ s ids)))))
+ ((c %prefix s)
+ (##sys#check-syntax loc spec '(_ _ _))
+ (let ((pref (tostr (caddr spec))))
+ (define (ren imp)
+ (cons
+ (##sys#string->symbol
+ (##sys#string-append pref (##sys#symbol->string (car imp))) )
+ (cdr imp) ) )
+ (cons (map ren impv) (map ren imps))))
+ (else (##sys#syntax-error-hook loc "invalid import specification" spec)))))))
+ (##sys#check-syntax loc x '(_ . #(_ 1)))
+ (let ((cm (##sys#current-module)))
+ (when cm
+ ;; save import form
+ (if meta?
+ (set-module-meta-import-forms!
+ cm
+ (append (module-meta-import-forms cm) (cdr x)))
+ (set-module-import-forms!
+ cm
+ (append (module-import-forms cm) (cdr x)))))
+ (for-each
+ (lambda (spec)
+ (let* ((vs (import-spec spec))
+ (vsv (car vs))
+ (vss (cdr vs))
+ (prims '()))
+ (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)))
+ (##sys#mark-imported-symbols vsv) ; mark imports as ##core#aliased
+ (for-each
+ (lambda (imp)
+ (let* ((id (car imp))
+ (aid (cdr imp))
+ (prim (getp aid '##core#primitive)))
+ (when prim
+ (set! prims (cons imp prims)))
+ (and-let* ((a (assq id (import-env)))
+ ((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"))
+ (set-module-export-list!
+ cm
+ (append
+ (let ((xl (module-export-list cm) ))
+ (if (eq? #t xl) '() xl))
+ (map car vsv)
+ (map car vss)))
+ (when (pair? prims)
+ (set-module-meta-expressions!
+ cm
+ (append
+ (module-meta-expressions cm)
+ `((##sys#mark-primitive ',prims)))))
+ (dm "export-list: " (module-export-list cm)))
+ (import-env (append vsv (import-env)))
+ (macro-env (append vss (macro-env)))))
+ (cdr x))
+ '(##core#undefined))))
+
+(define (##sys#module-rename sym prefix)
+ (##sys#string->symbol
+ (string-append
+ (##sys#slot prefix 1)
+ "#"
+ (##sys#slot sym 1) ) ) )
+
+(define (##sys#alias-global-hook sym assign where)
+ (define (mrename sym)
+ (cond ((##sys#current-module) =>
+ (lambda (mod)
+ (dm "(ALIAS) global alias " sym " in " (module-name mod))
+ (unless assign
+ (##sys#register-undefined sym mod where))
+ (##sys#module-rename sym (module-name mod))))
+ (else sym)))
+ (cond ((##sys#qualified-symbol? sym) sym)
+ ((getp sym '##core#primitive) =>
+ (lambda (p)
+ (dm "(ALIAS) primitive: " p)
+ p))
+ ((getp sym '##core#aliased)
+ (dm "(ALIAS) marked: " sym)
+ sym)
+ ((assq sym (##sys#current-environment)) =>
+ (lambda (a)
+ (dm "(ALIAS) in current environment: " sym)
+ (let ((sym2 (cdr a)))
+ (if (pair? sym2) ; macro (*** can this be?)
+ (mrename sym)
+ (or (getp sym2 '##core#primitive) sym2)))))
+ (else (mrename sym))))
+
+(define (##sys#register-interface name exps)
+ ;; expects exps to be stripped and validated
+ (putp name '##core#interface exps))
+
+(define (##sys#validate-exports exps loc)
+ ;; expects "exps" to be stripped
+ (define (err . args)
+ (apply ##sys#syntax-error-hook loc args))
+ (cond ((eq? '* exps) exps)
+ ((not (pair? exps))
+ (err "invalid exports" exps))
+ (else
+ (let loop ((xps exps))
+ (cond ((null? xps) '())
+ ((not (pair? xps))
+ (err "invalid exports" exps))
+ (else
+ (let ((x (car xps)))
+ (cond ((symbol? x) (cons x (loop (cdr xps))))
+ ((not (list? x))
+ (err "invalid export" x exps))
+ ((eq? #:syntax (car x))
+ (cons (cdr x) (loop (cdr xps)))) ; currently not used
+ ((eq? #:interface (car x))
+ (if (and (pair? (cdr x)) (symbol? (cadr x)))
+ (cond ((getp (cadr x) '##core#interface) =>
+ (lambda (iface)
+ (append iface (loop (cdr xps)))))
+ (else
+ (err "invalid interface specification" x exps)))
+ (err "invalid interface specification" x exps)))
+ (else (err "invalid export" x exps))))))))))
diff --git a/rules.make b/rules.make
index 521a8010..f0bc4bb3 100644
--- a/rules.make
+++ b/rules.make
@@ -38,7 +38,7 @@ SETUP_API_OBJECTS_1 = setup-api setup-download
LIBCHICKEN_OBJECTS_1 = \
library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
srfi-14 srfi-18 srfi-69 $(POSIXFILE) irregex scheduler \
- profiler stub expand chicken-syntax chicken-ffi-syntax runtime
+ profiler stub expand modules chicken-syntax chicken-ffi-syntax runtime
LIBCHICKEN_SHARED_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=$(O))
LIBCHICKEN_STATIC_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=-static$(O))
@@ -473,6 +473,8 @@ eval.c: $(SRCDIR)eval.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
expand.c: $(SRCDIR)expand.scm $(SRCDIR)synrules.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
+modules.c: $(SRCDIR)modules.scm $(SRCDIR)common-declarations.scm
+ $(bootstrap-lib)
extras.c: $(SRCDIR)extras.scm $(SRCDIR)private-namespace.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
posixunix.c: $(SRCDIR)posixunix.scm $(SRCDIR)posix-common.scm $(SRCDIR)common-declarations.scm
Trap