From 21791d2c83bf62c75c356cc7b0ae7999b52ca0d3 Mon Sep 17 00:00:00 2001 From: "Henry M. Wu" Date: Tue, 26 May 1992 23:09:18 +0000 Subject: [PATCH] Exposed compression operations on ports. --- v7/src/runtime/cpress.scm | 86 ++++++------------ v7/src/runtime/infutl.scm | 173 ++++++++++++++++++++----------------- v7/src/runtime/runtime.pkg | 13 ++- v8/src/runtime/infutl.scm | 173 ++++++++++++++++++++----------------- v8/src/runtime/runtime.pkg | 13 ++- 5 files changed, 237 insertions(+), 221 deletions(-) diff --git a/v7/src/runtime/cpress.scm b/v7/src/runtime/cpress.scm index 601dd6e9d..045c82557 100644 --- a/v7/src/runtime/cpress.scm +++ b/v7/src/runtime/cpress.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/cpress.scm,v 1.2 1992/05/26 17:51:50 mhwu Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/cpress.scm,v 1.3 1992/05/26 23:09:18 mhwu Exp $ Copyright (c) 1992 Massachusetts Institute of Technology @@ -92,41 +92,36 @@ MIT in each case. |# ;;; This program implements the window data structures required by ;;; the algorithms B1, B2, and C2. The encoder, which appears below, ;;; determines the algorithm. - + (define input-port) (define output-port) (define (compress ifile ofile) - (let ((ifile (merge-pathnames ifile)) - (ofile (merge-pathnames ofile))) - (dynamic-wind - (lambda () - (set! input-port (open-binary-input-file ifile)) - (set! output-port (open-binary-output-file ofile))) - (lambda () - (if (not (input-port? input-port)) - (error "Cannot open input file" ifile input-port)) - (if (not (output-port? output-port)) - (error "Cannot open output file" ofile output-port)) - (fluid-let ((root-nodes (make-vector 256 false)) - (oldest-node false) - (newest-node false) - (window-filled? false) - (compress-continuation) - (byte-buffer (make-byte-buffer)) - (current-pointer 0) - (current-bp 0) - (command-bp 0) - (output-buffer (make-output-buffer))) - (write-string "Compressed-B1-1.00" output-port) - (call-with-current-continuation - (lambda (continuation) - (set! compress-continuation continuation) - (idle))) - (flush-output-buffer))) - (lambda () - (close-output-port output-port) - (close-input-port input-port))))) + (call-with-binary-input-file (merge-pathnames ifile) + (lambda (input) + (call-with-binary-output-file (merge-pathnames ofile) + (lambda (output) + (write-string "Compressed-B1-1.00" output) + (compress-ports input output)))))) + +(define (compress-ports input output) + (fluid-let ((root-nodes (make-vector 256 false)) + (oldest-node false) + (newest-node false) + (window-filled? false) + (compress-continuation) + (byte-buffer (make-byte-buffer)) + (current-pointer 0) + (current-bp 0) + (command-bp 0) + (output-buffer (make-output-buffer)) + (input-port input) + (output-port output)) + (call-with-current-continuation + (lambda (continuation) + (set! compress-continuation continuation) + (idle))) + (flush-output-buffer))) (define (idle) ;; This is the top of the compression loop. We've just emitted a @@ -378,33 +373,6 @@ MIT in each case. |# (set-node-nb! node true))) unspecific)))) -#| -(define (delete-child parent child) - (let ((previous (node-previous child)) - (next (node-next child))) - (if next - (set-node-previous! next previous)) - (if previous - (set-node-next! previous next) - (set-node-children! parent next))) - (let ((child (node-children parent))) - ;; If only one child remains, splice out PARENT. - (if (not (node-next child)) - (begin - (replace-child parent child) - (let ((older (node-older parent)) - (newer (node-newer parent))) - (if older - (set-node-newer! older newer)) - (if newer - (set-node-older! newer older)) - (if (eq? parent oldest-node) - (set! oldest-node child)) - (if (eq? parent newest-node) - (set! newest-node child)) - unspecific))))) -|# - (define (delete-child parent child) (let ((previous (node-previous child)) (next (node-next child))) diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm index 8dec41833..650065eee 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.32 1992/05/26 21:31:03 mhwu Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.33 1992/05/26 23:07:52 mhwu Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -392,7 +392,7 @@ MIT in each case. |# (->namestring (rewrite-directory (merge-pathnames name)))) -;;; The conversion hack. + ;;; The conversion hack. (define (inf->bif/bsm inffile) (let* ((infpath (merge-pathnames inffile)) @@ -428,85 +428,102 @@ MIT in each case. |# (loop (fix:1+ pos)))))))) (else (error "Unknown inf format" binf))))) - -;;; UNCOMPRESS: A simple extractor for compressed binary info files. -(define (uncompress-internal ifile ofile if-fail) + ;;; UNCOMPRESS: A simple extractor for compressed binary info files. + +(define (uncompress-ports input-port output-port #!optional buffer-size) (define-integrable window-size 4096) - (define (expand input-port output-channel buffer-size) - (let ((buffer (make-string buffer-size)) - (cp-table (make-vector window-size)) - (port/read-char - (or (input-port/operation/read-char input-port) - (if-fail "Port doesn't support read-char" input-port))) - (port/read-substring - (or (input-port/operation input-port 'READ-SUBSTRING) - (if-fail "Port doesn't support read-substring" input-port)))) - (define (displacement->cp-index displacement cp) - (let ((index (fix:- cp displacement))) - (if (fix:< index 0) (fix:+ window-size index) index))) - (define-integrable (cp:+ cp n) - (fix:remainder (fix:+ cp n) window-size)) - (define-integrable (read-substring! buffer start end) - (port/read-substring input-port buffer start end)) - (define (read-ascii) - (let ((char (port/read-char input-port))) - (and (not (eof-object? char)) - (char->ascii char)))) - (define (guarantee-buffer nbp) - (if (fix:> nbp buffer-size) - (let* ((new-size (fix:+ buffer-size (fix:quotient buffer-size 4))) - (nbuffer (make-string new-size))) - (substring-move-right! buffer 0 buffer-size nbuffer 0) - (set! buffer-size new-size) - (set! buffer nbuffer)))) - - (let loop ((bp 0) (cp 0) (byte (read-ascii))) - (cond ((not byte) - (channel-write output-channel buffer 0 bp) - bp) - ((fix:< byte 16) - (let ((length (fix:+ byte 1))) - (let ((nbp (fix:+ bp length)) (ncp (cp:+ cp length))) - (guarantee-buffer nbp) - (read-substring! buffer bp nbp) - (do ((bp bp (fix:+ bp 1)) (cp cp (cp:+ cp 1))) - ((fix:= bp nbp)) - (vector-set! cp-table cp bp)) - (loop nbp ncp (read-ascii))))) - (else - (let ((cpi (displacement->cp-index - (fix:+ (fix:* (fix:remainder byte 16) 256) - (read-ascii)) - cp)) - (length (fix:+ (fix:quotient byte 16) 1))) - (let ((bp* (vector-ref cp-table cpi)) - (nbp (fix:+ bp length)) - (ncp (cp:+ cp 1))) - (guarantee-buffer nbp) - (substring-move-right! buffer bp* (fix:+ bp* length) - buffer bp) - (vector-set! cp-table cp bp) - (loop nbp ncp (read-ascii))))))))) + (if (default-object? buffer-size) + (set! buffer-size 4096)) + (let ((buffer (make-string buffer-size)) + (cp-table (make-vector window-size)) + (port/read-char + (or (input-port/operation/read-char input-port) + (if-fail "Port doesn't support read-char" input-port))) + (port/read-substring + (or (input-port/operation input-port 'READ-SUBSTRING) + input-port/read-substring))) + + (define (displacement->cp-index displacement cp) + (let ((index (fix:- cp displacement))) + (if (fix:< index 0) (fix:+ window-size index) index))) + (define-integrable (cp:+ cp n) + (fix:remainder (fix:+ cp n) window-size)) + (define-integrable (read-substring! buffer start end) + (port/read-substring input-port buffer start end)) + (define (read-ascii) + (let ((char (port/read-char input-port))) + (and (not (eof-object? char)) + (char->ascii char)))) + (define (guarantee-buffer nbp) + (if (fix:> nbp buffer-size) + (let* ((new-size (fix:+ buffer-size (fix:quotient buffer-size 4))) + (nbuffer (make-string new-size))) + (substring-move-right! buffer 0 buffer-size nbuffer 0) + (set! buffer-size new-size) + (set! buffer nbuffer)))) + + (let loop ((bp 0) (cp 0) (byte (read-ascii))) + (cond ((not byte) + (output-port/write-substring output-port buffer 0 bp) + bp) + ((fix:< byte 16) + (let ((length (fix:+ byte 1))) + (let ((nbp (fix:+ bp length)) (ncp (cp:+ cp length))) + (guarantee-buffer nbp) + (read-substring! buffer bp nbp) + (do ((bp bp (fix:+ bp 1)) (cp cp (cp:+ cp 1))) + ((fix:= bp nbp)) + (vector-set! cp-table cp bp)) + (loop nbp ncp (read-ascii))))) + (else + (let ((cpi (displacement->cp-index + (fix:+ (fix:* (fix:remainder byte 16) 256) + (read-ascii)) + cp)) + (length (fix:+ (fix:quotient byte 16) 1))) + (let ((bp* (vector-ref cp-table cpi)) + (nbp (fix:+ bp length)) + (ncp (cp:+ cp 1))) + (guarantee-buffer nbp) + (substring-move-right! buffer bp* (fix:+ bp* length) + buffer bp) + (vector-set! cp-table cp bp) + (loop nbp ncp (read-ascii))))))))) + - (let ((input (open-binary-input-file (merge-pathnames ifile)))) - (if (not (input-port? input)) - (if-fail "Cannot open input" ifile)) - (let* ((file-marker "Compressed-B1-1.00") - (marker-size (string-length file-marker)) - (actual-marker (make-string marker-size))) - ;; This may get more hairy as we up versions - (if (and (fix:= ((input-port/operation input 'read-substring) - input actual-marker 0 marker-size) - marker-size) - (string=? file-marker actual-marker)) - (let ((output (file-open-output-channel - (->namestring (merge-pathnames ofile)))) - (size (file-attributes/length (file-attributes ifile)))) - (expand input output (fix:* size 2)) - (channel-close output) - (close-input-port input)) - (if-fail "Not a recognized compressed file" ifile))))) +(define (uncompress-internal ifile ofile if-fail) + (call-with-binary-input-file (merge-pathnames ifile) + (lambda (input) + (let* ((file-marker "Compressed-B1-1.00") + (marker-size (string-length file-marker)) + (actual-marker (make-string marker-size))) + ;; This may get more hairy as we up versions + (if (and (fix:= (input-port/read-substring + input actual-marker 0 marker-size) + marker-size) + (string=? file-marker actual-marker)) + (call-with-binary-output-file (merge-pathnames ofile) + (lambda (output) + (let ((size (file-attributes/length (file-attributes ifile)))) + (uncompress-ports input output (fix:* size 2))))) + (if-fail "Not a recognized compressed file" ifile)))))) + +;;; Should be in the runtime system +(define (input-port/read-substring input-port buffer start end) + (let ((port/read-substring + (or (input-port/operation input-port 'READ-SUBSTRING) + (let ((port/read-char + (or (input-port/operation/read-char input-port) + (error "Port doesn't support read-char" input-port)))) + (lambda (port buffer start end) + (let loop ((i start) (char (port/read-char port))) + (if (eof-object? char) + (fix:- i start) + (begin + (string-set! buffer i char) + (loop (fix:1+ i) (port/read-char port)))))))))) + (port/read-substring input-port buffer start end))) (define (find-alternate-file-type base-pathname exts/receivers) (or (null? exts/receivers) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index e8c82b98d..b30b58c8d 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.152 1992/05/26 17:50:35 mhwu Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.153 1992/05/26 23:08:05 mhwu Exp $ Copyright (c) 1988-92 Massachusetts Institute of Technology @@ -223,7 +223,9 @@ MIT in each case. |# compiled-procedure/name compiled-procedure/lambda discard-debugging-info! - load-debugging-info-on-demand?) + load-debugging-info-on-demand? + uncompress-ports + ) (export (runtime load) dbg-info-vector/purification-root dbg-info-vector? @@ -895,7 +897,8 @@ MIT in each case. |# (parent ()) (export () compress - uncompress)) + uncompress + compress-ports)) (define-package (runtime port) (files "port") @@ -964,6 +967,7 @@ MIT in each case. |# (parent ()) (export () call-with-input-file + call-with-binary-input-file char-ready? current-input-port eof-object? @@ -982,6 +986,7 @@ MIT in each case. |# read-string set-current-input-port! with-input-from-file + with-input-from-binary-file with-input-from-port) (export (runtime primitive-io) eof-object)) @@ -992,6 +997,7 @@ MIT in each case. |# (export () beep call-with-output-file + call-with-binary-output-file clear current-output-port display @@ -1009,6 +1015,7 @@ MIT in each case. |# output-port/y-size set-current-output-port! with-output-to-file + with-output-to-binary-file with-output-to-port write write-char diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm index e774e14a5..21001f676 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.32 1992/05/26 21:31:03 mhwu Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.33 1992/05/26 23:07:52 mhwu Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -392,7 +392,7 @@ MIT in each case. |# (->namestring (rewrite-directory (merge-pathnames name)))) -;;; The conversion hack. + ;;; The conversion hack. (define (inf->bif/bsm inffile) (let* ((infpath (merge-pathnames inffile)) @@ -428,85 +428,102 @@ MIT in each case. |# (loop (fix:1+ pos)))))))) (else (error "Unknown inf format" binf))))) - -;;; UNCOMPRESS: A simple extractor for compressed binary info files. -(define (uncompress-internal ifile ofile if-fail) + ;;; UNCOMPRESS: A simple extractor for compressed binary info files. + +(define (uncompress-ports input-port output-port #!optional buffer-size) (define-integrable window-size 4096) - (define (expand input-port output-channel buffer-size) - (let ((buffer (make-string buffer-size)) - (cp-table (make-vector window-size)) - (port/read-char - (or (input-port/operation/read-char input-port) - (if-fail "Port doesn't support read-char" input-port))) - (port/read-substring - (or (input-port/operation input-port 'READ-SUBSTRING) - (if-fail "Port doesn't support read-substring" input-port)))) - (define (displacement->cp-index displacement cp) - (let ((index (fix:- cp displacement))) - (if (fix:< index 0) (fix:+ window-size index) index))) - (define-integrable (cp:+ cp n) - (fix:remainder (fix:+ cp n) window-size)) - (define-integrable (read-substring! buffer start end) - (port/read-substring input-port buffer start end)) - (define (read-ascii) - (let ((char (port/read-char input-port))) - (and (not (eof-object? char)) - (char->ascii char)))) - (define (guarantee-buffer nbp) - (if (fix:> nbp buffer-size) - (let* ((new-size (fix:+ buffer-size (fix:quotient buffer-size 4))) - (nbuffer (make-string new-size))) - (substring-move-right! buffer 0 buffer-size nbuffer 0) - (set! buffer-size new-size) - (set! buffer nbuffer)))) - - (let loop ((bp 0) (cp 0) (byte (read-ascii))) - (cond ((not byte) - (channel-write output-channel buffer 0 bp) - bp) - ((fix:< byte 16) - (let ((length (fix:+ byte 1))) - (let ((nbp (fix:+ bp length)) (ncp (cp:+ cp length))) - (guarantee-buffer nbp) - (read-substring! buffer bp nbp) - (do ((bp bp (fix:+ bp 1)) (cp cp (cp:+ cp 1))) - ((fix:= bp nbp)) - (vector-set! cp-table cp bp)) - (loop nbp ncp (read-ascii))))) - (else - (let ((cpi (displacement->cp-index - (fix:+ (fix:* (fix:remainder byte 16) 256) - (read-ascii)) - cp)) - (length (fix:+ (fix:quotient byte 16) 1))) - (let ((bp* (vector-ref cp-table cpi)) - (nbp (fix:+ bp length)) - (ncp (cp:+ cp 1))) - (guarantee-buffer nbp) - (substring-move-right! buffer bp* (fix:+ bp* length) - buffer bp) - (vector-set! cp-table cp bp) - (loop nbp ncp (read-ascii))))))))) + (if (default-object? buffer-size) + (set! buffer-size 4096)) + (let ((buffer (make-string buffer-size)) + (cp-table (make-vector window-size)) + (port/read-char + (or (input-port/operation/read-char input-port) + (if-fail "Port doesn't support read-char" input-port))) + (port/read-substring + (or (input-port/operation input-port 'READ-SUBSTRING) + input-port/read-substring))) + + (define (displacement->cp-index displacement cp) + (let ((index (fix:- cp displacement))) + (if (fix:< index 0) (fix:+ window-size index) index))) + (define-integrable (cp:+ cp n) + (fix:remainder (fix:+ cp n) window-size)) + (define-integrable (read-substring! buffer start end) + (port/read-substring input-port buffer start end)) + (define (read-ascii) + (let ((char (port/read-char input-port))) + (and (not (eof-object? char)) + (char->ascii char)))) + (define (guarantee-buffer nbp) + (if (fix:> nbp buffer-size) + (let* ((new-size (fix:+ buffer-size (fix:quotient buffer-size 4))) + (nbuffer (make-string new-size))) + (substring-move-right! buffer 0 buffer-size nbuffer 0) + (set! buffer-size new-size) + (set! buffer nbuffer)))) + + (let loop ((bp 0) (cp 0) (byte (read-ascii))) + (cond ((not byte) + (output-port/write-substring output-port buffer 0 bp) + bp) + ((fix:< byte 16) + (let ((length (fix:+ byte 1))) + (let ((nbp (fix:+ bp length)) (ncp (cp:+ cp length))) + (guarantee-buffer nbp) + (read-substring! buffer bp nbp) + (do ((bp bp (fix:+ bp 1)) (cp cp (cp:+ cp 1))) + ((fix:= bp nbp)) + (vector-set! cp-table cp bp)) + (loop nbp ncp (read-ascii))))) + (else + (let ((cpi (displacement->cp-index + (fix:+ (fix:* (fix:remainder byte 16) 256) + (read-ascii)) + cp)) + (length (fix:+ (fix:quotient byte 16) 1))) + (let ((bp* (vector-ref cp-table cpi)) + (nbp (fix:+ bp length)) + (ncp (cp:+ cp 1))) + (guarantee-buffer nbp) + (substring-move-right! buffer bp* (fix:+ bp* length) + buffer bp) + (vector-set! cp-table cp bp) + (loop nbp ncp (read-ascii))))))))) + - (let ((input (open-binary-input-file (merge-pathnames ifile)))) - (if (not (input-port? input)) - (if-fail "Cannot open input" ifile)) - (let* ((file-marker "Compressed-B1-1.00") - (marker-size (string-length file-marker)) - (actual-marker (make-string marker-size))) - ;; This may get more hairy as we up versions - (if (and (fix:= ((input-port/operation input 'read-substring) - input actual-marker 0 marker-size) - marker-size) - (string=? file-marker actual-marker)) - (let ((output (file-open-output-channel - (->namestring (merge-pathnames ofile)))) - (size (file-attributes/length (file-attributes ifile)))) - (expand input output (fix:* size 2)) - (channel-close output) - (close-input-port input)) - (if-fail "Not a recognized compressed file" ifile))))) +(define (uncompress-internal ifile ofile if-fail) + (call-with-binary-input-file (merge-pathnames ifile) + (lambda (input) + (let* ((file-marker "Compressed-B1-1.00") + (marker-size (string-length file-marker)) + (actual-marker (make-string marker-size))) + ;; This may get more hairy as we up versions + (if (and (fix:= (input-port/read-substring + input actual-marker 0 marker-size) + marker-size) + (string=? file-marker actual-marker)) + (call-with-binary-output-file (merge-pathnames ofile) + (lambda (output) + (let ((size (file-attributes/length (file-attributes ifile)))) + (uncompress-ports input output (fix:* size 2))))) + (if-fail "Not a recognized compressed file" ifile)))))) + +;;; Should be in the runtime system +(define (input-port/read-substring input-port buffer start end) + (let ((port/read-substring + (or (input-port/operation input-port 'READ-SUBSTRING) + (let ((port/read-char + (or (input-port/operation/read-char input-port) + (error "Port doesn't support read-char" input-port)))) + (lambda (port buffer start end) + (let loop ((i start) (char (port/read-char port))) + (if (eof-object? char) + (fix:- i start) + (begin + (string-set! buffer i char) + (loop (fix:1+ i) (port/read-char port)))))))))) + (port/read-substring input-port buffer start end))) (define (find-alternate-file-type base-pathname exts/receivers) (or (null? exts/receivers) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index c7d52fde9..793f67e50 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.152 1992/05/26 17:50:35 mhwu Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.153 1992/05/26 23:08:05 mhwu Exp $ Copyright (c) 1988-92 Massachusetts Institute of Technology @@ -223,7 +223,9 @@ MIT in each case. |# compiled-procedure/name compiled-procedure/lambda discard-debugging-info! - load-debugging-info-on-demand?) + load-debugging-info-on-demand? + uncompress-ports + ) (export (runtime load) dbg-info-vector/purification-root dbg-info-vector? @@ -895,7 +897,8 @@ MIT in each case. |# (parent ()) (export () compress - uncompress)) + uncompress + compress-ports)) (define-package (runtime port) (files "port") @@ -964,6 +967,7 @@ MIT in each case. |# (parent ()) (export () call-with-input-file + call-with-binary-input-file char-ready? current-input-port eof-object? @@ -982,6 +986,7 @@ MIT in each case. |# read-string set-current-input-port! with-input-from-file + with-input-from-binary-file with-input-from-port) (export (runtime primitive-io) eof-object)) @@ -992,6 +997,7 @@ MIT in each case. |# (export () beep call-with-output-file + call-with-binary-output-file clear current-output-port display @@ -1009,6 +1015,7 @@ MIT in each case. |# output-port/y-size set-current-output-port! with-output-to-file + with-output-to-binary-file with-output-to-port write write-char -- 2.25.1