From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 12 Aug 1989 08:18:31 +0000 (+0000)
Subject: * Change `environment-link-name' to call `->environment' on its two
X-Git-Tag: 20090517-FFI~11838
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6064c3e68651adf0c4e734a969c010e1fca7f647;p=mit-scheme.git

* 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 90636276f..b8e8f6123 100644
--- 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
-  "]=>")
+  "]=>")
+
+(define (environment-link-name to from name)
+  ((ucode-primitive environment-link-name)
+   (->environment to)
+   (->environment from)
+   name))
+
 (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 c1bcafe65..58401a77d 100644
--- 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))))))))
+
 (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 cac8985a1..d9d96c40d 100644
--- 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. |#
 
 (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 ce56bd851..bdba0dbd0 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.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 cbd1246df..1bf147954 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.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 68bde34b4..337516466 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.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 a9fc34d18..a296b0cf7 100644
--- 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
-  "]=>")
+  "]=>")
+
+(define (environment-link-name to from name)
+  ((ucode-primitive environment-link-name)
+   (->environment to)
+   (->environment from)
+   name))
+
 (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 ba4be1fae..a6a88a9c2 100644
--- 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))))))))
+
 (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 0d10a9d87..f82ad9a68 100644
--- 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. |#
 
 (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 c23da2961..7e92cc2b2 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.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