load-packed-binaries now captures fasload as well, so that .bad files

can be collected into packed binaries.

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index 5668e6145d53bb38f6e64e1c6b457cbef28020fe..fff14c0098973534bc5866308cec7e10cd913f13 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.33 1992/05/23 00:11:09 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.34 1992/05/26 01:00:57 jinx Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -360,9 +360,19 @@ MIT in each case. |#
                  (car alist)
                  (loop (cdr alist)))))))
 
+  (define (loading-message fname suppress? kind)
+    (if (not suppress?)
+       (let ((port (nearest-cmdl/port)))
+         (fresh-line port)
+         (write-string kind port)
+         (write-string (->namestring (->pathname fname)))
+         (write-string "..."))))
+
   (define (process-bunch alist)
-    (let* ((real-load load)
-          (new-load
+    (let ((real-load load)
+         (real-fasload fasload))
+      (fluid-let
+         ((load
            (lambda (fname #!optional env syntax-table purify?)
              (let ((env (if (default-object? env)
                             environment
@@ -377,18 +387,29 @@ MIT in each case. |#
                  (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 "...")))
+                       (loading-message fname
+                                         load/suppress-loading-message?
+                                        ";Pseudo-loading ")
                        (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))))
+                       (extended-scode-eval scode env)))))))
+\f
+          (fasload
+           (lambda (filename #!optional suppress-message?)
+             (let ((suppress-message?
+                    (if (default-object? suppress-message?)
+                        load/suppress-loading-message?
+                        suppress-message?))
+                   (place (find-filename filename alist)))
+               (if (not place)
+                   (real-fasload filename suppress-message?)
+                   (begin
+                     (loading-message filename
+                                      suppress-message?
+                                      ";Pseudo-fasloading ")
+                     (caddr place))))))
+          (flush-purification-queue! (lambda () 'done)))
+        (load (caar alist))))
     (flush-purification-queue!))
 
   (with-binary-input-file (->truename pathname)
@@ -408,8 +429,8 @@ MIT in each case. |#
            ((= count 1)
             (process-next-bunch))
          (process-next-bunch))))))
-\f
-;;;; Utilities for the binary unpacker
+
+;;; Utilities for the binary unpacker
 
 (define (with-binary-file-channel file action open extract-channel name)
   (let ((port false))

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 940d017f001691580dbfb77455933c4bba8d97dd..cc71f1544e12589e1b2e70507da218237a5486d3 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.151 1992/05/22 23:58:56 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.152 1992/05/26 01:01:05 jinx Exp $
 
 Copyright (c) 1988-1992 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 151))
+  (add-identification! "Runtime" 14 152))
 
 (define microcode-system)
 

diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm
index cccda57434109602806addbefb35ab59948c8448..5f8d84b5d8e1496a95c3f2e32f36cb974bd85f01 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.33 1992/05/23 00:11:09 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.34 1992/05/26 01:00:57 jinx Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -360,9 +360,19 @@ MIT in each case. |#
                  (car alist)
                  (loop (cdr alist)))))))
 
+  (define (loading-message fname suppress? kind)
+    (if (not suppress?)
+       (let ((port (nearest-cmdl/port)))
+         (fresh-line port)
+         (write-string kind port)
+         (write-string (->namestring (->pathname fname)))
+         (write-string "..."))))
+
   (define (process-bunch alist)
-    (let* ((real-load load)
-          (new-load
+    (let ((real-load load)
+         (real-fasload fasload))
+      (fluid-let
+         ((load
            (lambda (fname #!optional env syntax-table purify?)
              (let ((env (if (default-object? env)
                             environment
@@ -377,18 +387,29 @@ MIT in each case. |#
                  (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 "...")))
+                       (loading-message fname
+                                         load/suppress-loading-message?
+                                        ";Pseudo-loading ")
                        (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))))
+                       (extended-scode-eval scode env)))))))
+\f
+          (fasload
+           (lambda (filename #!optional suppress-message?)
+             (let ((suppress-message?
+                    (if (default-object? suppress-message?)
+                        load/suppress-loading-message?
+                        suppress-message?))
+                   (place (find-filename filename alist)))
+               (if (not place)
+                   (real-fasload filename suppress-message?)
+                   (begin
+                     (loading-message filename
+                                      suppress-message?
+                                      ";Pseudo-fasloading ")
+                     (caddr place))))))
+          (flush-purification-queue! (lambda () 'done)))
+        (load (caar alist))))
     (flush-purification-queue!))
 
   (with-binary-input-file (->truename pathname)
@@ -408,8 +429,8 @@ MIT in each case. |#
            ((= count 1)
             (process-next-bunch))
          (process-next-bunch))))))
-\f
-;;;; Utilities for the binary unpacker
+
+;;; Utilities for the binary unpacker
 
 (define (with-binary-file-channel file action open extract-channel name)
   (let ((port false))