Add a packed binary loader so that the compiler (or edwin) can be

shipped as a single binary to be loaded on top of a vanilla runtime
system.

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index dc9320ea7aceb76a0bdfe662dec8ff6f5eec8072..5668e6145d53bb38f6e64e1c6b457cbef28020fe 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.32 1992/04/05 02:00:34 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.33 1992/05/23 00:11:09 jinx Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -338,4 +338,97 @@ MIT in each case. |#
                             (1+ index)
                             (cons (vector-ref unused-command-line index)
                                   unhandled-options))))))))
-      (load-init-file)))
\ No newline at end of file
+      (load-init-file)))
+\f
+;;;; Loader for packed binaries
+
+(define (load-packed-binaries pathname fname count environment)
+  (define (find-filename fname alist)
+    (define (compatible? path1 path2)
+      (and (equal? (pathname-directory path1)
+                   (pathname-directory path2))
+           (equal? (pathname-name path1)
+                   (pathname-name path2))
+           (or (equal? (pathname-type path1) (pathname-type path2))
+               (and (member (pathname-type path1) '(#f "bin" "com"))
+                    (member (pathname-type path2) '(#f "bin" "com"))))))
+
+    (let ((path (->pathname fname)))
+      (let loop ((alist alist))
+        (and (not (null? alist))
+             (if (compatible? path (cadar alist))
+                 (car alist)
+                 (loop (cdr alist)))))))
+
+  (define (process-bunch alist)
+    (let* ((real-load load)
+          (new-load
+           (lambda (fname #!optional env syntax-table purify?)
+             (let ((env (if (default-object? env)
+                            environment
+                            env))
+                   (st (if (default-object? syntax-table)
+                           default-object
+                           syntax-table))
+                   (purify? (if (default-object? purify?)
+                                default-object
+                                purify?)))
+               (let ((place (find-filename fname alist)))
+                 (if (not place)
+                     (real-load fname env st purify?)
+                     (let ((scode (caddr place)))
+                       (if (not load/suppress-loading-message?)
+                           (begin
+                             (newline)
+                             (display ";Pseudo-loading ")
+                             (display (->namestring (->pathname fname)))
+                             (display "...")))
+                       (if (and purify? (not (eq? purify? default-object)))
+                           (purify (load/purification-root scode)))
+                       (extended-scode-eval scode env))))))))
+      (fluid-let ((load new-load)
+                 (flush-purification-queue! (lambda () 'done)))
+        (new-load (caar alist))))
+    (flush-purification-queue!))
+
+  (with-binary-input-file (->truename pathname)
+    (lambda (channel)
+      ((ucode-primitive binary-fasload) channel) ; Dismiss header.
+      (let ((process-next-bunch
+            (lambda ()
+              (process-bunch
+               (map (lambda (pair)
+                      (list (car pair)
+                            (->pathname (car pair))
+                            (cdr pair)))
+                    ((ucode-primitive binary-fasload) channel))))))
+
+
+       (do ((count count (-1+ count)))
+           ((= count 1)
+            (process-next-bunch))
+         (process-next-bunch))))))
+\f
+;;;; Utilities for the binary unpacker
+
+(define (with-binary-file-channel file action open extract-channel name)
+  (let ((port false))
+    (dynamic-wind
+     (lambda ()
+       (if port
+           (error "cannot re-enter with-binary-file-channel" name)))
+     (lambda ()
+       (set! port (open file))
+       (action (channel-descriptor (extract-channel port))))
+     (lambda ()
+       (if (and port
+                (not (eq? port true)))
+           (begin
+             (close-port port)
+             (set! port true)))))))
+
+(define (with-binary-input-file file action)
+  (with-binary-file-channel file action
+    open-binary-input-file
+    input-port/channel
+    'with-binary-input-file))
\ No newline at end of file

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index ce4c52acf67bdd6c790f7e4c2e90db72dc7b28b4..5ba1c862bae98154676f2b5f9b2648edb484e024 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.148 1992/05/07 22:24:59 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.149 1992/05/23 00:11:27 jinx Exp $
 
 Copyright (c) 1988-92 Massachusetts Institute of Technology
 
@@ -1575,6 +1575,8 @@ MIT in each case. |#
          tty-input-channel
          tty-output-channel
          with-channel-blocking)
+  (export (runtime load)
+         channel-descriptor)
   (export (runtime socket)
          channel-descriptor
          make-channel)

diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm
index b3a5b0a6e622e57c6f96e7864163d27fa32da2cd..cccda57434109602806addbefb35ab59948c8448 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.32 1992/04/05 02:00:34 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.33 1992/05/23 00:11:09 jinx Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -338,4 +338,97 @@ MIT in each case. |#
                             (1+ index)
                             (cons (vector-ref unused-command-line index)
                                   unhandled-options))))))))
-      (load-init-file)))
\ No newline at end of file
+      (load-init-file)))
+\f
+;;;; Loader for packed binaries
+
+(define (load-packed-binaries pathname fname count environment)
+  (define (find-filename fname alist)
+    (define (compatible? path1 path2)
+      (and (equal? (pathname-directory path1)
+                   (pathname-directory path2))
+           (equal? (pathname-name path1)
+                   (pathname-name path2))
+           (or (equal? (pathname-type path1) (pathname-type path2))
+               (and (member (pathname-type path1) '(#f "bin" "com"))
+                    (member (pathname-type path2) '(#f "bin" "com"))))))
+
+    (let ((path (->pathname fname)))
+      (let loop ((alist alist))
+        (and (not (null? alist))
+             (if (compatible? path (cadar alist))
+                 (car alist)
+                 (loop (cdr alist)))))))
+
+  (define (process-bunch alist)
+    (let* ((real-load load)
+          (new-load
+           (lambda (fname #!optional env syntax-table purify?)
+             (let ((env (if (default-object? env)
+                            environment
+                            env))
+                   (st (if (default-object? syntax-table)
+                           default-object
+                           syntax-table))
+                   (purify? (if (default-object? purify?)
+                                default-object
+                                purify?)))
+               (let ((place (find-filename fname alist)))
+                 (if (not place)
+                     (real-load fname env st purify?)
+                     (let ((scode (caddr place)))
+                       (if (not load/suppress-loading-message?)
+                           (begin
+                             (newline)
+                             (display ";Pseudo-loading ")
+                             (display (->namestring (->pathname fname)))
+                             (display "...")))
+                       (if (and purify? (not (eq? purify? default-object)))
+                           (purify (load/purification-root scode)))
+                       (extended-scode-eval scode env))))))))
+      (fluid-let ((load new-load)
+                 (flush-purification-queue! (lambda () 'done)))
+        (new-load (caar alist))))
+    (flush-purification-queue!))
+
+  (with-binary-input-file (->truename pathname)
+    (lambda (channel)
+      ((ucode-primitive binary-fasload) channel) ; Dismiss header.
+      (let ((process-next-bunch
+            (lambda ()
+              (process-bunch
+               (map (lambda (pair)
+                      (list (car pair)
+                            (->pathname (car pair))
+                            (cdr pair)))
+                    ((ucode-primitive binary-fasload) channel))))))
+
+
+       (do ((count count (-1+ count)))
+           ((= count 1)
+            (process-next-bunch))
+         (process-next-bunch))))))
+\f
+;;;; Utilities for the binary unpacker
+
+(define (with-binary-file-channel file action open extract-channel name)
+  (let ((port false))
+    (dynamic-wind
+     (lambda ()
+       (if port
+           (error "cannot re-enter with-binary-file-channel" name)))
+     (lambda ()
+       (set! port (open file))
+       (action (channel-descriptor (extract-channel port))))
+     (lambda ()
+       (if (and port
+                (not (eq? port true)))
+           (begin
+             (close-port port)
+             (set! port true)))))))
+
+(define (with-binary-input-file file action)
+  (with-binary-file-channel file action
+    open-binary-input-file
+    input-port/channel
+    'with-binary-input-file))
\ No newline at end of file

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index ac66c58e3ff201b0235b8b04e4667220858f4060..2aa9acb131770d3c0140c4f8898c878d642e33a5 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.148 1992/05/07 22:24:59 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.149 1992/05/23 00:11:27 jinx Exp $
 
 Copyright (c) 1988-92 Massachusetts Institute of Technology
 
@@ -1575,6 +1575,8 @@ MIT in each case. |#
          tty-input-channel
          tty-output-channel
          with-channel-blocking)
+  (export (runtime load)
+         channel-descriptor)
   (export (runtime socket)
          channel-descriptor
          make-channel)