* Change `environment-link-name' to call `->environment' on its two

environment arguments.

* Move `vector-binary-search' to the global environment.  Fix a bug in
it -- a confusion between the < used for comparing integers, and that
for comparing keys.

* New variable `load/suppress-loading-message?' prevents the file
loader from printing the "loading -- done" messages.

* Implement `pathname-relative?' which accepts two pathnames; if the
second has a directory part which is a "prefix" of the first, this
returns a copy of the first pathname with the "prefix" removed.
Example:

    (pathname-relative? (->pathname "/usr/bin")
			(->pathname "/usr/"))
	   ==> #[pathname 5 "bin"]

diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index 90636276f1434611c727f88ef85c44984e4fbf73..b8e8f6123528b0391d4cf0d8a41bd73728fcb0ff 100644 (file)
--- a/v7/src/runtime/global.scm
+++ b/v7/src/runtime/global.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.11 1989/08/07 07:36:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.12 1989/08/12 08:18:06 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -49,7 +49,6 @@ MIT in each case. |#
   ;; Environment
   lexical-reference lexical-assignment local-assignment
   lexical-unassigned? lexical-unbound? lexical-unreferenceable?
-  environment-link-name
 
   ;; Pointers
   (object-type 1)
@@ -189,7 +188,14 @@ MIT in each case. |#
   (let () (the-environment)))
 
 (define user-initial-prompt
-  "]=>")\f
+  "]=>")
+
+(define (environment-link-name to from name)
+  ((ucode-primitive environment-link-name)
+   (->environment to)
+   (->environment from)
+   name))
+\f
 (define (copy-program exp)
   (if (not (object-type? (ucode-type compiled-entry) exp))
       (error "COPY-PROGRAM: Can only copy compiled programs" exp))

diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm
index c1bcafe65634d3478cd9a6bea3cc4a19dc003937..58401a77d98e138e59d5175499feaf002e760ddc 100644 (file)
--- a/v7/src/runtime/infutl.scm
+++ b/v7/src/runtime/infutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.7 1989/01/06 21:00:16 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.8 1989/08/12 08:18:14 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -159,16 +159,7 @@ MIT in each case. |#
 
 (define (dbg-labels/find-offset labels offset)
   (vector-binary-search labels < dbg-label/offset offset))
-
-(define (vector-binary-search vector < unwrap-key key)
-  (let loop ((start 0) (end (vector-length vector)))
-    (and (< start end)
-        (let ((midpoint (quotient (+ start end) 2)))
-          (let ((item (vector-ref vector midpoint)))
-            (let ((key* (unwrap-key item)))
-              (cond ((< key key*) (loop start midpoint))
-                    ((< key* key) (loop (1+ midpoint) end))
-                    (else item))))))))\f
+\f
 (define (fasload/update-debugging-info! value com-pathname)
   (let ((process-block
         (lambda (block)

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index cac8985a1b347816b088e660ebe1e033ae7692ab..d9d96c40de514de7f04f2011ec2038ebae4b3627 100644 (file)
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.5 1988/12/30 06:43:04 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.6 1989/08/12 08:18:19 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -39,11 +39,13 @@ MIT in each case. |#
 \f
 (define (initialize-package!)
   (set! load-noisily? false)
+  (set! load/suppress-loading-message? false)
   (set! load/default-types '("com" "bin" "scm"))
   (set! fasload/default-types '("com" "bin"))
   (add-event-receiver! event:after-restart load-init-file))
 
 (define load-noisily?)
+(define load/suppress-loading-message?)
 (define load/default-types)
 (define fasload/default-types)
 
@@ -53,18 +55,20 @@ MIT in each case. |#
     (lambda (port)
       (stream->list (read-stream port)))))
 
-(define (fasload filename #!optional quiet?)
+(define (fasload filename #!optional suppress-loading-message?)
   (fasload/internal
    (find-true-pathname (->pathname filename) fasload/default-types)
-   (if (default-object? quiet?) false quiet?)))
+   (if (default-object? suppress-loading-message?)
+       load/suppress-loading-message?
+       suppress-loading-message?)))
 
-(define (fasload/internal true-pathname quiet?)
+(define (fasload/internal true-pathname suppress-loading-message?)
   (let ((value
         (let ((true-filename (pathname->string true-pathname)))
           (let ((do-it
                  (lambda ()
                    ((ucode-primitive binary-fasload) true-filename))))
-            (if quiet?
+            (if suppress-loading-message?
                 (do-it)
                 (let ((port (cmdl/output-port (nearest-cmdl))))
                   (newline port)
@@ -130,8 +134,9 @@ MIT in each case. |#
          (let loop ((filenames filename/s))
            (if (null? (cdr filenames))
                (kernel (car filenames) true)
-               (begin (kernel (car filenames) false)
-                      (loop (cdr filenames)))))
+               (begin
+                 (kernel (car filenames) false)
+                 (loop (cdr filenames)))))
          (kernel filename/s true)))))
 
 (define default-object
@@ -142,14 +147,17 @@ MIT in each case. |#
   (let ((port
         (open-input-file/internal pathname (pathname->string true-pathname))))
     (if (= 250 (char->ascii (peek-char port)))
-       (begin (close-input-port port)
-              (scode-eval
-               (let ((scode (fasload/internal true-pathname false)))
-                 (if purify? (purify scode))
-                 scode)
-               (if (eq? environment default-object)
-                   (nearest-repl/environment)
-                   environment)))
+       (begin
+         (close-input-port port)
+         (scode-eval
+          (let ((scode
+                 (fasload/internal true-pathname
+                                   load/suppress-loading-message?)))
+            (if purify? (purify scode))
+            scode)
+          (if (eq? environment default-object)
+              (nearest-repl/environment)
+              environment)))
        (write-stream (eval-stream (read-stream port) environment syntax-table)
                      (if load-noisily?
                          (lambda (value)
@@ -173,8 +181,9 @@ MIT in each case. |#
                 (current-parser-table)
                 (lambda (object)
                   (and (eof-object? object)
-                       (begin (close-input-port port)
-                              true)))))
+                       (begin
+                         (close-input-port port)
+                         true)))))
 
 (define (eval-stream stream environment syntax-table)
   (stream-map stream
@@ -193,6 +202,8 @@ MIT in each case. |#
   (if (stream-pair? stream)
       (let loop ((value (stream-car stream)) (stream (stream-cdr stream)))
        (if (stream-pair? stream)
-           (begin (write value)
-                  (loop (stream-car stream) (stream-cdr stream)))          value))
+           (begin
+             (write value)
+             (loop (stream-car stream) (stream-cdr stream)))
+           value))
       unspecific))
\ No newline at end of file

diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index ce56bd851ce3bc13d900cadcff05c362a88f957e..bdba0dbd0d7507a25a380f89140922882972ba16 100644 (file)
--- 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.5 1989/08/03 23:06:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.6 1989/08/12 08:18:23 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -120,6 +120,26 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|#
   (let ((directory (pathname-directory pathname)))
     (and (pair? directory)
         (eq? (car directory) 'ROOT))))
+
+(define (pathname-relative? pathname pathname*)
+  (and (equal? (pathname-host pathname)
+              (pathname-host pathname*))
+       (equal? (pathname-device pathname)
+              (pathname-device pathname*))
+       (let loop
+          ((directory (pathname-directory pathname))
+           (directory* (pathname-directory pathname*)))
+        (if (null? directory*)
+            (make-pathname false
+                           false
+                           directory
+                           (pathname-name pathname)
+                           (pathname-type pathname)
+                           (pathname-version pathname))
+            (and (not (null? directory))
+                 (equal? (car directory) (car directory*))
+                 (loop (cdr directory) (cdr directory*)))))))
+
 (define (pathname-directory-path pathname)
   (make-pathname (pathname-host pathname)
                 (pathname-device pathname)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index cbd1246df4f8fb74a138e2111ef30329020e02ac..1bf147954402d1179378ec43c3573cdb3450e35e 100644 (file)
--- 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.47 1989/08/11 02:59:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.48 1989/08/12 08:18:31 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -865,6 +865,7 @@ MIT in each case. |#
          load-noisily
          load-noisily?
          load/default-types
+         load/suppress-loading-message?
          read-file)
   (initialization (initialize-package!)))
 
@@ -1129,7 +1130,9 @@ MIT in each case. |#
          pathname-new-host
          pathname-new-name
          pathname-new-type
-         pathname-new-version    pathname-type
+         pathname-new-version
+         pathname-relative?
+         pathname-type
          pathname-version
          pathname?
          string->pathname

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 68bde34b4e38a956523cce92ad2a61880cd375a0..3375164668c45df92a635fb51683f327b6cc1795 100644 (file)
--- 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.52 1989/08/11 02:59:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.53 1989/08/12 08:17:45 cph Exp $
 
 Copyright (c) 1988, 1989 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 52))
+  (add-identification! "Runtime" 14 53))
 (define microcode-system)
 
 (define (snarf-microcode-version!)

diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm
index a9fc34d189b142139cf44607eb54dca404d17ecf..a296b0cf72d8ac5a45226cbbf47627ac178d1d92 100644 (file)
--- a/v8/src/runtime/global.scm
+++ b/v8/src/runtime/global.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.11 1989/08/07 07:36:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.12 1989/08/12 08:18:06 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -49,7 +49,6 @@ MIT in each case. |#
   ;; Environment
   lexical-reference lexical-assignment local-assignment
   lexical-unassigned? lexical-unbound? lexical-unreferenceable?
-  environment-link-name
 
   ;; Pointers
   (object-type 1)
@@ -189,7 +188,14 @@ MIT in each case. |#
   (let () (the-environment)))
 
 (define user-initial-prompt
-  "]=>")\f
+  "]=>")
+
+(define (environment-link-name to from name)
+  ((ucode-primitive environment-link-name)
+   (->environment to)
+   (->environment from)
+   name))
+\f
 (define (copy-program exp)
   (if (not (object-type? (ucode-type compiled-entry) exp))
       (error "COPY-PROGRAM: Can only copy compiled programs" exp))

diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm
index ba4be1fae117a3254f43a3751a0caa7a0643b570..a6a88a9c242b2befae1e7578d6f5feb049e35a2a 100644 (file)
--- a/v8/src/runtime/infutl.scm
+++ b/v8/src/runtime/infutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.7 1989/01/06 21:00:16 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.8 1989/08/12 08:18:14 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -159,16 +159,7 @@ MIT in each case. |#
 
 (define (dbg-labels/find-offset labels offset)
   (vector-binary-search labels < dbg-label/offset offset))
-
-(define (vector-binary-search vector < unwrap-key key)
-  (let loop ((start 0) (end (vector-length vector)))
-    (and (< start end)
-        (let ((midpoint (quotient (+ start end) 2)))
-          (let ((item (vector-ref vector midpoint)))
-            (let ((key* (unwrap-key item)))
-              (cond ((< key key*) (loop start midpoint))
-                    ((< key* key) (loop (1+ midpoint) end))
-                    (else item))))))))\f
+\f
 (define (fasload/update-debugging-info! value com-pathname)
   (let ((process-block
         (lambda (block)

diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm
index 0d10a9d877e178d9afa4873232913e353de9c739..f82ad9a686dc02825c4de0ddf3feae552c4a3f5f 100644 (file)
--- a/v8/src/runtime/load.scm
+++ b/v8/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.5 1988/12/30 06:43:04 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.6 1989/08/12 08:18:19 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -39,11 +39,13 @@ MIT in each case. |#
 \f
 (define (initialize-package!)
   (set! load-noisily? false)
+  (set! load/suppress-loading-message? false)
   (set! load/default-types '("com" "bin" "scm"))
   (set! fasload/default-types '("com" "bin"))
   (add-event-receiver! event:after-restart load-init-file))
 
 (define load-noisily?)
+(define load/suppress-loading-message?)
 (define load/default-types)
 (define fasload/default-types)
 
@@ -53,18 +55,20 @@ MIT in each case. |#
     (lambda (port)
       (stream->list (read-stream port)))))
 
-(define (fasload filename #!optional quiet?)
+(define (fasload filename #!optional suppress-loading-message?)
   (fasload/internal
    (find-true-pathname (->pathname filename) fasload/default-types)
-   (if (default-object? quiet?) false quiet?)))
+   (if (default-object? suppress-loading-message?)
+       load/suppress-loading-message?
+       suppress-loading-message?)))
 
-(define (fasload/internal true-pathname quiet?)
+(define (fasload/internal true-pathname suppress-loading-message?)
   (let ((value
         (let ((true-filename (pathname->string true-pathname)))
           (let ((do-it
                  (lambda ()
                    ((ucode-primitive binary-fasload) true-filename))))
-            (if quiet?
+            (if suppress-loading-message?
                 (do-it)
                 (let ((port (cmdl/output-port (nearest-cmdl))))
                   (newline port)
@@ -130,8 +134,9 @@ MIT in each case. |#
          (let loop ((filenames filename/s))
            (if (null? (cdr filenames))
                (kernel (car filenames) true)
-               (begin (kernel (car filenames) false)
-                      (loop (cdr filenames)))))
+               (begin
+                 (kernel (car filenames) false)
+                 (loop (cdr filenames)))))
          (kernel filename/s true)))))
 
 (define default-object
@@ -142,14 +147,17 @@ MIT in each case. |#
   (let ((port
         (open-input-file/internal pathname (pathname->string true-pathname))))
     (if (= 250 (char->ascii (peek-char port)))
-       (begin (close-input-port port)
-              (scode-eval
-               (let ((scode (fasload/internal true-pathname false)))
-                 (if purify? (purify scode))
-                 scode)
-               (if (eq? environment default-object)
-                   (nearest-repl/environment)
-                   environment)))
+       (begin
+         (close-input-port port)
+         (scode-eval
+          (let ((scode
+                 (fasload/internal true-pathname
+                                   load/suppress-loading-message?)))
+            (if purify? (purify scode))
+            scode)
+          (if (eq? environment default-object)
+              (nearest-repl/environment)
+              environment)))
        (write-stream (eval-stream (read-stream port) environment syntax-table)
                      (if load-noisily?
                          (lambda (value)
@@ -173,8 +181,9 @@ MIT in each case. |#
                 (current-parser-table)
                 (lambda (object)
                   (and (eof-object? object)
-                       (begin (close-input-port port)
-                              true)))))
+                       (begin
+                         (close-input-port port)
+                         true)))))
 
 (define (eval-stream stream environment syntax-table)
   (stream-map stream
@@ -193,6 +202,8 @@ MIT in each case. |#
   (if (stream-pair? stream)
       (let loop ((value (stream-car stream)) (stream (stream-cdr stream)))
        (if (stream-pair? stream)
-           (begin (write value)
-                  (loop (stream-car stream) (stream-cdr stream)))          value))
+           (begin
+             (write value)
+             (loop (stream-car stream) (stream-cdr stream)))
+           value))
       unspecific))
\ No newline at end of file

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index c23da296106839f7b3aa33f9e1cadc6f352076a1..7e92cc2b2bc6687c64ffc7816f9117d02d4e04b8 100644 (file)
--- 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.47 1989/08/11 02:59:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.48 1989/08/12 08:18:31 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -865,6 +865,7 @@ MIT in each case. |#
          load-noisily
          load-noisily?
          load/default-types
+         load/suppress-loading-message?
          read-file)
   (initialization (initialize-package!)))
 
@@ -1129,7 +1130,9 @@ MIT in each case. |#
          pathname-new-host
          pathname-new-name
          pathname-new-type
-         pathname-new-version    pathname-type
+         pathname-new-version
+         pathname-relative?
+         pathname-type
          pathname-version
          pathname?
          string->pathname