From: Chris Hanson Date: Mon, 8 Oct 2018 01:07:19 +0000 (-0700) Subject: Get loader to work with R7RS files processed with SF. X-Git-Tag: mit-scheme-pucked-9.2.19~2^2~7 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f67beb1e22ab7bf6370a7c57121959f763a1f893;p=mit-scheme.git Get loader to work with R7RS files processed with SF. --- diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm index 11e83f335..a3f1ff743 100644 --- a/src/runtime/library-loader.scm +++ b/src/runtime/library-loader.scm @@ -233,7 +233,14 @@ USA. (scode-library->library library filename)) (r7rs-scode-file-libraries scode))))) (register-libraries! libraries db) - (for-each library-eval-result libraries))) + (let loop ((libraries libraries) (result unspecific)) + (if (pair? libraries) + (loop (cdr libraries) + (let* ((library (car libraries)) + (result* (library-eval-result library))) + (or (library-name library) + result*))) + result)))) (define (scode-library->library library filename) (make-library (scode-library-name library) @@ -262,39 +269,4 @@ USA. (let ((p (assq name export-alist))) (if (not p) (error "Not an exported name:" name)) - (cdr p)))))) - -;;;; Load - -#| -(define (load db) - (for-each (lambda (parsed) - (load-library (syntax-library parsed db) - db)) - parsed-libraries) - (if (pair? imports) - (let ((environment* - (imports->environment - (expand-import-sets imports db)))) - (let loop ((exprs body) (value unspecific)) - (if (pair? exprs) - (loop (cdr exprs) - (eval (car exprs) environment*)) - value))))) - -(define (load-library library-name db) - (or (db 'get-loaded library-name #f) - (let ((syntaxed (db 'get-syntaxed library-name))) - (let ((environment - (imports->environment - (syntaxed-library-imports syntaxed) - db))) - (scode-eval (syntaxed-library-body syntaxed) - environment) - (let ((loaded - (make-loaded-library (syntaxed-library-name syntaxed) - (syntaxed-library-exports syntaxed) - environment))) - (db 'save-loaded! loaded) - loaded))))) -|# \ No newline at end of file + (cdr p)))))) \ No newline at end of file diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm index 73bdd8eea..74e5a3f03 100644 --- a/src/runtime/library-standard.scm +++ b/src/runtime/library-standard.scm @@ -89,7 +89,8 @@ USA. imports)) (define (define-standard-library name exports) - (let ((p (assoc name standard-libraries))) + (let ((p (assoc name standard-libraries)) + (exports (extend-with-macro-deps exports))) (if p (set-cdr! p exports) (begin @@ -101,6 +102,71 @@ USA. (define standard-libraries '()) +;; Make sure that the names introduced by macro expansions are also included. +;; This is a kludge to work around our inability to address names globally. +(define (extend-with-macro-deps names) + (define (scan-new to-scan new names) + (cond ((pair? to-scan) + (let ((name (car to-scan)) + (rest (cdr to-scan))) + (let ((p (assq name macro-dependencies))) + (if p + (scan-deps (cdr p) rest new names) + (scan-new rest new names))))) + ((pair? new) + (scan-new new '() names)) + (else names))) + + (define (scan-deps deps rest new names) + (if (pair? deps) + (let ((dep (car deps))) + (if (memq dep names) + (scan-deps (cdr deps) rest new names) + (scan-deps (cdr deps) + rest + (cons dep new) + (cons dep names)))) + (scan-new rest new names))) + + (scan-new names '() names)) + +(define macro-dependencies + '((and if) + (and-let* and begin let) + (assert error if not) + (begin0 let) + (bundle alist->bundle cons list) + (case begin eq? eqv? if let or quote) + (case-lambda apply default-object? error fix:= fix:>= if lambda length let) + (circular-stream cons delay letrec) + (cond begin if let) + (cond-expand begin) + (cons-stream cons delay) + (cons-stream* cons delay) + (define lambda named-lambda) + (define-integrable begin lambda let set! shallow-fluid-bind) + (define-record-type define new-make-record-type quote record-accessor + record-constructor record-modifier record-predicate) + (define-values begin call-with-values define lambda set!) + (delay delay-force make-promise) + (delay-force lambda make-unforced-promise) + (do begin if let) + (guard begin call-with-current-continuation if lambda let raise-continuable + with-exception-handler) + (include begin) + (include-ci begin) + (let declare lambda letrec letrec* named-lambda) + (let* let) + (let-syntax* let-syntax) + (letrec lambda let set!) + (letrec* begin lambda let) + (local-declare declare let) + (parameterize cons lambda list parameterize*) + (quasiquote append cons list list->vector quote vector) + (receive call-with-values lambda) + (unless begin if not) + (when begin if))) + (define-standard-library '(scheme base) '(* + diff --git a/src/runtime/load.scm b/src/runtime/load.scm index 8c1d14f13..a7f43e83e 100644 --- a/src/runtime/load.scm +++ b/src/runtime/load.scm @@ -124,7 +124,7 @@ USA. (receive (pathname* loader notifier) (choose-fasload-method pathname) (if pathname* (values pathname* - (wrap-loader pathname (fasloader->loader loader)) + (wrap-loader pathname (fasloader->loader pathname loader)) notifier) (let ((pathname* (if (file-regular? pathname) @@ -138,11 +138,13 @@ USA. (loading-notifier pathname*)) (values #f #f #f))))))) -(define (fasloader->loader loader) +(define (fasloader->loader pathname loader) (lambda (environment purify?) (let ((scode (loader))) (if purify? (purify (load/purification-root scode))) - (extended-scode-eval scode environment)))) + (if (r7rs-scode-file? scode) + (eval-r7rs-scode-file scode pathname (current-load-library-db)) + (extended-scode-eval scode environment))))) (define (source-loader pathname) (lambda (environment purify?) @@ -173,7 +175,7 @@ USA. (define (file-fasloadable? pathname) (receive (pathname* loader notifier) (choose-fasload-method pathname) - loader notifier + (declare (ignore loader notifier)) (if pathname* #t #f))) (define (choose-fasload-method pathname) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index c76c91dfe..a0b9d9ce9 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -527,6 +527,7 @@ USA. (runtime unsyntaxer) (runtime pretty-printer) (runtime extended-scode-eval) + (runtime syntax low) (runtime syntax items) (runtime syntax rename) (runtime syntax top-level) diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index a970b7733..3ed2e05df 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -927,4 +927,4 @@ USA. (syntax-rules () ((_ predicate name ...) (alist->bundle predicate - (list (cons 'name name) ...))))) \ No newline at end of file + (list (cons 'name name) ...))))) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 89d1dcb62..59da5d0fc 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4555,7 +4555,8 @@ USA. sc-macro-transformer->keyword-item spar-classifier->keyword spar-classifier->runtime - spar-macro-transformer->keyword-item)) + spar-macro-transformer->keyword-item + top-level-senv)) (define-package (runtime syntax items) (files "syntax-items") diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm index 1991bce5b..2ac7e941b 100644 --- a/src/runtime/syntax-environment.scm +++ b/src/runtime/syntax-environment.scm @@ -283,6 +283,8 @@ USA. => cdr) ((environment-lookup-macro env identifier)) (else + (if (not (environment-bound? env identifier)) + (warn "Reference to unbound variable:" identifier)) ;; Capture free runtime references: (let ((item (var-item identifier))) (set! free (cons (cons identifier item) free)) diff --git a/src/runtime/syntax-low.scm b/src/runtime/syntax-low.scm index 605fc1c78..95c05fae0 100644 --- a/src/runtime/syntax-low.scm +++ b/src/runtime/syntax-low.scm @@ -149,13 +149,15 @@ USA. form use-senv hist - (runtime-environment->syntactic - (if (default-object? env) - system-global-environment - env))) + (if (default-object? env) + (top-level-senv) + (runtime-environment->syntactic env))) use-senv hist)))) +(define-deferred top-level-senv + (make-unsettable-parameter #f)) + (define (syntactic-keyword->item keyword environment) (let ((item (environment-lookup-macro environment keyword))) (if (not item) diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index 0dbaae971..a04a2d7cd 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -67,11 +67,12 @@ USA. (get-free))))))) (define (syntax-internal forms senv) - (compile-item - (body-item #f - (map-in-order (lambda (form) - (classify-form form senv (initial-hist form))) - forms)))) + (parameterize ((top-level-senv senv)) + (compile-item + (body-item #f + (map-in-order (lambda (form) + (classify-form form senv (initial-hist form))) + forms))))) ;;;; Classifier