From 9f67bcd9f6c364c84fb81d250a2c09c5fc56d072 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 6 Oct 2018 17:06:49 -0700 Subject: [PATCH] Change the loader so that it can load R7RS source files. Now to make compiled files work. :) --- src/runtime/library-database.scm | 3 --- src/runtime/library-loader.scm | 8 +++++++- src/runtime/library-standard.scm | 6 ++++++ src/runtime/load.scm | 26 ++++++++++++++++---------- src/runtime/make.scm | 4 +++- src/runtime/runtime.pkg | 11 +++++++---- 6 files changed, 39 insertions(+), 19 deletions(-) diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm index 2b43e9404..ff26459c9 100644 --- a/src/runtime/library-database.scm +++ b/src/runtime/library-database.scm @@ -72,9 +72,6 @@ USA. (define library-db? (make-bundle-predicate 'library-database)) - -(define-deferred host-library-db - (make-library-db 'host)) (define (make-library name . keylist) (if name diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm index 19413bdd0..69b7dd733 100644 --- a/src/runtime/library-loader.scm +++ b/src/runtime/library-loader.scm @@ -31,7 +31,7 @@ USA. ;;;; Syntax -(define-automatic-property '->scode '(name imports exports syntaxed-contents) +(define-automatic-property 'scode '(name imports exports contents) #f (lambda (name imports exports contents) (make-scode-declaration @@ -41,6 +41,12 @@ USA. (exports ,(map library-export->list exports)))) (make-scode-quotation contents)))) +(define (eval-r7rs-source source db) + (let ((program (register-r7rs-source! source db))) + (if program + (scode-eval (library-contents program) + (library-environment program))))) + (define-automatic-property 'contents '(parsed-contents imports exports imports-environment) #f diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm index f15501806..976fb08a6 100644 --- a/src/runtime/library-standard.scm +++ b/src/runtime/library-standard.scm @@ -29,6 +29,12 @@ USA. (declare (usual-integrations)) +(define-deferred host-library-db + (make-library-db 'host)) + +(define (finish-host-library-db!) + (add-standard-libraries! host-library-db)) + (define (add-standard-libraries! db) (register-libraries! (make-standard-libraries) db)) diff --git a/src/runtime/load.scm b/src/runtime/load.scm index a9ed8a812..8c1d14f13 100644 --- a/src/runtime/load.scm +++ b/src/runtime/load.scm @@ -52,6 +52,9 @@ USA. value)) #f)) +(define-deferred current-load-library-db + (make-unsettable-parameter host-library-db)) + (define-deferred param:eval-unit (make-unsettable-parameter #f (lambda (value) @@ -86,7 +89,7 @@ USA. load/suppress-loading-message?)) (define (load pathname #!optional environment syntax-table purify?) - syntax-table ;ignored + (declare (ignore syntax-table)) (let ((environment (if (default-object? environment) (current-load-environment) @@ -113,7 +116,7 @@ USA. (define (file-loadable? pathname) (receive (pathname* loader notifier) (choose-load-method pathname) - loader notifier + (declare (ignore loader notifier)) (if pathname* #t #f))) (define (choose-load-method pathname) @@ -143,14 +146,17 @@ USA. (define (source-loader pathname) (lambda (environment purify?) - purify? - (call-with-input-file pathname - (lambda (port) - (let loop ((value unspecific)) - (let ((sexp (read port))) - (if (eof-object? sexp) - value - (loop (repl-eval sexp environment))))))))) + (declare (ignore purify?)) + (let ((source (read-r7rs-source pathname))) + (if source + (eval-r7rs-source source (current-load-library-db)) + (call-with-input-file pathname + (lambda (port) + (let loop ((value unspecific)) + (let ((sexp (read port))) + (if (eof-object? sexp) + value + (loop (repl-eval sexp environment))))))))))) (define (wrap-loader pathname loader) (lambda (environment purify?) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 82c4cc10b..c76c91dfe 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -475,7 +475,7 @@ USA. (runtime hash) (runtime dynamic) (runtime regular-sexpression) - (runtime library database) + (runtime library standard) ;; Microcode data structures (runtime history) (runtime scode) @@ -560,6 +560,8 @@ USA. (runtime structure-parser) (runtime swank) (runtime stack-sampler) + ;; Done very late since it will look up lots of global variables. + ((runtime library standard) finish-host-library-db!) ;; Last since it turns on runtime handling of microcode errors. ((runtime microcode-errors) initialize-error-hooks!))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 16bc6ec0c..dee2664fc 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3160,6 +3160,7 @@ USA. built-in-object-file condition-type:not-loading current-load-environment + current-load-library-db current-load-pathname fasl-file? fasload @@ -5838,7 +5839,6 @@ USA. (parent (runtime library)) (export (runtime library) define-automatic-property - host-library-db library-contents library-db? library-environment @@ -5879,6 +5879,8 @@ USA. (define-package (runtime library parser) (files "library-parser") (parent (runtime library)) + (export (runtime) + read-r7rs-source) (export (runtime library) library-name=? library-name? @@ -5889,12 +5891,13 @@ USA. r7rs-source-program r7rs-source-libraries r7rs-source? - read-r7rs-source register-r7rs-source!)) (define-package (runtime library standard) (files "library-standard") (parent (runtime library)) + (export (runtime) + host-library-db) (export (runtime library) add-standard-libraries! check-standard-libraries! @@ -5916,5 +5919,5 @@ USA. (export () environment ;R7RS ) - (export (runtime library) - imports->environment)) \ No newline at end of file + (export (runtime) + eval-r7rs-source)) \ No newline at end of file -- 2.25.1