#| -*-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
;;; This program implements the window data structures required by
;;; the algorithms B1, B2, and C2. The encoder, which appears below,
;;; determines the algorithm.
-
+\f
(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)))
\f
(define (idle)
;; This is the top of the compression loop. We've just emitted a
(set-node-nb! node true)))
unspecific))))
\f
-#|
-(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)))
#| -*-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
(->namestring
(rewrite-directory (merge-pathnames name))))
-;;; The conversion hack.
+\f;;; The conversion hack.
(define (inf->bif/bsm inffile)
(let* ((infpath (merge-pathnames inffile))
(loop (fix:1+ pos))))))))
(else
(error "Unknown inf format" binf)))))
-\f
-;;; UNCOMPRESS: A simple extractor for compressed binary info files.
-(define (uncompress-internal ifile ofile if-fail)
+\f;;; 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)))))))))
+
\f
- (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)
#| -*-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
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?
(parent ())
(export ()
compress
- uncompress))
+ uncompress
+ compress-ports))
(define-package (runtime port)
(files "port")
(parent ())
(export ()
call-with-input-file
+ call-with-binary-input-file
char-ready?
current-input-port
eof-object?
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))
(export ()
beep
call-with-output-file
+ call-with-binary-output-file
clear
current-output-port
display
output-port/y-size
set-current-output-port!
with-output-to-file
+ with-output-to-binary-file
with-output-to-port
write
write-char
#| -*-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
(->namestring
(rewrite-directory (merge-pathnames name))))
-;;; The conversion hack.
+\f;;; The conversion hack.
(define (inf->bif/bsm inffile)
(let* ((infpath (merge-pathnames inffile))
(loop (fix:1+ pos))))))))
(else
(error "Unknown inf format" binf)))))
-\f
-;;; UNCOMPRESS: A simple extractor for compressed binary info files.
-(define (uncompress-internal ifile ofile if-fail)
+\f;;; 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)))))))))
+
\f
- (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)
#| -*-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
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?
(parent ())
(export ()
compress
- uncompress))
+ uncompress
+ compress-ports))
(define-package (runtime port)
(files "port")
(parent ())
(export ()
call-with-input-file
+ call-with-binary-input-file
char-ready?
current-input-port
eof-object?
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))
(export ()
beep
call-with-output-file
+ call-with-binary-output-file
clear
current-output-port
display
output-port/y-size
set-current-output-port!
with-output-to-file
+ with-output-to-binary-file
with-output-to-port
write
write-char
projects / mit-scheme.git / commitdiff