From: Chris Hanson Date: Thu, 15 Nov 1990 23:27:53 +0000 (+0000) Subject: Use new primitive `microcode-library-path', if present, to get a X-Git-Tag: 20090517-FFI~11042 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9f57be41f5ce0f93e27fd4db9d4ed9e86b0af944;p=mit-scheme.git Use new primitive `microcode-library-path', if present, to get a sequence of library directory names. Change `system-library-directory-pathname' to search through this sequence; also change it to accept an argument which is the name of a subdirectory to look for. New procedure `system-library-pathname' searches for a given file in one of the library directories. `load-option' and `disk-restore' changed to use `system-library-pathname'. --- diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index ba03be578..2b3417147 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.24 1990/11/09 08:44:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.25 1990/11/15 23:27:03 cph Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -325,6 +325,7 @@ MIT in each case. |# (RUNTIME TRUNCATED-STRING-OUTPUT) (RUNTIME INPUT-PORT) (RUNTIME OUTPUT-PORT) + (RUNTIME PATHNAME) (RUNTIME WORKING-DIRECTORY) (RUNTIME DIRECTORY) (RUNTIME LOAD) diff --git a/v7/src/runtime/option.scm b/v7/src/runtime/option.scm index 8baa79b2f..9d53a2402 100644 --- a/v7/src/runtime/option.scm +++ b/v7/src/runtime/option.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/option.scm,v 14.7 1990/02/10 23:45:01 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/option.scm,v 14.8 1990/11/15 23:27:15 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -39,10 +39,7 @@ MIT in each case. |# (define (load-option name) (let ((entry (assq name options)) - (pathname - (pathname-as-directory - (merge-pathnames (string->pathname "options") - (system-library-directory-pathname))))) + (pathname (pathname-as-directory (string->pathname "options")))) (if (not entry) (error "Unknown option name" name)) (for-each @@ -50,8 +47,9 @@ MIT in each case. |# (let ((environment (package/environment (find-package (car descriptor))))) (for-each (lambda (filename) - (load (merge-pathnames (string->pathname filename) - pathname) + (load (system-library-pathname + (merge-pathnames (string->pathname filename) + pathname)) environment syntax-table/system-internal true)) diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm index 76d05c967..671e00fe3 100644 --- a/v7/src/runtime/pathnm.scm +++ b/v7/src/runtime/pathnm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.7 1990/06/20 20:29:44 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.8 1990/11/15 23:27:22 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -394,7 +394,7 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (define (file-exists? filename) (pathname->input-truename (->pathname filename))) - + (define (init-file-truename) (let ((pathname (init-file-pathname))) (and pathname @@ -403,6 +403,43 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (pathname->input-truename (merge-pathnames pathname (home-directory-pathname))))))) -(define (system-library-directory-pathname) - (pathname-directory-path - (string->pathname ((ucode-primitive microcode-tables-filename 0))))) \ No newline at end of file +(define (initialize-package!) + (reset-library-directory-path!) + (add-event-receiver! event:after-restore reset-library-directory-path!)) + +(define (reset-library-directory-path!) + (set! library-directory-path + (if (implemented-primitive-procedure? microcode-library-path) + (map (lambda (filename) + (pathname-as-directory (string->pathname filename))) + (vector->list (microcode-library-path))) + (list + (pathname-directory-path + (string->pathname (microcode-tables-filename)))))) + unspecific) + +(define-primitives + (microcode-library-path 0) + (microcode-tables-filename 0)) + +(define library-directory-path) + +(define (system-library-pathname pathname) + (let loop ((directories library-directory-path)) + (and (not (null? directories)) + (or (pathname->input-truename + (merge-pathnames pathname (car directories))) + (loop (cdr directories)))))) + +(define (system-library-directory-pathname pathname) + (if (not pathname) + (let ((pathname + (list-search-positive library-directory-path file-directory?))) + (and pathname + (pathname-as-directory pathname))) + (let loop ((directories library-directory-path)) + (and (not (null? directories)) + (let ((pathname (merge-pathnames pathname (car directories)))) + (if (file-directory? pathname) + (pathname-as-directory pathname) + (loop (cdr directories)))))))) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 80114acd1..4dd598226 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.86 1990/11/15 15:42:35 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.87 1990/11/15 23:27:32 cph Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -1349,9 +1349,11 @@ MIT in each case. |# pathname-version pathname? string->pathname - system-library-directory-pathname) + system-library-directory-pathname + system-library-pathname) (export (runtime pathname-parser) - simplify-directory)) + simplify-directory) + (initialization (initialize-package!))) (define-package (runtime pathname-parser) (file-case os-type diff --git a/v7/src/runtime/savres.scm b/v7/src/runtime/savres.scm index 4a073363b..c71cdb068 100644 --- a/v7/src/runtime/savres.scm +++ b/v7/src/runtime/savres.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.15 1990/11/14 13:27:28 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.16 1990/11/15 23:27:44 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -141,14 +141,21 @@ MIT in each case. |# ;; Force order of events -- no need to run event:before-exit if ;; there's an error here. (let ((filename - (canonicalize-input-filename + (pathname->string (if (default-object? filename) - (or ((ucode-primitive reload-band-name)) - (error "DISK-RESTORE: No default band name available")) - filename)))) + (canonicalize-input-pathname + (or ((ucode-primitive reload-band-name)) + (error "no default band name available"))) + (let ((pathname + (pathname-default-type (->pathname filename) "com"))) + (let ((truename + (or (pathname->input-truename pathname) + (system-library-pathname pathname)))) + (if (not truename) (error error-type:open-file pathname)) + truename)))))) (event-distributor/invoke! event:before-exit) ((ucode-primitive load-band) filename))) - + (define world-identification "Scheme") (define time-world-saved) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 353a7bb81..c9a3a8a5f 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.102 1990/11/14 13:28:42 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.103 1990/11/15 23:27:53 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 102)) + (add-identification! "Runtime" 14 103)) (define microcode-system) diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index 305245514..8b1131d18 100644 --- a/v8/src/runtime/make.scm +++ b/v8/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.24 1990/11/09 08:44:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.25 1990/11/15 23:27:03 cph Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -325,6 +325,7 @@ MIT in each case. |# (RUNTIME TRUNCATED-STRING-OUTPUT) (RUNTIME INPUT-PORT) (RUNTIME OUTPUT-PORT) + (RUNTIME PATHNAME) (RUNTIME WORKING-DIRECTORY) (RUNTIME DIRECTORY) (RUNTIME LOAD) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 106169252..32b798e85 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.86 1990/11/15 15:42:35 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.87 1990/11/15 23:27:32 cph Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -1349,9 +1349,11 @@ MIT in each case. |# pathname-version pathname? string->pathname - system-library-directory-pathname) + system-library-directory-pathname + system-library-pathname) (export (runtime pathname-parser) - simplify-directory)) + simplify-directory) + (initialization (initialize-package!))) (define-package (runtime pathname-parser) (file-case os-type