diff --git a/collects/mzlib/awk.ss b/collects/mzlib/awk.ss index 58d200f..489a20e 100644 --- a/collects/mzlib/awk.ss +++ b/collects/mzlib/awk.ss @@ -1,13 +1,235 @@ -(begin-elaboration-time - (require-library "invoke.ss")) +(module awk mzscheme -(begin-elaboration-time - (define-values/invoke-unit (awk) - (require-relative-library "awkr.ss"))) + (export awk match:start match:end match:substring regexp-exec) -(define-macro awk awk) + (define-syntax awk + (lambda (stx) + (syntax-case stx () + [(_ next-record + (record first field ...) + counter + ((state-variable init-expr) ...) + continue + clause ...) + (and (identifier? (syntax counter-variable)) + (identifier? (syntax continue-variable))) + (let ([clauses (syntax->list (syntax (clause ...)))] + [initvars null]) + (with-syntax ([(local-state ...) (generate-temporaries + (syntax (state-variable ...)))]) + (letrec ([get-after-clauses + (lambda () + (let loop ([l clauses][afters null]) + (cond + [(null? l) (if (stx-null? afters) + (syntax ((values state-variable ...))) + afters)] + [(syntax-case (car l) (after) + [(after . rest) (syntax rest)]) + => (lambda (rest) + (with-syntax ([(after ...) afters]) + (loop (cdr l) (syntax (after ... . rest)))))] + [else + (loop (cdr l) afters)])))] + [wrap-state + (lambda (e) + (syntax-case e (=>) + [(=> f) + (with-syntax ([body (wrap-state (syntax ((f arg))))]) + (syntax (=> (lambda (arg) + . body))))] + [else + (syntax + ((call-with-values (lambda () . body) + (lambda (local-state ... . extras) + (set! else-ready? #f) + (set! state-variable local-state) + ...))))]))] + [make-range + (lambda (include-on? include-off? body rest) + (syntax-case body () + [(t1 t2 . body) + (with-syntax ([on? (car (generate-temporaries '(1)))] + [t1 (make-test (syntax-e (syntax t1)) (syntax t1))] + [t2 (make-test (syntax-e (syntax t2)) (syntax t2))] + [body (wrap-state (syntax body))]) + (with-syntax ([check (if include-on? + (if include-off? + (syntax post-on-on?) + (syntax on?)) + (if include-off? + (syntax orig-on?) + (syntax (and orig-on? on?))))]) + (set! initvars (cons (syntax (on? #f)) initvars)) + (syntax + ((let ([orig-on? on?]) + (unless on? + (set! on? t1)) + (let ([post-on-on? on?]) + (when on? + (set! on? (not t2)))) + (when check + . body)) + . rest))))]))] + [make-test + (lambda (test expr) + (cond + [(string? test) + (with-syntax ([g (car (generate-temporaries '(1)))]) + (set! initvars (cons (syntax (g (regexp expr))) initvars)) + (syntax (regexp-exec g first)))] + [(number? test) + (syntax (= expr counter))] + [else expr]))] + [get-testing-clauses + (lambda () + (let loop ([l clauses]) + (if (null? l) + null + (syntax-case (car l) () + [(test-expr body ...) + (with-syntax ([rest (loop (cdr l))]) + (let ([test (syntax-e (syntax test-expr))] + [body (syntax (body ...))]) + (cond + [(or (string? test) (number? test)) + (with-syntax ([t (make-test test (syntax text-expr))] + [body (wrap-state body)]) + (syntax + ((cond [t . body] + [else (void)]) + . rest)))] + [(eq? test 'else) + (with-syntax ([body (wrap-state body)]) + (syntax + ((when else-ready? . body) + (set! else-ready? #t) + . rest)))] + [(eq? test 'range) + (make-range #f #f body (syntax rest))] + [(eq? test ':range) + (make-range #t #f body (syntax rest))] + [(eq? test 'range:) + (make-range #f #t body (syntax rest))] + [(eq? test ':range:) + (make-range #t #t body (syntax rest))] + [(eq? test 'after) + (syntax rest)] + [(eq? test '/) + (with-syntax ([g (car (generate-temporaries '(1)))]) + (syntax-case body (/) + [(/ re / (var ...) . body) + (and (string? (syntax-e (syntax re))) + (andmap (lambda (x) (or (identifier? x) + (not (syntax-e x)))) + (syntax->list (syntax (var ...))))) + (with-syntax ([(var ...) + (for-each (lambda (x) + (if (identifier? x) + x + (car (generate-temporaries '(1))))) + (syntax->list (syntax (var ...))))] + [body (wrap-state (syntax body))]) + (set! initvars (cons (syntax (g (regexp re))) initvars)) + (syntax + ((cond + [(regexp-match re first) + => (lambda (arg) + (apply + (lambda (var ...) . body) + arg))] + [else (void)]) + rest)))]))] + [else + (with-syntax ([body (wrap-state (syntax body))]) + (syntax + ((cond [test-expr . body] + [else (void)]) + . rest)))])))]))))]) + (with-syntax ([testing-clauses (get-testing-clauses)] + [after-clauses (get-after-clauses)] + [initvars initvars]) + (syntax + (let ((state-variable init-expr) ... + . initvars) + (let loop ([counter 1]) + (call-with-values (lambda () get-next-record) + (lambda (first field ...) + (if (eof-object? first) + (begin + . after-clauses) + (let ([else-ready? #t]) + (let/ec escape + (let ([continue + (lambda (local-state ... . extras) + (set! state-variable local-state) + ... + (escape))]) + . testing-clauses)) + (loop (add1 counter)))))))))))))] + ;; Left out continue... + [(_ next-record + (record field-variable ...) + counter-variable + ((state-variable init-expr) ...) + clause ...) + (identifier? (syntax counter-variable)) + (syntax + (awk next-record + (record field-variable ...) + counter-variable + ((state-variable init-expr) ...) + continue-variable + clause ...))] + ;; Left out counter... + [(_ next-record + (record field-variable ...) + ((state-variable init-expr) ...) + continue-variable + clause ...) + (identifier? (syntax continue-variable)) + (syntax + (awk next-record + (record field-variable ...) + counter-variable + ((state-variable init-expr) ...) + continue-variable + clause ...))] + ;; Left out both... + [(_ next-record + (record field-variable ...) + ((state-variable init-expr) ...) + clause ...) + (syntax + (awk next-record + (record field-variable ...) + counter-variable + ((state-variable init-expr) ...) + continue-variable + clause ...))]))) -(define-values/invoke-unit (match:start match:end match:substring regexp-exec) - (require-relative-library "awkr.ss")) + (define-struct match (s a)) + (define match:start + (case-lambda + [(rec) (match:start rec 0)] + [(rec which) (car (list-ref (match-a rec) which))])) + + (define match:end + (case-lambda + [(rec) (match:end rec 0)] + [(rec which) (cdr (list-ref (match-a rec) which))])) + + (define match:substring + (case-lambda + [(rec) (match:substring rec 0)] + [(rec which) (let ([p (list-ref (match-a rec) which)]) + (substring (match-s rec) (car p) (cdr p)))])) + + (define regexp-exec + (lambda (re s) + (let ([r (regexp-match-positions re s)]) + (if r + (make-match s r) + #f))))) diff --git a/collects/mzlib/cmdline.ss b/collects/mzlib/cmdline.ss index ee06bdd..4b0b4df 100644 --- a/collects/mzlib/cmdline.ss +++ b/collects/mzlib/cmdline.ss @@ -1,9 +1,469 @@ -(require-library "cmdlineu.ss") +(module cmdline mzscheme -(begin-elaboration-time - (require-library "invoke.ss")) + (define-syntax command-line + (lambda (stx) + (syntax-case stx () + [(_ program-name + argv + clause ...) + (let ([serror + (lambda (msg . detail) + (apply + raise-syntax-error + 'command-line + msg + stx + detail))]) + (unless (string? (syntax-e (syntax program-name))) + (serror + "program name is not a string" + (syntax program-name))) + (let ([extract (lambda (what args . detail) + (if (null? args) + (apply serror (format "missing ~a" what) detail) + (values (car args) (cdr args))))] + [formal-names + (lambda (l) + (map + (lambda (a) + (cons (syntax->datum (let ([s (symbol->string (syntax-e a))]) + (if (char=? #\* (string-ref s (sub1 (string-length s)))) + (substring s 0 (sub1 (string-length s))) + s)) + #f (quote-syntax here)))) + l))]) + (let ([clauses + (let loop ([csrcs (syntax->list (syntax (clause ...)))][clauses null]) + (with-syntax ([(clause ...) clauses]) + (if (null? csrcs) + (syntax (clause ... (lambda (accum) (void)) null)) + (let ([line (car csrcs)] + [arest (cdr csrcs)]) + (syntax-case line (help-labels => args) + [(help-labels s ...) + (begin + (unless (andmap (lambda (x) (string? (syntax-e x))) + (syntax->list (syntax (s ...)))) + (serror "help-labels clause must contain only strings" line)) + (loop arest + (syntax (clause + ... + '(help-labels s ...)))))] + [(tag . rest) + (ormap (lambda (x) (module-identifier=? (syntax tag) x)) + (syntax->list (syntax (once-each once-any multi)))) + (let slloop ([sublines (syntax->list (syntax rest))]) + (if (null? sublines) + (syntax ()) + (with-syntax ([looped (slloop (cdr sublines))] + [subline + (with-syntax ([flags (syntax-case (car sublines) () + [((flag ...) . rest) + (begin + (unless (andmap (lambda (x) (string? (syntax-e x))) + (syntax->list (syntax (flag ...)))) + (serror "flag specification is not a string or sequence of strings" + (syntax (flag ...)))) + (syntax (flag ...)))] + [(flag . rest) + (string? (syntax-e (syntax flag))) + (syntax (flag))] + [else + (serror "clause does not start with flags")])]) + (syntax-case (car sublines) () + [(_ => a b) + (syntax (list 'flags a b))] + [(_ rest ...) + (let*-values ([(formals rest) (let loop ([a null][rest (syntax->list (syntax (rest ...)))]) + (cond + [(null? rest) (values a null)] + [(identifier? (car rest)) + (values (append a (list (car rest))) + (cdr rest))] + [else (values a rest)]))] + [(help rest) (extract "help string" rest line)] + [(_) (unless (string? (syntax-e help)) + (serror "help info is not a string" help))] + [(expr1 rest) (extract "handler body expressions" rest line)]) + (with-syntax ([formals formals] + [formal-names (formal-names formals)] + [help help] + [expr1 expr1] + [rest rest]) + (syntax (list 'flags + (lambda (flag . formals) + expr1 . rest) + '(help . formal-names)))))]))]) + (loop arest + (syntax (clause + ... + (list 'tag . (subline . looped))))))))] + [(=> finish-proc arg-help help-proc unknown-proc) + (begin + (unless (null? arest) + (serror "=> must be the last clause line")) + (syntax (clause + ... + finish-proc arg-help help-proc unknown-proc)))] + [(=> . _) + (serror "bad => line" line)] + [(args arg-formals body1 body ...) + (begin + (unless (null? arest) + (serror "args must be the last clause" line)) + (let ([formals + (let loop ([f (syntax arg-formals)]) + (syntax-case f () + [(arg . rest) + (identifier? (syntax arg)) + (cons (syntax arg) (loop (syntax rest)))] + [arg + (identifier? (syntax arg)) + (list (syntax arg))] + [else + (serror "bad argument list" line)]))]) + (with-syntax ([formal-names (formal-names formals)]) + (syntax (clause + ... + (lambda (accume . arg-formals) + body1 body ...) + 'formal-names)))))] + [(args . _) + (serror "bad args line" line)] + [else (serror "not a once-each, once-any, multi, args, or => line" line)])))))]) + (with-syntax ([clauses clauses]) + (syntax + (parse-command-line + program-name argv + . clauses))))))]))) + + (define number-regexp (regexp "^[-+][0-9]*(|[.][0-9]*)$")) + + (define print-args + (lambda (port l f) + (let loop ([l l][a (letrec ([a (arity f)] + [a-c (lambda (a) + (cond + [(number? a) (cons (sub1 a) (sub1 a))] + [(arity-at-least? a) + (let ([v (sub1 (arity-at-least-value a))]) + (cons v v))] + [else (let ([r (map a-c a)]) + (cons (apply min (map car r)) + (apply max (map cdr r))))]))]) + (a-c a))]) + (unless (null? l) + (fprintf port " ~a<~a>~a" + (if (positive? (car a)) "" "[") + (car l) + (if (positive? (car a)) "" "]")) + (unless (positive? (cdr a)) + (fprintf port " ...")) + (loop (cdr l) (cons (sub1 (car a)) (sub1 (cdr a)))))))) + + (define (procedure-arity-includes-at-least? p n) + (letrec ([a-c + (lambda (a) + (cond + [(number? a) (>= a n)] + [(arity-at-least? a) #t] + [else (ormap a-c a)]))]) + (a-c (arity p)))) + + (define parse-command-line + (case-lambda + [(program arguments table finish finish-help) + (parse-command-line program arguments table finish finish-help + (lambda (s) + (display s) + (exit 0)))] + [(program arguments table finish finish-help help) + (parse-command-line program arguments table finish finish-help help + (lambda (flag) + (error (string->symbol program) "unknown flag: ~s" flag)))] + [(program arguments table finish finish-help help unknown-flag) + (unless (string? program) + (raise-type-error 'parse-command-line "program name string" program)) + (unless (and (vector? arguments) + (andmap string? (vector->list arguments))) + (raise-type-error 'parse-command-line "argument vector of strings" arguments)) + (unless (and (list? table) + (let ([bad-table + (lambda (reason) + (raise-type-error 'parse-command-line + (format "table as a list of flag-list/procedure pairs (~a)" + reason) + table))]) + (andmap + (lambda (spec) + (and (or (and (list? spec) (pair? spec)) + (bad-table (format "spec-set must be a non-empty list: ~a" spec))) + (or (memq (car spec) '(once-any once-each multi help-labels)) + (bad-table (format "spec-set type must be 'once-any, 'once-each, 'multi, or 'help-labels: ~a" + (car spec)))) + (andmap + (lambda (line) + (if (eq? (car spec) 'help-labels) + + (or (string? line) + (bad-table (format "help-labels line must be a string: ~e" line))) + + (and (or (and (list? line) (= (length line) 3)) + (bad-table (format "spec-line must be a list of at three items: ~e" line))) + + (or (list? (car line)) + (bad-table (format "flags part of a spec-line must be a list: ~e" (car line)))) + + (andmap + (lambda (flag) + (or (string? flag) + (bad-table (format "flag must be a string: ~e" flag))) + (or (and (or (regexp-match "^-[^-]$" flag) + (regexp-match "^[+][^+]$" flag) + (regexp-match "^--." flag) + (regexp-match "^[+][+]." flag)) + (not (or (regexp-match "^--help$" flag) + (regexp-match "^-h$" flag) + (regexp-match number-regexp flag)))) + (bad-table (format "no ill-formed or pre-defined flags: ~e" flag)))) + (car line)) + + (or (procedure? (cadr line)) + (bad-table (format "second item in a spec-line must be a procedure: ~e" (cadr line)))) + + (let ([a (arity (cadr line))]) + (or (and (number? a) + (or (>= a 1) + (bad-table (format "flag handler procedure must take at least 1 argument: ~e" + (cadr line))))) + (arity-at-least? a) + (bad-table (format "flag handler procedure cannot have multiple cases: ~e" (cadr line))))) + + (or (and (list? (caddr line)) + (andmap string? (caddr line))) + (bad-table (format "spec-line help section must be a list of strings"))) + + (or (let ([l (length (caddr line))] + [a (arity (cadr line))]) + (if (number? a) + (= a l) + (and (>= l 1) + (>= l (arity-at-least-value a))))) + (bad-table (format "spec-line help list strings must match procedure arguments")))))) + (cdr spec)))) + table))) + (raise-type-error 'parse-command-line "table of spec sets" table)) + (unless (and (procedure? finish) + (procedure-arity-includes-at-least? finish 1)) + (raise-type-error 'parse-command-line "finish procedure accepting at least 1 argument" finish)) + (unless (and (list? finish-help) (andmap string? finish-help)) + (raise-type-error 'parse-command-line "argument help list of strings" finish-help)) + (unless (and (procedure? help) (procedure-arity-includes? help 1)) + (raise-type-error 'parse-command-line "help procedure of arity 1" help)) + (unless (and (procedure? unknown-flag) (procedure-arity-includes? unknown-flag 1) + (let ([a (arity unknown-flag)]) + (or (number? a) (arity-at-least? a)))) + (raise-type-error 'parse-command-line "unknown-flag procedure of simple arity, accepting 1 argument (an perhaps more)" unknown-flag)) + + (letrec ([a (arity finish)] + [l (length finish-help)] + [a-c (lambda (a) + (or (and (number? a) (sub1 a)) + (and (arity-at-least? a) + (max 1 (arity-at-least-value a))) + (and (list? a) (apply max (map a-c a)))))]) + (unless (= (a-c a) l) + (error 'parse-command-line "the length of the argument help string list does not match the arity of the finish procedure"))) + + (let* ([once-spec-set + (lambda (lines) + (let ([set (cons #f (apply append (map car lines)))]) + (map + (lambda (line) (cons set line)) + lines)))] + [table + (apply + append + (list + (list #f (list "--help" "-h") + (lambda (f) + (let* ([sp (open-output-string)]) + (fprintf sp "~a~a" program + (if (null? table) + "" + " [ ... ]")) + (print-args sp finish-help finish) + (fprintf sp "~n where is one of~n") + (for-each + (lambda (set) + (if (eq? (car set) 'help-labels) + (for-each + (lambda (line) + (fprintf sp " ~a~n" line)) + (cdr set)) + (for-each + (lambda (line) + (fprintf sp (cond + [(and (eq? (car set) 'once-any) + (pair? (cddr set))) + (cond + [(eq? line (cadr set)) "/"] + [(eq? line (let loop ([l set]) + (if (pair? (cdr l)) + (loop (cdr l)) + (car l)))) "\\"] + [else "|"])] + [(eq? (car set) 'multi) + "*"] + [else " "])) + (let loop ([flags (car line)]) + (let ([flag (car flags)]) + (fprintf sp " ~a" flag) + (print-args sp (cdaddr line) (cadr line))) + (unless (null? (cdr flags)) + (fprintf sp ",") + (loop (cdr flags)))) + (fprintf sp " : ~a~n" (caaddr line))) + (cdr set)))) + table) ; the original table + (fprintf sp " --help, -h : Show this help~n") + (fprintf sp " -- : Do not treat any remaining argument as a flag (at this level)~n") + (when (assq 'multi table) + (fprintf sp " * Asterisks indicate flags allowed multiple times.~n")) + (when (assq 'once-any table) + (fprintf sp " /|\\ Brackets indicate mutually exclusive flags.~n")) + (fprintf sp " Multiple single-letter flags can be combined after one `-'; for~n") + (fprintf sp " example: `-h-' is the same as `-h --'~n") + (help (get-output-string sp)))) + (list "Help"))) + (map + (lambda (spec) + (cond + [(eq? (car spec) 'once-each) + (apply + append + (map + (lambda (line) (once-spec-set (list line))) + (cdr spec)))] + [(eq? (car spec) 'once-any) + (once-spec-set (cdr spec))] + [(eq? (car spec) 'help-labels) + null] + [(eq? (car spec) 'multi) + (map + (lambda (line) (cons #f line)) + (cdr spec))])) + table))] + [done + (lambda (args r-acc) + (let ([options (reverse r-acc)] + [c (length args)]) + (if (procedure-arity-includes? finish (add1 c)) + (apply finish options args) + (error (string->symbol program) + (format "expects~a on the command line, given ~a argument~a~a" + (if (null? finish-help) + " no arguments" + (let ([s (open-output-string)]) + (parameterize ([current-output-port s]) + (print-args s finish-help finish)) + (let ([s (get-output-string s)]) + (if (equal? 2 (arity finish)) + (format " 1~a" s) + s)))) + c + (cond + [(zero? c) "s"] + [(= c 1) ": "] + [else "s: "]) + (let loop ([args args]) + (if (null? args) + "" + (string-append (car args) " " (loop (cdr args))))))))))] + [call-handler + (lambda (handler flag args r-acc k) + (let* ([a (arity handler)] + [remaining (length args)] + [needed (if (number? a) + (sub1 a) + (sub1 (arity-at-least-value a)))] + [use (if (number? a) + (sub1 a) + remaining)]) + (if (< remaining needed) + (error (string->symbol program) + "the ~s flag needs ~a argument~a, but only ~a provided" + flag needed (if (> needed 1) "s" "") + remaining) + (let ([v (apply handler + flag + (let loop ([n use][args args]) + (if (zero? n) + null + (cons (car args) + (loop (sub1 n) (cdr args))))))]) + (k (list-tail args use) + (if (void? v) + r-acc + (cons v r-acc)))))))] + [handle-flag + (lambda (flag args r-acc orig-multi k) + (let loop ([table table]) + (cond + [(null? table) + (call-handler unknown-flag flag args r-acc k)] + [(member flag (cadar table)) + (when (caar table) + (let ([set (caar table)]) + (if (car set) + (let ([flags (cdr set)]) + (error (string->symbol program) + (let ([s (if (= 1 (length flags)) + (format "the ~a flag can only be specified once" (car flags)) + (format "only one instance of one flag from ~a is allowed" flags))]) + (if orig-multi + (format "~a; note that ~s is shorthand for ~s, in contrast to ~s" + s + orig-multi + (let loop ([prefix (string-ref orig-multi 0)] + [flags (string->list (substring orig-multi 1 (string-length orig-multi)))] + [sep ""]) + (if (null? flags) + "" + (format "~a~a~a~a" sep prefix (car flags) + (loop prefix (cdr flags) " ")))) + (string-append (substring orig-multi 0 1) orig-multi)) + s)))) + (set-car! set #t)))) + (call-handler (caddar table) flag args r-acc k)] + [else (loop (cdr table))])))]) + (let loop ([args (vector->list arguments)][r-acc null]) + (if (null? args) + (done args r-acc) + (let ([arg (car args)] + [rest (cdr args)]) + (cond + [(regexp-match number-regexp arg) + (done args r-acc)] + [(regexp-match "^--$" arg) + (done (cdr args) r-acc)] + [(regexp-match "^[-+][-+]" arg) + (handle-flag arg rest r-acc #f loop)] + [(regexp-match "^[-+]." arg) + (let a-loop ([s (string->list (substring arg 1 (string-length arg)))] + [rest rest] + [r-acc r-acc]) + (if (null? s) + (loop rest r-acc) + (handle-flag (string (string-ref arg 0) (car s)) + rest r-acc + arg + (lambda (args r-acc) + (a-loop (cdr s) args r-acc)))))] + [else + (done args r-acc)])))))])) + + (export command-line parse-command-line)) -(define-values/invoke-unit/sig mzlib:command-line^ mzlib:command-line@ #f) -(require-library "cmdlinem.ss") diff --git a/collects/mzlib/compat.ss b/collects/mzlib/compat.ss index a4383f5..d630336 100644 --- a/collects/mzlib/compat.ss +++ b/collects/mzlib/compat.ss @@ -1,11 +1,81 @@ -(require-library "compatu.ss") -(require-library "functio.ss") +(module compat mzscheme + (import "list.ss") -(begin-elaboration-time - (require-library "invoke.ss")) + (export real-time + 1+ 1- + >=? <=? >? ? >) + (define <=? <) + (define >=? >) -(define-values/invoke-unit/sig mzlib:compat^ - mzlib:compat@ - #f - mzlib:function^) + (define atom? (lambda (v) (not (pair? v)))) + + (define gentemp gensym) + + (define sort ; Chez argument order + (lambda (less-than? l) + (mergesort l less-than?))) + + (define bound? defined?) + + (define flush-output-port flush-output) + + (define real-time current-milliseconds) + + (define getprop (void)) + (define putprop (void)) + (let ([table (make-hash-table)]) + (letrec ([gp + (case-lambda + [(k prop) (gp k prop #f)] + [(k prop def) + (let ([al (hash-table-get table k (lambda () #f))]) + (if al + (let ([v (assq prop al)]) + (if v + (cdr v) + def)) + def))])] + [pp + (lambda (k prop nv) + (let ([al (hash-table-get table k (lambda () '()))]) + (let ([v (assq prop al)]) + (if v + (set-cdr! v nv) + (hash-table-put! table k (cons (cons prop nv) al))))))]) + (set! getprop gp) + (set! putprop pp))) + + ;; Chez's new-cafe + (define new-cafe + (letrec ([nc + (case-lambda + [() (nc (current-eval))] + [(eval) + (let/ec escape + (let ([orig-exit (exit-handler)] + [orig-eval (current-eval)]) + (dynamic-wind + (lambda () + (current-eval eval) + (exit-handler + (lambda (v) (escape v)))) + read-eval-print-loop + (lambda () + (current-eval orig-eval) + (exit-handler orig-exit)))))])]) + nc))) diff --git a/collects/mzlib/date.ss b/collects/mzlib/date.ss index 07589a5..354d08c 100644 --- a/collects/mzlib/date.ss +++ b/collects/mzlib/date.ss @@ -1,11 +1,362 @@ -(require-library "dateu.ss") -(require-library "functio.ss") +(module date mzscheme -(begin-elaboration-time - (require-library "invoke.ss")) + (import "list.ss") + + (export date->string + date-display-format + find-seconds + + date->julian/scalinger + julian/scalinger->string) + + + ;; Support for Julian calendar added by Shriram; + ;; current version only works until 2099 CE Gregorian + + #| + + (define-primitive seconds->date (num -> structure:date)) + (define-primitive current-seconds (-> num)) + (define-primitive date-second (structure:date -> num)) + (define-primitive date-minute (structure:date -> num)) + (define-primitive date-hour (structure:date -> num)) + (define-primitive date-day (structure:date -> num)) + (define-primitive date-month (structure:date -> num)) + (define-primitive date-year (structure:date -> num)) + (define-primitive date-week-day (structure:date -> num)) + (define-primitive date-year-day (structure:date -> num)) + (define-primitive date-dst? (structure:date -> bool)) + (define-primitive make-date (num num num num num num num num bool -> + structure:date)) + (define-primitive expr->string (a -> string)) + (define-primitive foldl (case-> + ((a z -> z) z (listof a) -> z) + ((a b z -> z) z (listof a) (listof b) -> z) + ((a b c z -> z) z (listof a) (listof b) (listof c) -> z) + (((arglistof x) ->* z) z (listof (arglistof x)) ->* z))) + (define-primitive foldr (case-> + ((a z -> z) z (listof a) -> z) + ((a b z -> z) z (listof a) (listof b) -> z) + ((a b c z -> z) z (listof a) (listof b) (listof c) -> z) + (((arglistof x) ->* z) z (listof (arglistof x)) ->* z))) + + |# + + (define legal-formats + (list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601)) + + (define date-display-format + (make-parameter 'american + (lambda (s) + (unless (memq s legal-formats) + (raise-type-error 'date-display-format + (format "symbol in ~a" legal-formats) + s)) + s))) + + (define month/number->string + (lambda (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 + (lambda (x) + (case x + [(0) "Sunday"] + [(1) "Monday"] + [(2) "Tuesday"] + [(3) "Wednesday"] + [(4) "Thursday"] + [(5) "Friday"] + [(6) "Saturday"] + [else ""]))) + + (define date->string + (case-lambda + [(date) (date->string date #f)] + [(date time?) + (let* ((add-zero (lambda (n) (if (< n 10) + (string-append "0" (number->string n)) + (number->string n)))) + (year (number->string (date-year date))) + (num-month (number->string (date-month date))) + (week-day (day/number->string (date-week-day date))) + (week-day-num (date-week-day date)) + (month (month/number->string (date-month date))) + (day (number->string (date-day date))) + (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"]))) + (hour (date-hour date)) + (am-pm (if (> hour 12) "pm" "am")) + (hour24 (add-zero hour)) + (hour12 (if (> hour 12) + (number->string (- hour 12)) + (number->string hour))) + (minute (add-zero (date-minute date))) + (second (add-zero (date-second date)))) + (let-values + ([(day time) + (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 + " libai" (case (date-week-day date) + [(0) "tian"] + [(1) "yi"] + [(2) "er"] + [(3) "san"] + [(4) "si"] + [(5) "wu"] + [(6) "liu"] + [else ""])) + (list " " hour24 ":" minute ":" second))] + [(indian) + (values (list day "-" num-month "-" year) + (list " " hour12 ":" minute ":" second am-pm))] + [(german) + (values (list day ". " month " " 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))] + [else (error 'date->string "unknown date-display-format: ~s" + (date-display-format))])]) + (apply string-append (if time? + (append day time) + day))))])) + + (define leap-year? + (lambda (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 date- + (lambda (date1 date2) + (let* ((second (- (date-second date1) (date-second date2))) + (minute (+ (- (date-minute date1) (date-minute date2)) + (if (< second 0) -1 0))) + (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]))) + (day (+ (- (date-year-day date1) (date-year-day date2)) + (if (< hour 0) -1 0))) + (year (+ (- (date-year date1) (date-year date2)) + (if (< day 0) -1 0))) + (fixup (lambda (s x) (if (< s 0) (+ s x) s)))) + (make-date-offset (fixup second 60) + (fixup minute 60) + (fixup hour 24) + (fixup day (if (leap-year? (date-year date1)) 366 365)) + year)))) + + + (define date-offset->string + (let ((first car) + (second cadr)) + (case-lambda + [(date) (date-offset->string date #f)] + [(date seconds?) + (let* ((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"))) + (non-zero-fields (foldl (lambda (x l) + (if (= 0 (first x)) + l + (cons x l))) + null + fields)) + (one-entry (lambda (b) + (string-append + (number->string (first b)) + " " + (second b) + (if (= 1 (first b)) "" "s"))))) + (cond + [(null? non-zero-fields) ""] + [(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))] + [else (foldl (lambda (b string) + (cond + [(= 0 (first b)) string] + [(string=? string "") + (string-append "and " + (one-entry b) + string)] + [else (string-append (one-entry b) ", " string)])) + "" + non-zero-fields)]))]))) + + (define days-per-month + (lambda (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 + (lambda (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 ([not-break-exn? (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 ([not-break-exn? + (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 find-seconds + (lambda (sec min hour day month year) + (let ([signal-error + (lambda (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)] + [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-existant 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) + (let ((day (date-day date)) + (month (date-month date)) + (year (date-year date))) + (let ((year (+ 4712 year))) + (let ((year (if (< month 3) (sub1 year) year))) + (let ((cycle-number (quotient year 4)) + (cycle-position (remainder year 4))) + (let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position)))) + (let ((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)))) + (let ((total-days (+ base-day month-day-number day))) + (let ((total-days/march-adjustment (+ total-days 59))) + (let ((gregorian-adjustment (cond + ((< year 1700) 11) + ((< year 1800) 12) + (else 13)))) + (let ((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)))) + (list (apply string-append reversed-digits))) + (else (cons (apply string-append + (list " " + (caddr reversed-digits) + (cadr reversed-digits) + (car reversed-digits))) + (loop (cdr (cdr (cdr reversed-digits)))))))))))) + + ) -(define-values/invoke-unit/sig mzlib:date^ - mzlib:date@ - #f - mzlib:function^) diff --git a/collects/mzlib/deflate.ss b/collects/mzlib/deflate.ss index a259219..d91fd54 100644 --- a/collects/mzlib/deflate.ss +++ b/collects/mzlib/deflate.ss @@ -1,10 +1,2296 @@ +#| +/* deflate.c -- compress data using the deflation algorithm + * 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. + */ +|# +; Taken from the gzip source distribution +; Translated directly from C (obviously) by Matthew, July 2000 -(require-library "deflateu.ss") +(module deflate mzscheme -(begin-elaboration-time - (require-library "invoke.ss")) + (export deflate + gzip-through-ports + gzip) -(define-values/invoke-unit/sig mzlib:deflate^ - mzlib:deflate@) + (import "unit.ss") + (define-syntax INSERT_STRING + (lambda (stx) + (syntax-case stx () + [(_ s match_head UPDATE_HASH window-vec head-vec prev-vec ins_h) + (syntax + (begin + (UPDATE_HASH (vector-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 + (lambda (stx) + (syntax-case stx () + [(_ tree top heap heap_len SMALLEST) + (syntax + (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) + (syntax (void)))) + + (define-syntax Assert + (lambda (stx) + (syntax (void)))) + + (define (for start < end next proc) + (let loop ([n start]) + (when (< n end) + (proc n) + (loop (next n))))) + + (define-struct gzvector (vector offset)) + (define (gzvector-ref v o) + (vector-ref (gzvector-vector v) + (+ (gzvector-offset v) o))) + (define (gzvector-set! v o x) + (vector-set! (gzvector-vector v) + (+ (gzvector-offset v) o) + x)) + (define (gzvector+ v o) + (make-gzvector (gzvector-vector v) + (+ (gzvector-offset v) o))) + + (define (gzvector> 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 prev (make-gzvector prev-vec 0)) +(define head-vec real-table) +(define head (make-gzvector head-vec head-vec-delta)) + +;; /* 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. */ + (gzvector-zero! head HASH_SIZE) + + ;; /* 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 0 < MIN_MATCH-1 add1 + (lambda (j) (UPDATE_HASH (vector-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 +;; */ +(define (longest_match cur_match) + ;; IPos cur_match; /* current match */ + + (define chain_length max_chain_length) ;; /* max hash chain length */ + (define scanpos strstart) ;; /* current string */ + (define matchpos 0) ;; /* matched string */ + (define len 0) ;; /* length of current match */ + (define best_len prev_length) ;; /* best match length so far */ + (define 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 + + (define strendpos (+ strstart MAX_MATCH)) + (define scan_end1 (vector-ref window-vec (+ scanpos best_len -1))) + (define scan_end (vector-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"))) + + (let/ec break + (define (continue loop) + (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))) + (loop))) + (define (*++scan) + (set! scanpos (add1 scanpos)) + (vector-ref window-vec scanpos)) + (define (*++match) + (set! matchpos (add1 matchpos)) + (vector-ref window-vec matchpos)) + + (let 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? (vector-ref window-vec (+ matchpos best_len)) scan_end)) + (not (eq? (vector-ref window-vec (+ matchpos best_len -1)) scan_end1)) + (not (eq? (vector-ref window-vec matchpos) (vector-ref window-vec scanpos))) + (not (eq? (begin (set! matchpos (add1 matchpos)) + (vector-ref window-vec matchpos)) + (vector-ref window-vec (add1 scanpos))))) + (continue loop) + + (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. + ;; */ + (let loop2 () + (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)) + (loop2))) + + (set! len (- MAX_MATCH (- strendpos scanpos))) + (set! scanpos (+ strendpos (- MAX_MATCH))) + (DEBUG (Trace stderr "Match: ~a~n" len)) + + (when (> len best_len) + (set! match_start cur_match) + (set! best_len len) + (when (>= len nice_match) + (break)) + + (set! scan_end1 (vector-ref window-vec (+ scanpos best_len -1))) + (set! scan_end (vector-ref window-vec (+ scanpos best_len)))) + + (continue loop))))) + + best_len) + +;; /* =========================================================================== +;; * 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)) + (gzvector-copy window (gzvector+ window 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 0 < HASH_SIZE add1 + (lambda (n) + (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 0 < WSIZE add1 + (lambda (n) + (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 (if (>= block_start 0) + (gzvector+ window block_start) + null) + (- 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) (vector-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 (vector-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 (vector-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 (vector-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 (vector-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-gzvector (make-vector (+ INBUFSIZ INBUF_EXTRA) 0) 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 0 < (- LENGTH_CODES 1) add1 + (lambda (code) + (vector-set! base_length code length) + (for 0 < (<< 1 (vector-ref extra_lbits code)) add1 + (lambda (n) + (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 0 < 16 add1 + (lambda (code) + (vector-set! base_dist code dist) + (for 0 < (<< 1 (vector-ref extra_dbits code)) add1 + (lambda (n) + (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 16 < D_CODES add1 + (lambda (code) + (vector-set! base_dist code (<< dist 7)) + (for 0 < (<< 1 (- (vector-ref extra_dbits code) 7)) add1 + (lambda (n) + (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 0 <= MAX_BITS add1 + (lambda (bits) + (vector-set! bl_count bits 0))) + + (let ([init-ltree + (lambda (s e v) + (for s <= e add1 + (lambda (n) + (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 0 < D_CODES add1 + (lambda (n) + (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 0 < (if inited-once? L_CODES HEAP_SIZE) add1 + (lambda (n) + (vector-set! dyn_ltree n (_make-ct_data 0 #f 0 #f)))) + (for 0 < (if inited-once? D_CODES (+ (* 2 D_CODES) 1)) add1 + (lambda (n) + (vector-set! dyn_dtree n (_make-ct_data 0 #f 0 #f)))) + (for 0 < (if inited-once? BL_CODES (+ (* 2 BL_CODES) 1)) add1 + (lambda (n) + (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/ec break + (let loop () + (when (<= j heap_len) + ;; /* Set j to the smallest of the two sons: */ + (when (and (< j heap_len) + (smaller tree + (vector-ref heap (+ j 1)) + (vector-ref heap j))) + (set! j (add1 j))) + + ;; /* Exit if v is smaller than both sons */ + (when (smaller tree v (vector-ref heap j)) + (break)) + + ;; /* Exchange v with the smallest son */ + (vector-set! heap k (vector-ref heap j)) + (set! k j) + + ;; /* And continue down the tree, setting j to the left son of k */ + (set! j (<< j 1)) + + (loop)))) + (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 0 <= MAX_BITS add1 + (lambda (bits) + (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 (+ 1 heap_max) < HEAP_SIZE add1 + (lambda (h) + (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 max_length > 0 sub1 + (lambda (bits) + (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 1 <= MAX_BITS add1 + (lambda (bits) + (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 0 <= max_code add1 + (lambda (n) + (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 0 < elems add1 + (lambda (n) + (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 (quotient heap_len 2) >= 1 sub1 + (lambda (n) + (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 0 <= max_code add1 + (lambda (n) + (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 0 <= max_code add1 + (lambda (n) + (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 0 < blcodes add1 + (lambda (rank) + (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 (<= (+ stored_len 4) opt_lenb) + (not (null? buf))) + ;; /* 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 dist lc) + ;; int dist; ;; /* distance of matched string */ + ;; int lc; ;; /* match length-MIN_MATCH or unmatched char (if dist==0) */ + + (gzvector-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)) + + (let/ec return + + ;; /* Try to guess if it is profitable to stop the current block here */ + (when (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 0 < D_CODES add1 + (lambda (dcode) + (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)))) + (when (and (< last_dist (quotient last_lit 2)) + (< out_length (quotient in_length 2))) + (return #t)))) + + (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 (gzvector-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 + (set! bi_buf (bitwise-ior bi_buf (<< value bi_valid))) + (put_short bi_buf) + (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 0) +(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 (vector-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-not len)) + (set! bits_sent (+ bits_sent (* 2 16)))) + + (set! bits_sent (+ bits_sent (<< len 3))) + + (let loop ([len len][pos 0]) + (unless (zero? len) + (put_byte (gzvector-ref buf pos)) + (loop (sub1 len) (add1 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-string size ifd)] + [len (if (eof-object? s) + EOF-const + (string-length s))]) + (when (positive? len) + (let rloop ([p 0]) + (unless (= p len) + (vector-set! window-vec (+ p startpos) (char->integer (string-ref s p))) + (rloop (add1 p)))) + + (updcrc startpos len) + (set! bytes_in (+ bytes_in len))) + + len)) + +(define (put_byte c) + (string-set! outbuf outcnt (integer->char (bitwise-and #xFF c))) + (set! outcnt (add1 outcnt)) + (when (= outcnt OUTBUFSIZ) + (flush_outbuf))) + +;; /* Output a 16 bit value, lsb first */ +(define (put_short w) + (if (< outcnt (- OUTBUFSIZ 2)) + (begin + (string-set! outbuf outcnt (integer->char (bitwise-and #xFF w))) + (string-set! outbuf (add1 outcnt) (integer->char (bitwise-and #xFF (>> w 8)))) + (set! outcnt (+ outcnt 2))) + (begin + (put_byte w) + (put_byte (>> w 8))))) + +;; /* Output a 32 bit value to the bit stream, lsb first */ +(define (put_long n) + (put_short n) + (put_short (>> n 16))) + +(define outcnt 0) +(define bytes_out 0) +(define outbuf (make-string 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) + + (display (substring outbuf 0 outcnt) ofd) + + (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)) + +(define (gzip-through-ports in out origname time_stamp) + + (define flags (if origname #x8 0)) ;; /* general purpose bit flags */ + + (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 put_byte (map char->integer (string->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 ([not-break-exn? (lambda (x) #f)]) + (let-values ([(base name dir?) (split-path infile)]) + name))] + [timestamp (with-handlers ([not-break-exn? (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)) + +) diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss new file mode 100644 index 0000000..e7b9fe0 --- /dev/null +++ b/collects/mzlib/etc.ss @@ -0,0 +1,121 @@ + +(module etc mzscheme + (import "spidey.ss") + + (export true false + boolean=? symbol=? + char->string + identity + compose + + build-string + build-vector + build-list + + loop-until) + + (define true #t) + (define false #f) + + (define identity (polymorphic (lambda (x) x))) + + (define compose + (polymorphic + (case-lambda + [(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))] + [(f g) + (let ([f (compose f)] + [g (compose g)]) + (if (eqv? 1 (arity f)) ; optimize: don't use call-w-values + (if (eqv? 1 (arity g)) ; optimize: single arity everywhere + (lambda (x) (f (g x))) + (lambda args (f (apply g args)))) + (if (eqv? 1 (arity g)) ; optimize: single input + (lambda (a) + (call-with-values + (lambda () (g a)) + f)) + (lambda args + (call-with-values + (lambda () (apply g args)) + f)))))] + [(f . more) + (let ([m (apply compose more)]) + (compose f m))]))) + + + (define build-string + (lambda (n fcn) + (unless (and (integer? n) (exact? n) (>= n 0)) + (error 'build-string "~s must be an exact integer >= 0" n)) + (unless (procedure? fcn) + (error 'build-string "~s must be a procedure" fcn)) + (let ((str (make-string n))) + (let loop ((i 0)) + (if (= i n) + str + (begin + (string-set! str i (fcn i)) + (loop (add1 i)))))))) + + ;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i). + ;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1. + ;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3) + + (define build-vector + (polymorphic + (lambda (n fcn) + (unless (and (integer? n) (exact? n) (>= n 0)) + (error 'build-vector "~s must be an exact integer >= 0" n)) + (unless (procedure? fcn) + (error 'build-vector "~s must be a procedure" fcn)) + (let ((vec (make-vector n))) + (let loop ((i 0)) + (if (= i n) vec + (begin + (vector-set! vec i (fcn i)) + (loop (add1 i))))))))) + + (define build-list + (polymorphic + (lambda (n fcn) + (unless (and (integer? n) (exact? n) (>= n 0)) + (error 'build-list "~s must be an exact integer >= 0" n)) + (unless (procedure? fcn) + (error 'build-list "~s must be a procedure" fcn)) + (if (zero? n) '() + (let ([head (list (fcn 0))]) + (let loop ([i 1] [p head]) + (if (= i n) head + (begin + (set-cdr! p (list (fcn i))) + (loop (add1 i) (cdr p)))))))))) + + (define loop-until + (polymorphic + (lambda (start done? next body) + (let loop ([i start]) + (unless (done? i) + (body i) + (loop (next i))))))) + + (define boolean=? + (lambda (x y) + (unless (and (boolean? x) + (boolean? y)) + (raise-type-error 'boolean=? + "boolean" + (if (boolean? x) y x))) + (eq? x y))) + + (define (symbol=? x y) + (unless (and (symbol? x) + (symbol? y)) + (raise-type-error 'symbol=? "symbol" + (if (symbol? x) y x))) + (eq? x y)) + + (define (char->string c) + (unless (char? c) + (raise-type-error 'char->string "character" c)) + (string c))) diff --git a/collects/mzlib/file.ss b/collects/mzlib/file.ss index d2e3b63..b3a5fd3 100644 --- a/collects/mzlib/file.ss +++ b/collects/mzlib/file.ss @@ -1,13 +1,287 @@ +(module file mzscheme + (export find-relative-path + explode-path + normalize-path + build-absolute-path + build-relative-path + filename-extension + file-name-from-path + path-only + delete-directory/files + make-directory* + make-temporary-file + find-library -(require-library "fileu.ss") -(require-library "functio.ss") -(require-library "string.ss") + with-input-from-file* + call-with-input-file* + with-output-to-file* + call-with-output-file*) -(begin-elaboration-time - (require-library "invoke.ss")) + (import "list.ss") -(define-values/invoke-unit/sig mzlib:file^ - mzlib:file@ - #f - mzlib:string^ - mzlib:function^) + (define build-relative-path + (lambda (p . args) + (if (relative-path? p) + (apply build-path p args) + (error 'build-relative-path "base path ~s is absolute" p)))) + + (define build-absolute-path + (lambda (p . args) + (if (relative-path? p) + (error 'build-absolute-path "base path ~s is relative" p) + (apply build-path p args)))) + + ; Note that normalize-path does not normalize the case + (define normalize-path + (letrec ([resolve-all + (lambda (path wrt) + (let ([orig-path (if (and wrt (not (complete-path? path))) + (path->complete-path path wrt) + path)]) + (let loop ([full-path orig-path][seen-paths (list orig-path)]) + (let ([resolved (resolve-path full-path)]) + (if (string=? resolved full-path) + (do-normalize-path resolved #f) + (let ([path (if (relative-path? resolved) + (build-path + (let-values ([(base name dir?) (split-path full-path)]) + base) + resolved) + resolved)]) + (if (member path seen-paths) + (error 'normalize-path "circular reference at ~s" path) + (let ([spath + ;; Use simplify-path to get rid of ..s, which can + ;; allow the path to grow indefinitely in a cycle. + ;; An exception must mean a cycle of links. + (with-handlers ([not-break-exn? + (lambda (x) + (error 'normalize-path "circular reference at ~s" path))]) + (simplify-path path))]) + (loop spath (cons path seen-paths))))))))))] + [resolve + (lambda (path) + (if (string=? path (resolve-path path)) + path + (resolve-all path #f)))] + [normalize-path + (case-lambda + [(orig-path) (do-normalize-path orig-path (current-directory))] + [(orig-path wrt) + (unless (complete-path? wrt) + (raise-type-error 'normalize-path "complete path" wrt)) + (do-normalize-path orig-path wrt)])] + [error-not-a-dir + (lambda (path) + (error 'normalize-path + "~s (within the input path) is not a directory or does not exist" + path))] + [do-normalize-path + (lambda (orig-path wrt) + (let normalize ([path (expand-path orig-path)]) + (let-values ([(base name dir?) (split-path path)]) + (cond + [(eq? name 'up) + (let up ([base (if (eq? base 'relative) + wrt + (resolve-all base wrt))]) + (if (directory-exists? base) + (let-values ([(prev name dir?) (split-path base)]) + (cond + [(not prev) + (error 'normalize-path + "root has no parent directory: ~s" + orig-path)] + [else + (let ([prev + (if (eq? prev 'relative) + wrt + (normalize prev))]) + (cond + [(eq? name 'same) (up prev)] + [(eq? name 'up) (up (up prev))] + [else prev]))])) + (error-not-a-dir base)))] + [(eq? name 'same) + (cond + [(eq? base 'relative) wrt] + [else (let ([n (normalize base)]) + (if (directory-exists? n) + n + (error-not-a-dir n)))])] + [else + (cond + [(not base) (path->complete-path path)] + [else (let* ([base (if (eq? base 'relative) + (normalize wrt) + (normalize base))] + [path (if (directory-exists? base) + (build-path base name) + (error-not-a-dir base))] + [resolved (expand-path (resolve path))]) + (cond + [(relative-path? resolved) + (normalize (build-path base resolved))] + [(complete-path? resolved) + resolved] + [else (path->complete-path resolved base)]))])]))))]) + normalize-path)) + + ; Argument must be in normal form + (define explode-path + (lambda (orig-path) + (let loop ([path orig-path][rest '()]) + (let-values ([(base name dir?) (split-path path)]) + (if (or (and base + (not (string? base))) + (not (string? name))) + (error 'explode-path "input was not in normal form: ~s" orig-path)) + (if base + (loop base (cons name rest)) + (cons name rest)))))) + + ; Arguments must be in normal form + (define find-relative-path + (lambda (directory filename) + (let ([dir (explode-path directory)] + [file (explode-path filename)]) + (if (string=? (normal-case-path (car dir)) + (normal-case-path (car file))) + (let loop ([dir (cdr dir)] + [file (cdr file)]) + (cond + [(null? dir) (if (null? file) filename (apply build-path file))] + [(null? file) (apply build-path (map (lambda (x) 'up) dir))] + [(string=? (normal-case-path (car dir)) + (normal-case-path (car file))) + (loop (cdr dir) (cdr file))] + [else + (apply build-path + (append (map (lambda (x) 'up) dir) + file))])) + filename)))) + + (define file-name-from-path + (lambda (name) + (let-values ([(base file dir?) (split-path name)]) + (if (and (not dir?) (string? file)) + file + #f)))) + + (define path-only + (lambda (name) + (let-values ([(base file dir?) (split-path name)]) + (cond + [dir? name] + [(string? base) base] + [else #f])))) + + ;; name can be any string; we just look for a dot + (define filename-extension + (lambda (name) + (let* ([len (string-length name)] + [extension + (let loop ([p (sub1 len)]) + (cond + [(negative? p) #f] + [(char=? (string-ref name p) #\.) + (substring name (add1 p) len)] + [else (loop (sub1 p))]))]) + extension))) + + (define (delete-directory/files path) + (cond + [(or (link-exists? path) (file-exists? path)) + (unless (delete-file path) + (error 'delete-directory/files + "error deleting file or link: ~a" path))] + [(directory-exists? path) + (for-each (lambda (e) (delete-directory/files (build-path path e))) + (directory-list path)) + (unless (delete-directory path) + (error 'delete-directory/files + "error deleting a directory: ~a" path))] + [else (error 'delete-directory/files + "encountered ~a, neither a file nor a directory" + path)])) + + (define (make-directory* dir) + (let-values ([(base name dir?) (split-path dir)]) + (when (and (string? base) + (not (directory-exists? base))) + (make-directory* base)) + (make-directory dir))) + + (define make-temporary-file + (case-lambda + [(template) + (with-handlers ([not-break-exn? + (lambda (x) + (raise-type-error 'make-temporary-file + "format string for 1 argument" + template))]) + (format template void)) + (let ([tmpdir (find-system-path 'temp-dir)]) + (let loop ([s (current-seconds)][ms (current-milliseconds)]) + (let ([name (build-path tmpdir (format template (format "~a~a" s ms)))]) + (with-handlers ([exn:i/o:filesystem? (lambda (x) + (if (eq? (exn:i/o:filesystem-detail x) + 'already-exists) + ;; try again with a new name + (loop (- s (random 10)) + (+ ms (random 10))) + ;; It's something else; give up + (raise x)))]) + (close-output-port (open-output-file name)) + name))))] + [() (make-temporary-file "mztmp~a")])) + + (define find-library + (case-lambda + [(name) (find-library name "mzlib")] + [(name collection . cp) + (let ([dir (with-handlers ([not-break-exn? (lambda (exn) #f)]) + (apply collection-path collection cp))]) + (if dir + (let ([file (build-path dir name)]) + (if (file-exists? file) + file + #f)) + #f))])) + + (define with-input-from-file* + (lambda (file thunk . flags) + (let ([p (apply open-input-file file flags)]) + (parameterize ([current-input-port p]) + (dynamic-wind + void + thunk + (lambda () (close-input-port p))))))) + + (define with-output-to-file* + (lambda (file thunk . flags) + (let ([p (apply open-output-file file flags)]) + (parameterize ([current-output-port p]) + (dynamic-wind + void + thunk + (lambda () (close-output-port p))))))) + + (define call-with-input-file* + (lambda (file thunk . flags) + (let ([p (apply open-input-file file flags)]) + (dynamic-wind + void + (lambda () (thunk p)) + (lambda () (close-input-port p)))))) + + (define call-with-output-file* + (lambda (file thunk . flags) + (let ([p (apply open-output-file file flags)]) + (dynamic-wind + void + (lambda () (thunk p)) + (lambda () (close-output-port p))))))) + + + diff --git a/collects/mzlib/functior.ss b/collects/mzlib/functior.ss index 7d5c0e2..2fe9a32 100644 --- a/collects/mzlib/functior.ss +++ b/collects/mzlib/functior.ss @@ -2,35 +2,6 @@ mzlib:function^ (import) - (define true #t) - (define false #f) - - (define identity (polymorphic (lambda (x) x))) - - (define compose - (polymorphic - (case-lambda - [(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))] - [(f g) - (let ([f (compose f)] - [g (compose g)]) - (if (eqv? 1 (arity f)) ; optimize: don't use call-w-values - (if (eqv? 1 (arity g)) ; optimize: single arity everywhere - (lambda (x) (f (g x))) - (lambda args (f (apply g args)))) - (if (eqv? 1 (arity g)) ; optimize: single input - (lambda (a) - (call-with-values - (lambda () (g a)) - f)) - (lambda args - (call-with-values - (lambda () (apply g args)) - f)))))] - [(f . more) - (let ([m (apply compose more)]) - (compose f m))]))) - (define quicksort (polymorphic (lambda (l less-than) @@ -290,53 +261,6 @@ (raise-type-error 'set-rest! "second argument must be a list" v)) (set-cdr! x v)))) - (define build-string - (lambda (n fcn) - (unless (and (integer? n) (exact? n) (>= n 0)) - (error 'build-string "~s must be an exact integer >= 0" n)) - (unless (procedure? fcn) - (error 'build-string "~s must be a procedure" fcn)) - (let ((str (make-string n))) - (let loop ((i 0)) - (if (= i n) - str - (begin - (string-set! str i (fcn i)) - (loop (add1 i)))))))) - - ;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i). - ;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1. - ;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3) - - (define build-vector - (polymorphic - (lambda (n fcn) - (unless (and (integer? n) (exact? n) (>= n 0)) - (error 'build-vector "~s must be an exact integer >= 0" n)) - (unless (procedure? fcn) - (error 'build-vector "~s must be a procedure" fcn)) - (let ((vec (make-vector n))) - (let loop ((i 0)) - (if (= i n) vec - (begin - (vector-set! vec i (fcn i)) - (loop (add1 i))))))))) - - (define build-list - (polymorphic - (lambda (n fcn) - (unless (and (integer? n) (exact? n) (>= n 0)) - (error 'build-list "~s must be an exact integer >= 0" n)) - (unless (procedure? fcn) - (error 'build-list "~s must be a procedure" fcn)) - (if (zero? n) '() - (let ([head (list (fcn 0))]) - (let loop ([i 1] [p head]) - (if (= i n) head - (begin - (set-cdr! p (list (fcn i))) - (loop (add1 i) (cdr p)))))))))) - (define loop-until (polymorphic (lambda (start done? next body)