From: Chris Hanson Date: Wed, 24 Oct 2018 03:18:48 +0000 (-0700) Subject: Change ->environment to work with library names too. X-Git-Tag: mit-scheme-pucked-10.1.2~16^2~182 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2ab4c70a3323e8b98f3c844e74532d70bca4f48b;p=mit-scheme.git Change ->environment to work with library names too. --- diff --git a/src/runtime/environment.scm b/src/runtime/environment.scm index 0944c1391..9338264cb 100644 --- a/src/runtime/environment.scm +++ b/src/runtime/environment.scm @@ -36,6 +36,14 @@ USA. (closure-ccenv? object))) (register-predicate! environment? 'environment) +(define (->environment object #!optional caller) + (let ((caller (if (default-object? caller) '->environment caller))) + (cond ((environment? object) object) + ((library->environment-helper object) => library-environment) + ((name->package object) => package/environment) + ((procedure? object) (procedure-environment object)) + (else (error:wrong-type-argument object "environment" caller))))) + (define (environment-has-parent? environment) (cond ((system-global-environment? environment) #f) diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm index bfee0c267..3fb06d104 100644 --- a/src/runtime/library-database.scm +++ b/src/runtime/library-database.scm @@ -331,4 +331,14 @@ USA. (define library-name (library-accessor 'name)) (define library-parsed-contents (library-accessor 'parsed-contents)) (define library-parsed-imports (library-accessor 'parsed-imports)) -(define library-syntaxed-contents (library-accessor 'syntaxed-contents)) \ No newline at end of file +(define library-syntaxed-contents (library-accessor 'syntaxed-contents)) + +(define (library->environment-helper name) + (if (library? name) + (and (name 'has? 'environment) + name) + (and (library-name? name) + (registered-library? name host-library-db) + (let ((library (registered-library name host-library-db))) + (and (library 'has? 'environment) + library))))) \ No newline at end of file diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm index f7b0ae5f4..1933dc7a7 100644 --- a/src/runtime/packag.scm +++ b/src/runtime/packag.scm @@ -65,6 +65,13 @@ USA. (define (package-name? object) (list-of-type? object symbol?)) +(define (package-name=? name1 name2) + (or (and (null? name1) (null? name2)) + (and (pair? name1) + (pair? name2) + (eq? (car name1) (car name2)) + (package-name=? (cdr name1) (cdr name2))))) + (define (package/reference package name) (lexical-reference (package/environment package) name)) @@ -103,19 +110,13 @@ USA. (define (find-package name #!optional error?) (let package-loop ((packages *packages*)) - (if (null? packages) - (if error? - (error "Unable to find package:" name) - #f) - (if (let name-loop ((name1 name) - (name2 (package/name (car packages)))) - (cond ((and (null? name1) (null? name2)) #t) - ((or (null? name1) (null? name2)) #f) - ((eq? (car name1) (car name2)) - (name-loop (cdr name1) (cdr name2))) - (else #f))) + (if (pair? packages) + (if (package-name=? name (package/name (car packages))) (car packages) - (package-loop (cdr packages)))))) + (package-loop (cdr packages))) + (begin + (if error? (error "Unable to find package:" name)) + #f)))) (define (name-append name package) (let loop ((names (package/name package))) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index b45f47f6e..5fefb5411 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -127,6 +127,7 @@ USA. (interaction-i/o-port #f) (working-directory-pathname (working-directory-pathname)) + (current-library-db (current-library-db)) (param:nearest-cmdl cmdl) (param:standard-error-hook #f) (param:standard-warning-hook #f) @@ -792,23 +793,6 @@ USA. (set-repl/environment! (nearest-repl) environment) environment)) -(define (->environment object #!optional caller) - (let ((caller (if (default-object? caller) '->environment caller))) - (cond ((environment? object) object) - ((package? object) (package/environment object)) - ((procedure? object) (procedure-environment object)) - (else - (let ((package - (let ((package-name - (cond ((symbol? object) (list object)) - ((list? object) object) - (else #f)))) - (and package-name - (name->package package-name))))) - (if (not package) - (error:wrong-type-argument object "environment" caller)) - (package/environment package)))))) - (define (re #!optional index) (repl-eval (repl-history/read (repl/reader-history (nearest-repl)) (if (default-object? index) 1 index)))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index b13e34014..4edba5cb7 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1957,6 +1957,7 @@ USA. (files "environment") (parent (runtime)) (export () + ->environment compiled-procedure/environment environment-arguments environment-assign! @@ -3866,7 +3867,6 @@ USA. (parent (runtime)) (export () (interaction-environment nearest-repl/environment) ;R7RS - ->environment abort->nearest abort->previous abort->top-level @@ -5852,6 +5852,13 @@ USA. (parent (runtime library)) (export (runtime) copy-library-db + library-bound-names + library-contents + library-db? + library-environment + library-imports-used + library-imports + library-name library-export-from library-export-to library-export=? @@ -5860,27 +5867,27 @@ USA. library-import-from-library library-import-to library-import=? - library-import?) + library-import? + library? + registered-libraries + registered-library + registered-library?) + (export (runtime environment) + library->environment-helper) (export (runtime library) define-automatic-property library-contents - library-db? - library-environment library-eval-result library-exporter library-export->list library-exports library-filename library-imports-from - library-imports-used library-import->list - library-imports library-imports-environment - library-name library-parsed-contents library-parsed-imports library-syntaxed-contents - library? list->library-export list->library-import make-library @@ -5888,10 +5895,7 @@ USA. make-library-export make-library-import register-libraries! - register-library! - registered-libraries - registered-library - registered-library?)) + register-library!)) (define-package (runtime library parser) (files "library-parser")