From dbc56199219ff575608c2463ea120e174939be9a Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 18 Nov 1993 00:47:36 +0000 Subject: [PATCH] Implement new mechanism to allow the system to specify its debugging-info files as relative pathnames that are resolved at lookup time rather than at the time the .com files are loaded. --- v7/src/runtime/infutl.scm | 60 +++++++++++++++++++++--------------- v7/src/runtime/make.scm | 33 +++++++++++--------- v7/src/runtime/site.scm.dos | 19 +++--------- v7/src/runtime/site.scm.unix | 20 ++---------- v8/src/runtime/infutl.scm | 60 +++++++++++++++++++++--------------- v8/src/runtime/make.scm | 33 +++++++++++--------- 6 files changed, 116 insertions(+), 109 deletions(-) diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm index 02ccc9d4e..b8e8b6eff 100644 --- a/v7/src/runtime/infutl.scm +++ b/v7/src/runtime/infutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: infutl.scm,v 1.48 1993/11/09 04:31:38 cph Exp $ +$Id: infutl.scm,v 1.49 1993/11/18 00:47:13 cph Exp $ -Copyright (c) 1988-1993 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -94,8 +94,8 @@ MIT in each case. |# (else false))) -(define (read-binf-file filename) - (let ((pathname (merge-pathnames filename))) +(define (read-binf-file pathname) + (let ((pathname (canonicalize-debug-info-pathname pathname))) (if (file-exists? pathname) (fasload-loader (->namestring pathname)) (find-alternate-file-type pathname @@ -189,11 +189,11 @@ MIT in each case. |# (define (compiled-code-block/filename block) (let loop ((info (compiled-code-block/debugging-info block))) - (cond ((string? info) (values info false)) + (cond ((string? info) (values (canonicalize-debug-info-filename info) #f)) ((not (pair? info)) (values false false)) ((dbg-info? (car info)) (loop (cdr info))) ((string? (car info)) - (values (car info) + (values (canonicalize-debug-info-filename (car info)) (and (exact-nonnegative-integer? (cdr info)) (cdr info)))) (else (values false false))))) @@ -261,6 +261,13 @@ MIT in each case. |# (define directory-rewriting-rules '()) +(define (with-directory-rewriting-rule match replace thunk) + (fluid-let ((directory-rewriting-rules + (cons (cons (pathname-as-directory (merge-pathnames match)) + replace) + directory-rewriting-rules))) + (thunk))) + (define (add-directory-rewriting-rule! match replace) (let ((match (pathname-as-directory (merge-pathnames match)))) (let ((rule @@ -283,19 +290,12 @@ MIT in each case. |# (pathname-directory (car rule))))))) (->namestring (if rule - (let ((replacement (cdr rule)) - (remaining-directories - (list-tail (pathname-directory pathname) - (length (pathname-directory (car rule)))))) - ;; Moby kludge: we are going to fool the pathname abstraction - ;; into giving us a namestring that might contain uncanonicalized - ;; characters in them. This will break if the pathname abstraction - ;; cares at all. - (pathname-new-device - (pathname-new-directory - pathname - `(relative ,replacement ,@remaining-directories)) - false)) + (merge-pathnames + (pathname-new-directory + pathname + (list-tail (pathname-directory pathname) + (length (pathname-directory (car rule))))) + (cdr rule)) pathname)))) (define (directory-prefix? x y) @@ -307,6 +307,20 @@ MIT in each case. |# (and (not (null? x)) (equal? (car x) (car y)) (loop (cdr x) (cdr y))))))) + +(define (canonicalize-debug-info-filename filename) + (->namestring (canonicalize-debug-info-pathname filename))) + +(define (canonicalize-debug-info-pathname pathname) + (if (pathname-absolute? pathname) + pathname + (merge-pathnames + pathname + (let ((value + (get-environment-variable "MITSCHEME_INF_DIRECTORY"))) + (if value + (pathname-as-directory value) + (system-library-directory-pathname "SRC")))))) (define-integrable (dbg-block/layout-first-offset block) (let ((layout (dbg-block/layout block))) @@ -405,7 +419,9 @@ MIT in each case. |# (define (read-bsm-file name) (let ((pathname - (let ((pathname (merge-pathnames (process-bsym-filename name)))) + (let ((pathname + (canonicalize-debug-info-pathname + (rewrite-directory (merge-pathnames name))))) (if (file-exists? pathname) pathname (let loop ((types '("bsm" "bcs"))) @@ -419,10 +435,6 @@ MIT in each case. |# (if (equal? "bcs" (pathname-type pathname)) ((compressed-loader "bsm") pathname) (fasload-loader pathname))))) - -(define (process-bsym-filename name) - (rewrite-directory (merge-pathnames name))) - ;;;; Splitting of info structures diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 3729e6994..142fad482 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.49 1993/09/19 22:38:02 adams Exp $ +$Id: make.scm,v 14.50 1993/11/18 00:47:19 cph Exp $ -Copyright (c) 1988-1993 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -481,17 +481,22 @@ MIT in each case. |# (let ((roots (list->vector - (let ((fasload/update-debugging-info! - (access fasload/update-debugging-info! - (->environment '(RUNTIME COMPILER-INFO)))) - (load/purification-root - (access load/purification-root - (->environment '(RUNTIME LOAD))))) - (map (lambda (entry) - (let ((object (cdr entry))) - (fasload/update-debugging-info! object (car entry)) - (load/purification-root object))) - fasload-purification-queue))))) + ((access with-directory-rewriting-rule + (->environment '(RUNTIME COMPILER-INFO))) + (working-directory-pathname) + (pathname-as-directory "runtime") + (lambda () + (let ((fasload/update-debugging-info! + (access fasload/update-debugging-info! + (->environment '(RUNTIME COMPILER-INFO)))) + (load/purification-root + (access load/purification-root + (->environment '(RUNTIME LOAD))))) + (map (lambda (entry) + (let ((object (cdr entry))) + (fasload/update-debugging-info! object (car entry)) + (load/purification-root object))) + fasload-purification-queue))))))) (set! (access gc-boot-loading? (->environment '(RUNTIME GARBAGE-COLLECTOR))) false) (set! fasload-purification-queue) @@ -507,4 +512,4 @@ MIT in each case. |# (package/add-child! system-global-package 'USER user-initial-environment) (start-thread-timer) -(initial-top-level-repl) +(initial-top-level-repl) \ No newline at end of file diff --git a/v7/src/runtime/site.scm.dos b/v7/src/runtime/site.scm.dos index 8198484dc..6b1a434aa 100644 --- a/v7/src/runtime/site.scm.dos +++ b/v7/src/runtime/site.scm.dos @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: site.scm.dos,v 1.12 1993/09/07 21:59:02 gjr Exp $ +$Id: site.scm.dos,v 1.13 1993/11/18 00:47:30 cph Exp $ -Copyright (c) 1992 Massachusetts Institute of Technology +Copyright (c) 1992-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -35,28 +35,17 @@ MIT in each case. |# ;;;; Switzerland site specific stuff (declare (usual-integrations)) - + ;;; Local hacks (define (call/cc . args) (warn "call/cc: Invoking the C compiler:" args) (warn "Segmentation fault (core dumped)")) -;;; Normalization of various directory structures. - -(let ((add-directory-rewriting-rule! - (access add-directory-rewriting-rule! - (->environment '(runtime compiler-info))))) - (for-each - (lambda (path) - (add-directory-rewriting-rule! path "$MITSCHEME_INF_DIRECTORY")) - '("/scheme"))) - (set-environment-variable-default! "MITSCHEME_INF_DIRECTORY" "\\scheme") (set-environment-variable-default! "TERM" (lambda () (if (string-ci=? microcode-id/operating-system-name "NT") "ansi.sys" - "ibm_pc_bios"))) - \ No newline at end of file + "ibm_pc_bios"))) \ No newline at end of file diff --git a/v7/src/runtime/site.scm.unix b/v7/src/runtime/site.scm.unix index 0722deee3..d16babe0b 100644 --- a/v7/src/runtime/site.scm.unix +++ b/v7/src/runtime/site.scm.unix @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: site.scm.unix,v 1.13 1993/11/13 03:52:54 gjr Exp $ +$Id: site.scm.unix,v 1.14 1993/11/18 00:47:36 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -71,20 +71,4 @@ MIT in each case. |# (lambda () (set! inside ((ucode-primitive working-directory-pathname 0))) ((ucode-primitive set-working-directory-pathname! 1) outside) - (start-thread-timer))))) - -;;; Normalization of various directory structures. - -(let ((add-directory-rewriting-rule! - (access add-directory-rewriting-rule! - (->environment '(runtime compiler-info))))) - (for-each - (lambda (path) - (add-directory-rewriting-rule! path "/usr/local/lib/mit-scheme/SRC")) - '("/scheme/300" - "/nfs/martigny/scheme/300" - "/scheme/700" - "/nfs/martigny/scheme/700" - "/usr/local/scheme/nws3250" - "/scheme/nws3250" - "/nfs/martigny/scheme/nws3250"))) \ No newline at end of file + (start-thread-timer))))) \ No newline at end of file diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm index 02ccc9d4e..b8e8b6eff 100644 --- a/v8/src/runtime/infutl.scm +++ b/v8/src/runtime/infutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: infutl.scm,v 1.48 1993/11/09 04:31:38 cph Exp $ +$Id: infutl.scm,v 1.49 1993/11/18 00:47:13 cph Exp $ -Copyright (c) 1988-1993 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -94,8 +94,8 @@ MIT in each case. |# (else false))) -(define (read-binf-file filename) - (let ((pathname (merge-pathnames filename))) +(define (read-binf-file pathname) + (let ((pathname (canonicalize-debug-info-pathname pathname))) (if (file-exists? pathname) (fasload-loader (->namestring pathname)) (find-alternate-file-type pathname @@ -189,11 +189,11 @@ MIT in each case. |# (define (compiled-code-block/filename block) (let loop ((info (compiled-code-block/debugging-info block))) - (cond ((string? info) (values info false)) + (cond ((string? info) (values (canonicalize-debug-info-filename info) #f)) ((not (pair? info)) (values false false)) ((dbg-info? (car info)) (loop (cdr info))) ((string? (car info)) - (values (car info) + (values (canonicalize-debug-info-filename (car info)) (and (exact-nonnegative-integer? (cdr info)) (cdr info)))) (else (values false false))))) @@ -261,6 +261,13 @@ MIT in each case. |# (define directory-rewriting-rules '()) +(define (with-directory-rewriting-rule match replace thunk) + (fluid-let ((directory-rewriting-rules + (cons (cons (pathname-as-directory (merge-pathnames match)) + replace) + directory-rewriting-rules))) + (thunk))) + (define (add-directory-rewriting-rule! match replace) (let ((match (pathname-as-directory (merge-pathnames match)))) (let ((rule @@ -283,19 +290,12 @@ MIT in each case. |# (pathname-directory (car rule))))))) (->namestring (if rule - (let ((replacement (cdr rule)) - (remaining-directories - (list-tail (pathname-directory pathname) - (length (pathname-directory (car rule)))))) - ;; Moby kludge: we are going to fool the pathname abstraction - ;; into giving us a namestring that might contain uncanonicalized - ;; characters in them. This will break if the pathname abstraction - ;; cares at all. - (pathname-new-device - (pathname-new-directory - pathname - `(relative ,replacement ,@remaining-directories)) - false)) + (merge-pathnames + (pathname-new-directory + pathname + (list-tail (pathname-directory pathname) + (length (pathname-directory (car rule))))) + (cdr rule)) pathname)))) (define (directory-prefix? x y) @@ -307,6 +307,20 @@ MIT in each case. |# (and (not (null? x)) (equal? (car x) (car y)) (loop (cdr x) (cdr y))))))) + +(define (canonicalize-debug-info-filename filename) + (->namestring (canonicalize-debug-info-pathname filename))) + +(define (canonicalize-debug-info-pathname pathname) + (if (pathname-absolute? pathname) + pathname + (merge-pathnames + pathname + (let ((value + (get-environment-variable "MITSCHEME_INF_DIRECTORY"))) + (if value + (pathname-as-directory value) + (system-library-directory-pathname "SRC")))))) (define-integrable (dbg-block/layout-first-offset block) (let ((layout (dbg-block/layout block))) @@ -405,7 +419,9 @@ MIT in each case. |# (define (read-bsm-file name) (let ((pathname - (let ((pathname (merge-pathnames (process-bsym-filename name)))) + (let ((pathname + (canonicalize-debug-info-pathname + (rewrite-directory (merge-pathnames name))))) (if (file-exists? pathname) pathname (let loop ((types '("bsm" "bcs"))) @@ -419,10 +435,6 @@ MIT in each case. |# (if (equal? "bcs" (pathname-type pathname)) ((compressed-loader "bsm") pathname) (fasload-loader pathname))))) - -(define (process-bsym-filename name) - (rewrite-directory (merge-pathnames name))) - ;;;; Splitting of info structures diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index 3729e6994..142fad482 100644 --- a/v8/src/runtime/make.scm +++ b/v8/src/runtime/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.49 1993/09/19 22:38:02 adams Exp $ +$Id: make.scm,v 14.50 1993/11/18 00:47:19 cph Exp $ -Copyright (c) 1988-1993 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -481,17 +481,22 @@ MIT in each case. |# (let ((roots (list->vector - (let ((fasload/update-debugging-info! - (access fasload/update-debugging-info! - (->environment '(RUNTIME COMPILER-INFO)))) - (load/purification-root - (access load/purification-root - (->environment '(RUNTIME LOAD))))) - (map (lambda (entry) - (let ((object (cdr entry))) - (fasload/update-debugging-info! object (car entry)) - (load/purification-root object))) - fasload-purification-queue))))) + ((access with-directory-rewriting-rule + (->environment '(RUNTIME COMPILER-INFO))) + (working-directory-pathname) + (pathname-as-directory "runtime") + (lambda () + (let ((fasload/update-debugging-info! + (access fasload/update-debugging-info! + (->environment '(RUNTIME COMPILER-INFO)))) + (load/purification-root + (access load/purification-root + (->environment '(RUNTIME LOAD))))) + (map (lambda (entry) + (let ((object (cdr entry))) + (fasload/update-debugging-info! object (car entry)) + (load/purification-root object))) + fasload-purification-queue))))))) (set! (access gc-boot-loading? (->environment '(RUNTIME GARBAGE-COLLECTOR))) false) (set! fasload-purification-queue) @@ -507,4 +512,4 @@ MIT in each case. |# (package/add-child! system-global-package 'USER user-initial-environment) (start-thread-timer) -(initial-top-level-repl) +(initial-top-level-repl) \ No newline at end of file -- 2.25.1