~ chicken-core (chicken-5) 27567757736aaba527985f71e6c96c14ea484a21
commit 27567757736aaba527985f71e6c96c14ea484a21
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Wed Feb 3 00:03:55 2016 +1300
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Tue Mar 8 22:52:34 2016 +1300
Add core form for library tracking
Add a `##core#provide` form and runtime primitives for tracking code
loading. Make units self-providing. Bring back the `require`, `provide`,
and `provided?` procedures for user control of library loading at
runtime.
Drop the unit mapping table from the eval unit and instead fetch library
dependencies of core modules from their import libraries and module
definitions. Load the special "chicken" and "chicken.foreign" modules
for-syntax.
Avoid expanding import forms twice, which would cause duplicate warnings
to be issued when invalid imports were encountered.
Remove the unused `##core#toplevel-begin` form.
diff --git a/batch-driver.scm b/batch-driver.scm
index ac8a35bf..19c3789d 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -579,6 +579,7 @@
(exps (append
(map (lambda (ic) `(set! ,(cdr ic) ',(car ic))) immutable-constants)
(map (lambda (uu) `(##core#callunit ,uu)) used-units)
+ (if unit-name `((##core#provide ,unit-name)) '())
(if emit-profile
(profiling-prelude-exps (and (not unit-name)
(or profile-name #t)))
@@ -631,10 +632,9 @@
(end-time "user pass") ) )
;; Convert s-expressions to node tree
- (let ((node0 (make-node
- 'lambda '(())
- (list (build-node-graph
- (canonicalize-begin-body exps) ) ) ) )
+ (let ((node0 (build-toplevel-procedure
+ (build-node-graph
+ (canonicalize-begin-body exps))))
(db #f))
(print-node "initial node tree" '|T| node0)
(initialize-analysis-database)
diff --git a/c-backend.scm b/c-backend.scm
index 5622debb..687efb19 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -389,6 +389,9 @@
(when (pair? args) (expr-args args i))
(gen #\)) ) )
+ ((##core#provide)
+ (gen "C_a_i_provide(&a,1,lf[" (first params) "])"))
+
((##core#callunit)
;; The code generated here does not use the extra temporary needed for standard calls, so we have
;; one unused variable:
@@ -813,7 +816,7 @@
[llen (length literals)] )
(gen #t "C_word *a;"
#t "if(toplevel_initialized) {C_kontinue(t1,C_SCHEME_UNDEFINED);}"
- #t "else C_toplevel_entry(C_text(\"" topname "\"));")
+ #t "else C_toplevel_entry(C_text(\"" (or unit-name topname) "\"));")
(when emit-debug-info
(gen #t "C_register_debug_info(C_debug_info);"))
(when disable-stack-overflow-checking
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index f37d7e23..7c1588b7 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -42,8 +42,11 @@
(import chicken.data-structures
chicken.format)
+(include "common-declarations.scm")
(include "mini-srfi-1.scm")
+(provide* chicken-ffi-syntax) ; TODO remove after snapshot release
+
(define ##sys#chicken-ffi-macro-environment
(let ((me0 (##sys#macro-environment)))
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 5761f855..4b55dbeb 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -39,8 +39,11 @@
(no-bound-checks)
(no-procedure-checks))
+(include "common-declarations.scm")
(include "mini-srfi-1.scm")
+(provide* chicken-syntax) ; TODO remove after snapshot release
+
;;; Non-standard macros:
(define ##sys#chicken-macro-environment
diff --git a/chicken.h b/chicken.h
index 308db0a8..2b120a1f 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1794,6 +1794,8 @@ C_fctexport C_word C_fcall C_callback_wrapper(void *proc, int argc);
C_fctexport void C_fcall C_callback_adjust_stack(C_word *base, int size);
C_fctexport void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *stack, C_word *symbols);
C_fctexport void C_fcall C_toplevel_entry(C_char *name) C_regparm;
+C_fctexport C_word C_fcall C_a_i_provide(C_word **a, int c, C_word id) C_regparm;
+C_fctexport C_word C_fcall C_i_providedp(C_word id) C_regparm;
C_fctexport C_word C_fcall C_enable_interrupts(void) C_regparm;
C_fctexport C_word C_fcall C_disable_interrupts(void) C_regparm;
C_fctexport void C_fcall C_paranoid_check_for_interrupt(void) C_regparm;
diff --git a/chicken.import.scm b/chicken.import.scm
index 74d08057..1290f7ae 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -139,6 +139,8 @@
port-name
port-position
port?
+ (provide . chicken.eval#provide)
+ (provided? . chicken.eval#provided?)
print
print-call-chain
print-error-message
@@ -155,6 +157,7 @@
remprop!
rename-file
(repository-path . chicken.eval#repository-path)
+ (require . chicken.eval#require)
reset
reset-handler
return-to-host
diff --git a/common-declarations.scm b/common-declarations.scm
index b3bbd4df..fc625aca 100644
--- a/common-declarations.scm
+++ b/common-declarations.scm
@@ -27,6 +27,16 @@
(declare
(usual-integrations))
+;; In chicken-5 units are self-providing, but when bootstrapping with
+;; chicken-4 we need to manually trigger C_a_i_provide for some
+;; special-case units (see `core-unit-requirements` in eval.scm).
+(define-syntax provide*
+ (er-macro-transformer
+ (lambda (x r c)
+ (cond-expand
+ (chicken-5 `(void))
+ (chicken-4 `(##core#inline_allocate ("C_a_i_provide" 8) ',(cadr x)))))))
+
(cond-expand
(debugbuild
(define-syntax d
diff --git a/core.scm b/core.scm
index d1078a14..3523b25c 100644
--- a/core.scm
+++ b/core.scm
@@ -111,11 +111,11 @@
; (##core#lambda ({<variable>}+ [. <variable>]) <body>)
; (##core#set! <variable> <exp>)
; (##core#begin <exp> ...)
-; (##core#toplevel-begin <exp> ...)
; (##core#include <string>)
; (##core#loop-lambda <llist> <body>)
; (##core#undefined)
; (##core#primitive <name>)
+; (##core#provide <id>)
; (##core#inline {<op>} <exp>)
; (##core#inline_allocate (<op> <words>) {<exp>})
; (##core#inline_ref (<name> <type>))
@@ -172,6 +172,7 @@
; [##core#callunit {<unitname>} <exp>...]
; [##core#switch {<count>} <exp> <const1> <body1> ... <defaultbody>]
; [##core#cond <exp> <exp> <exp>]
+; [##core#provide <id>]
; [##core#recurse {<tail-flag>} <exp1> ...]
; [##core#return <exp>]
; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
@@ -216,6 +217,7 @@
; [##core#literal {<literal>}]
; [##core#immediate {<type> [<immediate>]}] - type: bool/fix/nil/char
; [##core#proc {<name> [<non-internal>]}]
+; [##core#provide <literal>]
; [##core#recurse {<tail-flag> <call-id>} <exp1> ...]
; [##core#return <exp>]
; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
@@ -272,7 +274,7 @@
(module chicken.compiler.core
(analyze-expression canonicalize-expression compute-database-statistics
initialize-compiler perform-closure-conversion perform-cps-conversion
- prepare-for-code-generation
+ prepare-for-code-generation build-toplevel-procedure
;; These are both exported for use in eval.scm (which is a bit of
;; a hack). file-requirements is also used by batch-driver
@@ -651,7 +653,7 @@
(hide-variable var)
var) ] ) ) )
- ((##core#undefined ##core#callunit ##core#primitive) x)
+ ((##core#callunit ##core#provide ##core#primitive ##core#undefined) x)
((##core#inline_ref)
`(##core#inline_ref
@@ -663,13 +665,8 @@
,(walk (caddr x) e se dest ldest h ln)))
((##core#require-for-syntax)
- (let ([ids (map eval (cdr x))])
- (apply ##sys#require ids)
- (##sys#hash-table-update!
- file-requirements 'dynamic/syntax
- (cut lset-union/eq? <> ids)
- (lambda () ids) )
- '(##core#undefined) ) )
+ (apply ##sys#load-extension (cdr x))
+ '(##core#undefined))
((##core#require)
(walk
@@ -927,7 +924,8 @@
((##core#module)
(let* ((name (strip-syntax (cadr x)))
- (unit (or unit-name name))
+ (import-lib (or (assq name import-libraries) all-import-libraries))
+ (unit (and import-lib (or unit-name name)))
(exports
(or (eq? #t (caddr x))
(map (lambda (exp)
@@ -966,30 +964,27 @@
(print-error-message ex (current-error-port))
(exit 1))
(##sys#finalize-module (##sys#current-module)))
- (cond ((or (assq name import-libraries) all-import-libraries)
- => (lambda (il)
- (when enable-module-registration
- (emit-import-lib name il))
- ;; Remove from list to avoid error
- (when (pair? il)
- (set! import-libraries
- (delete il import-libraries)))
- (values
- (reverse xs)
- `((##sys#provide ',unit)))))
+ (cond (import-lib
+ (when enable-module-registration
+ (emit-import-lib name import-lib))
+ ;; Remove from list to avoid error
+ (when (pair? import-lib)
+ (set! import-libraries
+ (delete import-lib import-libraries)))
+ (values
+ (reverse xs)
+ '((##core#undefined))))
((not enable-module-registration)
(values
(reverse xs)
- '((##core#undefined)))) ; XXX correct?
+ '((##core#undefined))))
(else
(values
(reverse xs)
- `((##sys#provide ',unit)
- .
- ,(if standalone-executable
- `()
- (##sys#compiled-module-registration
- (##sys#current-module))))))))
+ (if standalone-executable
+ '()
+ (##sys#compiled-module-registration
+ (##sys#current-module)))))))
(else
(loop
(cdr body)
@@ -1123,7 +1118,7 @@
(##sys#eval/meta (cadr x))
'(##core#undefined) )
- ((##core#begin ##core#toplevel-begin)
+ ((##core#begin)
(if (pair? (cdr x))
(canonicalize-begin-body
(let fold ([xs (cdr x)])
@@ -1691,6 +1686,12 @@
'(##core#undefined) ) ) )
+;;; Create entry procedure:
+
+(define (build-toplevel-procedure node)
+ (make-node 'lambda '(()) (list node)))
+
+
;;; Expand "foreign-lambda"/"foreign-safe-lambda" forms and add item to stub-list:
(define-record-type foreign-stub
@@ -1821,7 +1822,7 @@
(params (node-parameters n))
(class (node-class n)) )
(case (node-class n)
- ((##core#variable quote ##core#undefined ##core#primitive) (k n))
+ ((##core#variable quote ##core#undefined ##core#primitive ##core#provide) (k n))
((if) (let* ((t1 (gensym 'k))
(t2 (gensym 'r))
(k1 (lambda (r) (make-node '##core#call (list #t) (list (varnode t1) r)))) )
@@ -1947,7 +1948,7 @@
(class (node-class n)) )
(grow 1)
(case class
- ((quote ##core#undefined ##core#proc) #f)
+ ((quote ##core#undefined ##core#provide ##core#proc) #f)
((##core#variable)
(let ((var (first params)))
@@ -2352,7 +2353,7 @@
(list var)
'())))
- ((quote ##core#undefined ##core#proc ##core#primitive)
+ ((quote ##core#undefined ##core#provide ##core#proc ##core#primitive)
'())
((let)
@@ -2433,7 +2434,7 @@
(class (node-class n)) )
(case class
- ((quote ##core#undefined ##core#proc) n)
+ ((quote ##core#undefined ##core#provide ##core#proc) n)
((##core#variable)
(let* ((var (first params))
@@ -2706,6 +2707,12 @@
'()
subs) ) )
+ ((##core#provide)
+ ;; Allocate enough space for the ##core#provided property.
+ (let ((id (literal (first params))))
+ (set! allocated (+ allocated 8))
+ (make-node class (list id) '())))
+
((##core#lambda ##core#direct_lambda)
(let ((temps temporaries)
(ubtemps ubtemporaries)
diff --git a/eval.scm b/eval.scm
index 42b14d75..e17dbdca 100644
--- a/eval.scm
+++ b/eval.scm
@@ -51,61 +51,45 @@
eval eval-handler extension-information
load load-library load-noisily load-relative load-verbose
interaction-environment null-environment scheme-report-environment
- load-extension repository-path set-dynamic-load-mode!)
+ load-extension provide provided? repository-path
+ require set-dynamic-load-mode!)
-;; Exclude values defined within this module.
-(import (except scheme eval load interaction-environment null-environment scheme-report-environment))
-(import chicken)
+;; Exclude bindings defined within this module.
+(import (except scheme eval load interaction-environment null-environment scheme-report-environment)
+ (except chicken chicken-home provide provided? repository-path require))
-(import chicken.internal
- chicken.expand
- chicken.keyword
- chicken.foreign)
+(import chicken.expand
+ chicken.foreign
+ chicken.internal
+ chicken.keyword)
(include "common-declarations.scm")
(include "mini-srfi-1.scm")
(define-syntax d (syntax-rules () ((_ . _) (void))))
+(provide* eval) ; TODO remove after a snapshot release
+
(define-foreign-variable install-egg-home c-string "C_INSTALL_EGG_HOME")
(define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")
(define-foreign-variable binary-version int "C_BINARY_VERSION")
(define-foreign-variable uses-soname? bool "C_USES_SONAME")
(define-foreign-variable install-lib-name c-string "C_INSTALL_LIB_NAME")
-;; TODO take these mappings from import files instead
-(define-constant core-chicken-modules
- '((chicken . chicken-syntax)
- (chicken.bitwise . library)
- (chicken.continuation . continuation)
- (chicken.data-structures . data-structures)
- (chicken.eval . eval)
- (chicken.expand . expand)
- (chicken.files . files)
- (chicken.flonum . library)
- (chicken.foreign . chicken-ffi-syntax)
- (chicken.format . extras)
- (chicken.gc . library)
- (chicken.internal . internal)
- (chicken.io . extras)
- (chicken.irregex . irregex)
- (chicken.keyword . library)
- (chicken.locative . lolevel)
- (chicken.lolevel . lolevel)
- (chicken.ports . ports)
- (chicken.posix . posix)
- (chicken.pretty-print . extras)
- (chicken.tcp . tcp)
- (chicken.time . library)
- (chicken.repl . repl)
- (chicken.read-syntax . read-syntax)
- (chicken.utils . utils)))
-
-(define-constant core-library-units
- `(srfi-4 . ,(map cdr core-chicken-modules)))
-
-(define-constant core-syntax-units
- '(chicken-syntax chicken-ffi-syntax))
+(define-constant core-unit-requirements
+ '((scheme ; XXX not totally correct, also needs eval
+ . (##core#require library))
+ (chicken.foreign
+ . (##core#require-for-syntax chicken-ffi-syntax))
+ (chicken
+ . (##core#begin
+ (##core#require-for-syntax chicken-syntax)
+ (##core#require library)))))
+
+(define-constant core-units
+ '(chicken-syntax chicken-ffi-syntax continuation data-structures eval
+ expand extras files internal irregex library lolevel ports posix
+ srfi-4 tcp repl read-syntax utils))
(define-constant cygwin-default-dynamic-load-libraries '("cygchicken-0"))
(define-constant macosx-load-library-extension ".dylib")
@@ -119,17 +103,11 @@
(define-constant prefix-environment-variable "CHICKEN_PREFIX")
; these are actually in unit extras, but that is used by default
-; srfi-12 in unit library
-; srfi-98 partially in unit posix
(define-constant builtin-features
- '(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) )
+ '(srfi-12 srfi-30 srfi-46 srfi-61 srfi-62 ; runtime
+ srfi-0 srfi-2 srfi-8 srfi-9 srfi-11 srfi-15 ; syntax
+ srfi-16 srfi-17 srfi-26 srfi-31 srfi-55 srfi-88)) ; syntax cont
(define default-dynamic-load-libraries
(case (build-platform)
@@ -144,7 +122,16 @@
(lambda (#!optional dir)
(and prefix
(if dir (##sys#string-append prefix dir) prefix) ) ) ) )
-
+
+
+;;; Library registration (used for code loading):
+
+(define (##sys#provide id)
+ (##core#inline_allocate ("C_a_i_provide" 8) id))
+
+(define (##sys#provided? id)
+ (##core#inline "C_i_providedp" id))
+
;;; System settings
@@ -373,7 +360,7 @@
(compile '(##core#undefined) e #f tf cntr se) ) ] )
(lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
- [(##core#begin ##core#toplevel-begin)
+ [(##core#begin)
(let* ((body (##sys#slot x 1))
(len (length body)) )
(case len
@@ -678,7 +665,7 @@
(when (##sys#current-module)
(##sys#syntax-error-hook 'module "modules may not be nested" name))
(parameterize ((##sys#current-module
- (##sys#register-module name name exports))
+ (##sys#register-module name #f exports))
(##sys#current-environment '())
(##sys#macro-environment
##sys#initial-macro-environment)
@@ -690,7 +677,6 @@
(if (null? body)
(let ((xs (reverse xs)))
(##sys#finalize-module (##sys#current-module))
- (##sys#provide name)
(lambda (v)
(let loop2 ((xs xs))
(if (null? xs)
@@ -712,9 +698,11 @@
[(##core#loop-lambda)
(compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se) ]
+ [(##core#provide)
+ (compile `(##sys#provide (##core#quote ,(cadr x))) e #f tf cntr se)]
+
[(##core#require-for-syntax)
- (let ([ids (map (lambda (x) (##sys#eval/meta x))
- (cdr x))])
+ (let ((ids (cdr x)))
(apply ##sys#load-extension ids)
(let ((rs (lookup-runtime-requirements ids)))
(compile
@@ -1128,8 +1116,7 @@
(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))
+ ((##sys#dload (##sys#make-c-string (##sys#slot libs 0) 'load-library) top) #t)
(else (loop (##sys#slot libs 1))))))))))
(define load-library
@@ -1229,19 +1216,17 @@
(or (check pa)
(loop (##sys#slot paths 1)) ) ) ) ) ) ) ))
-(define (load-extension id)
+(define (##sys#load-extension id #!optional loc)
(define (fail message)
- (##sys#error 'load-extension message id))
+ (##sys#error loc message id))
(cond ((string? id) (set! id (string->symbol id)))
- (else (##sys#check-symbol id 'load-extension)))
+ (else (##sys#check-symbol id loc)))
(cond ((##sys#provided? id))
- ((memq id core-syntax-units)
- (fail "cannot load core library"))
- ((memq id core-library-units)
+ ((memq id core-units)
(or (load-library-0 id #f)
(fail "cannot load core library")))
(else
- (let* ((path (##sys#canonicalize-extension-path id 'load-extension))
+ (let* ((path (##sys#canonicalize-extension-path id loc))
(ext (##sys#find-extension path #f)))
(cond (ext
(load/internal ext #f #f #f #f id)
@@ -1249,7 +1234,21 @@
(else
(fail "cannot load extension")))))))
-(define ##sys#load-extension load-extension)
+(define (load-extension id)
+ (##sys#load-extension id 'load-extension))
+
+(define (require . ids)
+ (for-each (cut ##sys#load-extension <> 'require) ids))
+
+(define (provide . ids)
+ (for-each (cut ##sys#check-symbol <> 'provide) ids)
+ (for-each (cut ##sys#provide <>) ids))
+
+(define (provided? . ids)
+ (let loop ((ids ids))
+ (or (null? ids)
+ (and (##sys#provided? (car ids))
+ (loop (cdr ids))))))
(define extension-information/internal
(let ([with-input-from-file with-input-from-file]
@@ -1289,31 +1288,27 @@
;;
(define (##sys#expand-require lib #!optional compiling? (static-units '()))
(let ((id (library-id lib)))
- (let loop ((id (library-id lib)))
(cond
- ((assq id core-chicken-modules) =>
- (lambda (mod) (loop (cdr mod))))
- ((or (memq id builtin-features)
- (and compiling? (memq id builtin-features/compiled)))
+ ((assq id core-unit-requirements) =>
+ (lambda (x) (values (cdr x) id #f)))
+ ((memq id builtin-features)
(values '(##core#undefined) id #f))
((memq id static-units)
(values '(##core#undefined) id #f))
- ((memq id core-syntax-units)
- (values '(##core#undefined) id #f))
- ((memq id core-library-units)
+ ((memq id core-units)
(values
(if compiling?
`(##core#declare (uses ,id))
`(##sys#load-library (##core#quote ,id) #f))
id #f))
- ((extension-information/internal id 'require) =>
+ ((extension-information/internal id #f) =>
(lambda (info)
(let ((s (assq 'syntax info))
(nr (assq 'syntax-only info))
(rr (assq 'require-at-runtime info)))
(values
`(##core#begin
- ,@(if s `((##core#require-for-syntax (##core#quote ,id))) '())
+ ,@(if s `((##core#require-for-syntax ,id)) '())
,@(if (or nr (and (not rr) s))
'()
(begin
diff --git a/expand.scm b/expand.scm
index d035901a..34d03041 100644
--- a/expand.scm
+++ b/expand.scm
@@ -29,7 +29,7 @@
(declare
(unit expand)
- (uses extras internal)
+ (uses internal)
(disable-interrupts)
(fixnum)
(hide check-for-multiple-bindings)
@@ -950,11 +950,12 @@
(##sys#er-transformer
(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))))
+ ,@(map (lambda (spec)
+ (let-values (((name lib v s i) (##sys#expand-import spec r c 'import)))
+ (##sys#finalize-import
+ name v s i
+ ##sys#current-environment ##sys#macro-environment #f #f 'import)
+ (if (not lib) '(##core#undefined) `(##core#require ,lib))))
(cdr x))))))
(##sys#extend-macro-environment
diff --git a/internal.scm b/internal.scm
index 96d77fa3..b505586a 100644
--- a/internal.scm
+++ b/internal.scm
@@ -34,6 +34,7 @@
(import scheme chicken)
+(include "common-declarations.scm")
(include "mini-srfi-1.scm")
diff --git a/library.scm b/library.scm
index 2ebdc2d9..8696851e 100644
--- a/library.scm
+++ b/library.scm
@@ -162,6 +162,7 @@ EOF
(define-constant default-parameter-vector-size 16)
(define maximal-string-length (foreign-value "C_HEADER_SIZE_MASK" unsigned-long))
+(provide* library) ; TODO remove after snapshot release
;;; System routines:
diff --git a/manual/Using the compiler b/manual/Using the compiler
index 93700f33..e5aeb983 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -417,15 +417,12 @@ Let's take a simple example.
% csc -t hello.scm -optimize-level 3 -output-file hello.c
-Compiled to C, we get {{hello.c}}. We need the files {{chicken.h}},
-{{chicken-config.h}}, {{build-version.c}}, {{buildtag.h}} and
-{{runtime.c}}, which contain the basic runtime system, plus the five
-basic library files {{library.c}}, {{eval.c}}, {{expand.c}},
-{{modules.c}} and {{build-version.c}} which contain the same
-functionality as the library linked into a plain CHICKEN-compiled
-application, or which is available by default in the interpreter,
-{{csi}}:
-
+Compiled to C, we get {{hello.c}}. We need the files {{chicken-config.h}},
+{{chicken.h}}, {{buildtag.h}} and {{runtime.c}}, which contain the basic runtime
+system, plus the library files {{library.c}}, {{internal.c}}, {{eval.c}},
+{{expand.c}}, {{modules.c}} and {{build-version.c}}, which contain the same
+functionality as the library linked into a plain CHICKEN-compiled application,
+or which is available by default in the interpreter, {{csi}}:
% cd /tmp
% echo '(print "Hello World.")' > hello.scm
@@ -444,8 +441,13 @@ application, or which is available by default in the interpreter,
Now we have all files together, and can create an tarball containing all the files:
+<<<<<<< HEAD
% tar cf hello.tar hello.c runtime.c build-version.c library.c eval.c extras.c \
expand.c modules.c chicken.h chicken-config.h
+=======
+ % tar cf hello.tar hello.c runtime.c build-version.c library.c internal.c \
+ eval.c extras.c expand.c modules.c chicken.h chicken-config.h
+>>>>>>> 0b88ca1... Add core form for library tracking
% gzip hello.tar
This is naturally rather simplistic. Things like enabling dynamic
diff --git a/modules.scm b/modules.scm
index 1271fb74..226cb418 100644
--- a/modules.scm
+++ b/modules.scm
@@ -695,63 +695,66 @@
(define (##sys#import x r c import-env macro-env meta? reexp? loc)
(##sys#check-syntax loc x '(_ . #(_ 1)))
+ (for-each
+ (lambda (spec)
+ (let-values (((name _ vsv vss vsi) (##sys#expand-import spec r c loc)))
+ (##sys#finalize-import name vsv vss vsi import-env macro-env meta? reexp? loc)))
+ (cdr x))
+ '(##core#undefined))
+
+(define (##sys#finalize-import name vsv vss vsi import-env macro-env meta? reexp? loc)
(let ((cm (##sys#current-module)))
+ (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 (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
- (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)))
+ (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!
+ 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)))))
(define (module-rename sym prefix)
(##sys#string->symbol
diff --git a/rules.make b/rules.make
index be11fbe7..aa377239 100644
--- a/rules.make
+++ b/rules.make
@@ -815,8 +815,7 @@ stub.c: $(SRCDIR)stub.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
debugger-client.c: $(SRCDIR)debugger-client.scm $(SRCDIR)common-declarations.scm dbg-stub.c
$(bootstrap-lib)
-build-version.c: $(SRCDIR)build-version.scm buildbranch buildid \
- $(SRCDIR)buildversion buildtag.h
+build-version.c: $(SRCDIR)build-version.scm $(SRCDIR)buildversion buildbranch buildid buildtag.h
$(bootstrap-lib)
define declare-bootstrap-import-lib
diff --git a/runtime.c b/runtime.c
index f187de2e..0149b4d3 100644
--- a/runtime.c
+++ b/runtime.c
@@ -450,6 +450,7 @@ static C_TLS C_word
error_hook_symbol,
pending_finalizers_symbol,
callback_continuation_stack_symbol,
+ core_provided_symbol,
*forwarding_table;
static C_TLS int
trace_buffer_full,
@@ -1150,6 +1151,7 @@ void initialize_symbol_table(void)
C_bignum_type_tag = C_intern2(C_heaptop, C_text("\003sysbignum"));
C_ratnum_type_tag = C_intern2(C_heaptop, C_text("\003sysratnum"));
C_cplxnum_type_tag = C_intern2(C_heaptop, C_text("\003syscplxnum"));
+ core_provided_symbol = C_intern2(C_heaptop, C_text("\004coreprovided"));
interrupt_hook_symbol = C_intern2(C_heaptop, C_text("\003sysinterrupt-hook"));
error_hook_symbol = C_intern2(C_heaptop, C_text("\003syserror-hook"));
callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("\003syscallback-continuation-stack"), C_SCHEME_END_OF_LIST);
@@ -3603,6 +3605,7 @@ C_regparm void C_fcall mark_system_globals(void)
mark(&C_bignum_type_tag);
mark(&C_ratnum_type_tag);
mark(&C_cplxnum_type_tag);
+ mark(&core_provided_symbol);
mark(&interrupt_hook_symbol);
mark(&error_hook_symbol);
mark(&callback_continuation_stack_symbol);
@@ -3962,6 +3965,7 @@ C_regparm void C_fcall remark_system_globals(void)
remark(&C_bignum_type_tag);
remark(&C_ratnum_type_tag);
remark(&C_cplxnum_type_tag);
+ remark(&core_provided_symbol);
remark(&interrupt_hook_symbol);
remark(&error_hook_symbol);
remark(&callback_continuation_stack_symbol);
@@ -4534,9 +4538,23 @@ C_regparm C_word C_fcall C_u_i_string_ci_hash(C_word str, C_word rnd)
C_regparm void C_fcall C_toplevel_entry(C_char *name)
{
if(debug_mode)
- C_dbg(C_text("debug"), C_text("entering toplevel %s...\n"), name);
+ C_dbg(C_text("debug"), C_text("entering %s...\n"), name);
}
+C_regparm C_word C_fcall C_a_i_provide(C_word **a, int c, C_word id)
+{
+ if (debug_mode == 2) {
+ C_word str = C_block_item(id, 1);
+ C_snprintf(buffer, C_header_size(str) + 1, C_text("%s"), (C_char *) C_data_pointer(str));
+ C_dbg(C_text("debug"), C_text("providing %s...\n"), buffer);
+ }
+ return C_a_i_putprop(a, 3, id, core_provided_symbol, C_SCHEME_TRUE);
+}
+
+C_regparm C_word C_fcall C_i_providedp(C_word id)
+{
+ return C_i_getprop(id, core_provided_symbol, C_SCHEME_FALSE);
+}
C_word C_halt(C_word msg)
{
diff --git a/support.scm b/support.scm
index 9c61ded4..fa2c17c5 100644
--- a/support.scm
+++ b/support.scm
@@ -544,7 +544,7 @@
(car x)
(list (if (and (pair? arg) (eq? 'quote (car arg))) (cadr arg) arg))
(map walk (cddr x)) ) ) )
- ((##core#inline ##core#callunit)
+ ((##core#inline ##core#provide ##core#callunit)
(make-node (car x) (list (cadr x)) (map walk (cddr x))) )
((##core#debug-event) ; 2nd argument is provided by canonicalization phase
(make-node (car x) (cdr x) '()))
diff --git a/tests/import-library-test1.scm b/tests/import-library-test1.scm
index f0c51381..e79658bd 100644
--- a/tests/import-library-test1.scm
+++ b/tests/import-library-test1.scm
@@ -1,3 +1,7 @@
+(import (only (chicken eval) provide))
+
+(provide 'foo) ; XXX
+
(module foo (foo xcase)
(import (rename scheme (case xcase)))
(define-syntax foo
diff --git a/tests/reexport-tests.scm b/tests/reexport-tests.scm
index 12fdd35d..d0ae6852 100644
--- a/tests/reexport-tests.scm
+++ b/tests/reexport-tests.scm
@@ -24,7 +24,7 @@
(syntax-rules ()
((_ name imp ...)
(module name ()
- (import scheme)
+ (import scheme imp ...)
(reexport imp ...)))))
(compound-module
@@ -49,7 +49,7 @@
(module
m5
* ; () works here
- (import chicken scheme)
+ (import chicken scheme m4)
(reexport m4))
(import m5)
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 0182af96..39d6c67c 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 in `let' binding of `g38' a single result, but were given 2 results
+ expected in `let' binding of `g20' a single result, but were given 2 results
Warning: at toplevel:
- in procedure call to `g38', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
+ in procedure call to `g20', 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:
diff --git a/tests/test-chained-modules.scm b/tests/test-chained-modules.scm
index 0e67445f..728ea9cf 100644
--- a/tests/test-chained-modules.scm
+++ b/tests/test-chained-modules.scm
@@ -1,3 +1,7 @@
+(import (only (chicken eval) provide))
+
+(provide 'm1 'm2 'm3) ; XXX
+
(module m1 ((s1 f1))
(import scheme chicken)
(define (f1) (print "f1") 'f1)
Trap