From: Chris Hanson Date: Fri, 16 Mar 2001 20:17:51 +0000 (+0000) Subject: Rewrite debugging-info directory on option files; they are sometimes X-Git-Tag: 20090517-FFI~2901 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6d1e14b110bac710b6d2460e92648d3be2a9a7ad;p=mit-scheme.git Rewrite debugging-info directory on option files; they are sometimes loaded while building the system but must refer to debugging info in it's installed location. --- diff --git a/v7/src/runtime/option.scm b/v7/src/runtime/option.scm index b00a1d7bd..2626857a1 100644 --- a/v7/src/runtime/option.scm +++ b/v7/src/runtime/option.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: option.scm,v 14.36 1999/01/02 06:11:34 cph Exp $ +$Id: option.scm,v 14.37 2001/03/16 20:17:48 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright (c) 1988-2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,7 +16,8 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. |# ;;;; Option Loader @@ -24,40 +25,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (declare (usual-integrations)) -(define *initial-options-file* #F) - -(define (initial-load-options) - (or *initial-options-file* - (get-environment-variable "MITSCHEME_LOAD_OPTIONS") - (local-load-options))) - -(define (local-load-options) - (or (library-file? "optiondb") - (standard-load-options))) - -(define (standard-load-options) - (or (library-file? "options/optiondb") - (error "Cannot locate a load-option database") - "optiondb")) - -(define (define-load-option name . loaders) - (set! *options* (cons (cons name loaders) *options*)) - unspecific) - -(define (further-load-options place) - (set! *parent* place) - unspecific) - (define (load-option name #!optional no-error?) (let ((no-error? (and (not (default-object? no-error?)) no-error?))) (define (find-option) (cond ((assq name *options*) => load-entry) - ((force* *parent*) => search-parent) - ((not no-error?) - (error "Unknown option name:" name) - #F) - (else #F))) + ((force* *parent*) => search-parent) + ((not no-error?) (error "Unknown option name:" name)) + (else #f))) (define (load-entry entry) (for-each (lambda (thunk) (thunk)) (cdr entry)) @@ -66,78 +41,89 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define (search-parent file) (fluid-let ((*options* '()) - (*parent* #F)) - (fluid-let ((load/suppress-loading-message? #T)) + (*parent* #f)) + (fluid-let ((load/suppress-loading-message? #t)) (load-latest (merge-pathnames file (library-directory-pathname "")) (make-load-environment) system-global-syntax-table - #F)) + #f)) (find-option))) (define (make-load-environment) (eval '(LET () (THE-ENVIRONMENT)) system-global-environment)) (fluid-let ((*parser-canonicalize-symbols?* #t)) - (if (not (memq name loaded-options)) - (find-option) - name)))) + (if (memq name loaded-options) + name + (find-option))))) -(define loaded-options '()) -(define *options* '()) ; Current options. -(define *parent* initial-load-options) ; A thunk or a pathname/string or #F. - -(define (library-file? library-internal-path) - (let* ((library (library-directory-pathname "")) - (pathname (merge-pathnames library-internal-path library))) - (let loop ((file-types load/default-types)) - (if (null? file-types) - #F - (let ((full-pathname (pathname-new-type pathname (caar file-types)))) - (if (file-exists? full-pathname) - pathname;; not full-pathname to allow load-latest - (loop (cdr file-types)))))))) +(define (define-load-option name . loaders) + (set! *options* (cons (cons name loaders) *options*)) + unspecific) -(define (force* value) - (cond ((procedure? value) (force* (value))) - ((promise? value) (force* (force value))) - (else value))) +(define (further-load-options place) + (set! *parent* place) + unspecific) + +(define (initial-load-options) + (or *initial-options-file* + (get-environment-variable "MITSCHEME_LOAD_OPTIONS") + (local-load-options))) + +(define (local-load-options) + (or (library-file? "optiondb") + (standard-load-options))) +(define (standard-load-options) + (or (library-file? "options/optiondb") + (error "Cannot locate a load-option database") + "optiondb")) + +(define (library-file? library-internal-path) + (let* ((library (library-directory-pathname "")) + (pathname (merge-pathnames library-internal-path library))) + (let loop ((file-types load/default-types)) + (and (not (null? file-types)) + (let ((full-pathname + (pathname-new-type pathname (caar file-types)))) + (if (file-exists? full-pathname) + ;; not full-pathname to allow load-latest + pathname + (loop (cdr file-types)))))))) + +(define loaded-options '()) +(define *options* '()) ; Current options. +(define *parent* initial-load-options) ; A thunk or a pathname/string or #f. +(define *initial-options-file* #f) + (define (standard-option-loader package-name init-expression . files) (lambda () - (let ((environment (package/environment (find-package package-name))) - (library-options (delay (library-directory-pathname "options")))) - (for-each - (lambda (file) - (let ((file (force* file))) - (cond - (((ucode-primitive initialize-c-compiled-block 1) - (string-append "runtime_" file)) - => (lambda (obj) - (purify obj) - (scode-eval obj environment))) - (else - (let ((path (merge-pathnames file (force library-options)))) - (with-working-directory-pathname - (directory-pathname path) - (lambda () - (load path - environment - syntax-table/system-internal - true)))))))) - files) + (let ((environment (package/environment (find-package package-name))) + (runtime (pathname-as-directory "runtime"))) + (for-each (lambda (file) + (let ((file (force* file))) + (cond + (((ucode-primitive initialize-c-compiled-block 1) + (string-append "runtime_" file)) + => (lambda (obj) + (purify obj) + (scode-eval obj environment))) + (else + (let* ((options (library-directory-pathname "options")) + (pathname (merge-pathnames file options))) + (with-directory-rewriting-rule options runtime + (lambda () + (with-working-directory-pathname + (directory-pathname pathname) + (lambda () + (load pathname + environment + syntax-table/system-internal + #t)))))))))) + files) (flush-purification-queue!) (eval init-expression environment)))) -(define (library-directory-pathname name) - (or (system-library-directory-pathname name) - (library-directory-pathname - (error:file-operation name - "find" - "directory" - "no such directory in system library path" - library-directory-pathname - (list name))))) - (define (declare-shared-library shared-library thunk) (let ((thunk-valid? (lambda (thunk) @@ -146,7 +132,22 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. event:after-restore (lambda () (if (not (thunk-valid? thunk)) - (fluid-let ((load/suppress-loading-message? true)) - (load (merge-pathnames - (library-directory-pathname "shared") - shared-library)))))))) \ No newline at end of file + (fluid-let ((load/suppress-loading-message? #t)) + (load + (merge-pathnames shared-library + (library-directory-pathname "shared"))))))))) + +(define (force* value) + (cond ((procedure? value) (force* (value))) + ((promise? value) (force* (force value))) + (else value))) + +(define (library-directory-pathname name) + (or (system-library-directory-pathname name) + (library-directory-pathname + (error:file-operation name + "find" + "directory" + "no such directory in system library path" + library-directory-pathname + (list name))))) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 821b3c8b9..3a5b40c70 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.363 2001/03/15 21:14:17 cph Exp $ +$Id: runtime.pkg,v 14.364 2001/03/16 20:17:51 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -410,6 +410,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA compiled-entry/filename-and-index) (export (runtime compress) uncompress-internal) + (export (runtime options) + with-directory-rewriting-rule) (initialization (initialize-package!))) (define-package (runtime console-i/o-port)