diff --git a/collects/mzlib/a-signature.rkt b/collects/mzlib/a-signature.rkt index 28026a6..6771c55 100644 --- a/collects/mzlib/a-signature.rkt +++ b/collects/mzlib/a-signature.rkt @@ -1,6 +1,6 @@ (module a-signature mzscheme - (require-for-syntax "private/unit-compiletime.rkt" - "private/unit-syntax.rkt") + (require-for-syntax racket/private/unit-compiletime + racket/private/unit-syntax) (require "unit.rkt") (provide (rename module-begin #%module-begin) diff --git a/collects/mzlib/control.rkt b/collects/mzlib/control.rkt index d59f00f..44b48c6 100644 --- a/collects/mzlib/control.rkt +++ b/collects/mzlib/control.rkt @@ -1,268 +1,6 @@ #lang racket/base -(require (for-syntax racket/base)) - -(provide call/prompt call/comp abort/cc - - abort - - fcontrol % - - control prompt control-at prompt-at - ;; `-at' variations expect a prompt tag - - shift reset shift-at reset-at - - control0 prompt0 control0-at prompt0-at - shift0 reset0 shift0-at reset0-at - - spawn - - splitter - - new-prompt set cupto) - -;; ---------------------------------------- - -(define call/prompt call-with-continuation-prompt) -(define call/comp call-with-composable-continuation) -(define abort/cc abort-current-continuation) - -;; ---------------------------------------- - -(define (abort . vals) - (abort-current-continuation - (default-continuation-prompt-tag) - (lambda () (apply values vals)))) - -;; ---------------------------------------- -;; Sitaram, PLDI'93 -;; The `%' here is compable with Sitaram & Felleisen, LSC'90, -;; since we make the handler optional. - -(define (fcontrol f #:tag [prompt-tag (default-continuation-prompt-tag)]) - (call-with-composable-continuation - (lambda (k) - (abort-current-continuation - prompt-tag - f - k)))) - -(define-syntax % - (syntax-rules () - [(_ expr handler #:tag prompt-tag) - (call-with-continuation-prompt - (lambda () expr) - prompt-tag - handler)] - [(_ expr handler) - (call-with-continuation-prompt - (lambda () expr) - (default-continuation-prompt-tag) - handler)] - [(_ expr) - (call-with-continuation-prompt - (lambda () expr))])) - -;; ---------------------------------------- -;; Predecessors of Sitaram, PLDI'93 -;; Felleisen, Wand, Friedman, & Duba, LFP'88 -;; Instead of `#', we use `prompt' as in Felleisen, POPL'88 -;; (where `control' is called `F') -;; See also Sitaram and Felleisen, LSC'90 - -;; Helpder function: abort-current-continuation/keep-prompt is -;; like abort-current-continuation, but it always leaves the -;; prompt in place, independent of the prompt's handler. -;; This is possible via call/cc (i.e., it must be possible -;; to abort and keep a prompt, because call/cc needs it). -(define (abort-current-continuation/keep-prompt tag thunk) - ((call-with-continuation-prompt - (lambda () - ((call-with-current-continuation - (lambda (k) (lambda () k)) - tag))) - tag) - thunk)) - -;; call-with-control, parameterized over whether to keep the -;; prompt (if the prompt's handler gives us the option of -;; removing it). The generated function is the same -;; as fcontrol when `abort-cc' is `abort-current-continuation'. -(define (make-call-with-control abort-cc) - ;; Uses call/cc to always keep the enclosing prompt. - (letrec ([call-with-control - (case-lambda - [(f) (call-with-control f (default-continuation-prompt-tag))] - [(f tag) (call-with-composable-continuation - (lambda (k) - (abort-cc - tag - (lambda () - (f k)))) - tag)])]) - call-with-control)) - -(define call-with-control - (make-call-with-control abort-current-continuation/keep-prompt)) - -(define-syntax define-control-macros - (syntax-rules () - [(_ control control-at call-with-control) - (begin - (define-syntax (control stx) - (syntax-case stx () - [(control id expr0 expr (... ...)) - (identifier? #'id) - #'(call-with-control (lambda (id) expr0 expr (... ...)))])) - (define-syntax (control-at stx) - (syntax-case stx () - [(control-at tag id expr0 expr (... ...)) - (identifier? #'id) - #'(call-with-control (lambda (id) expr0 expr (... ...)) tag)])))])) - -(define-control-macros control control-at call-with-control) - -(define-syntax define-prompt-macros - (syntax-rules () - [(_ prompt prompt-at call-with-prompt) - (begin - (define-syntax prompt - (syntax-rules () - [(prompt expr0 expr (... ...)) - (call-with-prompt (lambda () expr0 expr (... ...)))])) - (define-syntax prompt-at - (syntax-rules () - [(prompt-at tag expr0 expr (... ...)) - (call-with-prompt (lambda () expr0 expr (... ...)) tag)])))])) - -(define-prompt-macros prompt prompt-at call-with-continuation-prompt) - -;; ---------------------------------------- -;; Danvy & Filinski, LFP'90 - -;; call-with-shift, parameterized over whether to keep the prompt -;; (if the prompt's handler gives us the option of removing it), -;; and whether the new one is removable: -(define (make-call-with-shift abort-cc inserted-handler) - (letrec ([call-with-shift - (case-lambda - [(f) (call-with-shift f (default-continuation-prompt-tag))] - [(f tag) - (call-with-composable-continuation - (lambda (k) - (abort-cc - tag - (lambda () - (f (lambda vals - (call-with-continuation-prompt - (lambda () - (apply k vals)) - tag - inserted-handler)))))) - tag)])]) - call-with-shift)) - -(define call-with-shift - (make-call-with-shift abort-current-continuation/keep-prompt #f)) - -(define-control-macros shift shift-at call-with-shift) - -(define-prompt-macros reset reset-at call-with-continuation-prompt) - -;; ---------------------------------------- -;; Shan, SCHEME'04 -;; Kiselyov, Indiana CS TR-611, 2005 -;; -;; The `control0' and `shift0' here are closer to Kiselyov, in that -;; `control0' and `shift0' only behave as in Shan when paired with -;; `prompt0' or `reset0' (which are two names for the same thing). -;; When paired with `prompt' or `reset' (again, the same thing), -;; they act like `control' and `shift'. -;; -;; This difference is intentional. The programmer that inserts a -;; prompt should choose whether the current continuation is visible -;; or not. Note, also, that `control' and `shift' work whether -;; they're paired with `prompt'/`reset' or `prompt0'/`reset0'. - -(define call-with-control0 - ;; Uses abort-current-continuation, so that the prompt - ;; is removed --- if the prompt is willing to be removed. - (make-call-with-control abort-current-continuation)) - -(define call-with-shift0 - ;; Uses abort-current-continuation, so that the prompt - ;; is removed --- if the prompt is willing to be removed. - ;; The prompt installed with the captured continuation is - ;; itself willing to be removed. - (make-call-with-shift abort-current-continuation (lambda (thunk) (thunk)))) - -(define-control-macros control0 control0-at call-with-control0) - -(define-control-macros shift0 shift0-at call-with-shift0) - -(define call-with-prompt0 - (case-lambda - [(thunk) (call-with-prompt0 thunk (default-continuation-prompt-tag))] - [(thunk tag) - (call-with-continuation-prompt thunk tag (lambda (thunk) (thunk)))])) - -(define-prompt-macros prompt0 prompt0-at call-with-prompt0) - -(define-prompt-macros reset0 reset0-at call-with-prompt0) - -;; ---------------------------------------- -;; Hieb & Dybvig, PPOPP'90 - -(define (spawn f) - (let ([p (make-continuation-prompt-tag)]) - (call-with-continuation-prompt - (lambda () - (f (lambda (f) - (call-with-composable-continuation - (lambda (k) - (abort-current-continuation - p - (lambda () - (f (lambda vals - (call-with-continuation-prompt - (lambda () - (apply k vals)) - p - (lambda (thunk) (thunk)))))))) - p)))) - p - (lambda (thunk) (thunk))))) - -;; ---------------------------------------- -;; Queinnec & Serpette, POPL'91 - -(define (splitter receiver) - (let ([p (make-continuation-prompt-tag)]) - (call-with-continuation-prompt - (lambda () - (receiver (lambda (thunk) - (abort-current-continuation - p - thunk)) - (lambda (proc) - (call-with-composable-continuation - proc - p)))) - p - (lambda (thunk) (thunk))))) - -;; ---------------------------------------- -;; Gunter, Remy, & Rieke, FPLCA'95 -;; Unfortunately, the "prompt"s in Gunter et al. are what -;; we call "prompt tags". In our terminology, a "prompt" -;; is a tagged instance in a continuation. - -(define (new-prompt) (make-continuation-prompt-tag)) - -(define-syntax set (make-rename-transformer #'prompt0-at)) - -(define-syntax cupto (make-rename-transformer #'control0-at)) - -;; ---------------------------------------- +;; deprecated library, see `racket/control` +(require racket/control) +(provide (all-from-out racket/control)) diff --git a/collects/mzlib/date.rkt b/collects/mzlib/date.rkt index c37deea..558aea2 100644 --- a/collects/mzlib/date.rkt +++ b/collects/mzlib/date.rkt @@ -1,367 +1,6 @@ #lang racket/base -(require racket/promise - racket/match - racket/list - racket/function - racket/contract/base) -(provide/contract - [current-date (-> date?)] - [date->seconds ((date?) (any/c) . ->* . exact-integer?)] - [date->string ((date?) (any/c) . ->* . string?)] - [date-display-format (parameter/c (symbols 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))] - [find-seconds (((integer-in 0 61) - (integer-in 0 59) - (integer-in 0 23) - (integer-in 1 31) - (integer-in 1 12) - exact-nonnegative-integer?) - (any/c) - . ->* . - exact-integer?)] - [date->julian/scalinger (date? . -> . exact-integer?)] - [julian/scalinger->string (exact-integer? . -> . string?)]) +;; deprecated library, see `racket/date` -(define (current-date) - (seconds->date (current-seconds))) - -;; Support for Julian calendar added by Shriram; -;; current version only works until 2099 CE Gregorian - -(define date-display-format - (make-parameter 'american)) - -(define (month/number->string x) - (case x - [(12) "December"] [(1) "January"] [(2) "February"] - [(3) "March"] [(4) "April"] [(5) "May"] - [(6) "June"] [(7) "July"] [(8) "August"] - [(9) "September"] [(10) "October"] [(11) "November"] - [else ""])) - -(define (day/number->string x) - (case x - [(0) "Sunday"] - [(1) "Monday"] - [(2) "Tuesday"] - [(3) "Wednesday"] - [(4) "Thursday"] - [(5) "Friday"] - [(6) "Saturday"] - [else ""])) - -(define (add-zero n) - (if (< n 10) - (string-append "0" (number->string n)) - (number->string n))) - -(define (date->string date [time? #f]) - (define year (number->string (date-year date))) - (define num-month (number->string (date-month date))) - (define week-day (day/number->string (date-week-day date))) - (define week-day-num (date-week-day date)) - (define month (month/number->string (date-month date))) - (define day (number->string (date-day date))) - (define day-th - (if (<= 11 (date-day date) 13) - "th" - (case (modulo (date-day date) 10) - [(1) "st"] - [(2) "nd"] - [(3) "rd"] - [(0 4 5 6 7 8 9) "th"]))) - (define hour (date-hour date)) - (define am-pm (if (>= hour 12) "pm" "am")) - (define hour24 (add-zero hour)) - (define hour12 - (number->string - (cond - [(zero? hour) 12] - [(> hour 12) (- hour 12)] - [else hour]))) - (define minute (add-zero (date-minute date))) - (define second (add-zero (date-second date))) - (define-values - (day-strs time-strs) - (case (date-display-format) - [(american) - (values (list week-day ", " month " " day day-th ", " year) - (list " " hour12 ":" minute ":" second am-pm))] - [(chinese) - (values - (list year "/" num-month "/" day - " \u661F\u671F" (case (date-week-day date) - [(0) "\u5929"] - [(1) "\u4E00"] - [(2) "\u4E8C"] - [(3) "\u4e09"] - [(4) "\u56DB"] - [(5) "\u4E94"] - [(6) "\u516D"] - [else ""])) - (list " " hour24 ":" minute ":" second))] - [(indian) - (values (list day "-" num-month "-" year) - (list " " hour12 ":" minute ":" second am-pm))] - [(german) - (values (list day ". " - (case (date-month date) - [(1) "Januar"] - [(2) "Februar"] - [(3) "M\344rz"] - [(4) "April"] - [(5) "Mai"] - [(6) "Juni"] - [(7) "Juli"] - [(8) "August"] - [(9) "September"] - [(10) "Oktober"] - [(11) "November"] - [(12) "Dezember"] - [else ""]) - " " year) - (list ", " hour24 "." minute))] - [(irish) - (values (list week-day ", " day day-th " " month " " year) - (list ", " hour12 ":" minute am-pm))] - [(julian) - (values (list (julian/scalinger->string - (date->julian/scalinger date))) - (list ", " hour24 ":" minute ":" second))] - [(iso-8601) - (values - (list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date))) - (list " " hour24 ":" minute ":" second))] - [(rfc2822) - (values - (list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year) - (list* " " hour24 ":" minute ":" second " " - (let* ([delta (date-time-zone-offset date)] - [hours (quotient delta 3600)] - [minutes (modulo (quotient delta 60) 60)]) - (list - (if (negative? delta) "-" "+") - (add-zero (abs hours)) - (add-zero minutes)))))] - [else (error 'date->string "unknown date-display-format: ~s" - (date-display-format))])) - (apply string-append - (if time? - (append day-strs time-strs) - day-strs))) - -(define (leap-year? year) - (or (= 0 (modulo year 400)) - (and (= 0 (modulo year 4)) - (not (= 0 (modulo year 100)))))) - -;; it's not clear what months mean in this context -- use days -(define-struct date-offset (second minute hour day year)) - -(define (fixup s x) (if (< s 0) (+ s x) s)) -(define (date- date1 date2) - (define second (- (date-second date1) (date-second date2))) - (define minute - (+ (- (date-minute date1) (date-minute date2)) - (if (< second 0) -1 0))) - (define hour - (+ (- (date-hour date1) (date-hour date2)) - (if (< minute 0) -1 0) - (cond [(equal? (date-dst? date1) (date-dst? date2)) 0] - [(date-dst? date1) -1] - [(date-dst? date2) 1]))) - (define day - (+ (- (date-year-day date1) (date-year-day date2)) - (if (< hour 0) -1 0))) - (define year - (+ (- (date-year date1) (date-year date2)) - (if (< day 0) -1 0))) - (make-date-offset - (fixup second 60) - (fixup minute 60) - (fixup hour 24) - (fixup day (if (leap-year? (date-year date1)) 366 365)) - year)) - -(define (one-entry b) - (string-append - (number->string (first b)) - " " - (second b) - (if (= 1 (first b)) "" "s"))) -(define (date-offset->string date [seconds? #f]) - (define fields - (list (list (date-offset-year date) "year") - (list (date-offset-day date) "day") - (list (date-offset-hour date) "hour") - (list (date-offset-minute date) "minute") - (list (if seconds? (date-offset-second date) 0) "second"))) - (define non-zero-fields - (filter (negate (compose (curry = 0) first)) fields)) - (match non-zero-fields - [(list) ""] - [(list one) (one-entry one)] - [_ - (for/fold ([string ""]) - ([b (in-list non-zero-fields)]) - (cond - [(= 0 (first b)) string] - [(string=? string "") - (string-append "and " - (one-entry b) - string)] - [else (string-append (one-entry b) ", " string)]))])) - -(define (days-per-month year month) - (cond - [(and (= month 2) (leap-year? year)) 29] - [(= month 2) 28] - [(<= month 7) (+ 30 (modulo month 2))] - [else (+ 30 (- 1 (modulo month 2)))])) - -(define (find-extreme-date-seconds start offset) - (let/ec found - (letrec ([find-between - (lambda (lo hi) - (let ([mid (floor (/ (+ lo hi) 2))]) - (if (or (and (positive? offset) (= lo mid)) - (and (negative? offset) (= hi mid))) - (found lo) - (let ([mid-ok? - (with-handlers ([exn:fail? (lambda (exn) #f)]) - (seconds->date mid) - #t)]) - (if mid-ok? - (find-between mid hi) - (find-between lo mid))))))]) - (let loop ([lo start][offset offset]) - (let ([hi (+ lo offset)]) - (with-handlers ([exn:fail? - (lambda (exn) - ; failed - must be between lo & hi - (find-between lo hi))]) - (seconds->date hi)) - ; succeeded; double offset again - (loop hi (* 2 offset))))))) - -(define get-min-seconds - (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))]) - (lambda () - (force d)))) -(define get-max-seconds - (let ([d (delay (find-extreme-date-seconds (current-seconds) 1))]) - (lambda () - (force d)))) - -(define (date->seconds date [local-time? #t]) - (find-seconds - (date-second date) - (date-minute date) - (date-hour date) - (date-day date) - (date-month date) - (date-year date) - local-time?)) - -(define (find-seconds sec min hour day month year [local-time? #t]) - (define (signal-error msg) - (error 'find-secs (string-append - msg - " (inputs: ~a ~a ~a ~a ~a ~a)") - sec min hour day month year)) - (let loop ([below-secs (get-min-seconds)] - [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))] - [above-secs (get-max-seconds)]) - (let* ([date (seconds->date secs local-time?)] - [compare - (let loop ([inputs (list year month day - hour min sec)] - [tests (list (date-year date) - (date-month date) - (date-day date) - (date-hour date) - (date-minute date) - (date-second date))]) - (cond - [(null? inputs) 'equal] - [else (let ([input (car inputs)] - [test (car tests)]) - (if (= input test) - (loop (cdr inputs) (cdr tests)) - (if (<= input test) - 'input-smaller - 'test-smaller)))]))]) - ; (printf "~a ~a ~a\n" compare secs (date->string date)) - (cond - [(eq? compare 'equal) secs] - [(or (= secs below-secs) (= secs above-secs)) - (signal-error "non-existent date")] - [(eq? compare 'input-smaller) - (loop below-secs (floor (/ (+ secs below-secs) 2)) secs)] - [(eq? compare 'test-smaller) - (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)])))) - -;; date->julian/scalinger : -;; date -> number [julian-day] - -;; Note: This code is correct until 2099 CE Gregorian - -(define (date->julian/scalinger date) - (define day (date-day date)) - (define month (date-month date)) - (define d-year (date-year date)) - (define year (+ 4712 d-year)) - (define adj-year (if (< month 3) (sub1 year) year)) - (define cycle-number (quotient adj-year 4)) - (define cycle-position (remainder adj-year 4)) - (define base-day (+ (* 1461 cycle-number) (* 365 cycle-position))) - (define month-day-number - (case month - ((3) 0) - ((4) 31) - ((5) 61) - ((6) 92) - ((7) 122) - ((8) 153) - ((9) 184) - ((10) 214) - ((11) 245) - ((12) 275) - ((1) 306) - ((2) 337))) - (define total-days (+ base-day month-day-number day)) - (define total-days/march-adjustment (+ total-days 59)) - (define gregorian-adjustment - (cond - ((< adj-year 1700) 11) - ((< adj-year 1800) 12) - (else 13))) - (define final-date - (- total-days/march-adjustment - gregorian-adjustment)) - final-date) - -;; julian/scalinger->string : -;; number [julian-day] -> string [julian-day-format] - -(define (julian/scalinger->string julian-day) - (apply string-append - (cons "JD " - (reverse - (let loop ((reversed-digits (map number->string - (let loop ((jd julian-day)) - (if (zero? jd) null - (cons (remainder jd 10) - (loop (quotient jd 10)))))))) - (cond - ((or (null? reversed-digits) - (null? (cdr reversed-digits)) - (null? (cdr (cdr reversed-digits))) - (null? (cdr (cdr (cdr reversed-digits))))) - (list (apply string-append (reverse reversed-digits)))) - (else (cons (apply string-append - (list " " - (caddr reversed-digits) - (cadr reversed-digits) - (car reversed-digits))) - (loop (cdr (cdr (cdr reversed-digits)))))))))))) +(require racket/date) +(provide (all-from-out racket/date)) diff --git a/collects/mzlib/deflate.rkt b/collects/mzlib/deflate.rkt index 9ebc7bc..31d33e2 100644 --- a/collects/mzlib/deflate.rkt +++ b/collects/mzlib/deflate.rkt @@ -1,2242 +1,6 @@ -#| -/* deflate.c -- compress data using the deflation algorithm - * Copyright (C) 1992-1993 Jean-loup Gailly - */ -|# -;; Taken from the gzip source distribution -;; Translated directly from C (obviously) by Matthew, July 2000 +#lang racket/base -;; *** The original version that this code was taken from was -;; distributed with a GPL license, but later the code (later version of -;; it) was also included in zlib, which is distributed with an -;; LGPL-compatible license. I (Eli Barzilay) have tried to contact the -;; author, but no reply yet. +;; deprecated library, see `file/gzip` -(module deflate mzscheme - - (provide deflate gzip-through-ports gzip) - - (require "unit200.rkt") - - (define (vector-ref* v i) - (let ([r (vector-ref v i)]) - (if (<= 0 r 255) r (error 'vector-ref "BOOM: ~s" r)))) - - (define (vector-set!* v i n) - (if (<= 0 n 255) (vector-set! v i n) (error 'vector-ref "BOOM!: ~s" n))) - - (define-syntax INSERT_STRING - (syntax-rules () - [(_ s match_head UPDATE_HASH window-vec head-vec prev-vec ins_h) - (begin (UPDATE_HASH (bytes-ref window-vec (+ s MIN_MATCH-1))) - (let ([mh (vector-ref head-vec (+ ins_h head-vec-delta))]) - (set! match_head mh) - (vector-set! prev-vec (bitwise-and s WMASK) mh)) - (vector-set! head-vec (+ head-vec-delta ins_h) s))])) - - (define-syntax pqremove - (syntax-rules () - [(_ tree top heap heap_len SMALLEST) - (begin (set! top (vector-ref heap SMALLEST)) - (vector-set! heap SMALLEST (vector-ref heap heap_len)) - (set! heap_len (sub1 heap_len)) - (pqdownheap tree SMALLEST))])) - - (define-syntax DEBUG (lambda (stx) #'(void))) - - (define-syntax Assert (lambda (stx) #'(void))) - - (define-syntax for - (syntax-rules (:= then do) - [(for n := start < end do body ...) - (for n := start then add1 < end do body ...)] - [(for n := start then next < end do body ...) - (let ([endval end]) - (let loop ([n start]) - (when (< n endval) body ... (loop (next n)))))])) - - (define-struct gzbytes (bytes offset)) - (define (gzbytes-ref v o) - (bytes-ref (gzbytes-bytes v) (+ (gzbytes-offset v) o))) - (define (gzbytes-set! v o x) - (bytes-set! (gzbytes-bytes v) (+ (gzbytes-offset v) o) x)) - (define (gzbytes+ v o) - (make-gzbytes (gzbytes-bytes v) (+ (gzbytes-offset v) o))) - - (define (Trace stderr str . args) - (apply eprintf str args)) - (define Tracevv Trace) - (define Tracev Trace) - (define (Tracec test . args) - (when test (apply Trace args))) - (define Tracecv Tracec) - (define stderr 'sdterr) - -#| -/* - * PURPOSE - * - * Identify new text as repetitions of old text within a fixed- - * length sliding window trailing behind the new text. - * - * DISCUSSION - * - * The "deflation" process depends on being able to identify portions - * of the input text which are identical to earlier input (within a - * sliding window trailing behind the input currently being processed). - * - * The most straightforward technique turns out to be the fastest for - * most input files: try all possible matches and select the longest. - * The key feature of this algorithm is that insertions into the string - * dictionary are very simple and thus fast, and deletions are avoided - * completely. Insertions are performed at each input character, whereas - * string matches are performed only when the previous match ends. So it - * is preferable to spend more time in matches to allow very fast string - * insertions and avoid deletions. The matching algorithm for small - * strings is inspired from that of Rabin & Karp. A brute force approach - * is used to find longer strings when a small match has been found. - * A similar algorithm is used in comic (by Jan-Mark Wams) and freeze - * (by Leonid Broukhis). - * A previous version of this file used a more sophisticated algorithm - * (by Fiala and Greene) which is guaranteed to run in linear amortized - * time, but has a larger average cost, uses more memory and is patented. - * However the F&G algorithm may be faster for some highly redundant - * files if the parameter max_chain_length (described below) is too large. - * - * ACKNOWLEDGEMENTS - * - * The idea of lazy evaluation of matches is due to Jan-Mark Wams, and - * I found it in 'freeze' written by Leonid Broukhis. - * Thanks to many info-zippers for bug reports and testing. - * - * REFERENCES - * - * APPNOTE.TXT documentation file in PKZIP 1.93a distribution. - * - * A description of the Rabin and Karp algorithm is given in the book - * "Algorithms" by R. Sedgewick, Addison-Wesley, p252. - * - * Fiala,E.R., and Greene,D.H. - * Data Compression with Finite Windows, Comm.ACM, 32,4 (1989) 490-595 - * - * INTERFACE - * - * void lm_init (int pack_level, ush *flags) - * Initialize the "longest match" routines for a new file - * - * ulg deflate (void) - * Processes a new input file and return its compressed length. Sets - * the compressed length, crc, deflate flags and internal file - * attributes. - */ - -|# - - (define LEVEL 6) - - (define OUTBUFSIZ 16384);; /* output buffer size */ - (define INBUFSIZ #x8000);; /* input buffer size */ - (define INBUF_EXTRA 64) - - (define WSIZE #x8000) ;; /* window size--must be a power of two, and */ - ;; /* at least 32K for zip's deflate method */ - - (define MIN_MATCH 3) - (define MIN_MATCH-1 (- MIN_MATCH 1)) - (define MAX_MATCH 258) - ;; /* The minimum and maximum match lengths */ - - (define MIN_LOOKAHEAD (+ MAX_MATCH MIN_MATCH 1)) - ;; /* Minimum amount of lookahead, except at the end of the input file. - ;; * See for comments about the MIN_MATCH+1. - ;; */ - - (define MAX_DIST (- WSIZE MIN_LOOKAHEAD)) - ;; /* In order to simplify the code, particularly on 16 bit machines, match - ;; * distances are limited to MAX_DIST instead of WSIZE. - ;; */ - - (define HASH_BITS 15) - (define BITS 16) - - (define << arithmetic-shift) - (define (>> x y) (arithmetic-shift x (- y))) - (define EOF-const -1) - - ;; /* To save space (see unlzw.c), we overlay prev+head with tab_prefix and - ;; * window with tab_suffix. Check that we can do this: - ;; */ - (Assert - (when (> (<< WSIZE 1) (<< 1 BITS)) - (error "cannot overlay window with tab_suffix and prev with tab_prefix0"))) - (Assert - (when (> HASH_BITS (- BITS 1)) - (error "cannot overlay head with tab_prefix1"))) - - (define HASH_SIZE (<< 1 HASH_BITS)) - (define HASH_MASK (- HASH_SIZE 1)) - (define WMASK (- WSIZE 1)) - ;; /* HASH_SIZE and WSIZE must be powers of two */ - - (define NIL 0) - ;; /* Tail of hash chains */ - - (define FAST 4) - (define SLOW 2) - ;; /* speed options for the general purpose bit flag */ - - (define TOO_FAR 4096) - ;; /* Matches of length 3 are discarded if their distance exceeds TOO_FAR */ - - (define bits_sent 0) - (define (isgraph c) #t) - -(define head-vec-delta WSIZE) - - ;; The gzip code wasn't defined for threads (or even to be - ;; multiply invoked), so we pack it up into a unit to - ;; invoke each time we need it. - - (define code - (unit - (import) - (export) - - -;; /* =========================================================================== -;; * Local data used by the "longest match" routines. -;; */ - -(define real-table (make-vector (<< 1 BITS) 0)) - -(define prev-vec real-table) -(define head-vec real-table) - -;; /* DECLARE(uch, window, 2L*WSIZE); */ -;; /* Sliding window. Input bytes are read into the second half of the window, -;; * and move to the first half later to keep a dictionary of at least WSIZE -;; * bytes. With this organization, matches are limited to a distance of -;; * WSIZE-MAX_MATCH bytes, but this ensures that IO is always -;; * performed with a length multiple of the block size. Also, it limits -;; * the window size to 64K, which is quite useful on MSDOS. -;; * To do: limit the window size to WSIZE+BSZ if SMALL_MEM (the code would -;; * be less efficient). -;; */ - -;; /* DECLARE(Pos, prev, WSIZE); */ -;; /* Link to older string with same hash index. To limit the size of this -;; * array to 64K, this link is maintained only for the last 32K strings. -;; * An index in this array is thus a window index modulo 32K. -;; */ - -;; /* DECLARE(Pos, head, 1<= HASH_BITS -;; */ - -(define prev_length 0) -;; /* Length of the best match at previous step. Matches not greater than this -;; * are discarded. This is used in the lazy match evaluation. -;; */ - -(define strstart 0) ;; /* start of string to insert */ -(define match_start 0) ;; /* start of matching string */ -(define eofile #f) ;; /* flag set at end of input file */ -(define lookahead 0) ;; /* number of valid bytes ahead in window */ - -(define max_chain_length 0) -;; /* To speed up deflation, hash chains are never searched beyond this length. -;; * A higher limit improves compression ratio but degrades the speed. -;; */ - -(define max_lazy_match 0) -;; /* Attempt to find a better match only when the current match is strictly -;; * smaller than this value. This mechanism is used only for compression -;; * levels >= 4. -;; */ - -(define (max_insert_length) max_lazy_match) -;; /* Insert new strings in the hash table only if the match length -;; * is not greater than this length. This saves time but degrades compression. -;; * max_insert_length is used only for compression levels <= 3. -;; */ - -(define good_match 0) -;; /* Use a faster search when the previous match is longer than this */ - - -;; /* Values for max_lazy_match, good_match and max_chain_length, depending on -;; * the desired pack level (0..9). The values given below have been tuned to -;; * exclude worst case performance for pathological files. Better values may be -;; * found for specific files. -;; */ - -(define-struct config - (good_length ;; /* reduce lazy search above this match length */ - max_lazy ;; /* do not perform lazy search above this match length */ - nice_length ;; /* quit search above this match length */ - max_chain)) - -(define nice_match MAX_MATCH) -;; /* Stop searching when current match exceeds this */ - -(define configuration_table - (vector - ;; /* good lazy nice chain */ - (make-config 0 0 0 0) ;; /* 0 - store only */ - (make-config 4 4 8 4) ;; /* 1 - maximum speed, no lazy matches */ - (make-config 4 5 16 8) ;; /* 2 */ - (make-config 4 6 32 32) ;; /* 3 */ - - (make-config 4 4 16 16) ;; /* 4 - lazy matches */ - (make-config 8 16 32 32) ;; /* 5 */ - (make-config 8 16 128 128) ;; /* 6 */ - (make-config 8 32 128 256) ;; /* 7 */ - (make-config 32 128 258 1024) ;; /* 8 */ - (make-config 32 258 258 4096))) ;; /* 9 - maximum compression */ - -;; /* Note: the deflate() code requires max_lazy >= MIN_MATCH and max_chain >= 4 -;; * For deflate_fast() (levels <= 3) good is ignored and lazy has a different -;; * meaning. -;; */ - -;; /* =========================================================================== -;; * Update a hash value with the given input byte -;; * IN assertion: all calls to to UPDATE_HASH are made with consecutive -;; * input characters, so that a running hash key can be computed from the -;; * previous key instead of complete recalculation each time. -;; */ -(define (UPDATE_HASH c) - (set! ins_h (bitwise-and (bitwise-xor (<< ins_h H_SHIFT) c) HASH_MASK))) - -;; /* =========================================================================== -;; * Insert string s in the dictionary and set match_head to the previous head -;; * of the hash chain (the most recent string with same hash key). Return -;; * the previous length of the hash chain. -;; * IN assertion: all calls to to INSERT_STRING are made with consecutive -;; * input characters and the first MIN_MATCH bytes of s are valid -;; * (except for the last MIN_MATCH-1 bytes of the input file). -;; */ -;; (define-macro INSERT_STRING ) - -;; /* =========================================================================== -;; * Initialize the "longest match" routines for a new file -;; */ -(define (lm_init pack_level) - ;; int pack_level; /* 0: store, 1: best speed, 9: best compression */ - - (when (or (< pack_level 1) - (> pack_level 9)) - (error "bad pack level")) - - ;; /* Initialize the hash table. */ - (for i := head-vec-delta < (+ head-vec-delta HASH_SIZE) do - (vector-set! head-vec i 0)) - - ;; /* prev will be initialized on the fly */ - - ;; /* Set the default configuration parameters: - ;; */ - (set! max_lazy_match (config-max_lazy (vector-ref configuration_table pack_level))) - (set! good_match (config-good_length (vector-ref configuration_table pack_level))) - (set! nice_match (config-nice_length (vector-ref configuration_table pack_level))) - (set! max_chain_length (config-max_chain (vector-ref configuration_table pack_level))) - - (let ([flag (cond - [(= pack_level 1) FAST] - [(= pack_level 9) SLOW] - [else 0])]) - ;; /* ??? reduce max_chain_length for binary files */ - - (set! strstart 0) - (set! block_start 0) - - (set! lookahead (read_buf 0 (* 2 WSIZE))) - - (if (or (= lookahead 0) (= lookahead EOF-const)) - (begin - (set! eofile #t) - (set! lookahead 0)) - (begin - (set! eofile #f) - ;; /* Make sure that we always have enough lookahead. This is important - ;; * if input comes from a device such as a tty. - ;; */ - (let loop () - (when (and (< lookahead MIN_LOOKAHEAD) - (not eofile)) - (fill_window))) - - (set! ins_h 0) - (for j := 0 < MIN_MATCH-1 do (UPDATE_HASH (bytes-ref window-vec j))) - (DEBUG (Trace stderr "hash init: ~a\n" ins_h)) - ;; /* If lookahead < MIN_MATCH, ins_h is garbage, but this is - ;; * not important since only literal bytes will be emitted. - ;; */ - )) - - flag)) - -;; /* =========================================================================== -;; * Set match_start to the longest match starting at the given string and -;; * return its length. Matches shorter or equal to prev_length are discarded, -;; * in which case the result is equal to prev_length and match_start is -;; * garbage. -;; * IN assertions: cur_match is the head of the hash chain for the current -;; * string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1 -;; */ - -;; Since longest_match is not called recursively or in multiple threads, we can -;; make this C-derived code have more C-like allocation by lifting out its local -;; variables. - -(define longest_match - (let ((cur_match 0) - (chain_length 0) - (scanpos 0) - (matchpos 0) - (len 0) - (best_len 0) - (limit NIL) - (strendpos 0) - (scan_end1 0) - (scan_end 0)) - - (define (longest_match _cur_match) - ;; IPos cur_match; /* current match */ - - (set! cur_match _cur_match) - - (set! chain_length max_chain_length) ;; /* max hash chain length */ - (set! scanpos strstart) ;; /* current string */ - (set! matchpos 0) ;; /* matched string */ - (set! len 0) ;; /* length of current match */ - (set! best_len prev_length) ;; /* best match length so far */ - (set! limit (if (> strstart MAX_DIST) - (- strstart MAX_DIST) - NIL)) - ;; /* Stop when cur_match becomes <= limit. To simplify the code, - ;; * we prevent matches with the string of window index 0. - ;; */ - - ;; /* The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16. - ;; * It is easy to get rid of this optimization if necessary. - ;; */ - ;; #if HASH_BITS < 8 || MAX_MATCH != 258 - ;; error: Code too clever - ;; #endif - - (set! strendpos (+ strstart MAX_MATCH)) - (set! scan_end1 (bytes-ref window-vec (+ scanpos best_len -1))) - (set! scan_end (bytes-ref window-vec (+ scanpos best_len))) - - ;; /* Do not waste too much time if we already have a good match: */ - (when (>= prev_length good_match) - (set! chain_length (>> chain_length 2))) - - (Assert - (unless (<= strstart (- window_size MIN_LOOKAHEAD)) - (error "insufficient lookahead"))) - - (longest_match-loop) - - best_len) - - (define (continue) - (set! cur_match (vector-ref prev-vec (bitwise-and cur_match WMASK))) - (when (and (> cur_match limit) - (begin - (set! chain_length (sub1 chain_length)) - (positive? chain_length))) - (longest_match-loop))) - (define (*++scan) - (set! scanpos (add1 scanpos)) - (and (scanpos . < . window_size) ; the original C code can read past the end of the buffer - (bytes-ref window-vec scanpos))) - (define (*++match) - (set! matchpos (add1 matchpos)) - (bytes-ref window-vec matchpos)) - - (define (match-eight) - (when (and (eq? (*++scan) (*++match)) (eq? (*++scan) (*++match)) - (eq? (*++scan) (*++match)) (eq? (*++scan) (*++match)) - (eq? (*++scan) (*++match)) (eq? (*++scan) (*++match)) - (eq? (*++scan) (*++match)) (eq? (*++scan) (*++match)) - (< scanpos strendpos)) - (match-eight))) - - (define (longest_match-loop) - - (Assert - (unless (< cur_match strstart) - (error "no future"))) - - (set! matchpos cur_match) - - ;; /* Skip to next match if the match length cannot increase - ;; * or if the match length is less than 2: - ;; */ - - (if (or (not (eq? (bytes-ref window-vec (+ matchpos best_len)) scan_end)) - (not (eq? (bytes-ref window-vec (+ matchpos best_len -1)) scan_end1)) - (not (eq? (bytes-ref window-vec matchpos) (bytes-ref window-vec scanpos))) - (not (eq? (begin (set! matchpos (add1 matchpos)) - (bytes-ref window-vec matchpos)) - (bytes-ref window-vec (add1 scanpos))))) - (continue) - - (begin - ;; /* The check at best_len-1 can be removed because it will be made - ;; * again later. (This heuristic is not always a win.) - ;; * It is not necessary to compare scan[2] and match[2] since they - ;; * are always equal when the other bytes match, given that - ;; * the hash keys are equal and that HASH_BITS >= 8. - ;; */ - (set! scanpos (+ scanpos 2)) - (set! matchpos (+ matchpos 1)) - - ;; /* We check for insufficient lookahead only every 8th comparison; - ;; * the 256th check will be made at strstart+258. - ;; */ - (match-eight) - - (set! len (- MAX_MATCH (- strendpos scanpos))) - (set! scanpos (+ strendpos (- MAX_MATCH))) - (DEBUG (Trace stderr "Match: ~a\n" len)) - - (when (begin - (if (> len best_len) - (begin - (set! match_start cur_match) - (set! best_len len) - (if (>= len nice_match) - #f - (begin - (set! scan_end1 (bytes-ref window-vec (+ scanpos best_len -1))) - (set! scan_end (bytes-ref window-vec (+ scanpos best_len))) - #t))) - #t)) - (continue))))) - longest_match)) - -;; /* =========================================================================== -;; * Check that the match at match_start is indeed a match. -;; */ -;; -(define (check_match start match length) - #t) - -;; /* =========================================================================== -;; * Fill the window when the lookahead becomes insufficient. -;; * Updates strstart and lookahead, and sets eofile if end of input file. -;; * IN assertion: lookahead < MIN_LOOKAHEAD && strstart + lookahead > 0 -;; * OUT assertions: at least one byte has been read, or eofile is set; -;; * file reads are performed for at least two bytes (required for the -;; * translate_eol option). -;; */ -(define (fill_window) - (define more (- window_size lookahead strstart)) - ;; /* Amount of free space at the end of the window. */ - - ;; /* If the window is almost full and there is insufficient lookahead, - ;; * move the upper half to the lower one to make room in the upper half. - ;; */ - (when (>= strstart (+ WSIZE MAX_DIST)) - (let ([bs (gzbytes-bytes window)] [ofs (gzbytes-offset window)]) - (bytes-copy! bs ofs bs (+ ofs WSIZE) (+ ofs WSIZE WSIZE))) - (set! match_start (- match_start WSIZE)) - (set! strstart (- strstart WSIZE)) ;; /* we now have strstart >= MAX_DIST: */ - - (set! block_start (- block_start WSIZE)) - - (for n := 0 < HASH_SIZE do - (let ([m (vector-ref head-vec (+ n head-vec-delta))]) - (vector-set! head-vec (+ n head-vec-delta) - (if (>= m WSIZE) (- m WSIZE) NIL)))) - - (for n := 0 < WSIZE do - (let ([m (vector-ref prev-vec n)]) - (vector-set! prev-vec n - (if (>= m WSIZE) (- m WSIZE) NIL))) - ;; /* If n is not on any hash chain, prev[n] is garbage but - ;; * its value will never be used. - ;; */ - ) - - (set! more (+ more WSIZE))) - - (when (not eofile) - (let ([n (read_buf (+ strstart lookahead) more)]) - (if (or (= n 0) (= n EOF-const)) - (set! eofile #t) - (set! lookahead (+ lookahead n)))))) - -;; /* =========================================================================== -;; * Flush the current block, with given end-of-file flag. -;; * IN assertion: strstart is set to the end of the current match. -;; */ -(define (FLUSH-BLOCK eof) - (flush_block (and (>= block_start 0) (gzbytes+ window block_start)) - (- strstart block_start) - eof)) - -;; /* =========================================================================== -;; * Same as above, but achieves better compression. We use a lazy -;; * evaluation for matches: a match is finally adopted only if there is -;; * no better match at the next window position. -;; */ -(define (do-deflate) - (define hash_head 0) ;; /* head of hash chain */ - (define prev_match 0) ;; /* previous match */ - (define flush #f) ;; /* set if current block must be flushed */ - (define match_available #f) ;; /* set if previous match exists */ - (define match_length MIN_MATCH-1) ;; /* length of best match */ - - ;; /* Process the input block. */ - (let dloop () - (when (not (zero? lookahead)) - (DEBUG (Trace stderr - "prep ~a ~a ~a ~a ~a ~a ~a ~a ~a ~a\n" hash_head prev_length match_length max_lazy_match strstart - ins_h (+ strstart MIN_MATCH-1) (bytes-ref window-vec (+ strstart MIN_MATCH-1)) - H_SHIFT HASH_MASK)) - - ;; /* Insert the string window[strstart .. strstart+2] in the - ;; * dictionary, and set hash_head to the head of the hash chain: - ;; */ - (INSERT_STRING strstart hash_head UPDATE_HASH window-vec head-vec prev-vec ins_h) - - (DEBUG (Trace stderr - "inh ~a ~a ~a ~a ~a ~a ~a\n" hash_head prev_length match_length max_lazy_match strstart - ins_h (bytes-ref window-vec (+ strstart MIN_MATCH-1)))) - - ;; /* Find the longest match, discarding those <= prev_length. - ;; */ - (set! prev_length match_length) - (set! prev_match match_start) - (set! match_length MIN_MATCH-1) - - (when (and (not (= hash_head NIL)) - (< prev_length max_lazy_match) - (<= (- strstart hash_head) MAX_DIST)) - ;; /* To simplify the code, we prevent matches with the string - ;; * of window index 0 (in particular we have to avoid a match - ;; * of the string with itself at the start of the input file). - ;; */ - (set! match_length (longest_match hash_head)) - (DEBUG (Trace stderr "blip ~a\n" match_length)) - ;; /* longest_match() sets match_start */ - (when (> match_length lookahead) - (set! match_length lookahead)) - - ;; /* Ignore a length 3 match if it is too distant: */ - (when (and (= match_length MIN_MATCH) - (> (- strstart match_start) TOO_FAR)) - ;; /* If prev_match is also MIN_MATCH, match_start is garbage - ;; * but we will ignore the current match anyway. - ;; */ - (set! match_length (sub1 match_length)))) - - ;; /* If there was a match at the previous step and the current - ;; * match is not better, output the previous match: - ;; */ - (cond - [(and (>= prev_length MIN_MATCH) - (<= match_length prev_length)) - (DEBUG (Trace stderr "x1\n")) - - (check_match (- strstart 1) prev_match prev_length) - - (set! flush (ct_tally (- strstart 1 prev_match) - (- prev_length MIN_MATCH))) - - ;; /* Insert in hash table all strings up to the end of the match. - ;; * strstart-1 and strstart are already inserted. - ;; */ - (set! lookahead (- lookahead (- prev_length 1))) - (set! prev_length (- prev_length 2)) - (let loop () - (set! strstart (add1 strstart)) - (INSERT_STRING strstart hash_head UPDATE_HASH window-vec head-vec prev-vec ins_h) - (DEBUG (Trace stderr - "inhx ~a ~a ~a ~a ~a ~a\n" hash_head prev_length max_lazy_match strstart - ins_h (bytes-ref window-vec (+ strstart MIN_MATCH -1)))) - ;; /* strstart never exceeds WSIZE-MAX_MATCH, so there are - ;; * always MIN_MATCH bytes ahead. If lookahead < MIN_MATCH - ;; * these bytes are garbage, but it does not matter since the - ;; * next lookahead bytes will always be emitted as literals. - ;; */ - (set! prev_length (sub1 prev_length)) - (when (not (= prev_length 0)) - (loop))) - (set! match_available #f) - (set! match_length MIN_MATCH-1) - (set! strstart (add1 strstart)) - (when flush - (DEBUG (Trace stderr "flush\n")) - (FLUSH-BLOCK 0) - (DEBUG (Trace stderr "flush done\n")) - (set! block_start strstart))] - - [match_available - (DEBUG (Trace stderr "x2\n")) - ;; /* If there was no match at the previous position, output a - ;; * single literal. If there was a match but the current match - ;; * is longer, truncate the previous match to a single literal. - ;; */ - ;; (Tracevv stderr "~c" (integer->char (vector-ref window-vec (- strstart 1)))) - (when (ct_tally 0 (bytes-ref window-vec (- strstart 1))) - (FLUSH-BLOCK 0) - (set! block_start strstart)) - (set! strstart (add1 strstart)) - (set! lookahead (sub1 lookahead))] - - [else - (DEBUG (Trace stderr "x3\n")) - ;; /* There is no previous match to compare with, wait for - ;; * the next step to decide. - ;; */ - (set! match_available #t) - (set! strstart (add1 strstart)) - (set! lookahead (sub1 lookahead))]) - - (Assert - (unless (and (<= strstart bytes_in) - (<= lookahead bytes_in)) - (error "a bit too far"))) - - ;; /* Make sure that we always have enough lookahead, except - ;; * at the end of the input file. We need MAX_MATCH bytes - ;; * for the next match, plus MIN_MATCH bytes to insert the - ;; * string following the next match. - ;; */ - (let loop () - (when (and (< lookahead MIN_LOOKAHEAD) - (not eofile)) - (DEBUG (Trace stderr "fill\n")) - (fill_window) - (loop))) - - (dloop))) - - (when match_available - (ct_tally 0 (bytes-ref window-vec (- strstart 1)))) - - (FLUSH-BLOCK 1)); /* eof */ - -#| -/* trees.c -- output deflated data using Huffman coding - * Copyright (C) 1992-1993 Jean-loup Gailly - * This is free software; you can redistribute it and/or modify it under the - * terms of the GNU General Public License, see the file COPYING. - */ - -/* - * PURPOSE - * - * Encode various sets of source values using variable-length - * binary code trees. - * - * DISCUSSION - * - * The PKZIP "deflation" process uses several Huffman trees. The more - * common source values are represented by shorter bit sequences. - * - * Each code tree is stored in the ZIP file in a compressed form - * which is itself a Huffman encoding of the lengths of - * all the code strings (in ascending order by source values). - * The actual code strings are reconstructed from the lengths in - * the UNZIP process, as described in the "application note" - * (APPNOTE.TXT) distributed as part of PKWARE's PKZIP program. - * - * REFERENCES - * - * Lynch, Thomas J. - * Data Compression: Techniques and Applications, pp. 53-55. - * Lifetime Learning Publications, 1985. ISBN 0-534-03418-7. - * - * Storer, James A. - * Data Compression: Methods and Theory, pp. 49-50. - * Computer Science Press, 1988. ISBN 0-7167-8156-5. - * - * Sedgewick, R. - * Algorithms, p290. - * Addison-Wesley, 1983. ISBN 0-201-06672-6. - * - * INTERFACE - * - * void ct_init (ush *attr, int *methodp) - * Allocate the match buffer, initialize the various tables and save - * the location of the internal file attribute (ascii/binary) and - * method (DEFLATE/STORE) - * - * void ct_tally (int dist, int lc); - * Save the match info and tally the frequency counts. - * - * long flush_block (char *buf, ulg stored_len, int eof) - * Determine the best encoding for the current block: dynamic trees, - * static trees or store, and output the encoded block to the zip - * file. Returns the total compressed length for the file so far. - * - */ - -|# - -;; /* =========================================================================== -;; * Constants -;; */ - -(define MAX_BITS 15) -;; /* All codes must not exceed MAX_BITS bits */ - -(define MAX_BL_BITS 7) -;; /* Bit length codes must not exceed MAX_BL_BITS bits */ - -(define LENGTH_CODES 29) -;; /* number of length codes, not counting the special END_BLOCK code */ - -(define LITERALS 256) -;; /* number of literal bytes 0..255 */ - -(define END_BLOCK 256) -;; /* end of block literal code */ - -(define L_CODES (+ LITERALS 1 LENGTH_CODES)) -;; /* number of Literal or Length codes, including the END_BLOCK code */ - -(define D_CODES 30) -;; /* number of distance codes */ - -(define BL_CODES 19) -;; /* number of codes used to transfer the bit lengths */ - -(define extra_lbits ;; /* extra bits for each length code */ - (vector 0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0)) - -(define extra_dbits ;; /* extra bits for each distance code */ - (vector 0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13)) - -(define extra_blbits ;; /* extra bits for each bit length code */ - (vector 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 3 7)) - -(define STORED_BLOCK 0) -(define STATIC_TREES 1) -(define DYN_TREES 2) -;; /* The three kinds of block type */ - -(define LIT_BUFSIZE #x8000) -(define DIST_BUFSIZE #x8000) -;; /* Sizes of match buffers for literals/lengths and distances. There are -;; * 4 reasons for limiting LIT_BUFSIZE to 64K: -;; * - frequencies can be kept in 16 bit counters -;; * - if compression is not successful for the first block, all input data is -;; * still in the window so we can still emit a stored block even when input -;; * comes from standard input. (This can also be done for all blocks if -;; * LIT_BUFSIZE is not greater than 32K.) -;; * - if compression is not successful for a file smaller than 64K, we can -;; * even emit a stored file instead of a stored block (saving 5 bytes). -;; * - creating new Huffman trees less frequently may not provide fast -;; * adaptation to changes in the input data statistics. (Take for -;; * example a binary file with poorly compressible code followed by -;; * a highly compressible string table.) Smaller buffer sizes give -;; * fast adaptation but have of course the overhead of transmitting trees -;; * more frequently. -;; * - I can't count above 4 -;; * The current code is general and allows DIST_BUFSIZE < LIT_BUFSIZE (to save -;; * memory at the expense of compression). Some optimizations would be possible -;; * if we rely on DIST_BUFSIZE == LIT_BUFSIZE. -;; */ -(when (> LIT_BUFSIZE INBUFSIZ) - (error "cannot overlay l_buf and inbuf")) - -(define REP_3_6 16) -;; /* repeat previous bit length 3-6 times (2 bits of repeat count) */ - -(define REPZ_3_10 17) -;; /* repeat a zero length 3-10 times (3 bits of repeat count) */ - -(define REPZ_11_138 18) -;; /* repeat a zero length 11-138 times (7 bits of repeat count) */ - -;; /* =========================================================================== -;; * Local data -;; */ - -;; /* Data structure describing a single value and its code string. */ -(define-struct ct_data (freq code dad len)) -;; union { -;; ush freq; ;; /* frequency count */ -;; ush code; ;; /* bit string */ -;; } fc; -;; union { -;; ush dad; ;; /* father node in Huffman tree */ -;; ush len; ;; /* length of bit string */ -;; } dl; -#| -(define ct_data-freq ct_data-freq/code) -(define ct_data-code ct_data-freq/code) -(define ct_data-dad ct_data-dad/len) -(define ct_data-len ct_data-dad/len) -(define set-ct_data-freq! set-ct_data-freq/code!) -(define set-ct_data-code! set-ct_data-freq/code!) -(define set-ct_data-dad! set-ct_data-dad/len!) -(define set-ct_data-len! set-ct_data-dad/len!) -(define (_make-ct_data f c d l) (make-ct_data (or f c) (or d l))) -|# -(define _make-ct_data make-ct_data) - -(define HEAP_SIZE (+ (* 2 L_CODES) 1)) -;; /* maximum heap size */ - -(define dyn_ltree (make-vector HEAP_SIZE 'uninit-dl)) ;; /* literal and length tree */ -(define dyn_dtree (make-vector (+ (* 2 D_CODES) 1) 'uninit-dd)) ;; /* distance tree */ - -(define static_ltree (make-vector (+ L_CODES 2) 'uninit-sl)) -;; /* The static literal tree. Since the bit lengths are imposed, there is no -;; * need for the L_CODES extra codes used during heap construction. However -;; * The codes 286 and 287 are needed to build a canonical tree (see ct_init -;; * below). -;; */ - -(define static_dtree (make-vector D_CODES 'uninit-sd)) -;; /* The static distance tree. (Actually a trivial tree since all codes use -;; * 5 bits.) -;; */ - -(define bl_tree (make-vector (+ (* 2 BL_CODES) 1) 'uninit-dl)) -;; /* Huffman tree for the bit lengths */ - -(define-struct tree_desc - (dyn_tree; ;; /* the dynamic tree */ - static_tree; ;; /* corresponding static tree or NULL */ - extra_bits; ;; /* extra bits for each code or NULL */ - extra_base; ;; /* base index for extra_bits */ - elems; ;; /* max number of elements in the tree */ - max_length; ;; /* max bit length for the codes */ - max_code)); ;; /* largest code with non zero frequency */ - -(define l_desc (make-tree_desc - dyn_ltree static_ltree extra_lbits - (+ LITERALS 1) L_CODES MAX_BITS 0)) - -(define d_desc (make-tree_desc - dyn_dtree static_dtree extra_dbits - 0 D_CODES MAX_BITS 0)) - -(define bl_desc (make-tree_desc - bl_tree #f extra_blbits - 0 BL_CODES MAX_BL_BITS 0)) - - -(define bl_count (make-vector (+ MAX_BITS 1) 0)) -;; /* number of codes at each bit length for an optimal tree */ - -(define bl_order - (vector 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15)) -;; /* The lengths of the bit length codes are sent in order of decreasing -;; * probability, to avoid transmitting the lengths for unused bit length codes. -;; */ - -(define heap (make-vector (+ (* 2 L_CODES) 1) 0)) ;; /* heap used to build the Huffman trees */ -(define heap_len 0) ;; /* number of elements in the heap */ -(define heap_max 0) ;; /* element of largest frequency */ -;; /* The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used. -;; * The same heap array is used to build all trees. -;; */ - -(define depth (make-vector (+ (* 2 L_CODES) 1) 0)) -;; /* Depth of each subtree used as tie breaker for trees of equal frequency */ - -(define length_code (make-vector (- MAX_MATCH MIN_MATCH -1) 0)) -;; /* length code for each normalized match length (0 == MIN_MATCH) */ - -(define dist_code (make-vector 512 0)) -;; /* distance codes. The first 256 values correspond to the distances -;; * 3 .. 258, the last 256 values correspond to the top 8 bits of -;; * the 15 bit distances. -;; */ - -(define base_length (make-vector LENGTH_CODES 0)) -;; /* First normalized length for each code (0 = MIN_MATCH) */ - -(define base_dist (make-vector D_CODES 0)) -;; /* First normalized distance for each code (0 = distance of 1) */ - -(define inbuf (make-bytes (+ INBUFSIZ INBUF_EXTRA) 0)) -(define l_buf inbuf) -;; /* DECLARE(uch, l_buf, LIT_BUFSIZE); buffer for literals or lengths */ - -(define d_buf (make-vector DIST_BUFSIZE 0)) -;; /* DECLARE(ush, d_buf, DIST_BUFSIZE); buffer for distances */ - -(define flag_buf (make-vector (/ LIT_BUFSIZE 8) 0)) -;; /* flag_buf is a bit array distinguishing literals from lengths in -;; * l_buf, thus indicating the presence or absence of a distance. -;; */ - -(define last_lit 0) ;; /* running index in l_buf */ -(define last_dist 0) ;; /* running index in d_buf */ -(define last_flags 0) ;; /* running index in flag_buf */ -(define flags 0) ;; /* current flags not yet saved in flag_buf */ -(define flag_bit 0) ;; /* current bit used in flags */ -;; /* bits are filled in flags starting at bit 0 (least significant). -;; * Note: these flags are overkill in the current code since we don't -;; * take advantage of DIST_BUFSIZE == LIT_BUFSIZE. -;; */ - -(define opt_len 0); ;; /* bit length of current block with optimal trees */ -(define static_len 0); ;; /* bit length of current block with static trees */ - -(define compressed_len 0); ;; /* total bit length of compressed file */ - -(define input_len 0); ;; /* total byte length of input file */ -;; /* input_len is for debugging only since we can get it by other means. */ - -;; (define block_start 0); ;; /* window offset of current block */ -;; (define strstart 0); ;; /* window offset of current string */ - -(define (send_code c tree) - (send_bits (ct_data-code (vector-ref tree c)) - (ct_data-len (vector-ref tree c)))) -;; /* Send a code of the given tree. c and tree must not have side effects */ - -(define (d_code dist) - (if (< dist 256) - (vector-ref dist_code dist) - (vector-ref dist_code (+ 256 (>> dist 7))))) -;; /* Mapping from a distance to a distance code. dist is the distance - 1 and -;; * must not have side effects. dist_code[256] and dist_code[257] are never -;; * used. -;; */ - -;; /* =========================================================================== -;; * Allocate the match buffer, initialize the various tables and save the -;; * location of the internal file attribute (ascii/binary) and method -;; * (DEFLATE/STORE). -;; */ -(define (ct_init) - - (define length 0) ;; /* length value */ - (define dist 0) ;; /* distance index */ - - (set! compressed_len 0) - (set! input_len 0) - - (unless (ct_data? (vector-ref static_dtree 0)) ;; /* ct_init already called? */ - ;; /* Initialize the mapping length (0..255) -> length code (0..28) */ - (set! length 0) - (for code := 0 < (- LENGTH_CODES 1) do - (vector-set! base_length code length) - (for n := 0 < (<< 1 (vector-ref extra_lbits code)) do - (vector-set! length_code length code) - (set! length (add1 length)))) - - (Assert - (unless (= length 256) - (error "ct_init: length != 256"))) - - ;; /* Note that the length 255 (match length 258) can be represented - ;; * in two different ways: code 284 + 5 bits or code 285, so we - ;; * overwrite length_code[255] to use the best encoding: - ;; */ - (vector-set! length_code (- length 1) (- LENGTH_CODES 1)) - - ;; /* Initialize the mapping dist (0..32K) -> dist code (0..29) */ - (set! dist 0) - (for code := 0 < 16 do - (vector-set! base_dist code dist) - (for n := 0 < (<< 1 (vector-ref extra_dbits code)) do - (vector-set! dist_code dist code) - (set! dist (add1 dist)))) - - (Assert - (unless (= dist 256) - (error "ct_init: dist != 256"))) - (set! dist (>> dist 7)) ;; /* from now on, all distances are divided by 128 */ - (for code := 16 < D_CODES do - (vector-set! base_dist code (<< dist 7)) - (for n := 0 < (<< 1 (- (vector-ref extra_dbits code) 7)) do - (vector-set! dist_code (+ 256 dist) code) - (set! dist (add1 dist)))) - - (Assert - (unless (= dist 256) - (error "ct_init: 256+dist != 512"))) - - ;; /* Construct the codes of the static literal tree */ - (for bits := 0 <= MAX_BITS do - (vector-set! bl_count bits 0)) - - (let ([init-ltree - (lambda (s e v) - (for n := s <= e do - (vector-set! static_ltree n (_make-ct_data #f 0 #f v)) - (vector-set! bl_count v (add1 (vector-ref bl_count v)))))]) - (init-ltree 0 143 8) - (init-ltree 144 255 9) - (init-ltree 256 279 7) - (init-ltree 280 287 8)) - ;; /* Codes 286 and 287 do not exist, but we must include them in the - ;; * tree construction to get a canonical Huffman tree (longest code - ;; * all ones) - ;; */ - (gen_codes static_ltree (+ L_CODES 1)) - - ;; /* The static distance tree is trivial: */ - (for n := 0 < D_CODES do - (vector-set! static_dtree n - (_make-ct_data #f (bi_reverse n 5) #f 5))) - - ;; /* Initialize the first block of the first file: */ - (init_block))) - -;; /* =========================================================================== -;; * Initialize a new block. -;; */ -(define inited-once? #f) -(define (init_block) - (for n := 0 < (if inited-once? L_CODES HEAP_SIZE) do - (vector-set! dyn_ltree n (_make-ct_data 0 #f 0 #f))) - (for n := 0 < (if inited-once? D_CODES (+ (* 2 D_CODES) 1)) do - (vector-set! dyn_dtree n (_make-ct_data 0 #f 0 #f))) - (for n := 0 < (if inited-once? BL_CODES (+ (* 2 BL_CODES) 1)) do - (vector-set! bl_tree n (_make-ct_data 0 #f 0 #f))) - - (set! inited-once? #t) - - (set-ct_data-freq! (vector-ref dyn_ltree END_BLOCK) 1) - (set! opt_len 0) - (set! static_len 0) - (set! last_lit 0) - (set! last_dist 0) - (set! last_flags 0) - (set! flags 0) - (set! flag_bit 1)) - -(define SMALLEST 1) -;; /* Index within the heap array of least frequent node in the Huffman tree */ - - -;; /* =========================================================================== -;; * Remove the smallest element from the heap and recreate the heap with -;; * one less element. Updates heap and heap_len. -;; */ -;; (define-macro pqremove ) - -;; /* =========================================================================== -;; * Compares to subtrees, using the tree depth as tie breaker when -;; * the subtrees have equal frequency. This minimizes the worst case length. -;; */ -(define (smaller tree n m) - (or (< (ct_data-freq (vector-ref tree n)) (ct_data-freq (vector-ref tree m))) - (and (= (ct_data-freq (vector-ref tree n)) (ct_data-freq (vector-ref tree m))) - (<= (vector-ref depth n) (vector-ref depth m))))) - -;; /* =========================================================================== -;; * Restore the heap property by moving down the tree starting at node k, -;; * exchanging a node with the smallest of its two sons if necessary, stopping -;; * when the heap property is re-established (each father smaller than its -;; * two sons). -;; */ -(define (pqdownheap tree k) - ;; ct_data near *tree; /* the tree to restore */ - ;; int k; /* node to move down */ - - (define v (vector-ref heap k)) - (define j (<< k 1)) ;; /* left son of k */ - (let loop ([k k][j j]) - (if (<= j heap_len) - ;; /* Set j to the smallest of the two sons: */ - (let ([j (if (and (< j heap_len) - (smaller tree - (vector-ref heap (+ j 1)) - (vector-ref heap j))) - (add1 j) - j)]) - ;; /* Exit if v is smaller than both sons */ - (if (smaller tree v (vector-ref heap j)) - (vector-set! heap k v) - (begin - ;; /* Exchange v with the smallest son */ - (vector-set! heap k (vector-ref heap j)) - ;; /* And continue down the tree, setting j to the left son of k */ - (loop j (<< j 1))))) - (vector-set! heap k v)))) - -;; /* =========================================================================== -;; * Compute the optimal bit lengths for a tree and update the total bit length -;; * for the current block. -;; * IN assertion: the fields freq and dad are set, heap[heap_max] and -;; * above are the tree nodes sorted by increasing frequency. -;; * OUT assertions: the field len is set to the optimal bit length, the -;; * array bl_count contains the frequencies for each bit length. -;; * The length opt_len is updated; static_len is also updated if stree is -;; * not null. -;; */ -(define (gen_bitlen desc) - ;; tree_desc near *desc; ;; /* the tree descriptor */ - - (define tree (tree_desc-dyn_tree desc)) - (define extra (tree_desc-extra_bits desc)) - (define base (tree_desc-extra_base desc)) - (define max_code (tree_desc-max_code desc)) - (define max_length (tree_desc-max_length desc)) - (define stree (tree_desc-static_tree desc)) - (define n 0) (define m 0) ;; /* iterate over the tree elements */ - (define bits 0) ;; /* bit length */ - (define xbits 0) ;; /* extra bits */ - (define f 0); ;; /* frequency */ - (define overflow 0); ;; /* number of elements with bit length too large */ - (define h 0) - - (for bits := 0 <= MAX_BITS do - (vector-set! bl_count bits 0)) - - ;; /* In a first pass, compute the optimal bit lengths (which may - ;; * overflow in the case of the bit length tree). - ;; */ - (set-ct_data-len! (vector-ref tree (vector-ref heap heap_max)) 0) ;; /* root of the heap */ - - (for h := (+ 1 heap_max) < HEAP_SIZE do - (set! n (vector-ref heap h)) - (set! bits (+ (ct_data-len (vector-ref tree (ct_data-dad (vector-ref tree n)))) 1)) - (when (> bits max_length) - (set! bits max_length) - (set! overflow (add1 overflow))) - (set-ct_data-len! (vector-ref tree n) bits) - ;; /* We overwrite tree[n].Dad which is no longer needed */ - (unless (> n max_code) - ;; /* leaf node */ - (vector-set! bl_count bits (add1 (vector-ref bl_count bits))) - (set! xbits 0) - (when (>= n base) - (set! xbits (vector-ref extra (- n base)))) - (set! f (ct_data-freq (vector-ref tree n))) - (set! opt_len (+ opt_len (* f (+ bits xbits)))) - (when stree - (set! static_len - (+ static_len - (* f (+ (ct_data-len (vector-ref stree n)) xbits))))))) - - (unless (= overflow 0) - - (DEBUG (Trace stderr "\nbit length overflow\n")) - ;; /* This happens for example on obj2 and pic of the Calgary corpus */ - - ;; /* Find the first bit length which could increase: */ - (let loop () - (set! bits (- max_length 1)) - (let loop () - (when (= (vector-ref bl_count bits) 0) - (set! bits (sub1 bits)) - (loop))) - (vector-set! bl_count bits (sub1 (vector-ref bl_count bits))) - (vector-set! bl_count (+ bits 1) (+ (vector-ref bl_count (+ bits 1)) 2)) - (vector-set! bl_count max_length (sub1 (vector-ref bl_count max_length))) - ;; /* The brother of the overflow item also moves one step up, - ;; * but this does not affect bl_count[max_length] - ;; */ - (set! overflow (- overflow 2)) - (when (> overflow 0) - (loop))) - - (set! h HEAP_SIZE) - ;; /* Now recompute all bit lengths, scanning in increasing frequency. - ;; * h is still equal to HEAP_SIZE. (It is simpler to reconstruct all - ;; * lengths instead of fixing only the wrong ones. This idea is taken - ;; * from 'ar' written by Haruhiko Okumura.) - ;; */ - (for bits := max_length then sub1 > 0 do - (set! n (vector-ref bl_count bits)) - (let loop () - (when (not (= n 0)) - (set! h (sub1 h)) - (set! m (vector-ref heap h)) - (if (> m max_code) - (loop) - (begin - (when (not (= (ct_data-len (vector-ref tree m)) bits)) - (set! opt_len - (+ opt_len (* (- bits (ct_data-len (vector-ref tree m))) - (ct_data-freq (vector-ref tree m)))))) - (set-ct_data-len! (vector-ref tree m) bits) - (set! n (sub1 n)) - (loop)))))))) - -;; /* =========================================================================== -;; * Generate the codes for a given tree and bit counts (which need not be -;; * optimal). -;; * IN assertion: the array bl_count contains the bit length statistics for -;; * the given tree and the field len is set for all tree elements. -;; * OUT assertion: the field code is set for all tree elements of non -;; * zero code length. -;; */ -(define (gen_codes tree max_code) - ;; ct_data near *tree; /* the tree to decorate */ - ;; int max_code; /* largest code with non zero frequency */ - - (define next_code (make-vector (+ MAX_BITS 1) 0)) ;; /* next code value for each bit length */ - (define code 0) ;; /* running code value */ - (define bits 0) ;; /* bit index */ - - ;; /* The distribution counts are first used to generate the code values - ;; * without bit reversal. - ;; */ - (for bits := 1 <= MAX_BITS do - (set! code (<< (+ code (vector-ref bl_count (- bits 1))) 1)) - (vector-set! next_code bits code)) - ;; /* Check that the bit counts in bl_count are consistent. The last code - ;; * must be all ones. - ;; */ - (Assert - (unless (= (+ code (vector-ref bl_count MAX_BITS)-1) - (- (<< 1 MAX_BITS) 1)) - "inconsistent bit counts")) - (DEBUG (Tracev stderr "\ngen_codes: max_code ~a " max_code)) - - (for n := 0 <= max_code do - (let ([len (ct_data-len (vector-ref tree n))]) - (unless (= len 0) - ;; /* Now reverse the bits */ - (let ([nc (vector-ref next_code len)]) - (set-ct_data-code! (vector-ref tree n) (bi_reverse nc len)) - (vector-set! next_code len (add1 nc))) - - (DEBUG (Tracec (not (eq? tree static_ltree)) - stderr - "\nn ~a ~c l ~a c ~x (~x) " - n #\space len - (or (ct_data-code (vector-ref tree n)) 0) - (or (- (vector-ref next_code len) 1) 0))))))) - -;; /* =========================================================================== -;; * Construct one Huffman tree and assigns the code bit strings and lengths. -;; * Update the total bit length for the current block. -;; * IN assertion: the field freq is set for all tree elements. -;; * OUT assertions: the fields len and code are set to the optimal bit length -;; * and corresponding code. The length opt_len is updated; static_len is -;; * also updated if stree is not null. The field max_code is set. -;; */ -(define (build_tree desc) - ;; tree_desc near *desc; ;; /* the tree descriptor */ - - (define tree (tree_desc-dyn_tree desc)) - (define stree (tree_desc-static_tree desc)) - (define elems (tree_desc-elems desc)) - (define n 0) (define m 0) ;; /* iterate over heap elements */ - (define max_code -1) ;; /* largest code with non zero frequency */ - (define node elems) ;; /* next internal node of the tree */ - - ;; /* Construct the initial heap, with least frequent element in - ;; * heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1]. - ;; * heap[0] is not used. - ;; */ - (set! heap_len 0) - (set! heap_max HEAP_SIZE) - - (for n := 0 < elems do - (DEBUG (Trace stderr "freq: ~a ~a\n" n (ct_data-freq (vector-ref tree n)))) - (if (not (= (ct_data-freq (vector-ref tree n)) 0)) - (begin (set! heap_len (add1 heap_len)) - (set! max_code n) - (vector-set! heap heap_len n) - (vector-set! depth n 0)) - (set-ct_data-len! (vector-ref tree n) 0))) - - (DEBUG (Trace stderr "Building: ~a ~a ~a\n" elems heap_len max_code)) - - ;; /* The pkzip format requires that at least one distance code exists, - ;; * and that at least one bit should be sent even if there is only one - ;; * possible code. So to avoid special checks later on we force at least - ;; * two codes of non zero frequency. - ;; */ - (let loop () - (when (< heap_len 2) - (let ([new (if (< max_code 2) - (begin - (set! max_code (add1 max_code)) - max_code) - 0)]) - (set! heap_len (add1 heap_len)) - (vector-set! heap heap_len new) - (set-ct_data-freq! (vector-ref tree new) 1) - (vector-set! depth new 0) - (set! opt_len (sub1 opt_len)) - (when stree - (set! static_len (- static_len (ct_data-len (vector-ref stree new))))) - ;; /* new is 0 or 1 so it does not have extra bits */ - (loop)))) - - (set-tree_desc-max_code! desc max_code) - - ;; /* The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree, - ;; * establish sub-heaps of increasing lengths: - ;; */ - (for n := (quotient heap_len 2) then sub1 >= 1 do (pqdownheap tree n)) - - ;; /* Construct the Huffman tree by repeatedly combining the least two - ;; * frequent nodes. - ;; */ - (let loop () - ;; /* n = node of least frequency */ - (set! n (vector-ref heap SMALLEST)) - (vector-set! heap SMALLEST (vector-ref heap heap_len)) - (set! heap_len (sub1 heap_len)) - (pqdownheap tree SMALLEST) - - (set! m (vector-ref heap SMALLEST)) ;; /* m = node of next least frequency */ - - (set! heap_max (sub1 heap_max)) - (vector-set! heap heap_max n) ;; /* keep the nodes sorted by frequency */ - (set! heap_max (sub1 heap_max)) - (vector-set! heap heap_max m) - - ;; /* Create a new node father of n and m */ - (set-ct_data-freq! (vector-ref tree node) - (+ (ct_data-freq (vector-ref tree n)) - (ct_data-freq (vector-ref tree m)))) - (vector-set! depth node (+ (max (vector-ref depth n) - (vector-ref depth m)) - 1)) - (set-ct_data-dad! (vector-ref tree n) node) - (set-ct_data-dad! (vector-ref tree m) node) - - ;; /* and insert the new node in the heap */ - (vector-set! heap SMALLEST node) - (set! node (add1 node)) - (pqdownheap tree SMALLEST) - - (when (>= heap_len 2) - (loop))) - - (set! heap_max (sub1 heap_max)) - (vector-set! heap heap_max (vector-ref heap SMALLEST)) - - ;; /* At this point, the fields freq and dad are set. We can now - ;; * generate the bit lengths. - ;; */ - (gen_bitlen desc) - - (DEBUG (Trace stderr "Build: ~a\n" max_code)) - ;; /* The field len is now set, we can generate the bit codes */ - (gen_codes tree max_code)) - -;; /* =========================================================================== -;; * Scan a literal or distance tree to determine the frequencies of the codes -;; * in the bit length tree. Updates opt_len to take into account the repeat -;; * counts. (The contribution of the bit length codes will be added later -;; * during the construction of bl_tree.) -;; */ -(define (scan_tree tree max_code) - ;; ct_data near *tree; ;; /* the tree to be scanned */ - ;; int max_code; ;; /* and its largest code of non zero frequency */ - - (define prevlen -1) ;; /* last emitted length */ - (define curlen 0) ;; /* length of current code */ - (define nextlen (ct_data-len (vector-ref tree 0))) ;; /* length of next code */ - (define count 0) ;; /* repeat count of the current code */ - (define max_count 7) ;; /* max repeat count */ - (define min_count 4) ;; /* min repeat count */ - - (when (= nextlen 0) - (set! max_count 138) - (set! min_count 3)) - - (set-ct_data-len! (vector-ref tree (+ max_code 1)) #xffff) ;; /* guard */ - - (for n := 0 <= max_code do - (let/ec continue - (define (inc-bl_tree-freq which amt) - (set-ct_data-freq! (vector-ref bl_tree which) - (+ amt (ct_data-freq (vector-ref bl_tree which))))) - - (set! curlen nextlen) - (set! nextlen (ct_data-len (vector-ref tree (+ n 1)))) - (set! count (add1 count)) - - (cond [(and (< count max_count) (= curlen nextlen)) - (continue)] - [(< count min_count) - (inc-bl_tree-freq curlen count)] - [(not (= curlen 0)) - (when (not (= curlen prevlen)) - (inc-bl_tree-freq curlen 1)) - (inc-bl_tree-freq REP_3_6 1)] - [(<= count 10) - (inc-bl_tree-freq REPZ_3_10 1)] - [else - (inc-bl_tree-freq REPZ_11_138 1)]) - - (set! count 0) - (set! prevlen curlen) - - (cond [(= nextlen 0) (set! max_count 138) (set! min_count 3)] - [(= curlen nextlen) (set! max_count 6) (set! min_count 3)] - [else (set! max_count 7) (set! min_count 4)])))) - -;; /* =========================================================================== -;; * Send a literal or distance tree in compressed form, using the codes in -;; * bl_tree. -;; */ -(define (send_tree tree max_code) - ;; ct_data near *tree; ;; /* the tree to be scanned */ - ;; int max_code; ;; /* and its largest code of non zero frequency */ - - (define prevlen -1) ;; /* last emitted length */ - (define curlen 0) ;; /* length of current code */ - (define nextlen (ct_data-len (vector-ref tree 0))) ;; /* length of next code */ - (define count 0) ;; /* repeat count of the current code */ - (define max_count 7) ;; /* max repeat count */ - (define min_count 4) ;; /* min repeat count */ - - ;; /* tree[max_code+1].Len = -1; */ ;; /* guard already set */ - (when (= nextlen 0) - (set! max_count 138) - (set! min_count 3)) - - (for n := 0 <= max_code do - (let/ec continue - (set! curlen nextlen) - (set! nextlen (ct_data-len (vector-ref tree (+ n 1)))) - - (set! count (add1 count)) - (cond [(and (< count max_count) (= curlen nextlen)) - (continue)] - [(< count min_count) - (let loop () - (send_code curlen bl_tree) - (set! count (sub1 count)) - (when (not (= count 0)) (loop)))] - [(not (= curlen 0)) - (when (not (= curlen prevlen)) - (send_code curlen bl_tree) - (set! count (sub1 count))) - (Assert - (unless (>= 6 count 3) - (error " 3_6?"))) - (send_code REP_3_6 bl_tree) - (send_bits (- count 3) 2)] - [(<= count 10) - (send_code REPZ_3_10 bl_tree) - (send_bits (- count 3) 3)] - [else - (send_code REPZ_11_138 bl_tree) - (send_bits (- count 11) 7)]) - - (set! count 0) - (set! prevlen curlen) - - (cond [(= nextlen 0) (set! max_count 138) (set! min_count 3)] - [(= curlen nextlen) (set! max_count 6) (set! min_count 3)] - [else (set! max_count 7) (set! min_count 4)])))) - -;; /* =========================================================================== -;; * Construct the Huffman tree for the bit lengths and return the index in -;; * bl_order of the last bit length code to send. -;; */ -(define (build_bl_tree) - (define max_blindex 0) ;; /* index of last bit length code of non zero freq */ - - ;; /* Determine the bit length frequencies for literal and distance trees */ - (scan_tree dyn_ltree (tree_desc-max_code l_desc)) - (scan_tree dyn_dtree (tree_desc-max_code d_desc)) - - ;; /* Build the bit length tree: */ - (build_tree bl_desc) - ;; /* opt_len now includes the length of the tree representations, except - ;; * the lengths of the bit lengths codes and the 5+5+4 bits for the counts. - ;; */ - - ;; /* Determine the number of bit length codes to send. The pkzip format - ;; * requires that at least 4 bit length codes be sent. (appnote.txt says - ;; * 3 but the actual value used is 4.) - ;; */ - (set! max_blindex (- BL_CODES 1)) - (let loop () - (when (and (>= max_blindex 3) - (= (ct_data-len (vector-ref bl_tree - (vector-ref bl_order max_blindex))) - 0)) - (set! max_blindex (sub1 max_blindex)) - (loop))) - - ;; /* Update opt_len to include the bit length tree and counts */ - (set! opt_len (+ opt_len (* 3 (+ max_blindex 1)) 5 5 4)) - (DEBUG (Tracev stderr "\ndyn trees: dyn ~a, stat ~a" opt_len static_len)) - - max_blindex) - -;; /* =========================================================================== -;; * Send the header for a block using dynamic Huffman trees: the counts, the -;; * lengths of the bit length codes, the literal tree and the distance tree. -;; * IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4. -;; */ -(define (send_all_trees lcodes dcodes blcodes) - ;; int lcodes, dcodes, blcodes; ;; /* number of codes for each tree */ - - (Assert - (unless (and (>= lcodes 257) - (>= dcodes 1) - (>= blcodes 4)) - (error "not enough codes"))) - (Assert - (unless (and (<= lcodes L_CODES) - (<= dcodes D_CODES) - (<= blcodes BL_CODES)) - (error "too many codes ~a(~a) ~a(~a) ~a(~a)" - lcodes L_CODES - dcodes D_CODES - blcodes BL_CODES))) - - (DEBUG (Tracev stderr "\nbl counts: ")) - - (send_bits (- lcodes 257) 5) ;; /* not +255 as stated in appnote.txt */ - (send_bits (- dcodes 1) 5) - (send_bits (- blcodes 4) 4) ;; /* not -3 as stated in appnote.txt */ - (for rank := 0 < blcodes do - (DEBUG (Tracev stderr "\nbl code ~a " (vector-ref bl_order rank))) - (send_bits (ct_data-len (vector-ref bl_tree (vector-ref bl_order rank))) - 3)) - (DEBUG (Tracev stderr "\nbl tree: sent ~a" bits_sent)) - - (send_tree dyn_ltree (- lcodes 1)) ;; /* send the literal tree */ - (DEBUG (Tracev stderr "\nlit tree: sent ~a" bits_sent)) - - (send_tree dyn_dtree (- dcodes 1)) ;; /* send the distance tree */ - (DEBUG (Tracev stderr "\ndist tree: sent ~a" bits_sent))) - -;; /* =========================================================================== -;; * Determine the best encoding for the current block: dynamic trees, static -;; * trees or store, and output the encoded block to the zip file. This function -;; * returns the total compressed length for the file so far. -;; */ -(define (flush_block buf stored_len eof) - ;; char *buf; ;; /* input block, or NULL if too old */ - ;; ulg stored_len; ;; /* length of input block */ - ;; int eof; ;; /* true if this is the last block for a file */ - - (define opt_lenb 0) (define static_lenb 0) ;; /* opt_len and static_len in bytes */ - (define max_blindex 0) ;; /* index of last bit length code of non zero freq */ - - (vector-set! flag_buf last_flags flags) ;; /* Save the flags for the last 8 items */ - - ;; /* Construct the literal and distance trees */ - (build_tree l_desc) - (DEBUG (Tracev stderr "\nlit data: dyn ~a, stat ~a" opt_len static_len)) - - (build_tree d_desc) - (DEBUG (Tracev stderr "\ndist data: dyn ~a, stat ~a" opt_len static_len)) - ;; /* At this point, opt_len and static_len are the total bit lengths of - ;; * the compressed block data, excluding the tree representations. - ;; */ - - ;; /* Build the bit length tree for the above two trees, and get the index - ;; * in bl_order of the last bit length code to send. - ;; */ - (set! max_blindex (build_bl_tree)) - - ;; /* Determine the best encoding. Compute first the block length in bytes */ - (set! opt_lenb (>> (+ opt_len 3 7) 3)) - (set! static_lenb (>> (+ static_len 3 7) 3)) - (set! input_len (+ input_len stored_len)) ;; /* for debugging only */ - - (DEBUG (Trace stderr "\nopt ~a(~a) stat ~a(~a) stored ~a lit ~a dist ~a " - opt_lenb opt_len static_lenb static_len stored_len - last_lit last_dist)) - - (when (<= static_lenb opt_lenb) - (set! opt_lenb static_lenb)) - - ;; /* If compression failed and this is the first and last block, - ;; * and if the zip file can be seeked (to rewrite the local header), - ;; * the whole file is transformed into a stored file: - ;; */ - (cond - [(and buf (<= (+ stored_len 4) opt_lenb)) - ;; /* 4: two words for the lengths */ - - ;; /* The test buf != NULL is only necessary if LIT_BUFSIZE > WSIZE. - ;; * Otherwise we can't have processed more than WSIZE input bytes since - ;; * the last block flush, because compression would have been - ;; * successful. If LIT_BUFSIZE <= WSIZE, it is never too late to - ;; * transform a block into a stored block. - ;; */ - (send_bits (+ (<< STORED_BLOCK 1) eof) 3) ;; /* send block type */ - (set! compressed_len (bitwise-and (+ compressed_len 3 7) (bitwise-not 7))) - (set! compressed_len (+ compressed_len (<< (+ stored_len 4) 3))) - - (copy_block buf stored_len #t)] ;; /* with header */ - [(= static_lenb opt_lenb) - (send_bits (+ (<< STATIC_TREES 1) eof) 3) - (compress_block static_ltree static_dtree) - (set! compressed_len (+ compressed_len 3 static_len))] - [else - (send_bits (+ (<< DYN_TREES 1) eof) 3) - (send_all_trees (+ (tree_desc-max_code l_desc) 1) - (+ (tree_desc-max_code d_desc) 1) - (+ max_blindex 1)) - (compress_block dyn_ltree dyn_dtree) - (set! compressed_len (+ compressed_len 3 opt_len))]) - - ;; Assert - ;; (unless (= compressed_len bits_sent) - ;; (error "bad compressed size")) - (init_block) - - (when (not (= eof 0)) - (Assert - (unless (= input_len bytes_in) - (newline (current-error-port)) - (error 'eof "bad input size: ~a != ~a" input_len bytes_in))) - (bi_windup) - (set! compressed_len ;; /* align on byte boundary */ - (+ compressed_len 7))) - - (DEBUG (Tracev stderr "\ncomprlen ~a(~a) " (>> compressed_len 3) - (- compressed_len (* 7 eof)))) - - (>> compressed_len 3)) - -;; /* =========================================================================== -;; * Save the match info and tally the frequency counts. Return true if -;; * the current block must be flushed. -;; */ -(define ct_tally - (let ([dist 0]) - (lambda (_dist lc) - ;; int dist; ;; /* distance of matched string */ - ;; int lc; ;; /* match length-MIN_MATCH or unmatched char (if dist==0) */ - - (set! dist _dist) - - (bytes-set! l_buf last_lit lc) - (set! last_lit (add1 last_lit)) - (if (= dist 0) - ;; /* lc is the unmatched char */ - (set-ct_data-freq! (vector-ref dyn_ltree lc) - (add1 (ct_data-freq (vector-ref dyn_ltree lc)))) - (begin - ;; /* Here, lc is the match length - MIN_MATCH */ - (set! dist (sub1 dist)) ;; /* dist = match distance - 1 */ - (Assert - (unless (and (< dist MAX_DIST) - (<= lc (- MAX_MATCH MIN_MATCH)) - (< (d_code dist) D_CODES)) - (error "ct_tally: bad match"))) - - (let* ([i (+ (vector-ref length_code lc) LITERALS 1)] - [ct (vector-ref dyn_ltree i)]) - (DEBUG (Trace stderr "Set: ~a -> ~a\n" lc i)) - (set-ct_data-freq! ct (add1 (ct_data-freq ct)))) - (let ([ct (vector-ref dyn_dtree (d_code dist))]) - (set-ct_data-freq! ct (add1 (ct_data-freq ct)))) - - (vector-set! d_buf last_dist dist) - (set! last_dist (add1 last_dist)) - (set! flags (bitwise-ior flags flag_bit)))) - - (set! flag_bit (<< flag_bit 1)) - - ;; /* Output the flags if they fill a byte: */ - (when (= (bitwise-and last_lit 7) 0) - (vector-set! flag_buf last_flags flags) - (set! last_flags (add1 last_flags)) - (set! flags 0) (set! flag_bit 1)) - - (or - ;; /* Try to guess if it is profitable to stop the current block here */ - (and (and (> LEVEL 2) (= (bitwise-and last_lit #xfff) 0)) - (let () - ;; /* Compute an upper bound for the compressed length */ - (define out_length (* last_lit 8)) - (define in_length (- strstart block_start)) - - (for dcode := 0 < D_CODES do - (set! out_length - (+ out_length - (* (ct_data-freq (vector-ref dyn_dtree dcode)) - (+ 5 (vector-ref extra_dbits dcode)))))) - (set! out_length (>> out_length 3)) - (DEBUG (Trace stderr "\nlast_lit ~a, last_dist ~a, in ~a, out ~~~a(~a%) " - last_lit last_dist in_length out_length - (- 100 (/ (* out_length 100) in_length)))) - (and (< last_dist (quotient last_lit 2)) - (< out_length (quotient in_length 2))))) - - (or (= last_lit (- LIT_BUFSIZE 1)) - (= last_dist DIST_BUFSIZE)) - ;; /* We avoid equality with LIT_BUFSIZE because of wraparound at 64K - ;; * on 16 bit machines and because stored blocks are restricted to - ;; * 64K-1 bytes. - ;; */ - )))) - -;; /* =========================================================================== -;; * Send the block data compressed using the given Huffman trees -;; */ -(define (compress_block ltree dtree) - ;; ct_data near *ltree; ;; /* literal tree */ - ;; ct_data near *dtree; ;; /* distance tree */ - - (define dist 0) ;; /* distance of matched string */ - (define lc 0) ;; /* match length or unmatched char (if dist == 0) */ - (define lx 0) ;; /* running index in l_buf */ - (define dx 0) ;; /* running index in d_buf */ - (define fx 0) ;; /* running index in flag_buf */ - (define flag 0) ;; /* current flags */ - (define code 0) ;; /* the code to send */ - (define extra 0) ;; /* number of extra bits to send */ - - (when (not (= last_lit 0)) - (let loop () - (when (= (bitwise-and lx 7) 0) - (set! flag (vector-ref flag_buf fx)) - (set! fx (add1 fx))) - - (set! lc (bytes-ref l_buf lx)) - (set! lx (add1 lx)) - - (cond - [(= (bitwise-and flag 1) 0) - (send_code lc ltree) ;; /* send a literal byte */ - (DEBUG '(Tracecv (isgraph lc) stderr " '~c' " (integer->char lc)))] - [else - ;; /* Here, lc is the match length - MIN_MATCH */ - (set! code (vector-ref length_code lc)) - (send_code (+ code LITERALS 1) ltree) ;; /* send the length code */ - (set! extra (vector-ref extra_lbits code)) - (when (not (= extra 0)) - (set! lc (- lc (vector-ref base_length code))) - (send_bits lc extra)) ;; /* send the extra length bits */ - (set! dist (vector-ref d_buf dx)) - (set! dx (add1 dx)) - - ;; /* Here, dist is the match distance - 1 */ - (set! code (d_code dist)) - (Assert - (unless (< code D_CODES) - (error "bad d_code"))) - - (send_code code dtree) ;; /* send the distance code */ - (set! extra (vector-ref extra_dbits code)) - (when (not (= extra 0)) - (set! dist (- dist (vector-ref base_dist code))) - (send_bits dist extra))]) ;; /* send the extra distance bits */ - ;; /* literal or match pair ? */ - (set! flag (>> flag 1)) - (when (< lx last_lit) - (loop)))) - - (send_code END_BLOCK ltree)) - -#| -/* bits.c -- output variable-length bit strings - * Copyright (C) 1992-1993 Jean-loup Gailly - * This is free software; you can redistribute it and/or modify it under the - * terms of the GNU General Public License, see the file COPYING. - */ - - -/* - * PURPOSE - * - * Output variable-length bit strings. Compression can be done - * to a file or to memory. (The latter is not supported in this version.) - * - * DISCUSSION - * - * The PKZIP "deflate" file format interprets compressed file data - * as a sequence of bits. Multi-bit strings in the file may cross - * byte boundaries without restriction. - * - * The first bit of each byte is the low-order bit. - * - * The routines in this file allow a variable-length bit value to - * be output right-to-left (useful for literal values). For - * left-to-right output (useful for code strings from the tree routines), - * the bits must have been reversed first with bi_reverse(). - * - * For in-memory compression, the compressed bit stream goes directly - * into the requested output buffer. The input data is read in blocks - * by the mem_read() function. The buffer is limited to 64K on 16 bit - * machines. - * - * INTERFACE - * - * void bi_init (FILE *zipfile) - * Initialize the bit string routines. - * - * void send_bits (int value, int length) - * Write out a bit string, taking the source bits right to - * left. - * - * int bi_reverse (int value, int length) - * Reverse the bits of a bit string, taking the source bits left to - * right and emitting them right to left. - * - * void bi_windup (void) - * Write out any remaining bits in an incomplete byte. - * - * void copy_block(char *buf, unsigned len, int header) - * Copy a stored block to the zip file, storing first the length and - * its one's complement if requested. - * - */ -|# - -(define bytes_in 0) - -(define bi_buf 0) -;; /* Output buffer. bits are inserted starting at the bottom (least significant -;; * bits). -;; */ - -(define Buf_size (* 8 2)) -;; /* Number of bits used within bi_buf. (bi_buf might be implemented on -;; * more than 16 bits on some systems.) -;; */ - -(define bi_valid 0) -;; /* Number of valid bits in bi_buf. All bits above the last valid bit -;; * are always zero. -;; */ - -;; /* =========================================================================== -;; * Initialize the bit string routines. -;; */ -(define (bi_init) - (set! bi_buf 0) - (set! bi_valid 0) - (set! bits_sent 0)) - - -;; /* =========================================================================== -;; * Send a value on a given number of bits. -;; * IN assertion: length <= 16 and value fits in length bits. -;; */ -(define (send_bits value length) - ;; int value; /* value to send */ - ;; int length; /* number of bits */ - - (DEBUG (Tracev stderr " l ~a v ~x " length value)) - (Assert - (unless (and (> length 0) (<= length 15)) - (error "invalid length"))) - (set! bits_sent (+ bits_sent length)) - - ;; /* If not enough room in bi_buf, use (valid) bits from bi_buf and - ;; * (16 - bi_valid) bits from value, leaving (width - (16-bi_valid)) - ;; * unused bits in value. - ;; */ - (if (> bi_valid (- Buf_size length)) - (begin (put_short (bitwise-and (bitwise-ior bi_buf (<< value bi_valid)) - #xFFFF)) - (set! bi_buf (>> value (- Buf_size bi_valid))) - (set! bi_valid (+ bi_valid (- length Buf_size)))) - (begin (set! bi_buf (bitwise-ior bi_buf (<< value bi_valid))) - (set! bi_valid (+ bi_valid length))))) - -;; /* =========================================================================== -;; * Reverse the first len bits of a code, using straightforward code (a faster -;; * method would use a table) -;; * IN assertion: 1 <= len <= 15 -;; */ -(define (bi_reverse code len) - ;; unsigned code; /* the value to invert */ - ;; int len; /* its bit length */ - - (let loop ([res 0][code code][len len]) - (let ([res (<< (bitwise-ior res (bitwise-and code 1)) 1)]) - (if (> len 1) - (loop res (>> code 1) (sub1 len)) - (>> res 1))))) - -;; /* =========================================================================== -;; * Write out any remaining bits in an incomplete byte. -;; */ -(define (bi_windup) - (cond [(> bi_valid 8) (put_short bi_buf)] - [(> bi_valid 0) (put_byte bi_buf)]) - (set! bi_buf 0) - (set! bi_valid 0) - (set! bits_sent (bitwise-and (+ bits_sent 7) (bitwise-not 7)))) - -;; /* =========================================================================== -;; * Run a set of bytes through the crc shift register. If s is a NULL -;; * pointer, then initialize the crc shift register contents instead. -;; */ -(define crc #xffffffff) -(define (updcrc s n) - ;; uch *s; /* pointer to bytes to pump through */ - ;; unsigned n; /* number of bytes in s[] */ - (if s - (let loop ([c crc][p 0]) - (if (= p n) - (set! crc c) - (loop (bitwise-xor - (vector-ref crc_32_tab - (bitwise-and - (bitwise-xor c (bytes-ref window-vec (+ s p))) - #xff)) - (arithmetic-shift c -8)) - (add1 p)))) - (set! crc #xffffffff))) - -(define crc_32_tab - #(#x00000000 - #x77073096 #xee0e612c #x990951ba #x076dc419 - #x706af48f #xe963a535 #x9e6495a3 #x0edb8832 #x79dcb8a4 - #xe0d5e91e #x97d2d988 #x09b64c2b #x7eb17cbd #xe7b82d07 - #x90bf1d91 #x1db71064 #x6ab020f2 #xf3b97148 #x84be41de - #x1adad47d #x6ddde4eb #xf4d4b551 #x83d385c7 #x136c9856 - #x646ba8c0 #xfd62f97a #x8a65c9ec #x14015c4f #x63066cd9 - #xfa0f3d63 #x8d080df5 #x3b6e20c8 #x4c69105e #xd56041e4 - #xa2677172 #x3c03e4d1 #x4b04d447 #xd20d85fd #xa50ab56b - #x35b5a8fa #x42b2986c #xdbbbc9d6 #xacbcf940 #x32d86ce3 - #x45df5c75 #xdcd60dcf #xabd13d59 #x26d930ac #x51de003a - #xc8d75180 #xbfd06116 #x21b4f4b5 #x56b3c423 #xcfba9599 - #xb8bda50f #x2802b89e #x5f058808 #xc60cd9b2 #xb10be924 - #x2f6f7c87 #x58684c11 #xc1611dab #xb6662d3d #x76dc4190 - #x01db7106 #x98d220bc #xefd5102a #x71b18589 #x06b6b51f - #x9fbfe4a5 #xe8b8d433 #x7807c9a2 #x0f00f934 #x9609a88e - #xe10e9818 #x7f6a0dbb #x086d3d2d #x91646c97 #xe6635c01 - #x6b6b51f4 #x1c6c6162 #x856530d8 #xf262004e #x6c0695ed - #x1b01a57b #x8208f4c1 #xf50fc457 #x65b0d9c6 #x12b7e950 - #x8bbeb8ea #xfcb9887c #x62dd1ddf #x15da2d49 #x8cd37cf3 - #xfbd44c65 #x4db26158 #x3ab551ce #xa3bc0074 #xd4bb30e2 - #x4adfa541 #x3dd895d7 #xa4d1c46d #xd3d6f4fb #x4369e96a - #x346ed9fc #xad678846 #xda60b8d0 #x44042d73 #x33031de5 - #xaa0a4c5f #xdd0d7cc9 #x5005713c #x270241aa #xbe0b1010 - #xc90c2086 #x5768b525 #x206f85b3 #xb966d409 #xce61e49f - #x5edef90e #x29d9c998 #xb0d09822 #xc7d7a8b4 #x59b33d17 - #x2eb40d81 #xb7bd5c3b #xc0ba6cad #xedb88320 #x9abfb3b6 - #x03b6e20c #x74b1d29a #xead54739 #x9dd277af #x04db2615 - #x73dc1683 #xe3630b12 #x94643b84 #x0d6d6a3e #x7a6a5aa8 - #xe40ecf0b #x9309ff9d #x0a00ae27 #x7d079eb1 #xf00f9344 - #x8708a3d2 #x1e01f268 #x6906c2fe #xf762575d #x806567cb - #x196c3671 #x6e6b06e7 #xfed41b76 #x89d32be0 #x10da7a5a - #x67dd4acc #xf9b9df6f #x8ebeeff9 #x17b7be43 #x60b08ed5 - #xd6d6a3e8 #xa1d1937e #x38d8c2c4 #x4fdff252 #xd1bb67f1 - #xa6bc5767 #x3fb506dd #x48b2364b #xd80d2bda #xaf0a1b4c - #x36034af6 #x41047a60 #xdf60efc3 #xa867df55 #x316e8eef - #x4669be79 #xcb61b38c #xbc66831a #x256fd2a0 #x5268e236 - #xcc0c7795 #xbb0b4703 #x220216b9 #x5505262f #xc5ba3bbe - #xb2bd0b28 #x2bb45a92 #x5cb36a04 #xc2d7ffa7 #xb5d0cf31 - #x2cd99e8b #x5bdeae1d #x9b64c2b0 #xec63f226 #x756aa39c - #x026d930a #x9c0906a9 #xeb0e363f #x72076785 #x05005713 - #x95bf4a82 #xe2b87a14 #x7bb12bae #x0cb61b38 #x92d28e9b - #xe5d5be0d #x7cdcefb7 #x0bdbdf21 #x86d3d2d4 #xf1d4e242 - #x68ddb3f8 #x1fda836e #x81be16cd #xf6b9265b #x6fb077e1 - #x18b74777 #x88085ae6 #xff0f6a70 #x66063bca #x11010b5c - #x8f659eff #xf862ae69 #x616bffd3 #x166ccf45 #xa00ae278 - #xd70dd2ee #x4e048354 #x3903b3c2 #xa7672661 #xd06016f7 - #x4969474d #x3e6e77db #xaed16a4a #xd9d65adc #x40df0b66 - #x37d83bf0 #xa9bcae53 #xdebb9ec5 #x47b2cf7f #x30b5ffe9 - #xbdbdf21c #xcabac28a #x53b39330 #x24b4a3a6 #xbad03605 - #xcdd70693 #x54de5729 #x23d967bf #xb3667a2e #xc4614ab8 - #x5d681b02 #x2a6f2b94 #xb40bbe37 #xc30c8ea1 #x5a05df1b - #x2d02ef8d)) - -;; /* =========================================================================== -;; * Copy a stored block to the zip file, storing first the length and its -;; * one's complement if requested. -;; */ -(define (copy_block buf len header) - ;; char *buf; /* the input data */ - ;; unsigned len; /* its length */ - ;; int header; /* true if block header must be written */ - - (bi_windup);; /* align on byte boundary */ - - (when header - (put_short len) - (put_short (bitwise-and (bitwise-not len) #xFFFF)) - (set! bits_sent (+ bits_sent (* 2 16)))) - - (set! bits_sent (+ bits_sent (<< len 3))) - - (for pos := 0 < len do (put_byte (gzbytes-ref buf pos)))) - -;; /* =========================================================================== -;; * Read a new buffer from the current input file, perform end-of-line -;; * translation, and update the crc and input file size. -;; * IN assertion: size >= 2 (for end-of-line translation) -;; */ -(define (read_buf startpos size) - ;; char *buf; - ;; unsigned size; - - ;; Assert - ;; (unless (= insize 0) - ;; (error "inbuf not empty")) - - (let* ([s (read-bytes! window-vec ifd startpos (+ size startpos))] - [len (if (eof-object? s) EOF-const s)]) - (when (positive? len) - (updcrc startpos len) - (set! bytes_in (+ bytes_in len))) - len)) - -;; Assumes being called with c in 0..FF -(define-syntax put_byte - (syntax-rules () - [(_ c) - (begin (bytes-set! outbuf outcnt c) - (set! outcnt (add1 outcnt)) - (when (= outcnt OUTBUFSIZ) (flush_outbuf)))])) - -;; /* Output a 16 bit value, lsb first */ -;; Assumes being called with c in 0..FFFF -(define (put_short w) - (if (< outcnt (- OUTBUFSIZ 2)) - (begin (bytes-set! outbuf outcnt (bitwise-and #xFF w)) - (bytes-set! outbuf (add1 outcnt) (>> w 8)) - ;; this is not faster... - ;; (integer->integer-bytes w 2 #f #f outbuf outcnt) - (set! outcnt (+ outcnt 2))) - (begin (put_byte (bitwise-and #xFF w)) - (put_byte (>> w 8))))) - -;; /* Output a 32 bit value to the bit stream, lsb first */ -(define (put_long n) - (put_short (bitwise-and #xFFFF n)) - (put_short (bitwise-and #xFFFF (>> n 16)))) - -(define outcnt 0) -(define bytes_out 0) -(define outbuf (make-bytes OUTBUFSIZ)) - -;; /* =========================================================================== -;; * Write the output buffer outbuf[0..outcnt-1] and update bytes_out. -;; * (used for the compressed data only) -;; */ -(define (flush_outbuf) - (unless (= outcnt 0) - - (write-bytes outbuf ofd 0 outcnt) - - (set! bytes_out (+ bytes_out outcnt)) - (set! outcnt 0))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define ifd #f) -(define ofd #f) - -(define (deflate-inner in out) - (do-deflate)) - -(define (deflate in out) - - (set! bytes_in 0) - - (set! ifd in) - (set! ofd out) - (set! outcnt 0) - - (bi_init) - (ct_init) - (lm_init LEVEL) - - (deflate-inner in out) - - (flush_outbuf) - - (values bytes_in bytes_out (bitwise-xor crc #xffffffff))) - -(define (gzip-through-ports in out origname time_stamp) - - (define flags (if origname #x8 0)) ;; /* general purpose bit flags */ - - ;; make origname be a byte string - (set! origname (cond [(not origname) #f] - [(string? origname) (string->bytes/utf-8 origname)] - [(path? origname) (path->bytes origname)] - [else origname])) - - (set! bytes_in 0) - - (set! ifd in) - (set! ofd out) - (set! outcnt 0) - - ;; /* Write the header to the gzip file. See algorithm.doc for the format */ - (put_byte #o037) ;; /* magic header */ - (put_byte #o213) - (put_byte 8) ;; /* compression method */ - - (put_byte flags);; /* general flags */ - (put_long time_stamp); - - ;; /* Write deflated file to zip file */ - (updcrc #f 0) - - (bi_init) - (ct_init) - - (put_byte (lm_init LEVEL));; /* extra flags */ - (put_byte 3) ;; /* OS identifier */ - - (when origname - (for-each (lambda (b) (put_byte b)) (bytes->list origname)) - (put_byte 0)) - - (do-deflate) - - ;; /* Write the crc and uncompressed size */ - (put_long (bitwise-xor crc #xffffffff)) - (put_long bytes_in) - - (flush_outbuf)) - -(define (gzip infile outfile) - (let ([i (open-input-file infile)]) - (dynamic-wind - void - (lambda () - (let ([o (open-output-file outfile 'truncate/replace)]) - (dynamic-wind - void - (lambda () - (let ([name (with-handlers ([exn:fail? (lambda (x) #f)]) - (let-values ([(base name dir?) (split-path infile)]) - name))] - [timestamp (with-handlers ([exn:fail:filesystem? (lambda (x) 0)]) - (file-or-directory-modify-seconds infile))]) - (gzip-through-ports i o name timestamp))) - (lambda () (close-output-port o))))) - (lambda () (close-input-port i))))) - -(list gzip gzip-through-ports deflate))) - -(define gzip - (case-lambda - [(infile) (gzip infile (string-append infile ".gz"))] - [(infile outfile) ((car (invoke-unit code)) infile outfile)])) - -(define (gzip-through-ports in out origname time_stamp) - ((cadr (invoke-unit code)) in out origname time_stamp)) - -(define (deflate in out) - ((caddr (invoke-unit code)) in out)) - -) +(require file/gzip) +(provide (all-from-out file/gzip)) diff --git a/collects/mzlib/etc.rkt b/collects/mzlib/etc.rkt index aedc709..328ef6d 100644 --- a/collects/mzlib/etc.rkt +++ b/collects/mzlib/etc.rkt @@ -3,6 +3,7 @@ racket/local racket/bool racket/block + racket/private/this-expression-source-directory (only racket/function identity) (only racket/base @@ -10,7 +11,6 @@ build-list build-vector compose) - "private/this-expression-source-directory.rkt" (rename racket/base base-else else)) (require-for-syntax syntax/name diff --git a/collects/mzlib/inflate.rkt b/collects/mzlib/inflate.rkt index 5fa4b7a..1823d67 100644 --- a/collects/mzlib/inflate.rkt +++ b/collects/mzlib/inflate.rkt @@ -1,931 +1,6 @@ #lang racket/base -(require (for-syntax racket/base)) - (provide inflate - gunzip-through-ports - gunzip) - -#| - -/* inflate.c -- Not copyrighted 1992 by Mark Adler - version c10p1, 10 January 1993 */ -; Taken from the gzip source distribution -; Translated directly from C (obviously) by Matthew, April 1997 - -/* You can do whatever you like with this source file, though I would - prefer that if you modify it and redistribute it that you include - comments to that effect with your name and the date. Thank you. - [The history has been moved to the file ChangeLog.] - ; ChangeLog is distributed with the gzip source. - */ - -/* - Inflate deflated (PKZIP's method 8 compressed) data. The compression - method searches for as much of the current string of bytes (up to a - length of 258) in the previous 32K bytes. If it doesn't find any - matches (of at least length 3), it codes the next byte. Otherwise, it - codes the length of the matched string and its distance backwards from - the current position. There is a single Huffman code that codes both - single bytes (called "literals") and match lengths. A second Huffman - code codes the distance information, which follows a length code. Each - length or distance code actually represents a base value and a number - of "extra" (sometimes zero) bits to get to add to the base value. At - the end of each deflated block is a special end-of-block (EOB) literal/ - length code. The decoding process is basically: get a literal/length - code; if EOB then done; if a literal, emit the decoded byte; if a - length then get the distance and emit the referred-to bytes from the - sliding window of previously emitted data. - - There are (currently) three kinds of inflate blocks: stored, fixed, and - dynamic. The compressor deals with some chunk of data at a time, and - decides which method to use on a chunk-by-chunk basis. A chunk might - typically be 32K or 64K. If the chunk is uncompressible, then the - "stored" method is used. In this case, the bytes are simply stored as - is, eight bits per byte, with none of the above coding. The bytes are - preceded by a count, since there is no longer an EOB code. - - If the data is compressible, then either the fixed or dynamic methods - are used. In the dynamic method, the compressed data is preceded by - an encoding of the literal/length and distance Huffman codes that are - to be used to decode this block. The representation is itself Huffman - coded, and so is preceded by a description of that code. These code - descriptions take up a little space, and so for small blocks, there is - a predefined set of codes, called the fixed codes. The fixed method is - used if the block codes up smaller that way (usually for quite small - chunks), otherwise the dynamic method is used. In the latter case, the - codes are customized to the probabilities in the current block, and so - can code it much better than the pre-determined fixed codes. - - The Huffman codes themselves are decoded using a mutli-level table - lookup, in order to maximize the speed of decoding plus the speed of - building the decoding tables. See the comments below that precede the - lbits and dbits tuning parameters. - */ - - -/* - Notes beyond the 1.93a appnote.txt: - - 1. Distance pointers never point before the beginning of the output - stream. - 2. Distance pointers can point back across blocks, up to 32k away. - 3. There is an implied maximum of 7 bits for the bit length table and - 15 bits for the actual data. - 4. If only one code exists, then it is encoded using one bit. (Zero - would be more efficient, but perhaps a little confusing.) If two - codes exist, they are coded using one bit each (0 and 1). - 5. There is no way of sending zero distance codes--a dummy must be - sent if there are none. (History: a pre 2.0 version of PKZIP would - store blocks with no distance codes, but this was discovered to be - too harsh a criterion.) Valid only for 1.93a. 2.04c does allow - zero distance codes, which is sent as one code of zero bits in - length. - 6. There are up to 286 literal/length codes. Code 256 represents the - end-of-block. Note however that the static length tree defines - 288 codes just to fill out the Huffman codes. Codes 286 and 287 - cannot be used though, since there is no length base or extra bits - defined for them. Similarly, there are up to 30 distance codes. - However, static trees define 32 codes (all 5 bits) to fill out the - Huffman codes, but the last two had better not show up in the data. - 7. Unzip can check dynamic Huffman blocks for complete code sets. - The exception is that a single code would not be complete (see #4). - 8. The five bits following the block type is really the number of - literal codes sent minus 257. - 9. Length codes 8,16,16 are interpreted as 13 length codes of 8 bits - (1+6+6). Therefore, to output three times the length, you output - three codes (1+1+1), whereas to output four times the same length, - you only need two codes (1+3). Hmm. - 10. In the tree reconstruction algorithm, Code = Code + Increment - only if BitLength(i) is not zero. (Pretty obvious.) - 11. Correction: 4 Bits: # of Bit Length codes - 4 (4 - 19) - 12. Note: length code 284 can represent 227-258, but length code 285 - really is 258. The last length deserves its own, short code - since it gets used a lot in very redundant files. The length - 258 is special since 258 - 3 (the min match length) is 255. - 13. The literal/length and distance code bit lengths are read as a - single stream of lengths. It is possible (and advantageous) for - a repeat code (16, 17, or 18) to go across the boundary between - the two sets of lengths. - */ - -|# - -#| -/* Huffman code lookup table entry--this entry is four bytes for machines - that have 16-bit pointers (e.g. PC's in the small or medium model). - Valid extra bits are 0..13. e == 15 is EOB (end of block), e == 16 - means that v is a literal, 16 < e < 32 means that v is a pointer to - the next table, which codes e - 16 bits, and lastly e == 99 indicates - an unused code. If a code with e == 99 is looked up, this implies an - error in the data. */ -|# - - (define-struct huft (e b v) #:mutable) - - (define (huft-copy dest src) - (set-huft-e! dest (huft-e src)) - (set-huft-b! dest (huft-b src)) - (set-huft-v! dest (huft-v src))) - - (define (step start < end add1 f) - (let loop ([i start]) - (when (< i end) - (f i) - (loop (add1 i))))) - - (define (subvector v offset) - (let* ([len (- (vector-length v) offset)] - [new (make-vector len)]) - (step 0 < len add1 - (lambda (i) - (vector-set! new i (vector-ref v (+ i offset))))) - new)) - - (define (build-vector n p) - (let ([v (make-vector n)]) - (step 0 < n add1 (lambda (i) (vector-set! v i (p i)))) - v)) - - ;; We know that inflating will be a bottleneck, so we might as - ;; well help out the compiler... - (define-syntax define-const - (syntax-rules () - [(_ id v) (define-syntax id (make-const #'v))])) - (define-for-syntax (make-const val) - (make-set!-transformer - (lambda (stx) - (syntax-case stx (set!) - [(set! id . _) (raise-syntax-error (syntax-e #'id) - "cannot assign constant" - stx)] - [(id . rest) (quasisyntax/loc stx (#,val . rest))] - [id val])))) - -#| -/* The inflate algorithm uses a sliding 32K byte window on the uncompressed - stream to find repeated byte strings. This is implemented here as a - circular buffer. The index is updated simply by incrementing and then - and'ing with 0x7fff (32K-1). */ -|# - - (define-const WSIZE 32768) - - (define border - (vector - 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15)) - - (define cplens - (vector - 3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 - 35 43 51 59 67 83 99 115 131 163 195 227 258 0 0)) - ; /* note: see note #13 above about the 258 in this list. */ - (define cplext - (vector - 0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 - 3 3 3 3 4 4 4 4 5 5 5 5 0 99 99)) ; /* 99==invalid */ - (define cpdist - (vector - 1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 - 257 385 513 769 1025 1537 2049 3073 4097 6145 - 8193 12289 16385 24577)) - (define cpdext - (vector - 0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 - 7 7 8 8 9 9 10 10 11 11 - 12 12 13 13)) - - (define mask_bits - (vector - #x0000 - #x0001 #x0003 #x0007 #x000f #x001f #x003f #x007f #x00ff - #x01ff #x03ff #x07ff #x0fff #x1fff #x3fff #x7fff #xffff)) - - (define-const lbits 9) ; /* bits in base literal/length lookup table */ - (define-const dbits 6) ; /* bits in base distance lookup table */ - - - ; /* If BMAX needs to be larger than 16, then h and x[] should be ulg. */ - (define-const BMAX 16) ; /* maximum bit length of any code (16 for explode) */ - (define-const N_MAX 288) ; /* maximum number of codes in any set */ - -(define (inflate input-port output-port) - - (define slide (make-bytes WSIZE)) - (define wp 0) - - (define (flush-output len) - ; write out the data - (write-bytes slide output-port 0 len)) - - (define (check-flush) - (when (= wp WSIZE) - (flush-output WSIZE) - (set! wp 0))) - -#| -/* Macros for inflate() bit peeking and grabbing. - The usage is: - - NEEDBITS(j) - x = b & mask_bits[j]; - DUMPBITS(j) - - where NEEDBITS makes sure that b has at least j bits in it, and - DUMPBITS removes the bits from b. The macros use the variable k - for the number of bits in b. Normally, b and k are register - variables for speed, and are initialized at the beginning of a - routine that uses these macros from a global bit buffer and count. - - If we assume that EOB will be the longest code, then we will never - ask for bits with NEEDBITS that are beyond the end of the stream. - So, NEEDBITS should not read any more bytes than are needed to - meet the request. Then no bytes need to be "returned" to the buffer - at the end of the last block. - - However, this assumption is not true for fixed blocks--the EOB code - is 7 bits, but the other literal/length codes can be 8 or 9 bits. - (The EOB code is shorter than other codes because fixed blocks are - generally short. So, while a block always has an EOB, many other - literal/length codes have a significantly lower probability of - showing up at all.) However, by making the first table have a - lookup of seven bits, the EOB code will be found in that first - lookup, and so will not require that too many bits be pulled from - the stream. - */ -|# - - ;; We can't read the bytes outright, because we may - ;; look ahead. Assume that we need no more than 32 bytes - ;; look ahead, and peek in 4096-byte blocks. - (define MAX-LOOKAHEAD 32) - (define BUFFER-SIZE 4096) - (define buffer (make-bytes BUFFER-SIZE)) - (define buf-max 0) ; number of bytes in buffer - (define buf-pos 0) ; index into buffer = number of used peeked bytes - - (define bb 0) ; /* bit buffer */ - (define bk 0) ; /* bits in bit buffer */ - - (define (NEEDBITS n) - (when (< bk n) - (READBITS n))) - (define (READBITS n) - (if (= buf-pos buf-max) - (begin - (when (positive? buf-max) - (read-bytes! buffer input-port 0 (- buf-max MAX-LOOKAHEAD)) - ; (bytes-copy! buffer 0 buffer (- buf-max MAX-LOOKAHEAD) buf-max) - (set! buf-pos MAX-LOOKAHEAD)) - (let ([got (peek-bytes-avail! buffer buf-pos #f input-port buf-pos BUFFER-SIZE)]) - (if (eof-object? got) - (error 'inflate "unexpected end of file") - (set! buf-max (+ buf-pos got)))) - (READBITS n)) - (let ([v (bytes-ref buffer buf-pos)]) - (set! buf-pos (add1 buf-pos)) - (set! bb (+ bb (arithmetic-shift v bk))) - (set! bk (+ bk 8)) - (NEEDBITS n)))) - (define (DUMPBITS n) - (set! bb (arithmetic-shift bb (- n))) - (set! bk (- bk n))) - - (define (GETBITS n) - (NEEDBITS n) - (begin0 - bb - (DUMPBITS n))) - -#| -/* - Huffman code decoding is performed using a multi-level table lookup. - The fastest way to decode is to simply build a lookup table whose - size is determined by the longest code. However, the time it takes - to build this table can also be a factor if the data being decoded - is not very long. The most common codes are necessarily the - shortest codes, so those codes dominate the decoding time, and hence - the speed. The idea is you can have a shorter table that decodes the - shorter, more probable codes, and then point to subsidiary tables for - the longer codes. The time it costs to decode the longer codes is - then traded against the time it takes to make longer tables. - - This results of this trade are in the variables lbits and dbits - below. lbits is the number of bits the first level table for literal/ - length codes can decode in one step, and dbits is the same thing for - the distance codes. Subsequent tables are also less than or equal to - those sizes. These values may be adjusted either when all of the - codes are shorter than that, in which case the longest code length in - bits is used, or when the shortest code is *longer* than the requested - table size, in which case the length of the shortest code in bits is - used. - - There are two different values for the two tables, since they code a - different number of possibilities each. The literal/length table - codes 286 possible values, or in a flat code, a little over eight - bits. The distance table codes 30 possible values, or a little less - than five bits, flat. The optimum values for speed end up being - about one bit more than those, so lbits is 8+1 and dbits is 5+1. - The optimum values may differ though from machine to machine, and - possibly even between compilers. Your mileage may vary. - */ -|# - - (define (huft_build - b ; int vector /* code lengths in bits (all assumed <= BMAX) */ - n ; /* number of codes (assumed <= N_MAX) */ - s ; /* number of simple-valued codes (0..s-1) */ - d ; int vector /* list of base values for non-simple codes */ - e ; int vector /* list of extra bits for non-simple codes */ - m ; int /* maximum lookup bits, returns actual */ - incomp-ok?) - ; return: new-t new-m ok? - -#| -/* Given a list of code lengths and a maximum table size, make a set of - tables to decode that set of codes. Return zero on success, one if - the given code set is incomplete (the tables are still built in this - case), two if the input is invalid (all zero length codes or an - oversubscribed set of lengths), and three if not enough memory. */ -|# - (define c (make-vector (add1 BMAX) 0)) - (define x (make-vector (add1 BMAX))) - (define v (make-vector N_MAX)) - - (define final-y 0) - (define t-result #f) - - ; (printf "n: ~s\n" n) - - (let/ec return - -#| -(if (= n 270) - (step 0 < n add1 - (lambda (i) (printf "b[~a] = ~a\n" i (vector-ref b i))))) -|# - - (step 0 < n add1 - (lambda (i) - (let ([pos (vector-ref b i)]) - (vector-set! c pos (add1 (vector-ref c pos)))))) - - (when (= n (vector-ref c 0)) - ; (printf "zero\n") - (return #f 0 #t)) - -#| -(when (= n 270) - (step 0 <= BMAX add1 - (lambda (i) - (printf "c[~s]: ~s\n" i (vector-ref c i))))) -|# - - ; /* Find minimum and maximum length, bound m-result by those */ - (let* ([j ; min-code-length - (let loop ([j 1]) - (cond - [(> j BMAX) j] - [(positive? (vector-ref c j)) j] - [else (loop (add1 j))]))] - [k j] - [i ; max-code-length - (let loop ([i BMAX]) - (cond - [(zero? i) 0] - [(positive? (vector-ref c i)) i] - [else (loop (sub1 i))]))] - [g i] - [l (min (max m j) i)] - [m-result l]) - ; (printf "min: ~s max: ~s\n" k g) - ; /* Adjust last length count to fill out codes, if needed */ - (let-values ([(y j) - (let loop ([y (arithmetic-shift 1 j)][j j]) - (if (>= j i) - (values y j) - (let ([new-y (- y (vector-ref c j))]) - (if (negative? new-y) - (begin - (error 'inflate - "bad input: more codes than bits") - (return null m-result #f)) - (loop (* new-y 2) (add1 j))))))]) - ; (printf "loop y: ~s\n" y) - (let ([y (- y (vector-ref c i))]) - (when (negative? y) - (error 'inflate "bad input: more codes than bits") - (return #f m-result #f)) - ; (printf "set c[~s] ~s + ~s\n" i (vector-ref c i) y) - (vector-set! c i (+ (vector-ref c i) y)) - (set! final-y y))) - ; /* Generate starting offsets into the value table for each length */ - (vector-set! x 1 0) - (let* ([j (let loop ([i (sub1 i)][x-pos 2][c-pos 1][j 0]) - (if (zero? i) - j - (let ([v (vector-ref c c-pos)]) - (vector-set! x x-pos (+ j v)) - (loop (sub1 i) (add1 x-pos) (add1 c-pos) (+ j v)))))]) - ; /* Make a table of values in order of bit lengths */ - (let loop ([i 0][b-pos 0]) - (let ([j (vector-ref b b-pos)]) - (unless (zero? j) - (let ([xj (vector-ref x j)]) - (vector-set! x j (add1 xj)) - (vector-set! v xj i))) - (let ([new-i (add1 i)]) - (when (< new-i n) - (loop new-i (add1 b-pos)))))) - - ; /* Generate the Huffman codes and for each, make the table entries */ - (vector-set! x 0 0) ; /* first Huffman code is zero */ - (let ([v-pos 0] ; /* grab values in bit order */ - [i 0] ; /* the Huffman code of length k bits for value *p */ - [h -1] ; /* no tables yet--level -1 */ - [w (- l)] ; /* bits decoded == (l * h) */ - [u (make-vector BMAX)] ; /* table stack */ - [q null] ; /* points to current table */ - [z 0] ; /* number of entries in current table */ - [r (make-huft 0 0 0)]) ; /* table entry for structure assignment */ - ; /* go through the bit lengths (k already is bits in shortest code) */ - (let k-loop ([k k]) - ; (printf "k: ~s\n" k) - (when (<= k g) - (let ([a (vector-ref c k)]) - (let a-loop ([a (sub1 a)]) - (unless (negative? a) - ; (printf "a: ~s\n" a) - ; /* here i is the Huffman code of length k bits for value *p */ - ; /* make tables up to required level */ - (let kwl-loop () - (when (> k (+ w l)) - (set! h (add1 h)) - (set! w (+ w l)) ; /* previous table always l bits */ - - ; /* compute minimum size table less than or equal to l bits */ - (set! z (min (- g w) l)) ; /* upper limit on table size */ - - ; (printf "z: ~s k: ~s w: ~s\n" z k w) - - (let* ([j (- k w)] - [f (arithmetic-shift 1 j)]) - (when (> f (add1 a)) ; /* try a k-w bit table */ - ; /* too few codes for k-w bit table */ - (set! f (- f a 1)) ; /* deduct codes from patterns left */ - ; /* try smaller tables up to z bits */ - (let loop ([c-pos k]) - (set! j (add1 j)) - (when (< j z) - (set! f (* f 2)) - (let* ([c-pos (add1 c-pos)] - [cv (vector-ref c c-pos)]) - (if (<= f cv) - (void) ; /* enough codes to use up j bits */ - (begin - (set! f (- f cv)) ; /* else deduct codes from patterns */ - (loop c-pos))))))) - (set! z (arithmetic-shift 1 j)) ; /* table entries for j-bit table */ - - ; /* allocate and link in new table */ - ; (printf "alloc: ~a\n" z) - (set! q (build-vector z (lambda (i) (make-huft 0 0 0)))) - - (when (not t-result) - (set! t-result q)) - - (vector-set! u h q) - - ; /* connect to last table, if there is one */ - (unless (zero? h) - (vector-set! x h i) ; /* save pattern for backing up */ - (set-huft-b! r l) ; /* bits to dump before this table */ - (set-huft-e! r (+ j 16)); /* bits in this table */ - (set-huft-v! r q) ; /* pointer to this table */ - (set! j (arithmetic-shift i (- l w))) - ; /* connect to last table: */ - (huft-copy (vector-ref (vector-ref u (sub1 h)) j) r))) - - (kwl-loop))) - - (set-huft-b! r (- k w)) ; cast uch (- k w) if needed - (if (>= v-pos n) - (set-huft-e! r 99) ; /* out of values--invalid code */ - (let ([vv (vector-ref v v-pos)]) - ; (printf "*p: ~s s: ~s\n" vv s) - (if (< vv s) - (begin - (set-huft-e! r (if (< vv 256) 16 15)) ; /* 256 is end-of-block code */ - (set-huft-v! r vv)) ; /* simple code is just the value */ - (begin - (set-huft-e! r (vector-ref e (- vv s))) ; /* non-simple--look up in lists */ - (set-huft-v! r (vector-ref d (- vv s))))) - (set! v-pos (add1 v-pos)))) - ; /* fill code-like entries with r */ - ; (printf "i: ~s w: ~s k: ~s\n" i w k) - (let ([f (arithmetic-shift 1 (- k w))]) ; /* i repeats in table every f entries */ - (let loop ([j (arithmetic-shift i (- w))]) - (when (< j z) - (huft-copy (vector-ref q j) r) - (loop (+ j f))))) - ; /* backwards increment the k-bit code i */ - (let loop ([j (arithmetic-shift 1 (sub1 k))]) - (if (positive? (bitwise-and i j)) - (begin - (set! i (bitwise-xor i j)) - (loop (arithmetic-shift j -1))) - (set! i (bitwise-xor i j)))) - ; /* backup over finished tables */ - (let loop () - (unless (= (vector-ref x h) (bitwise-and i (sub1 (arithmetic-shift 1 w)))) - (set! h (sub1 h)) ; /* don't need to update q */ - (set! w (- w l)) - (loop))) - - (a-loop (sub1 a)))) - (k-loop (add1 k))))) - - ; /* Return #f as third if we were given an incomplete table */ - ; (printf "done: ~s ~s\n" final-y g) - (let ([ok? (or incomp-ok? - (not (and (not (zero? final-y)) - (not (= g 1)))))]) - (unless ok? - (error 'inflate "incomplete table")) - (values t-result m-result ok?))))))) - - (define (inflate_codes - tl ; vector of hufts ; /* literal/length tables */ - td ; vector of hufts ; /* distance decoder tables */ - bl ; /* number of bits decoded by tl */ - bd) ; /* number of bits decoded by td[] */ - ; /* inflate (decompress) the codes in a deflated (compressed) block. - ; Return an error code or zero if it all goes ok. */ - - ; /* inflate the coded data */ - - ; /* precompute masks for speed */ - (define ml (vector-ref mask_bits bl)) - (define md (vector-ref mask_bits bd)) - (define t (void)) - (define e 0) - (define n 0) - (define d 0) - - (let/ec return - - (define (jump-to-next) - (let loop () - (when (= e 99) - (error 'inflate "bad inflate code") - (return #f)) - (DUMPBITS (huft-b t)) - (set! e (- e 16)) - (NEEDBITS e) - (set! t (vector-ref (huft-v t) (bitwise-and bb (vector-ref mask_bits e)))) - (set! e (huft-e t)) - (when (> e 16) - (loop)))) - - (let loop () ; /* do until end of block */ - (NEEDBITS bl) - (set! t (vector-ref tl (bitwise-and bb ml))) - ; (printf "t->e: ~s t->b: ~s\n" (huft-e t) (huft-b t)) - (set! e (huft-e t)) - (when (> e 16) - (jump-to-next)) - (DUMPBITS (huft-b t)) - ; (printf "e: ~s\n" e) - (if (= e 16) ; /* then it's a literal */ - (begin - (bytes-set! slide wp (huft-v t)) - (set! wp (add1 wp)) - (check-flush)) - (begin ; /* it's an EOB or a length */ - ; /* exit if end of block */ - (when (= e 15) - (return #t)) - - ; /* get length of block to copy */ - (NEEDBITS e) - (set! n (+ (huft-v t) (bitwise-and bb (vector-ref mask_bits e)))) - (DUMPBITS e) - ; (printf "n: ~s bb: ~s md: ~s\n" n bb md) - - ; /* decode distance of block to copy */ - (NEEDBITS bd) - (set! t (vector-ref td (bitwise-and bb md))) - ; (printf "t->e: ~s t->b: ~s\n" (huft-e t) (huft-b t)) - (set! e (huft-e t)) - ; (printf "e: ~s\n" e) - (when (> e 16) - (jump-to-next)) - (DUMPBITS (huft-b t)) - ; (printf "e: ~s\n" e) - - (NEEDBITS e) - (set! d (modulo (- wp (huft-v t) (bitwise-and bb (vector-ref mask_bits e))) WSIZE)) - (DUMPBITS e) - - ; (printf "wp: ~s t->v: ~s d: ~s\n" wp (huft-v t) d) - - ; /* do the copy */ - (let loop () - (set! d (bitwise-and d (sub1 WSIZE))) - (set! e (min n (- WSIZE (max d wp)))) - (set! n (- n e)) - (let loop () - (bytes-set! slide wp (bytes-ref slide d)) - (set! wp (add1 wp)) - (set! d (add1 d)) - (set! e (sub1 e)) - (unless (zero? e) - (loop))) - (check-flush) - (unless (zero? n) - (loop))))) - (loop)))) - - (define (inflate_stored) - ; /* "decompress" an inflated type 0 (stored) block. */ - - (let/ec return - - ; /* go to byte boundary */ - (DUMPBITS (bitwise-and bk 7)) - - ; /* get the length and its complement */ - (NEEDBITS 16) - (let ([n (bitwise-and bb #xffff)]) - (DUMPBITS 16) - (NEEDBITS 16) - (unless (= n (bitwise-and (bitwise-not bb) #xffff)) - (error 'inflate "error in compressed data") - (return #f)) ; /* error in compressed data */ - (DUMPBITS 16) - - ; /* read and output the compressed data */ - (let loop ([n n]) - (when (positive? n) - (NEEDBITS 8) - (bytes-set! slide wp (bitwise-and bb #xff)) - (set! wp (add1 wp)) - (check-flush) - (DUMPBITS 8) - (loop (sub1 n)))) - - #t))) - - (define (inflate_fixed) - ; /* decompress an inflated type 1 (fixed Huffman codes) block. We should - ; either replace this with a custom decoder, or at least precompute the - ; Huffman tables. */ - - (define l (make-vector 288)) - - (step 0 < 144 add1 (lambda (i) (vector-set! l i 8))) - (step 144 < 256 add1 (lambda (i) (vector-set! l i 9))) - (step 256 < 280 add1 (lambda (i) (vector-set! l i 7))) - (step 280 < 288 add1 (lambda (i) (vector-set! l i 8))) - - (let-values ([(tl bl ok?) - (huft_build l 288 257 cplens cplext 7 #f)]) - - (if (not ok?) - #f - (begin - (step 0 < 30 add1 (lambda (i) (vector-set! l i 5))) - (let-values ([(td bd ok?) - (huft_build l 30 0 cpdist cpdext 5 #t)]) - (if (not ok?) - #f - ; /* decompress until an end-of-block code */ - (inflate_codes tl td bl bd))))))) - - (define (inflate_dynamic) - ; /* decompress an inflated type 2 (dynamic Huffman codes) block. */ - - (begin ; let/ec return - - ; /* read in table lengths */ - ; (define junk1 (begin (NEEDBITS 5) (printf "~s ~s\n" bb bk))) - (define nl (+ 257 (bitwise-and (GETBITS 5) #x1f))) - ; (define junk2 (begin (NEEDBITS 5) (printf "~s ~s\n" bb bk))) - (define nd (+ 1 (bitwise-and (GETBITS 5) #x1f))) - ; (define junk3 (begin (NEEDBITS 4) (printf "~s ~s\n" bb bk))) - (define nb (+ 4 (bitwise-and (GETBITS 4) #xf))) - - ; (define junk8 (printf "~s ~s ~s\n" nl nd nb)) - - (define ll (make-vector (+ 286 30))) - (define i 0) - (define l 0) - - (if (or (> nl 286) (> nd 30)) - (begin - (error 'inflate "bad lengths") - #f) ; /* bad lengths */ - (begin - ; /* read in bit-length-code lengths */ - (step 0 < nb add1 - (lambda (j) - (vector-set! ll (vector-ref border j) (bitwise-and (GETBITS 3) 7)))) - (step nb < 19 add1 - (lambda (j) - (vector-set! ll (vector-ref border j) 0))) - - ; /* build decoding table for trees--single level, 7 bit lookup */ - (let-values ([(tl bl ok?) - (huft_build ll 19 19 null null 7 #f)]) - (if (not ok?) - #f - (begin - ; /* read in literal and distance code lengths */ - (let ([n (+ nl nd)] - [m (vector-ref mask_bits bl)]) - ; (printf "bl: ~s\n" bl) - (set! i 0) - (set! l 0) - (let loop () - (when (< i n) - (NEEDBITS bl) - (let* ([pos (bitwise-and bb m)] - [td (vector-ref tl pos)] - [dmp (huft-b td)] - [j (huft-v td)] - [set-lit - (lambda (j l) - (when (> (+ i j) n) - (error 'inflate "bad hop") - #;(return #f)) - (let loop ([j j]) - (unless (zero? j) - (vector-set! ll i l) - (set! i (add1 i)) - (loop (sub1 j)))))]) - (DUMPBITS dmp) - ; (printf "pos: ~s j: ~s l: ~s i: ~s\n" pos j l i) - (cond - [(< j 16) ; /* length of code in bits (0..15) */ - (vector-set! ll i j) - (set! l j) ; /* save last length in l */ - (set! i (add1 i))] - [(= j 16) ; /* repeat last length 3 to 6 times */ - (let ([j (+ 3 (bitwise-and (GETBITS 2) 3))]) - (set-lit j l))] - [(= j 17) ; /* 3 to 10 zero length codes */ - (let ([j (+ 3 (bitwise-and (GETBITS 3) 7))]) - (set-lit j 0) - (set! l 0))] - [else ; /* j == 18: 11 to 138 zero length codes */ - (let ([j (+ 11 (bitwise-and (GETBITS 7) #x7f))]) - (set-lit j 0) - (set! l 0))])) - (loop))) - - ; /* build the decoding tables for literal/length and distance codes */ - (let-values ([(tl bl ok?) - (huft_build ll nl 257 cplens cplext lbits #f)]) - (if (not ok?) - (begin - (error 'inflate "incomplete code set") - #f) ; /* incomplete code set */ - (let-values ([(td bd ok?) - (huft_build (subvector ll nl) nd 0 cpdist cpdext dbits #f)]) - (if (not ok?) - (begin - (error 'inflate "incomplete code set") - #f) ; /* incomplete code set */ - ; /* decompress until an end-of-block code */ - (inflate_codes tl td bl bd))))))))))))) - - (define (inflate_block) - ; return values: /* last block flag */ ok? - ; /* decompress an inflated block */ - - (define e-result (bitwise-and (GETBITS 1) 1)) - - ; /* read in block type */ - (define t (bitwise-and (GETBITS 2) 3)) - - (values e-result - (case t - [(2) (inflate_dynamic)] - [(0) (inflate_stored)] - [(1) (inflate_fixed)] - [else (error 'inflate "unknown inflate type") - #f]))) - - ;;;;;;;;;;;;;;;;;;;;;;;; - ; inflate starts here - ;;;;;;;;;;;;;;;;;;;;;;;; - - ; /* decompress an inflated entry */ - ; /* initialize window, bit buffer */ - (set! wp 0) - (set! bk 0) - (set! bb 0) - - - ; /* decompress until the last block */ - (let loop () - (let-values ([(e ok?) (inflate_block)]) - (if ok? - (if (zero? e) - (loop) - (begin - ; /* Undo too much lookahead. The next read will be byte aligned so we - ; * can discard unused bits in the last meaningful byte. - ; */ - (let loop () - (when (>= bk 8) - (set! bk (- bk 8)) - (set! buf-pos (sub1 buf-pos)) - (loop))) - (read-bytes! buffer input-port 0 buf-pos) - (flush-output wp) - #t = (void))) - #f)))) - - (define make-small-endian - (case-lambda - [(a b) (+ a (arithmetic-shift b 8))] - [(a b c d) (+ a - (arithmetic-shift b 8) - (arithmetic-shift c 16) - (arithmetic-shift d 24))])) - - (define (do-gunzip in out name-filter) - (let ([header1 (read-byte in)] - [header2 (read-byte in)]) - (unless (and (= header1 #o037) (= header2 #o213)) - (error 'gnu-unzip "bad header"))) - (let ([compression-type (read-byte in)]) - (unless (= compression-type #o010) - (error 'gnu-unzip "unknown compression type"))) - (let* ([flags (read-byte in)] - [ascii? (positive? (bitwise-and flags #b1))] - [continuation? (positive? (bitwise-and flags #b10))] - [has-extra-field? (positive? (bitwise-and flags #b100))] - [has-original-filename? (positive? (bitwise-and flags #b1000))] - [has-comment? (positive? (bitwise-and flags #b10000))] - [encrypted? (positive? (bitwise-and flags #b100000))]) - (when encrypted? - (error 'gnu-unzip "cannot unzip encrypted file")) - (when continuation? - (error 'gnu-unzip "cannot handle multi-part files")) - (let ([unix-mod-time (make-small-endian (read-byte in) (read-byte in) - (read-byte in) (read-byte in))] - [extra-flags (read-byte in)] - [source-os (read-byte in)]) - (when continuation? - (let ([part-number (make-small-endian (read-byte in) (read-byte in))]) - 'ok)) - (when has-extra-field? - (let ([len (make-small-endian (read-byte in) (read-byte in))]) - (let loop ([len len]) - (unless (zero? len) - (read-byte in) - (loop (sub1 len)))))) - (let* ([read-null-term-string - (lambda () - (let loop ([s null]) - (let ([r (read-byte in)]) - (if (zero? r) - (list->bytes (reverse s)) - (loop (cons r s))))))] - [original-filename (and has-original-filename? - (read-null-term-string))] - [comment (and has-comment? (read-null-term-string))]) - (when encrypted? - (let loop ([n 12]) - (unless (zero? n) - (read-byte in) - (loop (sub1 n))))) - - (let-values ([(out close?) (if out - (values out #f) - (let-values ([(fn orig?) - (if original-filename - (values (bytes->path original-filename) #t) - (values "unzipped" #f))]) - (values (open-output-file (name-filter fn orig?) #:exists 'truncate) - #t)))]) - (dynamic-wind - void - (lambda () (begin0 (inflate in out) - (read-bytes 8 in))) ; read CRC32 and ISIZE - (lambda () (when close? (close-output-port out))))))))) - - (define (gunzip-through-ports in out) - (do-gunzip in out void)) - - (define gunzip - (case-lambda - [(src) (gunzip src (lambda (name from-file?) name))] - [(src name-filter) - (let ([in (open-input-file src #:mode 'binary)]) - (dynamic-wind - void - (lambda () (do-gunzip in #f name-filter)) - (lambda () (close-input-port in))))])) +;; deprecated library, see `file/gunzip` +(require file/gunzip) +(provide (all-from-out file/gunzip)) diff --git a/collects/mzlib/port.rkt b/collects/mzlib/port.rkt index e331742..73c8ee9 100644 --- a/collects/mzlib/port.rkt +++ b/collects/mzlib/port.rkt @@ -1,1796 +1,11 @@ #lang racket/base -(require (for-syntax racket/base) - racket/contract/base - "private/port.rkt") +;; deprecated library, see `racket/port` -(define (input-port-with-progress-evts? ip) - (and (input-port? ip) - (port-provides-progress-evts? ip))) - -(define (mutable-bytes? b) - (and (bytes? b) (not (immutable? b)))) -(define (mutable-string? b) - (and (string? b) (not (immutable? b)))) - -(define (line-mode-symbol? s) - (memq s '(linefeed return return-linefeed any any-one))) - -(define (evt?/false v) - (or (eq? #f v) (evt? v))) - -;; ---------------------------------------- - -(define (strip-shell-command-start in) - (when (regexp-match-peek #rx#"^#![^\r\n]*" in) - (let loop ([s (read-line in)]) - (when (regexp-match #rx#"\\\\$" s) - (loop (read-line in)))))) - -;; ---------------------------------------- - -(define merge-input - (case-lambda - [(a b) (merge-input a b 4096)] - [(a b limit) - (or (input-port? a) - (raise-argument-error 'merge-input "input-port?" a)) - (or (input-port? b) - (raise-argument-error 'merge-input "input-port?" b)) - (or (not limit) - (and (number? limit) (positive? limit) (exact? limit) (integer? limit)) - (raise-argument-error 'merge-input "(or/c exact-positive-integer #f)" limit)) - (let-values ([(rd wt) (make-pipe-with-specials limit)] - [(other-done?) #f] - [(sema) (make-semaphore 1)]) - (let ([copy - (lambda (from) - (thread - (lambda () - (copy-port from wt) - (semaphore-wait sema) - (if other-done? - (close-output-port wt) - (set! other-done? #t)) - (semaphore-post sema))))]) - (copy a) - (copy b) - rd))])) - -;; `make-input-port/read-to-peek' sometimes needs to wrap a special-value -;; procedure so that it's only called once when the value is both -;; peeked and read. -(define-values (struct:memoized make-memoized memoized? memoized-ref memoized-set!) - (make-struct-type 'memoized #f 1 0 #f null (current-inspector) 0)) -(define (memoize p) - (define result #f) - (make-memoized - (if (procedure-arity-includes? p 0) - ;; original p accepts 0 or 4 arguments: - (case-lambda - [() (unless result (set! result (box (p)))) (unbox result)] - [(src line col pos) - (unless result (set! result (box (p src line col pos)))) - (unbox result)]) - ;; original p accepts only 4 arguments: - (lambda (src line col pos) - (unless result (set! result (box (p src line col pos)))) - (unbox result))))) - -;; Not kill-safe. -;; If the `read' proc returns an event, the event must produce -;; 0 always (which implies that the `read' proc must not return -;; a pipe input port). -(define make-input-port/read-to-peek - (lambda (name read fast-peek close - [location-proc #f] - [count-lines!-proc void] - [init-position 1] - [buffer-mode-proc #f] - [buffering? #f] - [on-consumed #f]) - (define lock-semaphore (make-semaphore 1)) - (define commit-semaphore (make-semaphore 1)) - (define-values (peeked-r peeked-w) (make-pipe)) - (define special-peeked null) - (define special-peeked-tail #f) - (define progress-requested? #f) - (define line-counting? #f) - (define use-manager? #f) - (define manager-th #f) - (define manager-ch (make-channel)) - (define resume-ch (make-channel)) - (define buf (make-bytes 4096)) - (define (try-again) - (wrap-evt - (semaphore-peek-evt lock-semaphore) - (lambda (x) 0))) - (define (suspend-manager) - (channel-put manager-ch 'suspend)) - (define (resume-manager) - (channel-put resume-ch 'resume)) - (define (with-manager-lock thunk) - (thread-resume manager-th (current-thread)) - (dynamic-wind suspend-manager thunk resume-manager)) - (define (make-progress) - ;; We dont worry about this byte getting picked up directly - ;; from peeked-r, because the pipe must have been empty when - ;; we grabed the lock, and since we've grabbed the lock, - ;; no other thread could have re-returned the pipe behind - ;; our back. - (write-byte 0 peeked-w) - (read-byte peeked-r)) - (define (consume-from-peeked s) - (let ([n (read-bytes-avail!* s peeked-r)]) - (when on-consumed (on-consumed n)) - n)) - (define (read-it-with-lock s) - (if use-manager? - (with-manager-lock (lambda () (do-read-it s))) - (do-read-it s))) - (define (read-it s) - (call-with-semaphore lock-semaphore read-it-with-lock try-again s)) - (define (do-read-it s) - (if (byte-ready? peeked-r) - (if on-consumed (consume-from-peeked s) peeked-r) - ;; If nothing is saved from a peeking read, dispatch to - ;; `read', otherwise return previously peeked data - (cond - [(null? special-peeked) - (when progress-requested? (make-progress)) - (if (and buffering? ((bytes-length s) . < . 10)) - ;; Buffering is enabled, so read more to move things - ;; along: - (let ([r (read buf)]) - (if (and (number? r) (positive? r)) - (begin (write-bytes buf peeked-w 0 r) - (if on-consumed (consume-from-peeked s) peeked-r)) - (begin (when on-consumed (on-consumed r)) - r))) - ;; Just read requested amount: - (let ([v (read s)]) - (when on-consumed (on-consumed v)) - v))] - [else (if (bytes? (mcar special-peeked)) - (let ([b (mcar special-peeked)]) - (write-bytes b peeked-w) - (set! special-peeked (mcdr special-peeked)) - (when (null? special-peeked) (set! special-peeked-tail #f)) - (consume-from-peeked s)) - (let ([v (mcar special-peeked)]) - (make-progress) - (set! special-peeked (mcdr special-peeked)) - (when on-consumed (on-consumed v)) - (when (null? special-peeked) (set! special-peeked-tail #f)) - v))]))) - (define (peek-it-with-lock s skip unless-evt) - (if use-manager? - (with-manager-lock (lambda () (do-peek-it s skip unless-evt))) - (do-peek-it s skip unless-evt))) - (define (peek-it s skip unless-evt) - (let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)]) - (if (eq? v 0) - (call-with-semaphore lock-semaphore - peek-it-with-lock try-again s skip unless-evt) - v))) - (define (do-peek-it s skip unless-evt) - (let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)]) - (if (eq? v 0) - ;; The peek may have failed because peeked-r is empty, - ;; because unless-evt is ready, or because the skip is - ;; far. Handle nicely the common case where there are no - ;; specials. - (cond - [(and unless-evt (sync/timeout 0 unless-evt)) - #f] - [(null? special-peeked) - ;; Empty special queue, so read through the original proc. - ;; We only only need - ;; (- (+ skip (bytes-length s)) (pipe-content-length peeked-w)) - ;; bytes, but if buffering is enabled, read more (up to size of - ;; buf) to help move things along. - (let* ([dest (if buffering? - buf - (make-bytes (- (+ skip (bytes-length s)) - (pipe-content-length peeked-w))))] - [r (read dest)]) - (cond - [(number? r) - ;; The nice case --- reading gave us more bytes - (write-bytes dest peeked-w 0 r) - ;; Now try again - (peek-bytes-avail!* s skip #f peeked-r)] - [(evt? r) - (if unless-evt - ;; Technically, there's a race condition here. - ;; We might choose r (and return 0) even when - ;; unless-evt becomes available first. However, - ;; this race is detectable only by the inside - ;; of `read'. - (choice-evt r (wrap-evt unless-evt (lambda (x) #f))) - r)] - [else - (set! special-peeked (mcons r null)) - (set! special-peeked-tail special-peeked) - ;; Now try again - (do-peek-it s skip unless-evt)]))] - [else - ;; Non-empty special queue, so try to use it - (let* ([avail (pipe-content-length peeked-r)] - [sk (- skip avail)]) - (let loop ([sk sk] [l special-peeked]) - (cond - [(null? l) - ;; Not enough even in the special queue. - ;; Read once and add it. - (let* ([t (make-bytes (min 4096 (+ sk (bytes-length s))))] - [r (read t)]) - (cond - [(evt? r) - (if unless-evt - ;; See note above - (choice-evt r (wrap-evt unless-evt (lambda (x) #f))) - r)] - [(eq? r 0) - ;; Original read thinks a spin is ok, - ;; so we return 0 to skin, too. - 0] - [else (let ([v (if (number? r) - (subbytes t 0 r) - r)]) - (let ([pr (mcons v null)]) - (set-mcdr! special-peeked-tail pr) - (set! special-peeked-tail pr)) - ;; Got something; now try again - (do-peek-it s skip unless-evt))]))] - [(eof-object? (mcar l)) - ;; No peeking past an EOF - eof] - [(procedure? (mcar l)) - (if (zero? sk) - ;; We should call the procedure only once. Change - ;; (mcar l) to a memoizing function, if it isn't already: - (let ([proc (mcar l)]) - (if (memoized? proc) - proc - (let ([proc (memoize proc)]) - (set-mcar! l proc) - proc))) - ;; Skipping over special... - (loop (sub1 sk) (mcdr l)))] - [(bytes? (mcar l)) - (let ([len (bytes-length (mcar l))]) - (if (sk . < . len) - (let ([n (min (bytes-length s) - (- len sk))]) - (bytes-copy! s 0 (mcar l) sk (+ sk n)) - n) - (loop (- sk len) (mcdr l))))])))]) - v))) - (define (commit-it-with-lock amt unless-evt done-evt) - (if use-manager? - (with-manager-lock (lambda () (do-commit-it amt unless-evt done-evt))) - (do-commit-it amt unless-evt done-evt))) - (define (commit-it amt unless-evt done-evt) - (call-with-semaphore lock-semaphore - commit-it-with-lock #f amt unless-evt done-evt)) - (define (do-commit-it amt unless-evt done-evt) - (if (sync/timeout 0 unless-evt) - #f - (let* ([avail (pipe-content-length peeked-r)] - [p-commit (min avail amt)]) - (let loop ([amt (- amt p-commit)] - [l special-peeked] - ;; result is either bytes (if needed for line ounting) - ;; or an integer count (for on-consumed) - [result (if line-counting? null 0)]) - (cond - [(amt . <= . 0) - ;; Enough has been peeked. Do commit... - (actual-commit p-commit l unless-evt done-evt result)] - [(null? l) - ;; Requested commit was larger than previous peeks - #f] - [(bytes? (mcar l)) - (let ([bl (bytes-length (mcar l))]) - (if (bl . > . amt) - ;; Split the string - (let ([next (mcons (subbytes (mcar l) amt) (mcdr l))]) - (set-mcar! l (subbytes (mcar l) 0 amt)) - (set-mcdr! l next) - (when (eq? l special-peeked-tail) - (set! special-peeked-tail next)) - (loop 0 (mcdr l) (if line-counting? - (cons (subbytes (mcar l) 0 amt) result) - (+ amt result)))) - ;; Consume this string... - (loop (- amt bl) (mcdr l) (if line-counting? - (cons (mcar l) result) - (+ bl result)))))] - [else - (loop (sub1 amt) (mcdr l) (if line-counting? - (cons #"." result) - (add1 result)))]))))) - (define (actual-commit p-commit l unless-evt done-evt result) - ;; The `finish' proc finally, actually, will commit... - (define (finish) - (let ([result (if line-counting? - (cons (peek-bytes p-commit 0 peeked-r) result) - (+ p-commit result))]) - (unless (zero? p-commit) - (peek-byte peeked-r (sub1 p-commit)) - (port-commit-peeked p-commit unless-evt always-evt peeked-r)) - (set! special-peeked l) - (when (null? special-peeked) (set! special-peeked-tail #f)) - (when (and progress-requested? (zero? p-commit)) (make-progress)) - (if line-counting? - ;; bytes representation of committed text allows line counting - ;; to be updated correctly (when line counting is implemented - ;; automatically) - (let ([bstr (apply bytes-append (reverse result))]) - (when on-consumed (on-consumed (bytes-length bstr))) - bstr) - (begin - (when on-consumed (on-consumed result)) - #t)))) - ;; If we can sync done-evt immediately, then finish. - (if (sync/timeout 0 (wrap-evt done-evt (lambda (x) #t))) - (finish) - ;; We need to wait, so we'll have to release the lock. - ;; Send the work to a manager thread. - (let ([result-ch (make-channel)] - [w/manager? use-manager?]) - (if w/manager? - ;; Resume manager if it was running: - (resume-manager) - ;; Start manager if it wasn't running: - (begin (set! manager-th (thread manage-commits)) - (set! use-manager? #t) - (thread-resume manager-th (current-thread)))) - ;; Sets use-manager? if the manager wasn't already running: - (channel-put manager-ch (list finish unless-evt done-evt result-ch)) - ;; Release locks: - (semaphore-post lock-semaphore) - (begin0 ;; Wait for manager to complete commit: - (sync result-ch) - ;; Grab locks again, so they're released - ;; properly on exit: - (semaphore-wait lock-semaphore) - (when w/manager? (suspend-manager)))))) - (define (manage-commits) - (let loop ([commits null]) - (apply - sync - (handle-evt manager-ch - (lambda (c) - (case c - [(suspend) - (channel-get resume-ch) - (loop commits)] - [else - ;; adding a commit - (loop (cons c commits))]))) - (map (lambda (c) - (define (send-result v) - ;; Create a new thread to send the result asynchronously: - (thread-resume - (thread (lambda () (channel-put (list-ref c 3) v))) - (current-thread)) - (when (null? (cdr commits)) - (set! use-manager? #f)) - (loop (remq c commits))) - ;; Choose between done and unless: - (if (sync/timeout 0 (list-ref c 1)) - (handle-evt always-evt (lambda (x) (send-result #f))) - (choice-evt - (handle-evt (list-ref c 1) - (lambda (x) - ;; unless ready, which means that the commit must fail - (send-result #f))) - (handle-evt (list-ref c 2) - (lambda (x) - ;; done-evt ready, which means that the commit - ;; must succeed. - ;; If we get here, then commits are not - ;; suspended, so we implicitly have the - ;; lock. - ((list-ref c 0)) - (send-result #t)))))) - commits)))) - (make-input-port - name - ;; Read - read-it - ;; Peek - (if fast-peek - (let ([fast-peek-k (lambda (s skip) (peek-it s skip #f))]) - (lambda (s skip unless-evt) - (if (or unless-evt - (byte-ready? peeked-r) - (mpair? special-peeked)) - (peek-it s skip unless-evt) - (fast-peek s skip fast-peek-k)))) - peek-it) - close - (lambda () - (set! progress-requested? #t) - (port-progress-evt peeked-r)) - commit-it - location-proc - (lambda () - (set! line-counting? #t) - (count-lines!-proc)) - init-position - (and buffer-mode-proc - (case-lambda - [() (buffer-mode-proc)] - [(mode) - (set! buffering? (eq? mode 'block)) - (buffer-mode-proc mode)]))))) - -(define (peeking-input-port orig-in - [name (object-name orig-in)] - [delta 0] - #:init-position [init-position 1]) - (make-input-port/read-to-peek - name - (lambda (s) - (let ([r (peek-bytes-avail!* s delta #f orig-in)]) - (set! delta (+ delta (if (number? r) r 1))) - (if (eq? r 0) (wrap-evt orig-in (lambda (v) 0)) r))) - (lambda (s skip default) - (peek-bytes-avail!* s (+ delta skip) #f orig-in)) - void - #f - void - init-position)) - -(define relocate-input-port - (lambda (p line col pos [close? #t]) - (transplant-to-relocate transplant-input-port p line col pos close?))) - -(define transplant-input-port - (lambda (p location-proc pos [close? #t] [count-lines!-proc void]) - (make-input-port - (object-name p) - (lambda (s) - (let ([v (read-bytes-avail!* s p)]) - (if (eq? v 0) (wrap-evt p (lambda (x) 0)) v))) - (lambda (s skip evt) - (let ([v (peek-bytes-avail!* s skip evt p)]) - (if (eq? v 0) - (choice-evt - (wrap-evt p (lambda (x) 0)) - (if evt (wrap-evt evt (lambda (x) #f)) never-evt)) - v))) - (lambda () - (when close? (close-input-port p))) - (and (port-provides-progress-evts? p) - (lambda () (port-progress-evt p))) - (and (port-provides-progress-evts? p) - (lambda (n evt target-evt) (port-commit-peeked n evt target-evt p))) - location-proc - count-lines!-proc - pos))) - -(define filter-read-input-port - (lambda (p wrap-read wrap-peek [close? #t]) - (make-input-port - (object-name p) - (lambda (s) - (let ([v (read-bytes-avail!* s p)]) - (wrap-read - s - (if (eq? v 0) (wrap-evt p (lambda (x) 0)) v)))) - (lambda (s skip evt) - (let ([v (peek-bytes-avail!* s skip evt p)]) - (wrap-peek - s skip evt - (if (eq? v 0) - (choice-evt - (wrap-evt p (lambda (x) 0)) - (if evt (wrap-evt evt (lambda (x) #f)) never-evt)) - v)))) - (lambda () - (when close? (close-input-port p))) - (and (port-provides-progress-evts? p) - (lambda () (port-progress-evt p))) - (and (port-provides-progress-evts? p) - (lambda (n evt target-evt) (port-commit-peeked n evt target-evt p))) - (lambda () (port-next-location p)) - (lambda () (port-count-lines! p)) - (add1 (file-position p))))) - -;; Not kill-safe. -(define make-pipe-with-specials - ;; This implementation of pipes is almost CML-style, with a manager thread - ;; to guard access to the pipe content. But we only enable the manager - ;; thread when write evts are active; otherwise, we use a lock semaphore. - ;; (Actually, the lock semaphore has to be used all the time, to guard - ;; the flag indicating whether the manager thread is running.) - (lambda ([limit (expt 2 64)] [in-name 'pipe] [out-name 'pipe]) - (let-values ([(r w) (make-pipe limit)] - [(more) null] - [(more-last) #f] - [(more-sema) #f] - [(close-w?) #f] - [(lock-semaphore) (make-semaphore 1)] - [(mgr-th) #f] - [(via-manager?) #f] - [(mgr-ch) (make-channel)]) - (define (flush-more) - (if (null? more) - (begin (set! more-last #f) - (when close-w? (close-output-port w))) - (when (bytes? (mcar more)) - (let ([amt (bytes-length (mcar more))]) - (let ([wrote (write-bytes-avail* (mcar more) w)]) - (if (= wrote amt) - (begin (set! more (mcdr more)) - (flush-more)) - (begin - ;; This means that we let too many bytes - ;; get written while a special was pending. - ;; (The limit is disabled when a special - ;; is in the pipe.) - (set-mcar! more (subbytes (mcar more) wrote)) - ;; By peeking, make room for more: - (peek-byte r (sub1 (min (pipe-content-length w) - (- amt wrote)))) - (flush-more)))))))) - (define (read-one s) - (let ([v (read-bytes-avail!* s r)]) - (if (eq? v 0) - (if more-last - ;; Return a special - (let ([a (mcar more)]) - (set! more (mcdr more)) - (flush-more) - (lambda (file line col ppos) a)) - ;; Nothing available, yet. - (begin (unless more-sema (set! more-sema (make-semaphore))) - (wrap-evt (semaphore-peek-evt more-sema) - (lambda (x) 0)))) - v))) - (define (close-it) - (set! close-w? #t) - (unless more-last (close-output-port w)) - (when more-sema (semaphore-post more-sema))) - (define (write-these-bytes str start end) - (begin0 (if more-last - (let ([p (mcons (subbytes str start end) null)]) - (set-mcdr! more-last p) - (set! more-last p) - (- end start)) - (let ([v (write-bytes-avail* str w start end)]) - (if (zero? v) (wrap-evt w (lambda (x) #f)) v))) - (when more-sema - (semaphore-post more-sema) - (set! more-sema #f)))) - (define (write-spec v) - (let ([p (mcons v null)]) - (if more-last (set-mcdr! more-last p) (set! more p)) - (set! more-last p) - (when more-sema - (semaphore-post more-sema) - (set! more-sema #f)))) - (define (serve) - ;; A request is - ;; (list sym result-ch nack-evt . v) - ;; where `v' varies for different `sym's - ;; The possible syms are: read, reply, close, - ;; write, write-spec, write-evt, write-spec-evt - (let loop ([reqs null]) - (apply - sync - ;; Listen for a request: - (handle-evt - mgr-ch - (lambda (req) - (let ([req - ;; Most requests we handle immediately and - ;; convert to a reply. The manager thread - ;; implicitly has the lock. - (let ([reply (lambda (v) - (list 'reply (cadr req) (caddr req) v))]) - (case (car req) - [(read) - (reply (read-one (cadddr req)))] - [(close) - (reply (close-it))] - [(write) - (reply (apply write-these-bytes (cdddr req)))] - [(write-spec) - (reply (write-spec (cadddr req)))] - [else req]))]) - (loop (cons req reqs))))) - (if (and (null? reqs) via-manager?) - ;; If we can get the lock before another request - ;; turn off manager mode: - (handle-evt lock-semaphore - (lambda (x) - (set! via-manager? #f) - (semaphore-post lock-semaphore) - (loop null))) - never-evt) - (append - (map (lambda (req) - (case (car req) - [(reply) - (handle-evt (channel-put-evt (cadr req) (cadddr req)) - (lambda (x) (loop (remq req reqs))))] - [(write-spec-evt) - (if close-w? - ;; Report close error: - (handle-evt (channel-put-evt (cadr req) 'closed) - (lambda (x) (loop (remq req reqs)))) - ;; Try to write special: - (handle-evt (channel-put-evt (cadr req) #t) - (lambda (x) - ;; We sync'd, so now we *must* write - (write-spec (cadddr req)) - (loop (remq req reqs)))))] - [(write-evt) - (if close-w? - ;; Report close error: - (handle-evt (channel-put-evt (cadr req) 'closed) - (lambda (x) (loop (remq req reqs)))) - ;; Try to write bytes: - (let* ([start (list-ref req 4)] - [end (list-ref req 5)] - [len (if more-last - (- end start) - (min (- end start) - (max 0 - (- limit (pipe-content-length w)))))]) - (if (and (zero? len) (null? more)) - (handle-evt w (lambda (x) (loop reqs))) - (handle-evt - (channel-put-evt (cadr req) len) - (lambda (x) - ;; We sync'd, so now we *must* write - (write-these-bytes (cadddr req) start (+ start len)) - (loop (remq req reqs)))))))])) - reqs) - ;; nack => remove request (could be anything) - (map (lambda (req) - (handle-evt (caddr req) - (lambda (x) (loop (remq req reqs))))) - reqs))))) - (define (via-manager what req-sfx) - (thread-resume mgr-th (current-thread)) - (let ([ch (make-channel)]) - (sync (nack-guard-evt - (lambda (nack) - (channel-put mgr-ch (list* what ch nack req-sfx)) - ch))))) - (define (start-mgr) - (unless mgr-th (set! mgr-th (thread serve))) - (set! via-manager? #t)) - (define (evt what req-sfx) - (nack-guard-evt - (lambda (nack) - (resume-mgr) - (let ([ch (make-channel)]) - (call-with-semaphore - lock-semaphore - (lambda () - (unless mgr-th (set! mgr-th (thread serve))) - (set! via-manager? #t) - (thread-resume mgr-th (current-thread)) - (channel-put mgr-ch (list* what ch nack req-sfx)) - (wrap-evt ch (lambda (x) - (if (eq? x 'close) - (raise-mismatch-error 'write-evt "port is closed: " out) - x))))))))) - (define (resume-mgr) - (when mgr-th (thread-resume mgr-th (current-thread)))) - (define in - ;; ----- Input ------ - (make-input-port/read-to-peek - in-name - (lambda (s) - (let ([v (read-bytes-avail!* s r)]) - (if (eq? v 0) - (begin (resume-mgr) - (call-with-semaphore - lock-semaphore - (lambda () - (if via-manager? - (via-manager 'read (list s)) - (read-one s))))) - v))) - #f - void)) - (define out - ;; ----- Output ------ - (make-output-port - out-name - w - ;; write - (lambda (str start end buffer? w/break?) - (if (= start end) - 0 - (begin - (resume-mgr) - (call-with-semaphore - lock-semaphore - (lambda () - (if via-manager? - (via-manager 'write (list str start end)) - (write-these-bytes str start end))))))) - ;; close - (lambda () - (resume-mgr) - (call-with-semaphore - lock-semaphore - (lambda () - (if via-manager? (via-manager 'close null) (close-it))))) - ;; write-special - (lambda (v buffer? w/break?) - (resume-mgr) - (call-with-semaphore - lock-semaphore - (lambda () - (if via-manager? - (via-manager 'write-spec (list v)) - (write-spec v))))) - ;; write-evt - (lambda (str start end) - (if (= start end) - (wrap-evt always-evt (lambda (x) 0)) - (evt 'write-evt (list str start end)))) - ;; write-special-evt - (lambda (v) - (evt 'write-spec-evt (list v))))) - (values in out)))) - -(define input-port-append - (lambda (close-orig? . ports) - (make-input-port - (map object-name ports) - (lambda (str) - ;; Reading is easy -- read from the first port, - ;; and get rid of it if the result is eof - (if (null? ports) - eof - (let ([n (read-bytes-avail!* str (car ports))]) - (cond - [(eq? n 0) (wrap-evt (car ports) (lambda (x) 0))] - [(eof-object? n) - (when close-orig? (close-input-port (car ports))) - (set! ports (cdr ports)) - 0] - [else n])))) - (lambda (str skip unless-evt) - ;; Peeking is more difficult, due to skips. - (let loop ([ports ports][skip skip]) - (if (null? ports) - eof - (let ([n (peek-bytes-avail!* str skip unless-evt (car ports))]) - (cond - [(eq? n 0) - ;; Not ready, yet. - (peek-bytes-avail!-evt str skip unless-evt (car ports))] - [(eof-object? n) - ;; Port is exhausted, or we skipped past its input. - ;; If skip is not zero, we need to figure out - ;; how many chars were skipped. - (loop (cdr ports) - (- skip (compute-avail-to-skip skip (car ports))))] - [else n]))))) - (lambda () - (when close-orig? - (map close-input-port ports)))))) - -(define (convert-stream from from-port to to-port) - (let ([c (bytes-open-converter from to)] - [in (make-bytes 4096)] - [out (make-bytes 4096)]) - (unless c - (error 'convert-stream "could not create converter from ~e to ~e" - from to)) - (dynamic-wind - void - (lambda () - (let loop ([got 0]) - (let ([n (read-bytes-avail! in from-port got)]) - (let ([got (+ got (if (number? n) n 0))]) - (let-values ([(wrote used status) (bytes-convert c in 0 got out)]) - (when (eq? status 'error) - (error 'convert-stream "conversion error")) - (unless (zero? wrote) - (write-bytes out to-port 0 wrote)) - (bytes-copy! in 0 in used got) - (if (not (number? n)) - (begin - (unless (= got used) - (error 'convert-stream - "input stream ~a with a partial conversion" - (if (eof-object? n) "ended" "hit a special value"))) - (let-values ([(wrote status) (bytes-convert-end c out)]) - (when (eq? status 'error) - (error 'convert-stream "conversion-end error")) - (unless (zero? wrote) - (write-bytes out to-port 0 wrote)) - (if (eof-object? n) - ;; Success - (void) - (begin (write-special n to-port) - (loop 0))))) - (loop (- got used)))))))) - (lambda () (bytes-close-converter c))))) - -;; Helper for input-port-append; given a skip count -;; and an input port, determine how many characters -;; (up to upto) are left in the port. We figure this -;; out using binary search. -(define (compute-avail-to-skip upto p) - (let ([str (make-bytes 1)]) - (let loop ([upto upto][skip 0]) - (if (zero? upto) - skip - (let* ([half (quotient upto 2)] - [n (peek-bytes-avail!* str (+ skip half) #f p)]) - (if (eq? n 1) - (loop (- upto half 1) (+ skip half 1)) - (loop half skip))))))) - -(define make-limited-input-port - (lambda (port limit [close-orig? #t]) - (let ([got 0] - [lock-semaphore (make-semaphore 1)]) - (define (do-read str) - (let ([count (min (- limit got) (bytes-length str))]) - (if (zero? count) - eof - (let ([n (read-bytes-avail!* str port 0 count)]) - (cond [(eq? n 0) (wrap-evt port (lambda (x) 0))] - [(number? n) (set! got (+ got n)) n] - [(procedure? n) (set! got (add1 got)) n] - [else n]))))) - (define (do-peek str skip progress-evt) - (let ([count (max 0 (min (- limit got skip) (bytes-length str)))]) - (if (zero? count) - eof - (let ([n (peek-bytes-avail!* str skip progress-evt port 0 count)]) - (if (eq? n 0) - (wrap-evt port (lambda (x) 0)) - n))))) - (define (try-again) - (wrap-evt - (semaphore-peek-evt lock-semaphore) - (lambda (x) 0))) - (make-input-port - (object-name port) - (lambda (str) - (call-with-semaphore - lock-semaphore - do-read - try-again - str)) - (lambda (str skip progress-evt) - (call-with-semaphore - lock-semaphore - do-peek - try-again - str skip progress-evt)) - (lambda () - (when close-orig? - (close-input-port port))) - (and (port-provides-progress-evts? port) - (lambda () (port-progress-evt port))) - (and (port-provides-progress-evts? port) - (lambda (n evt target-evt) - (let loop () - (if (semaphore-try-wait? lock-semaphore) - (let ([ok? (port-commit-peeked n evt target-evt port)]) - (when ok? (set! got (+ got n))) - (semaphore-post lock-semaphore) - ok?) - (sync (handle-evt evt (lambda (v) #f)) - (handle-evt (semaphore-peek-evt lock-semaphore) - (lambda (v) (loop)))))))) - (lambda () (port-next-location port)) - (lambda () (port-count-lines! port)) - (add1 (file-position port)))))) - -(define special-filter-input-port - (lambda (p filter [close? #t]) - (unless (input-port? p) - (raise-argument-error 'special-filter-input-port "input-port?" p)) - (unless (and (procedure? filter) - (procedure-arity-includes? filter 2)) - (raise-argument-error 'special-filter-input-port "(any/c bytes? . -> . any/c)" filter)) - (make-input-port - (object-name p) - (lambda (s) - (let ([v (read-bytes-avail!* s p)]) - (cond - [(eq? v 0) (wrap-evt p (lambda (x) 0))] - [(procedure? v) (filter v s)] - [else v]))) - (lambda (s skip evt) - (let ([v (peek-bytes-avail!* s skip evt p)]) - (cond - [(eq? v 0) - (choice-evt - (wrap-evt p (lambda (x) 0)) - (if evt (wrap-evt evt (lambda (x) #f)) never-evt))] - [(procedure? v) (filter v s)] - [else v]))) - (lambda () - (when close? (close-input-port p))) - (and (port-provides-progress-evts? p) - (lambda () (port-progress-evt p))) - (and (port-provides-progress-evts? p) - (lambda (n evt target-evt) (port-commit-peeked n evt target-evt p))) - (lambda () (port-next-location p)) - (lambda () (port-count-lines! p)) - (add1 (file-position p))))) - -;; ---------------------------------------- - -(define (poll-or-spawn go) - (poll-guard-evt - (lambda (poll?) - (if poll? - ;; In poll mode, call `go' directly: - (let ([v (go never-evt #f #t)]) - (if v (wrap-evt always-evt (lambda (x) v)) never-evt)) - ;; In non-poll mode, start a thread to call go - (nack-guard-evt - (lambda (nack) - (define ch (make-channel)) - (define ready (make-semaphore)) - (let ([t (thread (lambda () - (parameterize-break #t - (with-handlers ([exn:break? void]) - (semaphore-post ready) - (go nack ch #f)))))]) - (thread (lambda () - (sync nack) - (semaphore-wait ready) - (break-thread t)))) - ch)))))) - -(define (read-at-least-bytes!-evt orig-bstr input-port need-more? shrink combo - peek-offset prog-evt) - ;; go is the main reading function, either called directly for - ;; a poll, or called in a thread for a non-poll read - (define (go nack ch poll?) - (let try-again ([pos 0] [bstr orig-bstr] [progress-evt #f]) - (let* ([progress-evt - ;; if no progress event is given, get one to ensure that - ;; consecutive bytes are read and can be committed: - (or progress-evt prog-evt (port-progress-evt input-port))] - [v (and - ;; to implement weak support for reusing the buffer in `read-bytes!-evt', - ;; need to check nack after getting progress-evt: - (not (sync/timeout 0 nack)) - ;; try to get bytes: - ((if poll? peek-bytes-avail!* peek-bytes-avail!) - bstr (+ pos (or peek-offset 0)) progress-evt input-port pos))]) - (cond - ;; the first two cases below are shortcuts, and not - ;; strictly necessary - [(sync/timeout 0 nack) - (void)] - [(sync/timeout 0 progress-evt) - (cond [poll? #f] - [prog-evt (void)] - [else (try-again 0 bstr #f)])] - [(and poll? (equal? v 0)) #f] - [(and (number? v) (need-more? bstr (+ pos v))) - => (lambda (bstr) (try-again (+ v pos) bstr progress-evt))] - [else - (let* ([v2 (cond [(number? v) (shrink bstr (+ v pos))] - [(positive? pos) pos] - [else v])] - [result (combo bstr v2)]) - (cond - [peek-offset - (if poll? - result - (sync (or prog-evt never-evt) - (channel-put-evt ch result)))] - [(port-commit-peeked (if (number? v2) v2 1) - progress-evt - (if poll? - always-evt - (channel-put-evt ch result)) - input-port) - result] - [(and (eof-object? eof) - (zero? pos) - (not (sync/timeout 0 progress-evt))) - ;; Must be a true end-of-file - (let ([result (combo bstr eof)]) - (if poll? result (channel-put ch result)))] - [poll? #f] - [else (try-again 0 orig-bstr #f)]))])))) - (if (zero? (bytes-length orig-bstr)) - (wrap-evt always-evt (lambda (x) 0)) - (poll-or-spawn go))) - -(define (-read-bytes-avail!-evt bstr input-port peek-offset prog-evt) - (read-at-least-bytes!-evt bstr input-port - (lambda (bstr v) (if (zero? v) bstr #f)) - (lambda (bstr v) v) - (lambda (bstr v) v) - peek-offset prog-evt)) - -(define (read-bytes-avail!-evt bstr input-port) - (-read-bytes-avail!-evt bstr input-port #f #f)) - -(define (peek-bytes-avail!-evt bstr peek-offset prog-evt input-port) - (-read-bytes-avail!-evt bstr input-port peek-offset prog-evt)) - -(define (-read-bytes!-evt bstr input-port peek-offset prog-evt) - (read-at-least-bytes!-evt bstr input-port - (lambda (bstr v) - (if (v . < . (bytes-length bstr)) bstr #f)) - (lambda (bstr v) v) - (lambda (bstr v) v) - peek-offset prog-evt)) - -(define (read-bytes!-evt bstr input-port [progress-evt #f]) - (-read-bytes!-evt bstr input-port #f progress-evt)) - -(define (peek-bytes!-evt bstr peek-offset prog-evt input-port) - (-read-bytes!-evt bstr input-port peek-offset prog-evt)) - -(define (-read-bytes-evt len input-port peek-offset prog-evt) - (guard-evt - (lambda () - (let ([bstr (make-bytes len)]) - (wrap-evt - (-read-bytes!-evt bstr input-port peek-offset prog-evt) - (lambda (v) - (if (number? v) - (if (= v len) bstr (subbytes bstr 0 v)) - v))))))) - -(define (read-bytes-evt len input-port) - (-read-bytes-evt len input-port #f #f)) - -(define (peek-bytes-evt len peek-offset prog-evt input-port) - (-read-bytes-evt len input-port peek-offset prog-evt)) - -(define (-read-string-evt goal input-port peek-offset prog-evt) - (if (zero? goal) - (wrap-evt always-evt (lambda (x) "")) - (guard-evt - (lambda () - (let ([bstr (make-bytes goal)] - [c (bytes-open-converter "UTF-8-permissive" "UTF-8")]) - (wrap-evt - (read-at-least-bytes!-evt - bstr input-port - (lambda (bstr v) - (if (= v (bytes-length bstr)) - ;; We can't easily use bytes-utf-8-length here, - ;; because we may need more bytes to figure out - ;; the true role of the last byte. The - ;; `bytes-convert' function lets us deal with - ;; the last byte properly. - (let-values ([(bstr2 used status) - (bytes-convert c bstr 0 v)]) - (let ([got (bytes-utf-8-length bstr2)]) - (if (= got goal) - ;; Done: - #f - ;; Need more bytes: - (let ([bstr2 (make-bytes (+ v (- goal got)))]) - (bytes-copy! bstr2 0 bstr) - bstr2)))) - ;; Need more bytes in bstr: - bstr)) - (lambda (bstr v) - ;; We may need one less than v, - ;; because we may have had to peek - ;; an extra byte to discover an - ;; error in the stream. - (if ((bytes-utf-8-length bstr #\? 0 v) . > . goal) (sub1 v) v)) - cons - peek-offset prog-evt) - (lambda (bstr+v) - (let ([bstr (car bstr+v)] - [v (cdr bstr+v)]) - (if (number? v) - (bytes->string/utf-8 bstr #\? 0 v) - v))))))))) - -(define (read-string-evt goal input-port) - (-read-string-evt goal input-port #f #f)) - -(define (peek-string-evt goal peek-offset prog-evt input-port) - (-read-string-evt goal input-port peek-offset prog-evt)) - -(define (-read-string!-evt str input-port peek-offset prog-evt) - (wrap-evt - (-read-string-evt (string-length str) input-port peek-offset prog-evt) - (lambda (s) - (if (string? s) - (begin (string-copy! str 0 s) - (string-length s)) - s)))) - -(define (read-string!-evt str input-port) - (-read-string!-evt str input-port #f #f)) - -(define (peek-string!-evt str peek-offset prog-evt input-port) - (-read-string!-evt str input-port peek-offset prog-evt)) - -(define (regexp-match-evt pattern input-port) - (define (go nack ch poll?) - (let try-again () - (if (port-closed? input-port) - #f - (let* ([progress-evt (port-progress-evt input-port)] - [m ((if poll? - regexp-match-peek-positions-immediate - regexp-match-peek-positions) - pattern input-port 0 #f progress-evt)]) - (cond - [(sync/timeout 0 nack) (void)] - [(sync/timeout 0 progress-evt) (try-again)] - [(not m) - (if poll? - #f - (sync nack - (handle-evt progress-evt - (lambda (x) (try-again)))))] - [else - (let ([m2 (map (lambda (p) - (and p - (let ([bstr (make-bytes (- (cdr p) (car p)))]) - (unless (= (car p) (cdr p)) - (let loop ([offset 0]) - (let ([v (peek-bytes-avail! bstr (car p) progress-evt input-port offset)]) - (unless (zero? v) - (when ((+ offset v) . < . (bytes-length bstr)) - (loop (+ offset v))))))) - bstr))) - m)]) - (cond - [(and (zero? (cdar m)) (or poll? (channel-put ch m2))) - m2] - [(port-commit-peeked - (cdar m) - progress-evt - (if poll? always-evt (channel-put-evt ch m2)) - input-port) - m2] - [poll? #f] - [else (try-again)]))]))))) - (poll-or-spawn go)) - -(define-syntax (newline-rx stx) - (syntax-case stx () - [(_ str) - (datum->syntax - #'here - (byte-regexp (string->bytes/latin-1 - (format "^(?:(.*?)~a)|(.*?$)" (syntax-e #'str)))))])) - -(define read-bytes-line-evt - (lambda (input-port [mode 'linefeed]) - (wrap-evt - (regexp-match-evt (case mode - [(linefeed) (newline-rx "\n")] - [(return) (newline-rx "\r")] - [(return-linefeed) (newline-rx "\r\n")] - [(any) (newline-rx "(?:\r\n|\r|\n)")] - [(any-one) (newline-rx "[\r\n]")]) - input-port) - (lambda (m) - (or (cadr m) - (let ([l (caddr m)]) - (if (and l (zero? (bytes-length l))) eof l))))))) - -(define read-line-evt - (lambda (input-port [mode 'linefeed]) - (wrap-evt - (read-bytes-line-evt input-port mode) - (lambda (s) - (if (eof-object? s) s (bytes->string/utf-8 s #\?)))))) - -(define (eof-evt input-port) - (wrap-evt (regexp-match-evt #rx#"^$" input-port) - (lambda (x) eof))) - -;; -------------------------------------------------- - -;; Helper for reencode-input-port: simulate the composition -;; of a CRLF/CRNEL/NEL/LS -> LF decoding and some other -;; decoding. -;; The "converter" `c' is (mcons converter saved), where -;; saved is #f if no byte is saved, otherwise it's a saved -;; byte. It would be nicer and closer to the `bytes-convert' -;; interface to not consume a trailing CR, but we don't -;; know the inner encoding, and so we can't rewind it. -(define (bytes-convert/post-nl c buf buf-start buf-end dest) - (cond - [(and (mcdr c) (= buf-start buf-end)) - ;; No more bytes to convert; provide single - ;; saved byte if it's not #\return, otherwise report 'aborts - (if (eq? (mcdr c) (char->integer #\return)) - (values 0 0 'aborts) - (begin (bytes-set! dest 0 (mcdr c)) - (set-mcdr! c #f) - (values 1 0 'complete)))] - [(and (mcdr c) (= 1 (bytes-length dest))) - ;; We have a saved byte, but the destination is only 1 byte. - ;; If the saved byte is a return, we need to try decoding more, - ;; which means we may end up saving a non-#\return byte: - (if (eq? (mcdr c) (char->integer #\return)) - (let-values ([(got-c used-c status) - (bytes-convert (mcar c) buf buf-start buf-end dest)]) - (if (positive? got-c) - (cond - [(eq? (bytes-ref dest 0) (char->integer #\newline)) - ;; Found CRLF, so just produce LF (and nothing to save) - (set-mcdr! c #f) - (values 1 used-c status)] - [else - ;; Next char fits in a byte, so it isn't NEL, etc. - ;; Save it, and for now return the #\return. - (set-mcdr! c (bytes-ref dest 0)) - (bytes-set! dest 0 (char->integer #\newline)) - (values 1 used-c 'continues)]) - ;; Didn't decode any more; ask for bigger input, etc. - (values 0 0 status))) - ;; Saved a non-#\return, so use that up now. - (begin (bytes-set! dest 0 (mcdr c)) - (set-mcdr! c #f) - (values 1 0 'continues)))] - [else - ;; Normal convert, maybe prefixed: - (let-values ([(got-c used-c status) - (bytes-convert (mcar c) buf buf-start buf-end dest - (if (mcdr c) 1 0))]) - (let* ([got-c (if (mcdr c) - ;; Insert saved character: - (begin (bytes-set! dest 0 (char->integer #\return)) - (set-mcdr! c #f) - (add1 got-c)) - got-c)] - [got-c (if (and (positive? got-c) - (eq? (bytes-ref dest (sub1 got-c)) - (char->integer #\return)) - (not (eq? status 'error))) - ;; Save trailing carriage return: - (begin (set-mcdr! c (char->integer #\return)) - (sub1 got-c)) - got-c)]) - ;; Iterate through the converted bytes to apply the newline - ;; conversions: - (let loop ([i 0] [j 0]) - (cond - [(= i got-c) - (values (- got-c (- i j)) - used-c - (if (and (eq? 'complete status) (mcdr c)) - 'aborts - status))] - [(eq? (bytes-ref dest i) (char->integer #\return)) - (cond [(= (add1 i) got-c) - ;; Found lone CR: - (bytes-set! dest j (char->integer #\newline)) - (loop (add1 i) (add1 j))] - [(eq? (bytes-ref dest (add1 i)) (char->integer #\newline)) - ;; Found CRLF: - (bytes-set! dest j (char->integer #\newline)) - (loop (+ i 2) (add1 j))] - [(and (eq? (bytes-ref dest (add1 i)) #o302) - (eq? (bytes-ref dest (+ i 2)) #o205)) - ;; Found CRNEL: - (bytes-set! dest j (char->integer #\newline)) - (loop (+ i 3) (add1 j))] - [else - ;; Found lone CR: - (bytes-set! dest j (char->integer #\newline)) - (loop (add1 i) (add1 j))])] - [(and (eq? (bytes-ref dest i) #o302) - (eq? (bytes-ref dest (+ i 1)) #o205)) - ;; Found NEL: - (bytes-set! dest j (char->integer #\newline)) - (loop (+ i 2) (add1 j))] - [(and (eq? (bytes-ref dest i) #o342) - (eq? (bytes-ref dest (+ i 1)) #o200) - (eq? (bytes-ref dest (+ i 2)) #o250)) - ;; Found LS: - (bytes-set! dest j (char->integer #\newline)) - (loop (+ i 3) (add1 j))] - [else - ;; Anything else: - (unless (= i j) - (bytes-set! dest j (bytes-ref dest i))) - (loop (add1 i) (add1 j))]))))])) - -(define reencode-input-port - (lambda (port encoding [error-bytes #f] [close? #f] - [name (object-name port)] - [newline-convert? #f] - [decode-error (lambda (msg port) - (error 'reencode-input-port - (format "~a: ~~e" msg) - port))]) - (let ([c (let ([c (bytes-open-converter encoding "UTF-8")]) - (if newline-convert? (mcons c #f) c))] - [ready-bytes (make-bytes 1024)] - [ready-start 0] - [ready-end 0] - [buf (make-bytes 1024)] - [buf-start 0] - [buf-end 0] - [buf-eof? #f] - [buf-eof-result #f] - [buffer-mode (or (file-stream-buffer-mode port) 'none)]) - ;; Main reader entry: - (define (read-it s) - (cond - [(> ready-end ready-start) - ;; We have leftover converted bytes: - (let ([cnt (min (bytes-length s) (- ready-end ready-start))]) - (bytes-copy! s 0 ready-bytes ready-start (+ ready-start cnt)) - (set! ready-start (+ ready-start cnt)) - cnt)] - [else - ;; Try converting already-read bytes: - (let-values ([(got-c used-c status) - (if (= buf-start buf-end) - (values 0 0 'aborts) - ((if newline-convert? - bytes-convert/post-nl - bytes-convert) - c buf buf-start buf-end s))]) - (when (positive? used-c) (set! buf-start (+ used-c buf-start))) - (cond - [(positive? got-c) - ;; We converted some bytes into s. - got-c] - [(eq? status 'aborts) - (if buf-eof? - ;; Had an EOF or special in the stream. - (if (= buf-start buf-end) - (if (and newline-convert? (mcdr c)) ; should be bytes-convert-end - ;; Have leftover CR: - (begin - (bytes-set! s 0 - (if (eq? (mcdr c) (char->integer #\return)) - (char->integer #\newline) - (mcdr c))) - (set-mcdr! c #f) - 1) - ;; Return EOF: - (begin0 buf-eof-result - (set! buf-eof? #f) - (set! buf-eof-result #f))) - (handle-error s)) - ;; Need more bytes. - (begin - (when (positive? buf-start) - (bytes-copy! buf 0 buf buf-start buf-end) - (set! buf-end (- buf-end buf-start)) - (set! buf-start 0)) - (let* ([amt (bytes-length s)] - [c (read-bytes-avail!* - buf port buf-end - (if (eq? buffer-mode 'block) - (bytes-length buf) - (min (bytes-length buf) (+ buf-end amt))))]) - (cond - [(or (eof-object? c) (procedure? c)) - ;; Got EOF/procedure - (set! buf-eof? #t) - (set! buf-eof-result c) - (read-it s)] - [(zero? c) - ;; No bytes ready --- try again later. - (wrap-evt port (lambda (v) 0))] - [else - ;; Got some bytes; loop to decode. - (set! buf-end (+ buf-end c)) - (read-it s)]))))] - [(eq? status 'error) - (handle-error s)] - [(eq? status 'continues) - ;; Need more room to make progress at all. - ;; Decode into ready-bytes. - (let-values ([(got-c used-c status) ((if newline-convert? - bytes-convert/post-nl - bytes-convert) - c buf buf-start buf-end ready-bytes)]) - (unless (memq status '(continues complete)) - (decode-error "unable to make decoding progress" - port)) - (set! ready-start 0) - (set! ready-end got-c) - (set! buf-start (+ used-c buf-start)) - (read-it s))]))])) - - ;; Raise exception or discard first buffered byte. - ;; We assume that read-bytes is empty - (define (handle-error s) - (if error-bytes - (begin - (set! buf-start (add1 buf-start)) - (let ([cnt (min (bytes-length s) - (bytes-length error-bytes))]) - (bytes-copy! s 0 error-bytes 0 cnt) - (bytes-copy! ready-bytes 0 error-bytes cnt) - (set! ready-start 0) - (set! ready-end (- (bytes-length error-bytes) cnt)) - cnt)) - (decode-error "decoding error in input stream" port))) - - (unless c - (error 'reencode-input-port - "could not create converter from ~e to UTF-8" - encoding)) - - (make-input-port/read-to-peek - name - read-it - #f - (lambda () - (when close? (close-input-port port)) - (bytes-close-converter (if newline-convert? (mcar c) c))) - #f void 1 - (case-lambda - [() buffer-mode] - [(mode) (set! buffer-mode mode)]) - (eq? buffer-mode 'block))))) - -;; -------------------------------------------------- - -(define reencode-output-port - (lambda (port encoding [error-bytes #f] [close? #f] - [name (object-name port)] - [convert-newlines-to #f] - [decode-error (lambda (msg port) - (error 'reencode-output-port - (format "~a: ~~e" msg) - port))]) - (let ([c (bytes-open-converter "UTF-8" encoding)] - [ready-bytes (make-bytes 1024)] - [ready-start 0] - [ready-end 0] - [out-bytes (make-bytes 1024)] - [out-start 0] - [out-end 0] - [buffer-mode (or (file-stream-buffer-mode port) 'block)] - [debuffer-buf #f] - [newline-buffer #f]) - (define-values (buffered-r buffered-w) (make-pipe 4096)) - - ;; The main writing entry point: - (define (write-it s start end no-buffer&block? enable-break?) - (cond - [(= start end) - ;; This is a flush request; no-buffer&block? must be #f - ;; Note: we could get stuck because only half an encoding - ;; is available in out-bytes. - (flush-buffer-pipe #f enable-break?) - (flush-some #f enable-break?) - (if (buffer-flushed?) - 0 - (write-it s start end no-buffer&block? enable-break?))] - [no-buffer&block? - (case (flush-all #t enable-break?) - [(not-done) - ;; We couldn't flush right away, so give up. - #f] - [(done) - (non-blocking-write s start end)] - [(stuck) - ;; We need more bytes to make progress. - ;; Add out-bytes and s into one string for non-blocking-write. - (let ([s2 (bytes-append (subbytes out-bytes out-start out-end) - (subbytes s start end))] - [out-len (- out-end out-start)]) - (let ([c (non-blocking-write s2 0 (bytes-length s2))]) - (and c (begin (set! out-start 0) - (set! out-end 0) - (- c out-len)))))])] - [(and (eq? buffer-mode 'block) - (zero? (pipe-content-length buffered-r))) - ;; The port system can buffer to a pipe faster, so give it a pipe. - buffered-w] - [else - ;; Flush/buffer from pipe, first: - (flush-buffer-pipe #f enable-break?) - ;; Flush as needed to make room in the buffer: - (make-buffer-room #f enable-break?) - ;; Buffer some bytes: - (let-values ([(s2 start2 cnt2 used) - (convert-newlines s start - (- end start) - (- (bytes-length out-bytes) out-end))]) - (if (zero? used) - ;; No room --- try flushing again: - (write-it s start end #f enable-break?) - ;; Buffer and report success: - (begin - (bytes-copy! out-bytes out-end s2 start2 (+ start2 cnt2)) - (set! out-end (+ cnt2 out-end)) - (case buffer-mode - [(none) (flush-all-now enable-break?)] - [(line) (when (regexp-match-positions #rx#"[\r\n]" s start - (+ start used)) - (flush-all-now enable-break?))]) - used)))])) - - (define (convert-newlines s start cnt avail) - ;; If newline converting is on, try convert up to cnt - ;; bytes to produce a result that fits in avail bytes. - (if convert-newlines-to - ;; Conversion: - (let ([end (+ start cnt)] - [avail (min avail 1024)]) - (unless newline-buffer - (set! newline-buffer (make-bytes 1024))) - (let loop ([i start][j 0]) - (cond - [(or (= j avail) (= i end)) (values newline-buffer 0 j i)] - [(eq? (char->integer #\newline) (bytes-ref s i)) - ;; Newline conversion - (let ([len (bytes-length convert-newlines-to)]) - (if ((+ j len) . > . avail) - ;; No room - (values newline-buffer 0 j i) - ;; Room - (begin (bytes-copy! newline-buffer j convert-newlines-to) - (loop (add1 i) (+ j len)))))] - [else - (bytes-set! newline-buffer j (bytes-ref s i)) - (loop (add1 i) (add1 j))]))) - ;; No conversion: - (let ([cnt (min cnt avail)]) - (values s start cnt cnt)))) - - (define (make-buffer-room non-block? enable-break?) - (when (or (> ready-end ready-start) - (< (- (bytes-length out-bytes) out-end) 100)) - ;; Make room for conversion. - (flush-some non-block? enable-break?) ;; convert some - (flush-some non-block? enable-break?)) ;; write converted - ;; Make room in buffer - (when (positive? out-start) - (bytes-copy! out-bytes 0 out-bytes out-start out-end) - (set! out-end (- out-end out-start)) - (set! out-start 0))) - - (define (flush-buffer-pipe non-block? enable-break?) - (let loop () - (if (zero? (pipe-content-length buffered-r)) - 'done - (begin - (unless debuffer-buf (set! debuffer-buf (make-bytes 4096))) - (make-buffer-room non-block? enable-break?) - (let ([amt (- (bytes-length out-bytes) out-end)]) - (if (zero? amt) - 'stuck - (if convert-newlines-to - ;; Peek, convert newlines, write, then read converted amount: - (let ([cnt (peek-bytes-avail! debuffer-buf 0 #f buffered-r - 0 amt)]) - (let-values ([(s2 start2 cnt2 used) - (convert-newlines debuffer-buf 0 cnt amt)]) - (bytes-copy! out-bytes out-end s2 start2 cnt2) - (set! out-end (+ cnt2 out-end)) - (read-bytes-avail! debuffer-buf buffered-r 0 used) - (loop))) - ;; Skip an indirection: read directly and write: - (let ([cnt (read-bytes-avail! debuffer-buf buffered-r - 0 amt)]) - (bytes-copy! out-bytes out-end debuffer-buf 0 cnt) - (set! out-end (+ cnt out-end)) - (loop))))))))) - - (define (non-blocking-write s start end) - ;; For now, everything that we can flushed is flushed. - ;; Try to write the minimal number of bytes, and hope for the - ;; best. If none of all of the minimal bytes get written, - ;; everyone is happy enough. If some of the bytes get written, - ;; the we will have buffered bytes when we shouldn't have. - ;; That probably won't happen, but we can't guarantee it. - (if (sync/timeout 0.0 port) - ;; We should be able to write one byte... - (let loop ([len 1]) - (let*-values ([(s2 start2 len2 used) - (convert-newlines s start (- end start) len)] - [(got-c used-c status) - (bytes-convert c s2 start2 (+ start2 len2) - ready-bytes)]) - (cond - [(positive? got-c) - (try-flush-ready got-c used-c) - ;; If used-c < len2, then we converted only partially - ;; --- which is strange, because we kept adding - ;; bytes one at a time. we will just guess is that - ;; the unused bytes were not converted bytes, and - ;; generally hope that this sort of encoding doesn't - ;; show up. - (- used (- len2 used-c))] - [(eq? status 'aborts) - (if (< len (- end start)) - ;; Try converting a bigger chunk - (loop (add1 len)) - ;; We can't flush half an encoding, so just buffer it. - (begin (when (> len2 (bytes-length out-bytes)) - (raise-insane-decoding-length)) - (bytes-copy! out-bytes 0 s2 start2 (+ start2 len2)) - (set! out-start 0) - (set! out-end len2) - used))] - [(eq? status 'continues) - ;; Not enough room in ready-bytes!? We give up. - (raise-insane-decoding-length)] - [else - ;; Encoding error. Try to flush error bytes. - (let ([cnt (bytes-length error-bytes)]) - (bytes-copy! ready-bytes 0 error-bytes) - (try-flush-ready cnt 1) - used)]))) - ;; Port is not ready for writing: - #f)) - - (define (write-special-it v no-buffer&block? enable-break?) - (cond - [(buffer-flushed?) - ((if no-buffer&block? - write-special-avail* - (if enable-break? - (lambda (v p) (parameterize-break #t (write-special v p))) - write-special)) - v port)] - [else - ;; Note: we could get stuck because only half an encoding - ;; is available in out-bytes. - (flush-buffer-pipe no-buffer&block? enable-break?) - (flush-some no-buffer&block? enable-break?) - (if (or (buffer-flushed?) (not no-buffer&block?)) - (write-special-it v no-buffer&block? enable-break?) - #f)])) - - ;; flush-all : -> 'done, 'not-done, or 'stuck - (define (flush-all non-block? enable-break?) - (if (eq? (flush-buffer-pipe non-block? enable-break?) 'done) - (let ([orig-none-ready? (= ready-start ready-end)] - [orig-out-start out-start] - [orig-out-end out-end]) - (flush-some non-block? enable-break?) - (if (buffer-flushed?) - 'done - ;; Couldn't flush everything. One possibility is that we need - ;; more bytes to convert before a flush. - (if (and orig-none-ready? - (= ready-start ready-end) - (= orig-out-start out-start) - (= orig-out-end out-end)) - 'stuck - 'not-done))) - 'stuck)) - - (define (flush-all-now enable-break?) - (case (flush-all #f enable-break?) - [(not-done) (flush-all-now enable-break?)])) - - (define (buffer-flushed?) - (and (= ready-start ready-end) - (= out-start out-end) - (zero? (pipe-content-length buffered-r)))) - - ;; Try to flush immediately a certain number of bytes. - ;; we've already converted them, so we have to keep - ;; the bytes in any case. - (define (try-flush-ready got-c used-c) - (let ([c (write-bytes-avail* ready-bytes port 0 got-c)]) - (unless (= c got-c) - (set! ready-start c) - (set! ready-end got-c)))) - - ;; Try to make progress flushing buffered bytes - (define (flush-some non-block? enable-break?) - (unless (= ready-start ready-end) - ;; Flush converted bytes: - (let ([cnt ((cond [non-block? write-bytes-avail*] - [enable-break? write-bytes-avail/enable-break] - [else write-bytes-avail]) - ready-bytes port ready-start ready-end)]) - (set! ready-start (+ ready-start cnt)))) - (when (= ready-start ready-end) - ;; Convert more, if available: - (set! ready-start 0) - (set! ready-end 0) - (when (> out-end out-start) - (let-values ([(got-c used-c status) - (bytes-convert c out-bytes out-start out-end - ready-bytes)]) - (set! ready-end got-c) - (set! out-start (+ out-start used-c)) - (when (and (eq? status 'continues) (zero? used-c)) - ;; Yikes! Size of ready-bytes isn't enough room for progress!? - (raise-insane-decoding-length)) - (when (and (eq? status 'error) (zero? used-c)) - ;; No progress before an encoding error. - (if error-bytes - ;; Write error bytes and drop an output byte: - (begin (set! out-start (add1 out-start)) - (bytes-copy! ready-bytes 0 error-bytes) - (set! ready-end (bytes-length error-bytes))) - ;; Raise an exception: - (begin - (set! out-start out-end) ;; flush buffer so close can work - (decode-error - "error decoding output to stream" - port)))))))) - - ;; This error is used when decoding wants more bytes to make - ;; progress even though we've supplied hundreds of bytes - (define (raise-insane-decoding-length) - (decode-error "unable to make decoding progress" port)) - - ;; Check that a decoder is available: - (unless c - (error 'reencode-output-port - "could not create converter from ~e to UTF-8" - encoding)) - - (make-output-port - name - port - write-it - (lambda () - ;; Flush output - (write-it #"" 0 0 #f #f) - (when close? - (close-output-port port)) - (bytes-close-converter c)) - write-special-it - #f #f - #f void - 1 - (case-lambda - [() buffer-mode] - [(mode) (let ([old buffer-mode]) - (set! buffer-mode mode) - (when (or (and (eq? old 'block) (memq mode '(none line))) - (and (eq? old 'line) (memq mode '(none)))) - ;; Flush output - (write-it #"" 0 0 #f #f)))]))))) - -;; ---------------------------------------- - -(define dup-output-port - (lambda (p [close? #f]) - (let ([new (transplant-output-port - p - (lambda () (port-next-location p)) - (add1 (file-position p)) - close? - (lambda () (port-count-lines! p)))]) - (port-display-handler new (port-display-handler p)) - (port-write-handler new (port-write-handler p)) - new))) - -(define dup-input-port - (lambda (p [close? #f]) - (let ([new (transplant-input-port - p - (lambda () (port-next-location p)) - (add1 (file-position p)) - close? - (lambda () (port-count-lines! p)))]) - (port-read-handler new (port-read-handler p)) - new))) - -;; ---------------------------------------- - -(provide open-output-nowhere +(require racket/port) +(provide ;; these are the functions that used to be defined in + ;; `mzlib/port` but are now defined in `racket/port` + open-output-nowhere make-pipe-with-specials make-input-port/read-to-peek peeking-input-port @@ -1809,41 +24,29 @@ reencode-output-port dup-input-port dup-output-port + + read-bytes-avail!-evt + peek-bytes-avail!-evt + read-bytes!-evt + peek-bytes!-evt + read-bytes-evt + peek-bytes-evt + read-string!-evt + peek-string!-evt + read-string-evt + peek-string-evt + regexp-match-evt + read-bytes-line-evt + read-line-evt + eof-evt + + ;; defined here and not in racket/port strip-shell-command-start) -(provide/contract - (read-bytes-avail!-evt (mutable-bytes? input-port-with-progress-evts? - . -> . evt?)) - (peek-bytes-avail!-evt (mutable-bytes? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (read-bytes!-evt (mutable-bytes? input-port-with-progress-evts? . -> . evt?)) - (peek-bytes!-evt (mutable-bytes? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (read-bytes-evt (exact-nonnegative-integer? input-port-with-progress-evts? - . -> . evt?)) - (peek-bytes-evt (exact-nonnegative-integer? exact-nonnegative-integer? - evt?/false input-port-with-progress-evts? - . -> . evt?)) - (read-string!-evt (mutable-string? input-port-with-progress-evts? - . -> . evt?)) - (peek-string!-evt (mutable-string? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (read-string-evt (exact-nonnegative-integer? input-port-with-progress-evts? - . -> . evt?)) - (peek-string-evt (exact-nonnegative-integer? exact-nonnegative-integer? - evt?/false input-port-with-progress-evts? - . -> . evt?)) - (regexp-match-evt ((or/c regexp? byte-regexp? string? bytes?) - input-port-with-progress-evts? - . -> . evt?)) +;; ---------------------------------------- - (read-bytes-line-evt (case-> (input-port-with-progress-evts? . -> . evt?) - (input-port-with-progress-evts? line-mode-symbol? - . -> . evt?))) - (read-line-evt (case-> (input-port-with-progress-evts? . -> . evt?) - (input-port-with-progress-evts? line-mode-symbol? - . -> . evt?))) - (eof-evt (input-port-with-progress-evts? . -> . evt?))) +(define (strip-shell-command-start in) + (when (regexp-match-peek #rx#"^#![^\r\n]*" in) + (let loop ([s (read-line in)]) + (when (regexp-match #rx#"\\\\$" s) + (loop (read-line in)))))) diff --git a/collects/mzlib/process.rkt b/collects/mzlib/process.rkt index 49f5562..ed07ddc 100644 --- a/collects/mzlib/process.rkt +++ b/collects/mzlib/process.rkt @@ -1,207 +1,6 @@ #lang racket/base -(provide process - process* - process/ports - process*/ports - system - system* - system/exit-code - system*/exit-code) -(require "private/streams.rkt") +;; deprecated library, see `racket/system` -;; Helpers: ---------------------------------------- - -(define (shell-path/args who argstr) - (case (system-type) - [(unix macosx) (append '("/bin/sh" "-c") (list argstr))] - [(windows) (let ([cmd - (let ([d (find-system-path 'sys-dir)]) - (let ([cmd (build-path d "cmd.exe")]) - (if (file-exists? cmd) - cmd - (let ([cmd (build-path d "command.com")]) - (if (file-exists? cmd) - cmd - ;; One last try: up a dir - (build-path d 'up "command.com"))))))]) - (list cmd - 'exact - (format "~a /c \"~a\"" (path->string cmd) argstr)))] - [else (raise-mismatch-error - who - (format "~a: don't know what shell to use for platform: " who) - (system-type))])) - -(define (check-exe who exe) - (unless (path-string? exe) - (raise-argument-error who "path-string?" exe)) - exe) - -(define (path-or-ok-string? s) - ;; use `path-string?' t check for nul characters in a string, - ;; but allow the empty string (which is not an ok path), too: - (or (path-string? s) - (equal? "" s))) - -(define (string-no-nuls? s) - (and (string? s) (path-or-ok-string? s))) - -(define (bytes-no-nuls? s) - (and (bytes? s) - (not (regexp-match? #rx#"\0" s)))) - -(define (check-args who args) - (cond - [(null? args) (void)] - [(eq? (car args) 'exact) - (when (null? (cdr args)) - (raise-mismatch-error - who - "expected a single string argument after: " - (car args))) - (unless (and (>= 2 (length args)) - (string? (cadr args)) - (path-or-ok-string? (cadr args))) - (raise-mismatch-error who - "expected a single string argument after 'exact, given: " - (cadr args))) - (when (pair? (cddr args)) - (raise-mismatch-error - who - "expected a single string argument after 'exact, given additional argument: " - (caddr args)))] - [else - (for ([s (in-list args)]) - (unless (or (path-or-ok-string? s) - (bytes-no-nuls? s)) - (raise-argument-error - who - (string-append "(or/c path-string?\n" - " (and/c bytes? (lambda (bs) (not (memv 0 (bytes->list bs))))))") - s)))]) - args) - -(define (check-command who str) - (unless (or (string-no-nuls? str) - (bytes-no-nuls? str)) - (raise-argument-error - who - (string-append "(or/c (and/c string? (lambda (s) (not (memv #\\nul (string->list s)))))\n" - " (and/c bytes? (lambda (bs) (not (memv 0 (bytes->list bs))))))") - str))) - -;; Old-style functions: ---------------------------------------- - -(define (do-process*/ports who cout cin cerr exe . args) - (let-values ([(subp out in err) (apply subprocess - (if-stream-out who cout) - (if-stream-in who cin) - (if-stream-out who cerr #t) - (check-exe who exe) - (check-args who args))] - [(it-ready) (make-semaphore)]) - (let ([so (streamify-out cout out)] - [si (streamify-in cin in (lambda (ok?) - (if ok? - (semaphore-post it-ready) - (semaphore-wait it-ready))))] - [se (streamify-out cerr err)] - [aport (lambda (x) (and (port? x) x))]) - (when (thread? si) - ;; Wait for process to end, then stop copying input: - (thread (lambda () - (sync subp si) - (semaphore-wait it-ready) - (break-thread si)))) - (let ([threads-still-going? - (lambda () - (ormap (lambda (s) (and (thread? s) (thread-running? s))) - (list so si se)))]) - (define (control m) - (case m - [(status) - (let ([s (subprocess-status subp)]) - (cond [(or (not (integer? s)) (threads-still-going?)) - 'running] - [(zero? s) 'done-ok] - [else 'done-error]))] - [(exit-code) - (if (threads-still-going?) - #f - (let ([s (subprocess-status subp)]) (and (integer? s) s)))] - [(wait) - (subprocess-wait subp) - (let ([twait (lambda (t) (when (thread? t) (thread-wait t)))]) - (twait so) - (twait si) - (twait se))] - [(interrupt) (subprocess-kill subp #f)] - [(kill) (subprocess-kill subp #t)] - [else (raise-argument-error - 'control-process - "(or/c 'status 'exit-code 'wait 'interrupt 'kill)" m)])) - (list (aport so) - (aport si) - (subprocess-pid subp) - (aport se) - control))))) - -(define (process*/ports cout cin cerr exe . args) - (apply do-process*/ports 'process*/ports cout cin cerr exe args)) - -(define (process/ports out in err str) - (apply do-process*/ports 'process/ports out in err (shell-path/args 'process/ports str))) - -(define (process* exe . args) - (apply do-process*/ports 'process* #f #f #f exe args)) - -(define (process str) - (check-command 'process str) - (apply do-process*/ports 'process #f #f #f (shell-path/args 'process str))) - -;; Note: these always use current ports -(define (do-system*/exit-code who exe . args) - (let ([cout (current-output-port)] - [cin (current-input-port)] - [cerr (current-error-port)] - [it-ready (make-semaphore)]) - (let-values ([(subp out in err) - (apply subprocess - (if-stream-out who cout) - (if-stream-in who cin) - (if-stream-out who cerr #t) - (check-exe who exe) - (check-args who args))]) - (let ([ot (streamify-out cout out)] - [it (streamify-in cin in (lambda (ok?) - (if ok? - (semaphore-post it-ready) - (semaphore-wait it-ready))))] - [et (streamify-out cerr err)]) - (subprocess-wait subp) - (when it - ;; stop piping output to subprocess - (semaphore-wait it-ready) - (break-thread it)) - ;; wait for other pipes to run dry: - (when (thread? ot) (thread-wait ot)) - (when (thread? et) (thread-wait et)) - (when err (close-input-port err)) - (when out (close-input-port out)) - (when in (close-output-port in))) - (subprocess-status subp)))) - -(define (system*/exit-code exe . args) - (apply do-system*/exit-code 'system*/exit-code exe args)) - -(define (system* exe . args) - (zero? (apply do-system*/exit-code 'system* exe args))) - -(define (system str) - (check-command 'system str) - (zero? (apply do-system*/exit-code 'system (shell-path/args 'system str)))) - -(define (system/exit-code str) - (check-command 'system/exit-code str) - (apply do-system*/exit-code 'system/exit-code (shell-path/args 'system/exit-code str))) +(require racket/system) +(provide (all-from-out racket/system)) \ No newline at end of file diff --git a/collects/mzlib/runtime-path.rkt b/collects/mzlib/runtime-path.rkt index 735b46c..dc070f5 100644 --- a/collects/mzlib/runtime-path.rkt +++ b/collects/mzlib/runtime-path.rkt @@ -1,172 +1,10 @@ -(module runtime-path racket/base - (require "private/this-expression-source-directory.rkt" - racket/list - setup/dirs - (only-in "private/runtime-path-table.rkt" table) - (for-syntax racket/base)) +#lang racket/base - (provide define-runtime-path - define-runtime-paths - define-runtime-path-list - define-runtime-module-path-index - runtime-paths) - - (define-for-syntax ext-file-table (make-hasheq)) +;; deprecated library, see `racket/runtime-path` - (define (lookup-in-table var-ref p) - ;; This function is designed to cooperate with a table embedded - ;; in an executable by create-embedding-executable. - (let ([modname (variable-reference->resolved-module-path var-ref)]) - (let ([p (hash-ref - table - (cons (resolved-module-path-name modname) - (if (path? p) - (path->bytes p) - (if (and (pair? p) (eq? 'module (car p))) - (list 'module (cadr p)) - p))) - #f)]) - (and p - (car p) - (let* ([p (car p)] - [p (if (bytes? p) - (bytes->path p) - p)]) - (if (symbol? p) - (module-path-index-join (list 'quote p) #f) ; make it a module path index - (if (absolute-path? p) - p - (parameterize ([current-directory (find-system-path 'orig-dir)]) - (or (find-executable-path (find-system-path 'exec-file) p #t) - (build-path (current-directory) p)))))))))) - - (define (resolve-paths tag-stx get-base paths) - (let ([base #f]) - (map (lambda (p) - (or - ;; Check table potentially substituted by - ;; mzc --exe: - (and table - (lookup-in-table tag-stx p)) - ;; Normal resolution - (cond - [(and (or (string? p) (path? p)) - (not (complete-path? p))) - (unless base - (set! base (get-base))) - (path->complete-path p base)] - [(string? p) (string->path p)] - [(path? p) p] - [(and (list? p) - (= 2 (length p)) - (eq? 'so (car p)) - (string? (cadr p))) - (let ([f (path-replace-suffix (cadr p) (system-type 'so-suffix))]) - (or (ormap (lambda (p) - (let ([p (build-path p f)]) - (and (file-exists? p) - p))) - (get-lib-search-dirs)) - (cadr p)))] - [(and (list? p) - ((length p) . > . 1) - (eq? 'lib (car p)) - (andmap string? (cdr p))) - (let* ([strs (regexp-split #rx"/" - (let ([s (cadr p)]) - (if (regexp-match? #rx"[./]" s) - s - (string-append s "/main.rkt"))))]) - (apply collection-file-path - (last strs) - (if (and (null? (cddr p)) - (null? (cdr strs))) - (list "mzlib") - (append (cddr p) (drop-right strs 1)))))] - [(and (list? p) - ((length p) . = . 3) - (eq? 'module (car p)) - (or (not (caddr p)) - (variable-reference? (caddr p)))) - (let ([p (cadr p)] - [vr (caddr p)]) - (unless (module-path? p) - (error 'runtime-path "not a module path: ~.s" p)) - (let ([base (and vr - (variable-reference->resolved-module-path vr))]) - (if (and (pair? p) - (eq? (car p) 'submod) - (path? (cadr p))) - (module-path-index-join `(submod "." ,@(cddr p)) - (module-path-index-join (cadr p) base)) - (module-path-index-join p base))))] - [else (error 'runtime-path "unknown form: ~.s" p)]))) - paths))) - - (define-for-syntax (register-ext-files var-ref paths) - (let ([modname (variable-reference->resolved-module-path var-ref)]) - (let ([files (hash-ref ext-file-table modname null)]) - (hash-set! ext-file-table modname (append paths files))))) - - (define-syntax (-define-runtime-path stx) - (syntax-case stx () - [(_ orig-stx (id ...) expr to-list to-values) - (let ([ids (syntax->list #'(id ...))]) - (unless (memq (syntax-local-context) '(module module-begin top-level)) - (raise-syntax-error #f "allowed only at the top level" #'orig-stx)) - (for-each (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - #'orig-stx - id))) - ids) - #`(begin - (define-values (id ...) - (let-values ([(id ...) expr]) - (let ([get-dir (lambda () - #,(datum->syntax - #'orig-stx - `(,#'this-expression-source-directory) - #'orig-stx))]) - (apply to-values (resolve-paths (#%variable-reference) - get-dir - (to-list id ...)))))) - (begin-for-syntax - (register-ext-files - (#%variable-reference) - (let-values ([(id ...) expr]) - (to-list id ...))))))])) - - (define-syntax (define-runtime-path stx) - (syntax-case stx () - [(_ id expr) #`(-define-runtime-path #,stx (id) expr list values)])) - - (define-syntax (define-runtime-paths stx) - (syntax-case stx () - [(_ (id ...) expr) #`(-define-runtime-path #,stx (id ...) expr list values)])) - - (define-syntax (define-runtime-path-list stx) - (syntax-case stx () - [(_ id expr) #`(-define-runtime-path #,stx (id) expr values list)])) - - (define-syntax (define-runtime-module-path-index stx) - (syntax-case stx () - [(_ id expr) #`(-define-runtime-path #,stx (id) `(module ,expr ,(#%variable-reference)) list values)])) - - (define-syntax (runtime-paths stx) - (syntax-case stx () - [(_ mp) - #`(quote - #,(hash-ref - ext-file-table - (module-path-index-resolve - (let ([p (syntax->datum #'mp)] - [base (syntax-source-module stx)]) - (if (and (pair? p) (eq? (car p) 'submod) (path? (cadr p))) - (module-path-index-join `(submod "." ,@(cddr p)) - (module-path-index-join (cadr p) base)) - (module-path-index-join p base)))) - null))])) - - ) +(require racket/runtime-path) +(provide define-runtime-path + define-runtime-paths + define-runtime-path-list + define-runtime-module-path-index + runtime-paths) diff --git a/collects/mzlib/shared.rkt b/collects/mzlib/shared.rkt index f6af9d4..04ffee5 100644 --- a/collects/mzlib/shared.rkt +++ b/collects/mzlib/shared.rkt @@ -1,21 +1,6 @@ #lang racket/base -(require (for-syntax racket/base - syntax/kerncase - syntax/struct - racket/struct-info - racket/include)) +;; deprecated library, see `racket/shared` + +(require racket/shared) (provide shared) - -(define-for-syntax code-insp (variable-reference->module-declaration-inspector - (#%variable-reference))) - -(define undefined (letrec ([x x]) x)) -(require (only-in racket/base [cons the-cons])) - -(define-syntax shared - (lambda (stx) - (define make-check-cdr #f) - ;; Include the implementation. - ;; See private/shared-body.rkt. - (include "private/shared-body.rkt"))) diff --git a/collects/mzlib/unit-exptime.rkt b/collects/mzlib/unit-exptime.rkt index df22354..088d79b 100644 --- a/collects/mzlib/unit-exptime.rkt +++ b/collects/mzlib/unit-exptime.rkt @@ -1,27 +1,6 @@ #lang racket/base -(require "private/unit-syntax.rkt" - "private/unit-compiletime.rkt") +;; deprecated library, see `racket/unit-exptime` -(provide unit-static-signatures - signature-members) - -(define (unit-static-signatures name err-stx) - (parameterize ((error-syntax err-stx)) - (let ((ui (lookup-def-unit name))) - (values (apply list (unit-info-import-sig-ids ui)) - (apply list (unit-info-export-sig-ids ui)))))) - -(define (signature-members name err-stx) - (parameterize ((error-syntax err-stx)) - (let ([s (lookup-signature name)]) - (values - ;; extends: - (and (pair? (cdr (siginfo-names (signature-siginfo s)))) - (cadr (siginfo-names (signature-siginfo s)))) - ;; vars - (apply list (signature-vars s)) - ;; defined vars - (apply list (apply append (map car (signature-val-defs s)))) - ;; defined stxs - (apply list (apply append (map car (signature-stx-defs s)))))))) +(require racket/unit-exptime) +(provide (all-from-out racket/unit-exptime)) diff --git a/collects/mzlib/unit.rkt b/collects/mzlib/unit.rkt index 7561aa3..e5efa5b 100644 --- a/collects/mzlib/unit.rkt +++ b/collects/mzlib/unit.rkt @@ -1,2324 +1,8 @@ #lang racket/base -(require (for-syntax racket/base - syntax/boundmap - syntax/context - syntax/kerncase - syntax/name - syntax/parse - syntax/struct - racket/struct-info - syntax/stx - syntax/location - "private/unit-contract-syntax.rkt" - "private/unit-compiletime.rkt" - "private/unit-syntax.rkt")) +;; deprecated library, see `racket/unit` -(require racket/block - racket/contract/base - racket/contract/region - racket/stxparam - syntax/location - "private/unit-contract.rkt" - "private/unit-keywords.rkt" - "private/unit-runtime.rkt" - "private/unit-utils.rkt" - (rename-in racket/private/struct [struct struct~])) - -(provide define-signature-form struct struct/ctc open - define-signature provide-signature-elements - only except rename import export prefix link tag init-depend extends contracted - define-values-for-export - unit? - (rename-out [:unit unit]) define-unit - compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer - invoke-unit define-values/invoke-unit - invoke-unit/infer define-values/invoke-unit/infer - unit-from-context define-unit-from-context - define-unit-binding - unit/new-import-export define-unit/new-import-export - unit/s define-unit/s - unit/c define-unit/contract - struct~s struct~s/ctc - struct~r struct~r/ctc) - -(define-syntax/err-param (define-signature-form stx) - (syntax-case stx () - ((_ (name arg) . val) - (begin - (check-id #'name) - (check-id #'arg) - #'(define-syntax name - (make-set!-transformer - (make-signature-form (λ (arg) . val)))))) - ((_ . l) - (let ((l (checked-syntax->list stx))) - (unless (>= 3 (length l)) - (raise-stx-err - (format "expected syntax matching (~a (id id) expr ...)" - (syntax-e (stx-car stx))))) - (unless (= 2 (length (checked-syntax->list (car l)))) - (raise-stx-err - "expected syntax matching (identifier identifier)" - (car l))))))) - -(define-signature-form (struct stx) - (parameterize ((error-syntax stx)) - (syntax-case stx () - ((_ name (field ...) . omissions) - (let ([omit-selectors #f] - [omit-setters #f] - [omit-constructor #f] - [omit-type #f]) - (define (remove-ctor&type-name l) - (cond - ((and omit-constructor omit-type) - (cddr l)) - (omit-type - (cdr l)) - (omit-constructor - (cons (car l) (cddr l))) - (else - l))) - (define (remove-ctor&type-info l) - (define new-type - (if omit-type - #f - (cadr l))) - (define new-ctor - (if omit-constructor - #f - (caddr l))) - (cons (car l) - (cons new-type - (cons new-ctor - (cdddr l))))) - (check-id #'name) - (for-each check-id (syntax->list #'(field ...))) - (for-each - (lambda (omission) - (cond - ((and (identifier? omission) - (free-identifier=? omission #'-selectors)) - (set! omit-selectors #t)) - ((and (identifier? omission) - (free-identifier=? omission #'-setters)) - (set! omit-setters #t)) - ((and (identifier? omission) - (free-identifier=? omission #'-constructor)) - (set! omit-constructor #t)) - ((and (identifier? omission) - (free-identifier=? omission #'-type)) - (set! omit-type #t)) - (else - (raise-stx-err - "expected \"-selectors\" or \"-setters\" or \"-constructor\" or \"-type\"" - omission)))) - (checked-syntax->list #'omissions)) - (cons - #`(define-syntaxes (name) - #,(remove-ctor&type-info - (build-struct-expand-info - #'name (syntax->list #'(field ...)) - omit-selectors omit-setters - #f '(#f) '(#f)))) - (remove-ctor&type-name - (build-struct-names #'name (syntax->list #'(field ...)) - omit-selectors omit-setters #f))))) - ((_ name (x . y) . omissions) - ;; Will fail - (checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))) - ((_ name fields . omissions) - (raise-stx-err "expected syntax matching (identifier ...)" #'fields)) - ((_ name) - (raise-stx-err "missing fields")) - ((_) - (raise-stx-err "missing name and fields"))))) - -(begin-for-syntax - (define-struct self-name-struct-info (id) - #:super struct:struct-info - #:property prop:procedure (lambda (me stx) - (syntax-case stx () - [(_ arg ...) (datum->syntax - stx - (cons ((self-name-struct-info-id me)) - #'(arg ...)) - stx - stx)] - [_ (let ([id ((self-name-struct-info-id me))]) - (datum->syntax id - (syntax-e id) - stx - stx))])) - #:omit-define-syntaxes)) - -(define-for-syntax option-keywords - "#:mutable, #:constructor-name, #:extra-constructor-name, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") - -;; Replacement `struct' signature form for `scheme/unit': -(define-for-syntax (do-struct~ stx extra-make?) - (syntax-case stx () - ((_ name (field ...) opt ...) - (begin - (unless (identifier? #'name) - (raise-syntax-error #f - "expected an identifier to name the structure type" - stx - #'name)) - (for-each (lambda (field) - (unless (identifier? field) - (syntax-case field () - [(id #:mutable) - (identifier? #'id) - 'ok] - [_ - (raise-syntax-error #f - "bad field specification" - stx - field)]))) - (syntax->list #'(field ...))) - (let*-values ([(no-ctr? mutable? no-stx? no-rt? opt-cname) - (let loop ([opts (syntax->list #'(opt ...))] - [no-ctr? #f] - [mutable? #f] - [no-stx? #f] - [no-rt? #f] - [cname #f]) - (if (null? opts) - (values no-ctr? mutable? no-stx? no-rt? cname) - (let ([opt (car opts)]) - (case (syntax-e opt) - [(#:constructor-name #:extra-constructor-name) - (if cname - (raise-syntax-error #f - "redundant option" - stx - opt) - (if (null? (cdr opts)) - (raise-syntax-error #f - "missing identifier after option" - stx - opt) - (if (identifier? (cadr opts)) - (loop (cddr opts) #f mutable? no-stx? no-rt? - (if (eq? (syntax-e opt) '#:extra-constructor-name) - (list (cadr opts)) - (cadr opts))) - (raise-syntax-error #f - "not an identifier for a constructor name" - stx - (cadr opts)))))] - [(#:omit-constructor) - (if no-ctr? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) #t mutable? no-stx? no-rt? cname))] - [(#:mutable) - (if mutable? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) no-ctr? #t no-stx? no-rt? cname))] - [(#:omit-define-syntaxes) - (if no-stx? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) no-ctr? mutable? #t no-rt? cname))] - [(#:omit-define-values) - (if no-rt? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) no-ctr? mutable? no-stx? #t cname))] - [else - (raise-syntax-error #f - (string-append - "expected a keyword to specify option: " - option-keywords) - stx - opt)]))))] - [(def-cname) (cond - [opt-cname (if (pair? opt-cname) - (car opt-cname) - opt-cname)] - [extra-make? #f] - [else (car (generate-temporaries #'(name)))])] - [(cname) (cond - [opt-cname (if (pair? opt-cname) - (cons def-cname #'name) - (cons opt-cname opt-cname))] - [extra-make? #f] - [else (cons def-cname #'name)])] - [(self-ctr?) (and cname (bound-identifier=? #'name (cdr cname)))]) - (cons - #`(define-syntaxes (name) - #,(let ([e (build-struct-expand-info - #'name (syntax->list #'(field ...)) - #f (not mutable?) - #f '(#f) '(#f) - #:omit-constructor? no-ctr? - #:constructor-name def-cname)]) - (if self-ctr? - #`(make-self-name-struct-info - (lambda () #,e) - (lambda () (quote-syntax #,def-cname))) - e))) - (let ([names (build-struct-names #'name (syntax->list #'(field ...)) - #f (not mutable?) - #:constructor-name def-cname)]) - (cond - [no-ctr? (cons (car names) (cddr names))] - [self-ctr? (cons #`(define-values-for-export (#,def-cname) name) - names)] - [else names])))))) - ((_ name fields opt ...) - (raise-syntax-error #f - "bad syntax; expected a parenthesized sequence of fields" - stx - #'fields)) - ((_ name) - (raise-syntax-error #f - "bad syntax; missing fields" - stx)) - ((_) - (raise-syntax-error #f - "missing name and fields" - stx)))) - -(define-signature-form (struct~s stx) - (do-struct~ stx #t)) -(define-signature-form (struct~r stx) - (do-struct~ stx #f)) - -(define-signature-form (struct/ctc stx) - (parameterize ((error-syntax stx)) - (syntax-case stx () - ((_ name ([field ctc] ...) . omissions) - (let ([omit-selectors #f] - [omit-setters #f] - [omit-constructor #f] - [omit-type #f]) - (define (remove-ctor&type-info l) - (define new-type - (if omit-type - #f - (cadr l))) - (define new-ctor - (if omit-constructor - #f - (caddr l))) - (cons (car l) - (cons new-type - (cons new-ctor - (cdddr l))))) - (define (add-contracts l) - (let* ([pred (caddr l)] - [ctor-ctc #`(-> ctc ... #,pred)] - [pred-ctc #`(-> any/c boolean?)] - [field-ctcs (apply append - (map (λ (c) - (append (if omit-selectors - null - (list #`(-> #,pred #,c))) - (if omit-setters - null - (list #`(-> #,pred #,c void?))))) - (syntax->list #'(ctc ...))))]) - (list* (car l) - (list (cadr l) ctor-ctc) - (list pred pred-ctc) - (map list (cdddr l) field-ctcs)))) - (check-id #'name) - (for-each check-id (syntax->list #'(field ...))) - (for-each - (lambda (omission) - (cond - ((and (identifier? omission) - (free-identifier=? omission #'-selectors)) - (set! omit-selectors #t)) - ((and (identifier? omission) - (free-identifier=? omission #'-setters)) - (set! omit-setters #t)) - ((and (identifier? omission) - (free-identifier=? omission #'-constructor)) - (set! omit-constructor #t)) - ((and (identifier? omission) - (free-identifier=? omission #'-type)) - (set! omit-type #t)) - (else - (raise-stx-err - "expected \"-selectors\" or \"-setters\" or \"-constructor\" or \"-type\"" - omission)))) - (checked-syntax->list #'omissions)) - (cons - #`(define-syntaxes (name) - #,(remove-ctor&type-info - (build-struct-expand-info - #'name (syntax->list #'(field ...)) - omit-selectors omit-setters - #f '(#f) '(#f)))) - (let* ([res (add-contracts - (build-struct-names #'name (syntax->list #'(field ...)) - omit-selectors omit-setters #f))] - [cpairs (cons 'contracted (if omit-constructor (cddr res) (cdr res)))]) - (if omit-type - (list cpairs) - (list (car res) cpairs)))))) - ((_ name (x . y) . omissions) - ;; Will fail - (checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))) - ((_ name fields . omissions) - (raise-stx-err "expected syntax matching (identifier ...)" #'fields)) - ((_ name) - (raise-stx-err "missing fields")) - ((_) - (raise-stx-err "missing name and fields"))))) - -;; Replacement struct/ctc form for `scheme/unit': -(define-for-syntax (do-struct~/ctc stx extra-make?) - (syntax-case stx () - ((_ name ([field ctc] ...) opt ...) - (begin - (unless (identifier? #'name) - (raise-syntax-error #f - "expected an identifier to name the structure type" - stx - #'name)) - (for-each (lambda (field) - (unless (identifier? field) - (syntax-case field () - [(id #:mutable) - (identifier? #'id) - 'ok] - [_ - (raise-syntax-error #f - "bad field specification" - stx - field)]))) - (syntax->list #'(field ...))) - (let*-values ([(no-ctr? mutable? no-stx? no-rt? opt-cname) - (let loop ([opts (syntax->list #'(opt ...))] - [no-ctr? #f] - [mutable? #f] - [no-stx? #f] - [no-rt? #f] - [cname #f]) - (if (null? opts) - (values no-ctr? mutable? no-stx? no-rt? cname) - (let ([opt (car opts)]) - (case (syntax-e opt) - [(#:constructor-name #:extra-constructor-name) - (if cname - (raise-syntax-error #f - "redundant option" - stx - opt) - (if (null? (cdr opts)) - (raise-syntax-error #f - "missing identifier after option" - stx - opt) - (if (identifier? (cadr opts)) - (loop (cddr opts) #f mutable? no-stx? no-rt? - (if (eq? (syntax-e opt) '#:extra-constructor-name) - (list (cadr opts)) - (cadr opts))) - (raise-syntax-error #f - "not an identifier for a constructor name" - stx - (cadr opts)))))] - [(#:omit-constructor) - (if no-ctr? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) #t mutable? no-stx? no-rt? cname))] - [(#:mutable) - (if mutable? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) no-ctr? #t no-stx? no-rt? cname))] - [(#:omit-define-syntaxes) - (if no-stx? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) no-ctr? mutable? #t no-rt? cname))] - [(#:omit-define-values) - (if no-rt? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) no-ctr? mutable? no-stx? #t cname))] - [else - (raise-syntax-error #f - (string-append - "expected a keyword to specify option: " - option-keywords) - stx - opt)]))))] - [(def-cname) (cond - [opt-cname (if (pair? opt-cname) - (car opt-cname) - opt-cname)] - [extra-make? #f] - [else (car (generate-temporaries #'(name)))])] - [(cname) (cond - [opt-cname (if (pair? opt-cname) - (cons def-cname #'name) - (cons def-cname def-cname))] - [extra-make? #f] - [else (cons def-cname #'name)])] - [(self-ctr?) (and cname (bound-identifier=? #'name (cdr cname)))]) - (define (add-contracts l) - (let* ([pred (caddr l)] - [ctor-ctc #`(-> ctc ... #,pred)] - [pred-ctc #'(-> any/c boolean?)] - [field-ctcs - (apply append - (map (λ (f c) - (cons #`(-> #,pred #,c) - (if (and (not mutable?) - (not (pair? (syntax-e f)))) - null - #`(-> #,pred #,c void?)))) - (syntax->list #'(field ...)) - (syntax->list #'(ctc ...))))]) - (list* (car l) - (list (cadr l) ctor-ctc) - (list pred pred-ctc) - (map list (cdddr l) field-ctcs)))) - (cons - #`(define-syntaxes (name) - #,(let ([e (build-struct-expand-info - #'name (syntax->list #'(field ...)) - #f (not mutable?) - #f '(#f) '(#f) - #:omit-constructor? no-ctr? - #:constructor-name def-cname)]) - (if self-ctr? - #`(make-self-name-struct-info - (lambda () #,e) - (lambda () (quote-syntax #,def-cname))) - e))) - (let* ([names (add-contracts - (build-struct-names #'name (syntax->list #'(field ...)) - #f (not mutable?) - #:constructor-name def-cname))] - [cpairs (cons 'contracted - (cond - [no-ctr? (cddr names)] - [else (cdr names)]))] - [l (list (car names) cpairs)]) - (if self-ctr? - (cons #`(define-values-for-export (#,def-cname) name) l) - l)))))) - ((_ name fields opt ...) - (raise-syntax-error #f - "bad syntax; expected a parenthesized sequence of fields" - stx - #'fields)) - ((_ name) - (raise-syntax-error #f - "bad syntax; missing fields" - stx)) - ((_) - (raise-syntax-error #f - "missing name and fields" - stx)))) - -(define-signature-form (struct~s/ctc stx) - (do-struct~/ctc stx #t)) -(define-signature-form (struct~r/ctc stx) - (do-struct~/ctc stx #f)) - -;; build-val+macro-defs : sig -> (list syntax-object^3) -(define-for-syntax (build-val+macro-defs sig) - (if (and (null? (cadr sig)) - (null? (caddr sig))) - ;; No renames needed; this shortcut avoids - ;; an explosion of renamings, especially with chains - ;; of `open': - (list #'(() (values)) #'() #'()) - ;; Renames and macros needes: - (with-syntax ([(((int-ivar . ext-ivar) ...) - ((((int-vid . ext-vid) ...) . vbody) ...) - ((((int-sid . ext-sid) ...) . sbody) ...) - _ - _) - (map-sig (lambda (x) x) - (make-syntax-introducer) - sig)]) - (list - #'((ext-ivar ... ext-vid ... ... ext-sid ... ...) - (make-rename-transformers - (quote-syntax - (int-ivar ... - int-vid ... ... - int-sid ... ...)))) - #'(((int-sid ...) sbody) ...) - #'(((int-vid ...) vbody) ...))))) - -;; build-post-val-defs : sig -> (list syntax-object) -(define-for-syntax (build-post-val-defs sig) - (with-syntax ([(((int-ivar . ext-ivar) ...) - ((((int-vid . ext-vid) ...) . _) ...) - ((((int-sid . ext-sid) ...) . _) ...) - _ - (((post-id ...) . post-rhs) ...)) - (map-sig (lambda (x) x) - (make-syntax-introducer) - sig)]) - (list - #'((ext-ivar ... ext-vid ... ... ext-sid ... ...) - (make-rename-transformers - (quote-syntax - (int-ivar ... - int-vid ... ... - int-sid ... ...)))) - #'(post-rhs ...)))) - -;; Using `make-rename-transformers' helps improve sharing in -;; a syntax-quoted list of identifiers, although it risks -;; losting certificates as the list is broken apart; since the -;; identifiers are bound at the same point that the rename -;; transformer is introduced, certificate loss should be ok. -(define-for-syntax (make-rename-transformers ids) - (apply values - (map - make-rename-transformer - (syntax->list ids)))) - -(define-signature-form (open stx) - (define (build-sig-elems sig) - (map (λ (p c) - (if c #`(contracted [#,(car p) #,c]) (car p))) - (car sig) - (cadddr sig))) - (parameterize ([error-syntax stx]) - (syntax-case stx () - ((_ export-spec) - (let ([sig (process-spec #'export-spec)]) - (with-syntax (((sig-elem ...) - (build-sig-elems sig)) - ((renames - (((mac-name ...) mac-body) ...) - (((val-name ...) val-body) ...)) - (build-val+macro-defs sig))) - (syntax->list - #'(sig-elem ... - (define-syntaxes . renames) - (define-syntaxes (mac-name ...) mac-body) ... - (define-values (val-name ...) val-body) ...))))) - (_ - (raise-stx-err (format "must match (~a export-spec)" - (syntax-e (stx-car stx)))))))) - -(define-signature-form (define-values-for-export stx) - (raise-syntax-error #f "internal error" stx)) - -(define-for-syntax (introduce-def d) - (cons (map syntax-local-introduce (car d)) - (syntax-local-introduce (cdr d)))) - -;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object -(define-for-syntax (build-define-signature sigid super-sigid sig-exprs) - (unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs)) - (raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs)) - (let ([ses (checked-syntax->list sig-exprs)]) - (define-values (super-names super-ctimes super-rtimes super-bindings - super-val-defs super-stx-defs super-post-val-defs - super-ctcs) - (if super-sigid - (let* ([super-sig (lookup-signature super-sigid)] - [super-siginfo (signature-siginfo super-sig)]) - (values (siginfo-names super-siginfo) - (siginfo-ctime-ids super-siginfo) - (map syntax-local-introduce - (siginfo-rtime-ids super-siginfo)) - (map syntax-local-introduce (signature-vars super-sig)) - (map introduce-def (signature-val-defs super-sig)) - (map introduce-def (signature-stx-defs super-sig)) - (map introduce-def (signature-post-val-defs super-sig)) - (map (lambda (ctc) - (if ctc - (syntax-local-introduce ctc) - ctc)) - (signature-ctcs super-sig)))) - (values '() '() '() '() '() '() '() '()))) - (let loop ((sig-exprs ses) - (bindings null) - (val-defs null) - (stx-defs null) - (post-val-defs null) - (ctcs null)) - (cond - ((null? sig-exprs) - (let* ([all-bindings (append super-bindings (reverse bindings))] - [all-val-defs (append super-val-defs (reverse val-defs))] - [all-stx-defs (append super-stx-defs (reverse stx-defs))] - [all-post-val-defs (append super-post-val-defs (reverse post-val-defs))] - [all-ctcs (append super-ctcs (reverse ctcs))] - [dup - (check-duplicate-identifier - (append all-bindings - (apply append (map car all-val-defs)) - (apply append (map car all-stx-defs))))]) - (when dup - (raise-stx-err "duplicate identifier" dup)) - (with-syntax (((super-rtime ...) super-rtimes) - ((super-name ...) super-names) - ((var ...) all-bindings) - ((ctc ...) all-ctcs) - ((((vid ...) . vbody) ...) all-val-defs) - ((((sid ...) . sbody) ...) all-stx-defs) - ((((pvid ...) . pvbody) ...) all-post-val-defs)) - #`(begin - (define signature-tag (gensym)) - (define-syntax #,sigid - (make-set!-transformer - (make-signature - (make-siginfo (list #'#,sigid #'super-name ...) - (list (quote-syntax signature-tag) - #'super-rtime - ...)) - (list (quote-syntax var) ...) - (list (cons (list (quote-syntax vid) ...) - (quote-syntax vbody)) - ...) - (list (cons (list (quote-syntax sid) ...) - (quote-syntax sbody)) - ...) - (list (cons (list (quote-syntax pvid) ...) - (quote-syntax pvbody)) - ...) - (list #,@(map (lambda (c) - (if c - #`(quote-syntax #,c) - #'#f)) - all-ctcs)) - (quote-syntax #,sigid)))) - (define-values () - (begin - (λ (var ...) - (letrec-syntaxes+values - ([(sid ...) sbody] ...) ([(vid ...) vbody] ...) - ctc ... - (void))) - (values))))))) - (else - (syntax-case (car sig-exprs) (define-values define-syntaxes contracted) - (x - (identifier? #'x) - (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs post-val-defs (cons #f ctcs))) - ((x (y z) ...) - (and (identifier? #'x) - (free-identifier=? #'x #'contracted) - (andmap identifier? (syntax->list #'(y ...)))) - (loop (cdr sig-exprs) - (append (syntax->list #'(y ...)) bindings) - val-defs - stx-defs - post-val-defs - (append (syntax->list #'(z ...)) ctcs))) - ((x . z) - (and (identifier? #'x) - (free-identifier=? #'x #'contracted)) - (raise-syntax-error - 'define-signature - "expected a list of [id contract] pairs after the contracted keyword" - (car sig-exprs))) - ((x . y) - (and (identifier? #'x) - (or (free-identifier=? #'x #'define-values) - (free-identifier=? #'x #'define-syntaxes) - (free-identifier=? #'x #'define-values-for-export))) - (begin - (check-def-syntax (car sig-exprs)) - (syntax-case #'y () - (((name ...) body) - (begin - (for-each (lambda (id) (check-id id)) - (syntax->list #'(name ...))) - (let ((b #'body)) - (loop (cdr sig-exprs) - bindings - (if (free-identifier=? #'x #'define-values) - (cons (cons (syntax->list #'(name ...)) b) - val-defs) - val-defs) - (if (free-identifier=? #'x #'define-syntaxes) - (cons (cons (syntax->list #'(name ...)) b) - stx-defs) - stx-defs) - (if (free-identifier=? #'x #'define-values-for-export) - (cons (cons (syntax->list #'(name ...)) b) - post-val-defs) - post-val-defs) - ctcs))))))) - ((x . y) - (let ((trans - (set!-trans-extract - (syntax-local-value - ;; redirect struct~ to struct~r - (if (free-identifier=? #'x #'struct~) - #'struct~r - (syntax-local-introduce #'x)) - (lambda () - (raise-stx-err "unknown signature form" #'x)))))) - (unless (signature-form? trans) - (raise-stx-err "not a signature form" #'x)) - (let ((results ((signature-form-f trans) (car sig-exprs)))) - (unless (list? results) - (raise-stx-err - (format "expected list of results from signature form, got ~e" results) - (car sig-exprs))) - (loop (append results (cdr sig-exprs)) - bindings - val-defs - stx-defs - post-val-defs - ctcs)))) - (x (raise-stx-err - "expected either an identifier or signature form" - #'x)))))))) - - -(define-syntax/err-param (define-signature stx) - (syntax-case stx (extends) - ((_ sig-name sig-exprs) - (begin - (check-id #'sig-name) - (build-define-signature #'sig-name #f #'sig-exprs))) - ((_ sig-name extends super-name sig-exprs) - (begin - (check-id #'sig-name) - (check-id #'super-name) - (build-define-signature #'sig-name #'super-name #'sig-exprs))) - (_ - (begin - (checked-syntax->list stx) - (raise-stx-err - (format "expected syntax matching (~a identifier (sig-expr ...)) or (~a identifier extends identifier (sig-expr ...))" - (syntax-e (stx-car stx)) (syntax-e (stx-car stx)))))))) - -(define-for-syntax (signature->identifiers sigids) - (define provide-tagged-sigs (map process-tagged-import sigids)) - (define provide-sigs (map caddr provide-tagged-sigs)) - (map sig-int-names provide-sigs)) - -(define-syntax/err-param (provide-signature-elements stx) - (syntax-case stx () - ((_ . p) - (let* ((sigs (checked-syntax->list #'p)) - (nameses (signature->identifiers sigs)) - ;; Export only the names that would be visible to uses - ;; with the same lexical context as p. Otherwise, we - ;; can end up with collisions with renamings that are - ;; symbolically the same, such as those introduced by - ;; `open'. - (nameses (map (lambda (sig names) - (filter (lambda (name) - (bound-identifier=? - name - (datum->syntax sig (syntax-e name)))) - names)) - sigs nameses)) - (names (apply append nameses)) - (dup (check-duplicate-identifier names))) - (when dup - (raise-stx-err (format "duplicate binding for ~.s" (syntax-e dup)))) - (quasisyntax/loc stx - (provide #,@names)))))) - -;; A unit is -;; - (unit (import import-spec ...) (export export-spec ...) unit-body-expr ...) - -(define-for-syntax (localify exp def-ctx) - (cadr (syntax->list - (local-expand #`(stop #,exp) - 'expression - (list #'stop) - def-ctx)))) - -(define-for-syntax (tagged-sigid->tagged-siginfo x) - (cons (car x) - (signature-siginfo (lookup-signature (cdr x))))) - -(define-for-syntax (make-import-unboxing var renamings loc ctc) - (if ctc - (with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)]) - (quasisyntax/loc (error-syntax) - (quote-syntax (let ([v/c (#,loc)]) - (if (pair? v/c) - (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) - (current-contract-region) - (quote #,var) (quote-srcloc #,var)) - (error 'unit "contracted import ~a used before definition" - (quote #,(syntax->datum var)))))))) - (quasisyntax/loc (error-syntax) - (quote-syntax (#,loc))))) - -;; build-unit : syntax-object -> -;; (values syntax-object (listof identifier) (listof identifier)) -;; constructs the code for a unit expression. stx must be -;; such that it passes check-unit-syntax. -;; The two additional values are the identifiers of the unit's import and export -;; signatures -(define-for-syntax (build-unit stx) - (syntax-case stx (import export init-depend) - (((import i ...) - (export e ...) - (init-depend id ...) - . body) - - (let* ([d (syntax->list #'(id ...))] - [dep-tagged-sigids (map check-tagged-id d)] - [dep-tagged-siginfos - (map tagged-sigid->tagged-siginfo dep-tagged-sigids)]) - - (define-values (isig tagged-import-sigs import-tagged-infos - import-tagged-sigids import-sigs) - (process-unit-import #'(i ...))) - - (define-values (esig tagged-export-sigs export-tagged-infos - export-tagged-sigids export-sigs) - (process-unit-export #'(e ...))) - - (check-duplicate-sigs import-tagged-infos isig dep-tagged-siginfos d) - - (check-duplicate-subs export-tagged-infos esig) - - (check-unit-ie-sigs import-sigs export-sigs) - - (with-syntax ((((dept . depr) ...) - (map - (lambda (tinfo) - (cons (car tinfo) - (syntax-local-introduce (car (siginfo-rtime-ids (cdr tinfo)))))) - dep-tagged-siginfos)) - [((renames (mac ...) (val ...)) ...) - (map build-val+macro-defs import-sigs)] - [(((int-ivar . ext-ivar) ...) ...) (map car import-sigs)] - [(((int-evar . ext-evar) ...) ...) (map car export-sigs)] - [((((e-post-id ...) . _) ...) ...) (map (lambda (s) (list-ref s 4)) export-sigs)] - [((post-renames (e-post-rhs ...)) ...) (map build-post-val-defs export-sigs)] - [((iloc ...) ...) - (map (lambda (x) (generate-temporaries (car x))) import-sigs)] - [((eloc ...) ...) - (map (lambda (x) (generate-temporaries (car x))) export-sigs)] - [((ectc ...) ...) - (map (λ (sig) - (map (λ (ctc) - (if ctc - (cons 'contract ctc) - #f)) - (cadddr sig))) export-sigs)] - [((import-key import-super-keys ...) ...) - (map tagged-info->keys import-tagged-infos)] - [((export-key ...) ...) - (map tagged-info->keys export-tagged-infos)] - [(import-name ...) - (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) - import-tagged-infos)] - [(export-name ...) - (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) - export-tagged-infos)] - [name (syntax-local-infer-name (error-syntax))] - [(icount ...) (map - (lambda (import) (length (car import))) - import-sigs)]) - (values - (quasisyntax/loc (error-syntax) - (make-unit - 'name - (vector-immutable (cons 'import-name - (vector-immutable import-key import-super-keys ...)) ...) - (vector-immutable (cons 'export-name - (vector-immutable export-key ...)) ...) - (list (cons 'dept depr) ...) - (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))]) - (lambda () - (let ([eloc (box undefined)] ... ...) - (values - (lambda (import-table) - (let-values ([(iloc ...) - (vector->values (hash-ref import-table import-key) 0 icount)] - ...) - (letrec-syntaxes (#,@(map (lambda (ivs e-ivs ils ics) - (with-syntax ([renamings - (map (λ (ev iv) - #`(#,ev - (make-rename-transformer - (quote-syntax #,iv)))) - (syntax->list e-ivs) - (syntax->list ivs))]) - (quasisyntax/loc (error-syntax) - [#,ivs - (make-id-mappers - #,@(map (lambda (iv l c) - (make-import-unboxing iv #'renamings l c)) - (syntax->list ivs) - (syntax->list ils) - ics))]))) - (syntax->list #'((int-ivar ...) ...)) - (syntax->list #'((ext-ivar ...) ...)) - (syntax->list #'((iloc ...) ...)) - (map cadddr import-sigs))) - (letrec-syntaxes+values (renames ... - mac ... ...) - (val ... ...) - (unit-body #,(error-syntax) - (int-ivar ... ...) - (int-evar ... ...) - (eloc ... ...) - (ectc ... ...) - (begin . body) - (define-values (e-post-id ...) - (letrec-syntaxes+values (post-renames ...) () - e-post-rhs)) ... ...))))) - (unit-export ((export-key ...) (vector-immutable (λ () (unbox eloc)) ...)) ...))))))) - import-tagged-sigids - export-tagged-sigids - dep-tagged-sigids)))))) - -(define-syntax/err-param (:unit stx) - (syntax-case stx () - ((_ . x) - (begin - (let-values (((u x y z) (build-unit (check-unit-syntax #'x)))) - u))))) - -(define-syntax (unit-body stx) - (syntax-case stx () - ((_ err-stx ivars evars elocs ectcs body ...) - (parameterize ((error-syntax #'err-stx)) - (let* ([expand-context (generate-expand-context)] - [def-ctx (syntax-local-make-definition-context)] - [stop-list - (append - (kernel-form-identifier-list) - (syntax->list #'ivars))] - [definition? - (lambda (id) - (and (identifier? id) - (or (free-identifier=? id (quote-syntax define-values)) - (free-identifier=? id (quote-syntax define-syntaxes)))))] - [expanded-body - (let expand-all ((defns&exprs (syntax->list #'(body ...)))) - ;; Also lifted from Matthew, to expand the body enough - (apply - append - (map - (lambda (defn-or-expr) - (let ([defn-or-expr - (local-expand - defn-or-expr - expand-context - stop-list - def-ctx)]) - (syntax-case defn-or-expr (begin define-values define-syntaxes) - [(begin . l) - (let ([l (parameterize ((error-syntax defn-or-expr)) - (checked-syntax->list #'l))]) - (expand-all (map (lambda (s) - (syntax-track-origin s defn-or-expr #'begin)) - l)))] - [(define-syntaxes (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (with-syntax ([rhs (local-transformer-expand - #'rhs - 'expression - null)]) - (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx) - (list #'(define-syntaxes (id ...) rhs)))] - [(define-values (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (begin - (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #f def-ctx) - (list defn-or-expr))] - [else (list defn-or-expr)]))) - defns&exprs)))] - ;; Get all the defined names, sorting out variable definitions - ;; from syntax definitions. - [defined-names-table - (let ((table (make-bound-identifier-mapping))) - (for-each - (lambda (defn-or-expr) - (syntax-case defn-or-expr () - ((dv . rest) - (definition? #'dv) - (begin - (check-def-syntax defn-or-expr) - (syntax-case #'rest () - [((id ...) expr) - (for-each - (lambda (id) - (when (bound-identifier-mapping-get table id (lambda () #f)) - (raise-stx-err "variable defined twice" id)) - (bound-identifier-mapping-put! - table id - (make-var-info (free-identifier=? #'dv (quote-syntax define-syntaxes)) - #f - id - #f))) - (syntax->list #'(id ...)))] - [_ (void)]))) - [_ (void)])) - expanded-body) - table)]) - (internal-definition-context-seal def-ctx) - - ;; Mark exported names and - ;; check that all exported names are defined (as var): - (for-each - (lambda (name loc ctc) - (let ([v (bound-identifier-mapping-get defined-names-table - name - (lambda () #f))]) - (unless v - (raise-stx-err (format "undefined export ~a" (syntax-e name)))) - (when (var-info-syntax? v) - (raise-stx-err "cannot export syntax from a unit" name)) - (set-var-info-exported?! v loc) - (when (pair? (syntax-e ctc)) - (set-var-info-ctc! v (localify (cdr (syntax-e ctc)) def-ctx))))) - (syntax->list (localify #'evars def-ctx)) - (syntax->list #'elocs) - (syntax->list #'ectcs)) - - ;; Check that none of the imports are defined - (for-each - (lambda (i) - (let ((defid (bound-identifier-mapping-get defined-names-table - i - (lambda () #f)))) - (when defid - (raise-stx-err - "definition for imported identifier" - (var-info-id defid))))) - (syntax->list (localify #'ivars def-ctx))) - - (let ([marker (lambda (id) ((make-syntax-introducer) (datum->syntax #f (syntax-e id))))]) - (with-syntax ([(defn-or-expr ...) - (apply append - (map (λ (defn-or-expr) - (syntax-case defn-or-expr (define-values) - [(define-values (id ...) body) - (let* ([ids (syntax->list #'(id ...))] - [tmps (map marker ids)] - [do-one - (λ (id tmp) - (let ([var-info (bound-identifier-mapping-get - defined-names-table - id)]) - (cond - [(var-info-exported? var-info) - => - (λ (export-loc) - (let ([ctc (var-info-ctc var-info)]) - (list (if ctc - (quasisyntax/loc defn-or-expr - (begin - (contract #,ctc #,tmp - (current-contract-region) - 'cant-happen - (quote #,id) - (quote-srcloc #,id)) - (set-box! #,export-loc - (cons #,tmp (current-contract-region))))) - (quasisyntax/loc defn-or-expr - (set-box! #,export-loc #,tmp))) - (quasisyntax/loc defn-or-expr - (define-syntax #,id - (make-id-mapper (quote-syntax #,tmp)))))))] - [else (list (quasisyntax/loc defn-or-expr - (define-syntax #,id - (make-rename-transformer (quote-syntax #,tmp)))))])))]) - (cons (quasisyntax/loc defn-or-expr - (define-values #,tmps body)) - (apply append (map do-one ids tmps))))] - [else (list defn-or-expr)])) - expanded-body))]) - #'(block defn-or-expr ...)))))))) - -(define-for-syntax (redirect-imports/exports import?) - (lambda (table-stx - import-tagged-infos - import-sigs - target-import-tagged-infos - target-import-sigs) - (define def-table (make-bound-identifier-mapping)) - (define ctc-table (make-bound-identifier-mapping)) - (define sig-table (make-bound-identifier-mapping)) - (for-each - (lambda (tagged-info sig) - (define v - #`(hash-ref #,table-stx #,(car (tagged-info->keys tagged-info)))) - (for-each - (lambda (int/ext-name index ctc) - (bound-identifier-mapping-put! def-table - (car int/ext-name) - #`(vector-ref #,v #,index)) - (bound-identifier-mapping-put! ctc-table - (car int/ext-name) - ctc) - (bound-identifier-mapping-put! sig-table - (car int/ext-name) - sig)) - (car sig) - (iota (length (car sig))) - (cadddr sig))) - import-tagged-infos - import-sigs) - (with-syntax ((((eloc ...) ...) - (map - (lambda (target-sig) - (map - (lambda (target-int/ext-name target-ctc) - (let* ([var (car target-int/ext-name)] - [vref - (bound-identifier-mapping-get - def-table - var - (lambda () - (raise-stx-err - (format (if import? - "identifier ~a is not present in new imports" - "identifier ~a is not present in old exports") - (syntax-e (car target-int/ext-name))))))] - [ctc (bound-identifier-mapping-get ctc-table var)] - [rename-bindings (get-member-bindings def-table - (bound-identifier-mapping-get sig-table var) - #'(current-contract-region))]) - (with-syntax ([ctc-stx (if ctc (syntax-property - #`(letrec-syntax #,rename-bindings #,ctc) - 'inferred-name var) - ctc)]) - (if target-ctc - #`(λ () - (cons #,(if ctc - #`(let ([old-v/c (#,vref)]) - (contract ctc-stx (car old-v/c) - (cdr old-v/c) (current-contract-region) - (quote #,var) (quote-srcloc #,var))) - #`(#,vref)) - (current-contract-region))) - (if ctc - #`(λ () - (let ([old-v/c (#,vref)]) - (contract ctc-stx (car old-v/c) - (cdr old-v/c) (current-contract-region) - (quote #,var) (quote-srcloc #,var)))) - vref))))) - (car target-sig) - (cadddr target-sig))) - target-import-sigs)) - (((export-keys ...) ...) - (map tagged-info->keys target-import-tagged-infos))) - #`(unit-export ((export-keys ...) - (vector-immutable eloc ...)) ...)))) - -(define-for-syntax redirect-imports (redirect-imports/exports #t)) -(define-for-syntax redirect-exports (redirect-imports/exports #f)) - - -;; build-unit/new-import-export : syntax-object -> -;; (values syntax-object (listof identifier) (listof identifier)) -;; constructs the code for a unit expression that changes the import and export signatures -;; of another. stx must be such that it passes check-unit-syntax. -;; The two additional values are the identifiers of the unit's import and export -;; signatures -(define-for-syntax (build-unit/new-import-export stx) - (syntax-case stx (import export init-depend) - (((import i ...) - (export e ...) - (init-depend id ...) - . body) - - (let* ([d (syntax->list #'(id ...))] - [dep-tagged-sigids (map check-tagged-id d)] - [dep-tagged-siginfos - (map tagged-sigid->tagged-siginfo dep-tagged-sigids)]) - (define-values (isig tagged-import-sigs import-tagged-infos - import-tagged-sigids import-sigs) - (process-unit-import #'(i ...))) - - (define-values (esig tagged-export-sigs export-tagged-infos - export-tagged-sigids export-sigs) - (process-unit-export #'(e ...))) - - (check-duplicate-sigs import-tagged-infos isig dep-tagged-siginfos d) - - (check-duplicate-subs export-tagged-infos esig) - - (check-unit-ie-sigs import-sigs export-sigs) - - (syntax-case #'body () - ((b) (check-link-line-syntax #'b)) - (() (raise-stx-err "missing unit specification")) - (_ (raise-stx-err "expects a single unit specification"))) - - (with-syntax (((((orig-e ...) unit-exp orig-i ...)) #'body)) - (define-values (orig-isig orig-tagged-import-sigs orig-import-tagged-infos - orig-import-tagged-sigids orig-import-sigs) - (process-unit-export #'(orig-i ...))) - - (define-values (orig-esig orig-tagged-export-sigs orig-export-tagged-infos - orig-export-tagged-sigids orig-export-sigs) - (process-unit-import #'(orig-e ...))) - (with-syntax ((((dept . depr) ...) - (map - (lambda (tinfo) - (cons (car tinfo) - (syntax-local-introduce (car (siginfo-rtime-ids (cdr tinfo)))))) - dep-tagged-siginfos)) - [((import-key ...) ...) - (map tagged-info->keys import-tagged-infos)] - [((export-key ...) ...) - (map tagged-info->keys export-tagged-infos)] - [((orig-import-key ...) ...) - (map tagged-info->keys orig-import-tagged-infos)] - [((orig-export-key ...) ...) - (map tagged-info->keys orig-export-tagged-infos)] - [(import-name ...) - (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) - import-tagged-infos)] - [(export-name ...) - (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) - export-tagged-infos)] - [(orig-import-name ...) - (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) - orig-import-tagged-infos)] - [(orig-export-name ...) - (map (lambda (tag/info) (car (siginfo-names (cdr tag/info)))) - orig-export-tagged-infos)] - [name (syntax-local-infer-name (error-syntax))] - [form (syntax-e (stx-car (error-syntax)))]) - (values - (quasisyntax/loc (error-syntax) - (let ([unit-tmp unit-exp]) - (check-unit unit-tmp 'form) - (check-sigs unit-tmp - (vector-immutable - (cons 'orig-import-name - (vector-immutable orig-import-key ...)) ...) - (vector-immutable - (cons 'orig-export-name - (vector-immutable orig-export-key ...)) ...) - 'form) - (make-unit - 'name - (vector-immutable (cons 'import-name - (vector-immutable import-key ...)) ...) - (vector-immutable (cons 'export-name - (vector-immutable export-key ...)) ...) - (list (cons 'dept depr) ...) - (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))]) - (lambda () - (let-values ([(unit-fn export-table) ((unit-go unit-tmp))]) - (values (lambda (import-table) - (unit-fn #,(redirect-imports #'import-table - import-tagged-infos - import-sigs - orig-import-tagged-infos - orig-import-sigs))) - #,(redirect-exports #'export-table - orig-export-tagged-infos - orig-export-sigs - export-tagged-infos - export-sigs)))))))) - import-tagged-sigids - export-tagged-sigids - dep-tagged-sigids))))))) - - -(define-syntax/err-param (unit/new-import-export stx) - (syntax-case stx () - ((_ . x) - (begin - (let-values (((u x y z) (build-unit/new-import-export (check-unit-syntax #'x)))) - u))))) - -;; build-compound-unit : syntax-object -> -;; (values syntax-object (listof identifier) (listof identifier)) -;; constructs the code for a compound-unit expression. stx match the return of -;; check-compound-syntax -;; The two additional values are the identifiers of the compound-unit's import and export -;; signatures -(define-for-syntax (build-compound-unit stx) - (define-struct lnkid-record (access-code names ctime-ids rtime-ids source-idx sigid siginfo)) - (define (lnkid-rec->keys t rec) - (map (lambda (rid) (build-key t rid)) - (lnkid-record-rtime-ids rec))) - (syntax-case stx () - (((import ...) - (export-lnktag ...) - (((sub-out ...) sub-exp sub-in-lnktag ...) ...)) - (with-syntax ((((import-tag import-lnkid . import-sigid) ...) - (map check-tagged-:-clause (syntax->list #'(import ...)))) - (((export-tag . export-lnkid) ...) - (map check-tagged-id - (syntax->list #'(export-lnktag ...)))) - ((((sub-out-tag sub-out-lnkid . sub-out-sigid) ...) ...) - (map (lambda (e) (map check-tagged-:-clause (syntax->list e))) - (syntax->list #'((sub-out ...) ...)))) - ((((sub-in-tag . sub-in-lnkid) ...) ...) - (map (lambda (t) (map check-tagged-id (syntax->list t))) - (syntax->list #'((sub-in-lnktag ...) ...))))) - - (let ([dup (check-duplicate-identifier - (syntax->list #'(import-lnkid ... sub-out-lnkid ... ...)))]) - (when dup - (raise-stx-err "duplicate linking identifier definition" dup))) - - - (let ([bt (make-bound-identifier-mapping)]) - (for-each - (lambda (lnkid) - (bound-identifier-mapping-put! bt lnkid #t)) - (syntax->list #'(import-lnkid ...))) - (for-each - (lambda (lnkid) - (when (bound-identifier-mapping-get bt lnkid (lambda () #f)) - (raise-stx-err "cannot directly export an import" lnkid))) - (syntax->list #'(export-lnkid ...)))) - - - (let* ([idxs (iota (add1 (length (syntax->list #'(sub-exp ...)))))] - [sub-export-table-tmps (generate-temporaries #'(sub-exp ...))] - [link-map - (let ((bt (make-bound-identifier-mapping))) - (for-each - (lambda (tags lnkids sigids tableid i) - (for-each - (lambda (tag lnkid sigid) - (define siginfo (signature-siginfo (lookup-signature sigid))) - (define rtime-ids (map syntax-local-introduce - (siginfo-rtime-ids siginfo))) - (bound-identifier-mapping-put! - bt - lnkid - (make-lnkid-record - #`(hash-ref - #,tableid - #,(build-key (syntax-e tag) (car rtime-ids))) - (siginfo-names siginfo) - (siginfo-ctime-ids siginfo) - rtime-ids - i - sigid - siginfo))) - (syntax->list tags) - (syntax->list lnkids) - (syntax->list sigids))) - (syntax->list #'((import-tag ...) (sub-out-tag ...) ...)) - (syntax->list #'((import-lnkid ...) (sub-out-lnkid ...) ...)) - (syntax->list #'((import-sigid ...) (sub-out-sigid ...) ...)) - (cons #'import-table-id sub-export-table-tmps) - idxs) - (lambda (id) - (bound-identifier-mapping-get - bt - id - (lambda () - (raise-stx-err "unknown linking identifier" id)))))] - [link-deps - (map - (lambda (tags lnkids i) - (define ht (make-hash)) - (for-each - (lambda (t l) - (define et (syntax-e t)) - (define el (syntax-e l)) - (define rec (link-map l)) - (define forward-dep (>= (lnkid-record-source-idx rec) i)) - (define import-dep (= 0 (lnkid-record-source-idx rec))) - (for-each - (lambda (ctime-id rtime-id name) - (hash-set! ht - (build-key et ctime-id) - (list forward-dep import-dep et rtime-id name el))) - (lnkid-record-ctime-ids rec) - (lnkid-record-rtime-ids rec) - (lnkid-record-names rec))) - (syntax->list tags) - (syntax->list lnkids)) - (hash-map ht (lambda (x y) y))) - (syntax->list #'((sub-in-tag ...) ...)) - (syntax->list #'((sub-in-lnkid ...) ...)) - (cdr idxs))]) - - (check-duplicate-subs - (map (lambda (t lid) (cons (syntax-e t) - (lnkid-record-siginfo (link-map lid)))) - (syntax->list #'(export-tag ...)) - (syntax->list #'(export-lnkid ...))) - (syntax->list #'(export-lnktag ...))) - - (with-syntax (((sub-tmp ...) (generate-temporaries #'(sub-exp ...))) - ((sub-export-table-tmp ...) sub-export-table-tmps) - (name (syntax-local-infer-name (error-syntax))) - (((import-key ...) ...) - (map - (lambda (t l) - (lnkid-rec->keys (syntax-e t) (link-map l))) - (syntax->list #'(import-tag ...)) - (syntax->list #'(import-lnkid ...)))) - (((export-key ...) ...) - (map - (lambda (t l) - (lnkid-rec->keys (syntax-e t) (link-map l))) - (syntax->list #'(export-tag ...)) - (syntax->list #'(export-lnkid ...)))) - ((import-name ...) - (map (lambda (l) (car (lnkid-record-names (link-map l)))) - (syntax->list #'(import-lnkid ...)))) - ((export-name ...) - (map (lambda (l) (car (lnkid-record-names (link-map l)))) - (syntax->list #'(export-lnkid ...)))) - (((((sub-in-key sub-in-code) ...) ...) ...) - (map - (lambda (stxed-tags lnkids) - (define lnkid-recs (map link-map (syntax->list lnkids))) - (define tags (map syntax-e (syntax->list stxed-tags))) - (define tagged-siginfos - (map - (lambda (t l) (cons t (lnkid-record-siginfo l))) - tags - lnkid-recs)) - (check-duplicate-subs tagged-siginfos (syntax->list lnkids)) - (map - (lambda (t lr) - (with-syntax (((key ...) - (lnkid-rec->keys t lr))) - #`((key #,(lnkid-record-access-code lr)) ...))) - tags - lnkid-recs)) - (syntax->list #'((sub-in-tag ...) ...)) - (syntax->list #'((sub-in-lnkid ...) ...)))) - ((((sub-out-key ...) ...) ...) - (map - (lambda (lnkids tags) - (map - (lambda (l t) - (lnkid-rec->keys (syntax-e t) (link-map l))) - (syntax->list lnkids) - (syntax->list tags))) - (syntax->list #'((sub-out-lnkid ...) ...)) - (syntax->list #'((sub-out-tag ...) ...)))) - (((export-sigid . export-code) ...) - (map (lambda (lnkid) - (define s (link-map lnkid)) - (cons (lnkid-record-sigid s) - (lnkid-record-access-code s))) - (syntax->list #'(export-lnkid ...)))) - (form (syntax-e (stx-car (error-syntax)))) - ) - - (with-syntax (((check-sub-exp ...) - (map - (lambda (stx link-deps) - (with-syntax (((sub-exp - sub-tmp - ((sub-in-key ...) ...) - ((sub-out-key ...) ...) - sub-in-lnkid - sub-out-lnkid) - stx)) - (with-syntax (((sub-in-signame ...) - (map (lambda (l) (car (lnkid-record-names (link-map l)))) - (syntax->list #'sub-in-lnkid))) - ((sub-out-signame ...) - (map (lambda (l) (car (lnkid-record-names (link-map l)))) - (syntax->list #'sub-out-lnkid))) - (((fdep-tag fdep-rtime fsig-name flnk-name) ...) - (map cddr (filter car link-deps))) - (((rdep-tag rdep-rtime . _) ...) - (map cddr (filter cadr link-deps)))) - #`(begin - #,(syntax/loc #'sub-exp - (check-unit sub-tmp 'form)) - #,(syntax/loc #'sub-exp - (check-sigs sub-tmp - (vector-immutable - (cons 'sub-in-signame - (vector-immutable sub-in-key ...)) - ...) - (vector-immutable - (cons 'sub-out-signame - (vector-immutable sub-out-key ...)) - ...) - 'form)) - (let ([fht (equal-hash-table - ((cons 'fdep-tag fdep-rtime) - (cons 'fsig-name 'flnk-name)) - ...)] - [rht (equal-hash-table - ((cons 'rdep-tag rdep-rtime) - #t) - ...)]) - #,(syntax/loc #'sub-exp (check-deps fht sub-tmp 'form)) - (for-each - (lambda (dep) - (when (hash-ref rht dep #f) - (set! deps (cons dep deps)))) - (unit-deps sub-tmp))))))) - (syntax->list #'((sub-exp - sub-tmp - ((sub-in-key ...) ...) - ((sub-out-key ...) ...) - (sub-in-lnkid ...) - (sub-out-lnkid ...)) - ...)) - link-deps)) - (((sub-in-key-code-workaround ...) ...) - (map - (lambda (x) - (with-syntax ((((a ...) ...) x)) - #'(a ... ...))) - (syntax->list #'((((sub-in-key sub-in-code) ...) ...) ...)))) - ) - (values - (quasisyntax/loc (error-syntax) - (let ([deps '()] - [sub-tmp sub-exp] ...) - check-sub-exp ... - (make-unit - 'name - (vector-immutable - (cons 'import-name - (vector-immutable import-key ...)) - ...) - (vector-immutable - (cons 'export-name - (vector-immutable export-key ...)) - ...) - deps - (lambda () - (let-values ([(sub-tmp sub-export-table-tmp) ((unit-go sub-tmp))] - ...) - (values (lambda (import-table-id) - (void) - (sub-tmp (equal-hash-table sub-in-key-code-workaround ...)) - ...) - (unit-export ((export-key ...) export-code) ...))))))) - (map syntax-e (syntax->list #'((import-tag . import-sigid) ...))) - (map syntax-e (syntax->list #'((export-tag . export-sigid) ...))) - '())))))) - (((i ...) (e ...) (l ...)) - (for-each check-link-line-syntax (syntax->list #'(l ...)))))) - - -(define-syntax/err-param (compound-unit stx) - (let-values (((u x y z) - (build-compound-unit - (check-compound-syntax (syntax-case stx () ((_ . x) #'x)))))) - u)) - - -(define (invoke-unit/core unit) - (check-unit unit 'invoke-unit) - (check-no-imports unit 'invoke-unit) - (let-values ([(f exports) ((unit-go unit))]) - (f #f))) - -(define-syntax/err-param (define-values/invoke-unit/core stx) - (syntax-case stx () - ((_ unit-expr . unit-out) - (let* ((unit-out (checked-syntax->list #'unit-out)) - (tagged-out (map process-tagged-import unit-out)) - (out-tags (map car tagged-out)) - (out-sigs (map caddr tagged-out)) - (dup (check-duplicate-identifier (apply append (map sig-int-names out-sigs)))) - (out-vec (generate-temporaries out-sigs)) - (tmarker (make-syntax-introducer)) - (tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs)) - (def-table (make-bound-identifier-mapping))) - (when dup - (raise-stx-err (format "duplicate binding for ~.s" (syntax-e dup)))) - (for-each - (λ (sig new-xs) - (for-each - (λ (old new) - (bound-identifier-mapping-put! def-table old new)) - (map car (car sig)) - new-xs)) - out-sigs - tmp-bindings) - (with-syntax ((((key1 key ...) ...) (map tagged-info->keys out-tags)) - ((((int-binding . ext-binding) ...) ...) (map car out-sigs)) - ((out-vec ...) out-vec) - (((renames - (((mac-name ...) mac-body) ...) - (((val-name ...) val-body) ...)) - ...) - (map build-val+macro-defs out-sigs)) - ((out-names ...) - (map (lambda (info) (car (siginfo-names (cdr info)))) - out-tags)) - (((tmp-binding ...) ...) tmp-bindings) - (((out-code ...) ...) - (map - (lambda (os ov) - (map - (lambda (i) - #`(vector-ref #,ov #,i)) - (iota (length (car os))))) - out-sigs - out-vec)) - (((wrap-code ...) ...) - (map (λ (os ov tbs) - (define rename-bindings - (get-member-bindings def-table os #'(quote-module-name))) - (map (λ (tb i v c) - (if c - (with-syntax ([ctc-stx - (syntax-property - #`(letrec-syntax #,rename-bindings #,c) - 'inferred-name v)]) - #`(let ([v/c (#,tb)]) - (contract ctc-stx (car v/c) (cdr v/c) - (current-contract-region) - (quote #,v) (quote-srcloc #,v)))) - #`(#,tb))) - tbs - (iota (length (car os))) - (map car (car os)) - (cadddr os))) - out-sigs - out-vec - tmp-bindings))) - (quasisyntax/loc stx - (begin - (define-values (tmp-binding ... ...) - #,(syntax/loc #'unit-expr - (let ((unit-tmp unit-expr)) - (check-unit unit-tmp 'define-values/invoke-unit) - (check-sigs unit-tmp - (vector-immutable) - (vector-immutable (cons 'out-names - (vector-immutable key1 key ...)) ...) - 'define-values/invoke-unit) - (let-values (((unit-fn export-table) - ((unit-go unit-tmp)))) - (let ([out-vec (hash-ref export-table key1)] ...) - (unit-fn #f) - (values out-code ... ...)))))) - (define-values (int-binding ... ...) - (values wrap-code ... ...)) - (define-syntaxes . renames) ... - (define-syntaxes (mac-name ...) mac-body) ... ... - (define-values (val-name ...) val-body) ... ...))))) - ((_) - (raise-stx-err "missing unit expression")))) - -;; build-unit-from-context : syntax-object -> -;; (values syntax-object (listof identifier) (listof identifier)) -;; constructs the code for a unit-from-context expression. stx must be -;; such that it passes check-ufc-syntax. -;; The two additional values are the identifiers of the unit's import and export -;; signatures -(define-for-syntax (build-unit-from-context stx) - (syntax-case stx () - ((export-spec) - (let* ((tagged-export-sig (process-tagged-export #'export-spec)) - (export-sig (caddr tagged-export-sig))) - (with-syntax ((((int-id . ext-id) ...) (car export-sig)) - ((def-name ...) (generate-temporaries (map car (car export-sig))))) - (values - #'(:unit (import) (export (rename export-spec (def-name int-id) ...)) - (define def-name int-id) - ...) - null - (list (cadr tagged-export-sig)) - '())))))) - -(define-for-syntax (check-ufc-syntax stx) - (syntax-case stx () - ((export-spec) (void)) - (() - (raise-stx-err "missing export-spec")) - (_ - (raise-stx-err "nothing is permitted after export-spec")))) - -(define-syntax/err-param (unit-from-context stx) - (syntax-case stx () - ((_ . x) - (begin - (check-ufc-syntax #'x) - (let-values (((u x y z) (build-unit-from-context #'x))) - u))))) - - - -(define-for-syntax (build-define-unit-helper contracted?) - (lambda (stx build err-msg) - (syntax-case stx () - ((_ name . rest) - (begin - (check-id #'name) - (let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))]) - (build #'rest )))) - (with-syntax ((((itag . isig) ...) i) - (((etag . esig) ...) e) - (((deptag . depsig) ...) d) - (contracted? contracted?)) - (quasisyntax/loc (error-syntax) - (begin - (define u #,exp) - (define-syntax name - (make-set!-transformer - (make-unit-info (quote-syntax u) - (list (cons 'itag (quote-syntax isig)) ...) - (list (cons 'etag (quote-syntax esig)) ...) - (list (cons 'deptag (quote-syntax deptag)) ...) - (quote-syntax name) - contracted?))))))))) - ((_) - (raise-stx-err err-msg))))) - -;; build-define-unit : syntax-object -;; (syntax-object -> (values syntax-object (listof identifier) (listof identifier)) -;; string -> -;; syntax-object -(define-for-syntax build-define-unit (build-define-unit-helper #f)) -(define-for-syntax build-define-unit/contracted (build-define-unit-helper #t)) - -(define-for-syntax (build-define-unit-binding stx) - - (define (check-helper tagged-info) - (cons (car (siginfo-names (cdr tagged-info))) - (tagged-info->keys tagged-info))) - - (syntax-case stx (import export init-depend) - ((unit-exp (import i ...) (export e ...) (init-depend idep ...)) - (let* ([ti (syntax->list #'(i ...))] - [te (syntax->list #'(e ...))] - [tidep (syntax->list #'(idep ...))] - [tagged-import-sigids (map check-tagged-id ti)] - [tagged-export-sigids (map check-tagged-id te)] - [tagged-dep-sigids (map check-tagged-id tidep)] - [tagged-import-infos (map tagged-sigid->tagged-siginfo tagged-import-sigids)] - [tagged-export-infos (map tagged-sigid->tagged-siginfo tagged-export-sigids)] - [tagged-dep-siginfos (map tagged-sigid->tagged-siginfo tagged-dep-sigids)]) - (check-duplicate-sigs tagged-import-infos ti tagged-dep-siginfos tidep) - (check-duplicate-subs tagged-export-infos te) - (with-syntax ((((import-name . (import-keys ...)) ...) - (map check-helper tagged-import-infos)) - (((export-name . (export-keys ...)) ...) - (map check-helper tagged-export-infos)) - (form (stx-car (error-syntax)))) - (values - #`(let ([unit-tmp unit-exp]) - #,(syntax/loc #'unit-exp - (check-unit unit-tmp 'form)) - #,(syntax/loc #'unit-exp - (check-sigs unit-tmp - (vector-immutable - (cons 'import-name - (vector-immutable import-keys ...)) - ...) - (vector-immutable - (cons 'export-name - (vector-immutable export-keys ...)) - ...) - 'form)) - unit-tmp) - tagged-import-sigids - tagged-export-sigids - tagged-dep-sigids)))))) - -(define-syntax/err-param (define-unit-binding stx) - (build-define-unit stx (lambda (unit) - (build-define-unit-binding (check-unit-body-syntax unit))) - "missing unit name, unit expression, import clause, and export clause")) - -(define-syntax/err-param (define-unit stx) - (build-define-unit stx (lambda (unit) - (build-unit (check-unit-syntax unit))) - "missing unit name, import clause, and export clause")) - -(define-syntax/err-param (define-unit/new-import-export stx) - (build-define-unit stx (lambda (unit) - (build-unit/new-import-export (check-unit-syntax unit))) - "missing unit name, import clause, and export clause")) - -(define-syntax/err-param (define-compound-unit stx) - (build-define-unit stx (lambda (clauses) - (build-compound-unit (check-compound-syntax clauses))) - "missing unit name")) - -(define-syntax/err-param (define-unit-from-context stx) - (build-define-unit stx (lambda (sig) - (check-ufc-syntax sig) - (build-unit-from-context sig)) - "missing unit name and signature")) - -(define-for-syntax (build-unit/contract stx) - (syntax-parse stx - [(:import-clause/contract :export-clause/contract dep:dep-clause . body) - (let-values ([(exp isigs esigs deps) - (build-unit - (check-unit-syntax - (syntax/loc stx - ((import i.s ...) (export e.s ...) dep . body))))]) - (with-syntax ([name (syntax-local-infer-name (error-syntax))] - [(import-tagged-sig-id ...) - (map (λ (i s) - (if (identifier? i) #`(tag #,i #,s) s)) - (syntax->list #'(i.s.i ...)) - (syntax->list #'(i.s.s.name ...)))] - [(export-tagged-sig-id ...) - (map (λ (i s) - (if (identifier? i) #`(tag #,i #,s) s)) - (syntax->list #'(e.s.i ...)) - (syntax->list #'(e.s.s.name ...)))]) - (with-syntax ([new-unit exp] - [unit-contract - (unit/c/core - #'name - (syntax/loc stx - ((import (import-tagged-sig-id [i.x i.c] ...) ...) - (export (export-tagged-sig-id [e.x e.c] ...) ...))))]) - (values - (syntax/loc stx - (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name))) - isigs esigs deps))))] - [(ic:import-clause/contract ec:export-clause/contract . body) - (build-unit/contract - (syntax/loc stx - (ic ec (init-depend) . body)))])) - -(define-syntax/err-param (define-unit/contract stx) - (build-define-unit/contracted stx (λ (stx) - (build-unit/contract stx)) - "missing unit name")) - -(define-for-syntax (unprocess-tagged-id ti) - (if (car ti) - #`(tag #,(car ti) #,(cdr ti)) - (cdr ti))) - -(define-for-syntax (temp-id-with-tags id i) - (syntax-case i (tag) - [(tag t sig) - (list id #`(tag t #,id) #'sig)] - [_else - (list id id i)])) - -(define-syntax/err-param (define-values/invoke-unit stx) - (syntax-case stx (import export) - ((_ u (import) (export e ...)) - (quasisyntax/loc stx - (define-values/invoke-unit/core u e ...))) - ((_ u (import i ...) (export e ...)) - (with-syntax (((EU ...) (generate-temporaries #'(e ...))) - (((IU IUl i) ...) (map temp-id-with-tags - (generate-temporaries #'(i ...)) - (syntax->list #'(i ...)))) - ((iu ...) (generate-temporaries #'(i ...))) - ((i-id ...) (map cdadr - (map process-tagged-import - (syntax->list #'(i ...))))) - ((e-id ...) (map cdadr - (map process-tagged-export - (syntax->list #'(e ...)))))) - (quasisyntax/loc stx - (begin - (define-unit-from-context iu i) - ... - (define-compound-unit u2 (import) - (export EU ...) - (link [((IU : i-id)) iu] ... [((EU : e-id) ...) u IUl ...])) - (define-values/invoke-unit/core u2 e ...))))) - ((_) - (raise-stx-err "missing unit" stx)) - ((_ . b) - (raise-stx-err - (format "expected syntax matching (~a (import ...) (export ...))" - (syntax-e (stx-car stx))))))) - -;; build-compound-unit/infer : syntax-object -> -;; (values syntax-object (listof identifier) (listof identifier)) -;; constructs the code for a compound-unit/infer expression. stx match the return of -;; check-compound-syntax -;; The two additional values are the identifiers of the compound-unit's import and export -;; signatures -(define-for-syntax (build-compound-unit/infer stx) - - (define (lookup-tagged tid) - (cons (car tid) (lookup-signature (cdr tid)))) - - (define (process-signature s) - (define l - ((check-tagged - (lambda (b) - (syntax-case* b (:) (lambda (x y) (eq? (syntax-e x) (syntax-e y))) - ((x : y) - (and (identifier? #'x) (identifier? #'y)) - (list #'x #'y (signature-siginfo (lookup-signature #'y)))) - (x - (identifier? #'x) - (list (car (generate-temporaries (list #'x))) - #'x - (signature-siginfo (lookup-signature #'x)))) - (_ - (raise-stx-err "expected syntax matching or ( : )" - b))))) - s)) - (apply make-link-record l)) - - (define ((process-tagged-sigid introducer) sid) - (make-link-record (car sid) #f (introducer (cdr sid)) (signature-siginfo (lookup-signature (cdr sid))))) - - (syntax-case stx () - (((import ...) - (export ...) - (((out ...) u l ...) ...)) - (let* ([us (syntax->list #'(u ...))] - [units (map lookup-def-unit us)] - [import-sigs (map process-signature - (syntax->list #'(import ...)))] - [sig-introducers (map (lambda (unit u) - (make-syntax-delta-introducer u (unit-info-orig-binder unit))) - units us)] - [sub-outs - (map - (lambda (outs unit sig-introducer) - (define o - (map - (lambda (clause) - (define c (check-tagged-:-clause clause)) - (make-link-record (car c) (cadr c) (cddr c) - (signature-siginfo (lookup-signature (cddr c))))) - (syntax->list outs))) - (complete-exports (map (process-tagged-sigid sig-introducer) (unit-info-export-sig-ids unit)) - o)) - (syntax->list #'((out ...) ...)) - units - sig-introducers)] - [link-defs (append import-sigs (apply append sub-outs))]) - - (define lnk-table (make-bound-identifier-mapping)) - (define sig-table (make-hasheq)) - - (let ([dup (check-duplicate-identifier (map link-record-linkid link-defs))]) - (when dup - (raise-stx-err "duplicate identifier" dup))) - - (for-each - (lambda (b) - (bound-identifier-mapping-put! lnk-table (link-record-linkid b) b)) - link-defs) - - (for-each - (lambda (b) - (for-each - (lambda (cid) - (define there? (hash-ref sig-table cid #f)) - (hash-set! sig-table cid (if there? 'duplicate (link-record-linkid b)))) - (siginfo-ctime-ids (link-record-siginfo b)))) - link-defs) - - (let ([sub-ins - (map - (lambda (ins unit sig-introducer unit-stx) - (define is (syntax->list ins)) - (define lrs - (map - (lambda (i) - (define tagged-lnkid (check-tagged-id i)) - (define sig - (bound-identifier-mapping-get lnk-table - (cdr tagged-lnkid) - (lambda () #f))) - (unless sig - (raise-stx-err "unknown linking identifier" i)) - (make-link-record (car tagged-lnkid) - (cdr tagged-lnkid) - (link-record-sigid sig) - (link-record-siginfo sig))) - is)) - (check-duplicate-subs - (map - (lambda (lr) (cons (link-record-tag lr) (link-record-siginfo lr))) - lrs) - is) - (complete-imports sig-table - lrs - (map (process-tagged-sigid sig-introducer) - (unit-info-import-sig-ids unit)) - unit-stx)) - (syntax->list #'((l ...) ...)) - units - sig-introducers - us)] - [exports - (map - (lambda (e) - (define tid (check-tagged-id e)) - (define lookup (bound-identifier-mapping-get - lnk-table - (cdr tid) - (lambda () #f))) - (cond - [lookup (unprocess-tagged-id tid)] - [else - (let ([lnkid (hash-ref - sig-table - (car (siginfo-ctime-ids (signature-siginfo (lookup-signature (cdr tid))))) - #f)]) - (cond - [(not lnkid) - (raise-stx-err "no sub unit exports this signature" (cdr tid))] - [(eq? lnkid 'duplicate) - (raise-stx-err "multiple sub units export this signature" (cdr tid))] - [else - (unprocess-tagged-id - (cons (car tid) lnkid))]))])) - (syntax->list #'(export ...)))]) - (with-syntax (((import ...) - (map unprocess-link-record-bind import-sigs)) - (((out ...) ...) - (map - (lambda (out) - (map unprocess-link-record-bind out)) - sub-outs)) - (((in ...) ...) - (map - (lambda (ins) - (map unprocess-link-record-use ins)) - sub-ins)) - ((unit-id ...) (map - (lambda (u stx) - (quasisyntax/loc stx #,(unit-info-unit-id u))) - units (syntax->list #'(u ...))))) - (build-compound-unit #`((import ...) - #,exports - (((out ...) unit-id in ...) ...))))))) - (((i ...) (e ...) (l ...)) - (for-each check-link-line-syntax (syntax->list #'(l ...)))))) - - -(define-for-syntax (check-compound/infer-syntax stx) - (syntax-case (check-compound-syntax stx) () - ((i e (b ...)) - (with-syntax (((b ...) - (map - (lambda (b) - (if (identifier? b) - #`(() #,b) - b)) - (syntax->list #'(b ...))))) - #'(i e (b ...)))))) - -(define-syntax/err-param (compound-unit/infer stx) - (let-values (((u i e d) - (build-compound-unit/infer - (check-compound/infer-syntax - (syntax-case stx () ((_ . x) #'x)))))) - u)) - -(define-for-syntax (do-define-compound-unit/infer stx) - (build-define-unit stx - (lambda (clause) - (build-compound-unit/infer (check-compound/infer-syntax clause))) - "missing unit name")) - -(define-syntax/err-param (define-compound-unit/infer stx) - (do-define-compound-unit/infer stx)) - -;; (syntax or listof[syntax]) boolean (boolean or listof[syntax]) -> syntax -(define-for-syntax (build-invoke-unit/infer units define? exports) - (define (imps/exps-from-unit u) - (let* ([ui (lookup-def-unit u)] - [unprocess (let ([i (make-syntax-delta-introducer u (unit-info-orig-binder ui))]) - (lambda (p) - (unprocess-tagged-id (cons (car p) (i (cdr p))))))] - [isigs (map unprocess (unit-info-import-sig-ids ui))] - [esigs (map unprocess (unit-info-export-sig-ids ui))]) - (values isigs esigs))) - (define (drop-from-other-list exp-tagged imp-tagged imp-sources) - (let loop ([ts imp-tagged] [ss imp-sources]) - (cond - [(null? ts) null] - [(ormap (lambda (tinfo2) - (and (eq? (car (car ts)) (car tinfo2)) - (siginfo-subtype (cdr tinfo2) (cdr (car ts))))) - exp-tagged) - (loop (cdr ts) (cdr ss))] - [else (cons (car ss) (loop (cdr ts) (cdr ss)))]))) - - (define (drop-duplicates tagged-siginfos sources) - (let loop ([ts tagged-siginfos] [ss sources] [res-t null] [res-s null]) - (cond - [(null? ts) (values res-t res-s)] - [(ormap (lambda (tinfo2) - (and (eq? (car (car ts)) (car tinfo2)) - (siginfo-subtype (cdr tinfo2) (cdr (car ts))))) - (cdr ts)) - (loop (cdr ts) (cdr ss) res-t res-s)] - [else (loop (cdr ts) (cdr ss) (cons (car ts) res-t) (cons (car ss) res-s))]))) - - (define (imps/exps-from-units units exports) - (define-values (isigs esigs) - (let loop ([units units] [imps null] [exps null]) - (if (null? units) - (values imps exps) - (let-values ([(i e) (imps/exps-from-unit (car units))]) - (loop (cdr units) (append i imps) (append e exps)))))) - (define-values (isig tagged-import-sigs import-tagged-infos - import-tagged-sigids import-sigs) - (process-unit-import (datum->syntax #f isigs))) - - (define-values (esig tagged-export-sigs export-tagged-infos - export-tagged-sigids export-sigs) - (process-unit-export (datum->syntax #f esigs))) - (check-duplicate-subs export-tagged-infos esig) - (let-values ([(itagged isources) (drop-duplicates import-tagged-infos isig)]) - (values (drop-from-other-list export-tagged-infos itagged isources) - (cond - [(list? exports) - (let-values ([(spec-esig spec-tagged-export-sigs spec-export-tagged-infos - spec-export-tagged-sigids spec-export-sigs) - (process-unit-export (datum->syntax #f exports))]) - (restrict-exports export-tagged-infos - spec-esig spec-export-tagged-infos))] - [else esig])))) - - (define (restrict-exports unit-tagged-exports spec-exports spec-tagged-exports) - (for-each (lambda (se ste) - (unless (ormap (lambda (ute) - (and (eq? (car ute) (car ste)) - (siginfo-subtype (cdr ute) (cdr ste)))) - unit-tagged-exports) - (raise-stx-err (format "no subunit exports signature ~a" - (syntax->datum se)) - se))) - spec-exports - spec-tagged-exports) - spec-exports) - (when (and (not define?) exports) - (error 'build-invoke-unit/infer - "internal error: exports for invoke-unit/infer")) - (when (null? units) - (raise-stx-err "no units in link clause")) - (cond [(identifier? units) - (let-values ([(isig esig) (imps/exps-from-units (list units) exports)]) - (with-syntax ([u units] - [(esig ...) esig] - [(isig ...) isig]) - (if define? - (syntax/loc (error-syntax) (define-values/invoke-unit u (import isig ...) (export esig ...))) - (syntax/loc (error-syntax) (invoke-unit u (import isig ...))))))] - [(list? units) - (let-values ([(isig esig) (imps/exps-from-units units exports)]) - (with-syntax ([(new-unit) (generate-temporaries '(new-unit))] - [(unit ...) units] - [(esig ...) esig] - [(isig ...) isig]) - (with-syntax ([u (let-values ([(u i e d) - (build-compound-unit/infer - (check-compound/infer-syntax - #'((import isig ...) - (export esig ...) - (link unit ...))))]) u)]) - (if define? - (syntax/loc (error-syntax) - (define-values/invoke-unit u - (import isig ...) (export esig ...))) - (syntax/loc (error-syntax) - (invoke-unit u - (import isig ...)))))))] - ;; just for error handling - [else (lookup-def-unit units)])) - -(define-syntax/err-param (define-values/invoke-unit/infer stx) - (syntax-case stx (export link) - [(_ (link unit ...)) - (build-invoke-unit/infer (syntax->list #'(unit ...)) #t #f)] - [(_ (export e ...) (link unit ...)) - (build-invoke-unit/infer (syntax->list #'(unit ...)) #t (syntax->list #'(e ...)))] - [(_ (export e ...) u) - (build-invoke-unit/infer #'u #t (syntax->list #'(e ...)))] - [(_ u) - (build-invoke-unit/infer #'u #t #f)] - [(_) - (raise-stx-err "missing unit" stx)] - [(_ . b) - (raise-stx-err - (format "expected syntax matching (~a [(export )] ) or (~a [(export )] (link ...))" - (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))])) - -(define-syntax/err-param (invoke-unit stx) - (syntax-case stx (import) - ((_ unit) - (syntax/loc stx - (invoke-unit/core unit))) - ((_ unit (import isig ...)) - (with-syntax (((u ...) (generate-temporaries (syntax->list #'(isig ...)))) - (((U Ul isig) ...) (map temp-id-with-tags - (generate-temporaries #'(isig ...)) - (syntax->list #'(isig ...)))) - ((isig-id ...) (map cdadr - (map process-tagged-import - (syntax->list #'(isig ...)))))) - (syntax/loc stx - (let () - (define-unit-from-context u isig) - ... - (define-compound-unit u2 (import) (export) - (link [((U : isig-id)) u] ... [() unit Ul ...])) - (invoke-unit/core u2))))) - (_ (raise-stx-err (format - "expected (~a ) or (~a (import ...))" - (syntax-e (stx-car stx)) - (syntax-e (stx-car stx))))))) - -(define-syntax/err-param (invoke-unit/infer stx) - (syntax-case stx () - [(_ (link unit ...)) - (build-invoke-unit/infer (syntax->list #'(unit ...)) #f #f)] - [(_ u) (build-invoke-unit/infer #'u #f #f)] - [(_) - (raise-stx-err "missing unit" stx)] - [(_ . b) - (raise-stx-err - (format "expected syntax matching (~a ) or (~a (link ...))" - (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))])) - -(define-for-syntax (build-unit/s stx) - (syntax-case stx (import export init-depend) - [((import i ...) (export e ...) (init-depend d ...) u) - (let* ([ui (lookup-def-unit #'u)] - [unprocess (let ([i (make-syntax-delta-introducer #'u (unit-info-orig-binder ui))]) - (lambda (p) - (unprocess-tagged-id (cons (car p) (i (cdr p))))))]) - (with-syntax ([(isig ...) (map unprocess (unit-info-import-sig-ids ui))] - [(esig ...) (map unprocess (unit-info-export-sig-ids ui))]) - (build-unit/new-import-export - (syntax/loc stx - ((import i ...) (export e ...) (init-depend d ...) ((esig ...) u isig ...))))))])) - -(define-syntax/err-param (define-unit/s stx) - (build-define-unit stx (λ (stx) (build-unit/s (check-unit-syntax stx))) - "missing unit name")) - -(define-syntax/err-param (unit/s stx) - (syntax-case stx () - [(_ . stx) - (let-values ([(u x y z) (build-unit/s (check-unit-syntax #'stx))]) - u)])) +(require racket/unit + (submod racket/unit compat)) +(provide (except-out (all-from-out racket/unit) struct/ctc) + (all-from-out (submod racket/unit compat))) diff --git a/collects/mzlib/zip.rkt b/collects/mzlib/zip.rkt index e67c2db..d1c59e6 100644 --- a/collects/mzlib/zip.rkt +++ b/collects/mzlib/zip.rkt @@ -1,269 +1,6 @@ -;; A modification of Dave Herman's zip module +#lang racket/base -(module zip mzscheme - (require mzlib/deflate racket/file mzlib/kw) +;; deprecated library, see `file/zip` - ;; =========================================================================== - ;; DATA DEFINITIONS - ;; =========================================================================== - - ;; An msdos-time or an msdos-date is an exact-integer in the respective format - ;; described at: - ;; - ;; http://msdn.microsoft.com/library/en-us/com/htm/cmf_a2c_25gl.asp - - ;; metadata : path * bytes * boolean * integer * integer * nat * integer - (define-struct metadata - (path name directory? time date compression attributes)) - - ;; header : metadata * exact-integer * nat * nat * nat - (define-struct header (metadata crc compressed uncompressed size)) - - ;; =========================================================================== - ;; CONSTANTS etc - ;; =========================================================================== - - (define *spec-version* 62) ; version 6.2 - (define *required-version* 20) ; version 2.0 - (define *compression-level* 8) ; I don't think this is configurable - (define *zip-comment* #"packed by Racket - http://racket-lang.org/") - - ;; PKZIP specification: - ;; http://www.pkware.com/company/standards/appnote/ - - (define *local-file-header* #x04034b50) - (define *archive-extra-record* #x08064b50) - (define *central-file-header* #x02014b50) - (define *digital-signature* #x05054b50) - (define *zip64-end-of-central-directory-record* #x06064b50) - (define *zip64-end-of-central-directory-locator* #x07064b50) - (define *end-of-central-directory-record* #x06054b50) - - (define *system* - (case (system-type) - [(unix oskit) 3] - [(windows) 0] - [(macos) 7] - [(macosx) 19])) - (define *os-specific-separator-regexp* - (case (system-type) - [(unix macosx oskit) #rx"/"] - [(windows) #rx"\\\\"] - [(macos) #rx":"])) - - (provide zip-verbose) - (define zip-verbose (make-parameter #f)) - - ;; =========================================================================== - ;; FILE CREATION - ;; =========================================================================== - - ;; date->msdos-time : date -> msdos-time - (define (date->msdos-time date) - (bitwise-ior (ceiling (/ (date-second date) 2)) - (arithmetic-shift (date-minute date) 5) - (arithmetic-shift (date-hour date) 11))) - - ;; date->msdos-date : date -> msdos-date - (define (date->msdos-date date) - (bitwise-ior (date-day date) - (arithmetic-shift (date-month date) 5) - (arithmetic-shift (- (date-year date) 1980) 9))) - - ;; seekable-port? : port -> boolean - (define (seekable-port? port) - (and (file-stream-port? port) - (with-handlers ([void (lambda (exn) #f)]) - (file-position port (file-position port)) - #t))) - - (define (write-int n size) - (write-bytes (integer->integer-bytes n size #f #f))) - - ;; zip-one-entry : metadata boolean -> header - (define (zip-one-entry metadata seekable?) - (let* ([directory? (metadata-directory? metadata)] - [path (metadata-path metadata)] - [filename (metadata-name metadata)] - [filename-length (bytes-length filename)] - [bits (if seekable? 0 #b1000)] - [time (metadata-time metadata)] - [date (metadata-date metadata)] - [compression (metadata-compression metadata)] - [mark1 #f] - [mark2 #f]) - (when (zip-verbose) - (eprintf "zip: compressing ~a...\n" filename)) - ;; write the contents to the output stream: - (write-int *local-file-header* 4) ; signature - (write-int *required-version* 2) ; version - (write-int bits 2) ; bits - (write-int compression 2) ; compression - (write-int time 2) ; time - (write-int date 2) ; date - (when seekable? (set! mark1 (file-position (current-output-port)))) - (write-int 0 4) ; crc-32 - (write-int 0 4) ; compressed - (write-int 0 4) ; uncompressed - (write-int filename-length 2) ; filename-length - (write-int 0 2) ; extra-length - (write-bytes filename) ; filename - (if directory? - (make-header metadata 0 0 0 (+ filename-length 30)) - (let-values ([(uncompressed compressed crc) - (with-input-from-file path - (lambda () - (deflate (current-input-port) - (current-output-port))))]) - (if seekable? - (begin (set! mark2 (file-position (current-output-port))) - (file-position (current-output-port) mark1)) - (write-int #x08074b50 4)) ; EXT signature - (write-int crc 4) ; crc-32 - (write-int compressed 4) ; compressed - (write-int uncompressed 4) ; uncompressed - (when seekable? (file-position (current-output-port) mark2)) - - ;; return the header information - (make-header metadata crc compressed uncompressed - (+ filename-length compressed - (if seekable? 30 46))))))) - - ;; write-end-of-central-directory : nat nat nat -> - (define (write-end-of-central-directory count start size) - (let ([comment-length (bytes-length *zip-comment*)]) - (write-int #x06054b50 4) ; signature - (write-int 0 2) ; # this disk - (write-int 0 2) ; # disk with start of central dir. - (write-int count 2) ; # entries in central dir. on this disk - (write-int count 2) ; # entries in central dir. - (write-int size 4) ; size of central dir. - (write-int start 4) ; offset of start of central dir. - (write-int comment-length 2) - (write-bytes *zip-comment*))) - - ;; write-central-directory : (listof header) -> - (define (write-central-directory headers) - (let ([count (length headers)]) - (let loop ([headers headers] [offset 0] [size 0]) - (if (null? headers) - ;; no digital signature (why?) - (write-end-of-central-directory count offset size) - (let* ([header (car headers)] - [metadata (header-metadata header)] - [filename-length (bytes-length (metadata-name metadata))] - [attributes (metadata-attributes metadata)] - [compression (metadata-compression metadata)] - [version (bitwise-ior *spec-version* - (arithmetic-shift *system* 8))]) - (write-int #x02014b50 4) - (write-int version 2) - (write-int *required-version* 2) - (write-int 0 2) - (write-int compression 2) - (write-int (metadata-time metadata) 2) - (write-int (metadata-date metadata) 2) - (write-int (header-crc header) 4) - (write-int (header-compressed header) 4) - (write-int (header-uncompressed header) 4) - (write-int filename-length 2) - (write-int 0 2) - (write-int 0 2) ; comment length - (write-int 0 2) - (write-int 0 2) ; internal attributes - (write-int attributes 4) ; external attributes - (write-int offset 4) - (write-bytes (metadata-name metadata)) - (loop (cdr headers) - (+ offset (header-size header)) - (+ size filename-length 46))))))) - - ;; The PKZIP specification includes an entry in the central directory for - ;; an entry's "external file attributes," which for standard ZIP files is - ;; the MS-DOS (i.e., FAT) directory attribute byte, and the Unix zip adds - ;; the Unix bits as the higher two bytes. - - ;; This is for reference - ;; (define *msdos:read-only* #x01) - ;; (define *msdos:hidden* #x02) - ;; (define *msdos:system* #x04) - ;; (define *msdos:volume* #x08) - ;; (define *msdos:directory* #x10) - ;; (define *msdos:archive* #x20) - ;; (define *unix:directory* #o40000) - ;; (define *unix:char-dev* #o20000) - ;; (define *unix:fifo* #o10000) - ;; (define *unix:suid* #o04000) - ;; (define *unix:sgid* #o02000) - ;; (define *unix:sticky* #o01000) - ;; (define *unix:owner-read* #o00400) - ;; (define *unix:owner-write* #o00200) - ;; (define *unix:owner-exe* #o00100) - ;; (define *unix:group-read* #o00040) - ;; (define *unix:group-write* #o00020) - ;; (define *unix:group-exe* #o00010) - ;; (define *unix:other-read* #o00004) - ;; (define *unix:other-write* #o00002) - ;; (define *unix:other-exe* #o00001) - (define (path-attributes path dir?) - (let ([dos (if dir? #x10 0)] - [unix (apply bitwise-ior (if dir? #o40000 0) - (map (lambda (p) - (case p - [(read) #o444] - [(write) #o200] ; mask out write bits - [(execute) #o111])) - (file-or-directory-permissions path)))]) - (bitwise-ior dos (arithmetic-shift unix 16)))) - - ;; with-trailing-slash : bytes -> bytes - (define (with-trailing-slash bytes) - (regexp-replace #rx#"/*$" bytes "/")) - - ;; with-slash-separator : bytes -> bytes - (define (with-slash-separator bytes) - (regexp-replace* *os-specific-separator-regexp* bytes #"/")) - - ;; build-metadata : relative-path -> metadata - (define (build-metadata path) - (let* ([mod (seconds->date (file-or-directory-modify-seconds path))] - [dir? (directory-exists? path)] - [path (cond [(path? path) path] - [(string? path) (string->path path)] - [(bytes? path) (bytes->path path)])] - [name (with-slash-separator (path->bytes path))] - [name (if dir? (with-trailing-slash name) name)] - [time (date->msdos-time mod)] - [date (date->msdos-date mod)] - [comp (if dir? 0 *compression-level*)] - [attr (path-attributes path dir?)]) - (make-metadata path name dir? time date comp attr))) - - ;; =========================================================================== - ;; FRONT END - ;; =========================================================================== - - ;; zip-write : (listof relative-path) -> - ;; writes a zip file to current-output-port - (provide zip->output) - (define/kw (zip->output files #:optional [out (current-output-port)]) - (parameterize ([current-output-port out]) - (let* ([seekable? (seekable-port? (current-output-port))] - [headers ; note: Racket's `map' is always left-to-right - (map (lambda (file) - (zip-one-entry (build-metadata file) seekable?)) - files)]) - (when (zip-verbose) - (eprintf "zip: writing headers...\n")) - (write-central-directory headers)) - (when (zip-verbose) - (eprintf "zip: done.\n")))) - - ;; zip : output-file paths -> - (provide zip) - (define (zip zip-file . paths) - (when (null? paths) (error 'zip "no paths specified")) - (with-output-to-file zip-file - (lambda () (zip->output (pathlist-closure paths))))) - - ) +(require file/zip) +(provide (all-from-out file/zip))