From: Guillermo J. Rozas Date: Tue, 26 May 1992 01:01:05 +0000 (+0000) Subject: load-packed-binaries now captures fasload as well, so that .bad files X-Git-Tag: 20090517-FFI~9378 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b27cc2471bc0629a01b9a421f4d0c696bbe4faee;p=mit-scheme.git 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 5668e6145..fff14c009 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.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))))))) + + (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)))))) - -;;;; 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 940d017f0..cc71f1544 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.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 cccda5743..5f8d84b5d 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.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))))))) + + (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)))))) - -;;;; Utilities for the binary unpacker + +;;; Utilities for the binary unpacker (define (with-binary-file-channel file action open extract-channel name) (let ((port false))