From 70fc6d23fe1b988b150bce8e2d6da54ab0fc3a4b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 30 Apr 1997 17:43:01 +0000 Subject: [PATCH] Initial revision original commit: 780c8abd1defdce429de13e3314420b6b1077bbd --- collects/mzlib/compat.ss | 11 + collects/mzlib/date.ss | 13 + collects/mzlib/file.ss | 13 + collects/mzlib/functior.ss | 248 ++++ collects/mzlib/inflate.ss | 7 + collects/mzlib/match.ss | 2292 ++++++++++++++++++++++++++++++++++++ collects/mzlib/pretty.ss | 5 + collects/mzlib/shared.ss | 141 +++ collects/mzlib/string.ss | 5 + collects/mzlib/unitsig.ss | 2 + 10 files changed, 2737 insertions(+) create mode 100644 collects/mzlib/compat.ss create mode 100644 collects/mzlib/date.ss create mode 100644 collects/mzlib/file.ss create mode 100644 collects/mzlib/functior.ss create mode 100644 collects/mzlib/inflate.ss create mode 100644 collects/mzlib/match.ss create mode 100644 collects/mzlib/pretty.ss create mode 100644 collects/mzlib/shared.ss create mode 100644 collects/mzlib/string.ss create mode 100644 collects/mzlib/unitsig.ss diff --git a/collects/mzlib/compat.ss b/collects/mzlib/compat.ss new file mode 100644 index 0000000..2e2533d --- /dev/null +++ b/collects/mzlib/compat.ss @@ -0,0 +1,11 @@ + +(require-library "compatu.ss") +(require-library "functiou.ss") + +(invoke-open-unit/sig + (compound-unit/sig + (import) + (link [compat@ : mzlib:compat^ (mzlib:compat@ function@)] + [function@ : mzlib:function^ (mzlib:function@)]) + (export (open compat@))) + #f) diff --git a/collects/mzlib/date.ss b/collects/mzlib/date.ss new file mode 100644 index 0000000..1c4b43e --- /dev/null +++ b/collects/mzlib/date.ss @@ -0,0 +1,13 @@ + +(require-library "dateu.ss") +(require-library "functiou.ss") + +(invoke-open-unit/sig + (compound-unit/sig + (import) + (link [date@ : mzlib:date^ (mzlib:date@ function@)] + [function@ : mzlib:function^ (mzlib:function@)]) + (export (open date@))) + #f) + + diff --git a/collects/mzlib/file.ss b/collects/mzlib/file.ss new file mode 100644 index 0000000..df44498 --- /dev/null +++ b/collects/mzlib/file.ss @@ -0,0 +1,13 @@ + +(require-library "fileu.ss") +(require-library "functio.ss") +(require-library "string.ss") + +(invoke-open-unit/sig + (compound-unit/sig + (import) + (link [file@ : mzlib:file^ (mzlib:file@ string@ function@)] + [function@ : mzlib:function^ (mzlib:function@)] + [string@ : mzlib:string^ (mzlib:string@)]) + (export (open file@))) + #f) diff --git a/collects/mzlib/functior.ss b/collects/mzlib/functior.ss new file mode 100644 index 0000000..e0713b9 --- /dev/null +++ b/collects/mzlib/functior.ss @@ -0,0 +1,248 @@ +(unit/sig + mzlib:function^ + (import) + + (define identity (polymorphic (lambda (x) x))) + + (define compose + (polymorphic + (case-lambda + [(f) f] + [(f 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)))) + (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) + (let* ([v (list->vector l)] + [count (vector-length v)]) + (let loop ([min 0][max count]) + (if (< min (sub1 max)) + (let ([pval (vector-ref v min)]) + (let pivot-loop ([pivot min] + [pos (add1 min)]) + (if (< pos max) + (let ([cval (vector-ref v pos)]) + (if (less-than cval pval) + (begin + (vector-set! v pos (vector-ref v pivot)) + (vector-set! v pivot cval) + (pivot-loop (add1 pivot) (add1 pos))) + (pivot-loop pivot (add1 pos)))) + (if (= min pivot) + (loop (add1 pivot) max) + (begin + (loop min pivot) + (loop pivot max)))))))) + (vector->list v))))) + + (define ignore-errors + (polymorphic + (lambda (thunk) + (let/ec escape + (with-handlers ([void (lambda (x) (escape (void)))]) + (thunk)))))) + + (define remove + (polymorphic + (letrec ([rm (case-lambda + [(item list) (rm item list equal?)] + [(item list equal?) + (let loop ([list list]) + (cond + [(null? list) ()] + [(equal? item (car list)) (cdr list)] + [else (cons (car list) + (loop (cdr list)))]))])]) + rm))) + + (define remq + (polymorphic + (lambda (item list) + (remove item list eq?)))) + + (define remv + (polymorphic + (lambda (item list) + (remove item list eqv?)))) + + (define dynamic-disable-break + (polymorphic + (lambda (thunk) + (parameterize ([break-enabled #f]) + (thunk))))) + + (define dynamic-wind/protect-break + (polymorphic + (lambda (a b c) + (let ([enabled? (break-enabled)]) + (dynamic-disable-break + (lambda () + (dynamic-wind + a + (if enabled? + (lambda () (dynamic-enable-break b)) + b) + c))))))) + + (define make-single-threader + (polymorphic + (lambda () + (let ([sema (make-semaphore 1)]) + (lambda (thunk) + (dynamic-wind + (lambda () (semaphore-wait sema)) + thunk + (lambda () (semaphore-post sema)))))))) + + ;; fold : ((A -> B) B (listof A) -> B) + ;; fold : ((A1 ... An -> B) B (listof A1) ... (listof An) -> B) + + ;; foldl builds "B" from the beginning of the list to the end of the + ;; list and foldr builds the "B" from the end of the list to the + ;; beginning of the list. + + (define mapadd + (polymorphic + (lambda (f l last) + (letrec ((helper + (lambda (l) + (cond + [(null? l) (list last)] + [else (cons (f (car l)) (helper (cdr l)))])))) + (helper l))))) + + (define foldl + (polymorphic + (letrec ((fold-one + (lambda (f init l) + (letrec ((helper + (lambda (init l) + (cond + [(null? l) init] + [else (helper (f (car l) init) (cdr l))])))) + (helper init l)))) + (fold-n + (lambda (f init l) + (cond + [(ormap null? l) + (if (andmap null? l) + init + (error 'foldl "received non-equal length input lists"))] + [else (fold-n + f + (apply f (mapadd car l init)) + (map cdr l))])))) + (case-lambda + [(f init l) (fold-one f init l)] + [(f init . ls) (fold-n f init ls)])))) + + (define foldr + (polymorphic + (letrec ((fold-one + (lambda (f init l) + (letrec ((helper + (lambda (init l) + (cond + [(null? l) init] + [else (f (car l) (helper init (cdr l)))])))) + (helper init l)))) + (fold-n + (lambda (f init l) + (cond + [(ormap null? l) + (if (andmap null? l) + init + (error 'foldr "received non-equal length input lists"))] + [else (apply f + (mapadd car l + (fold-n f init (map cdr l))))])))) + (case-lambda + [(f init l) (fold-one f init l)] + [(f init . ls) (fold-n f init ls)])))) + + (define first (polymorphic car)) + (define second (polymorphic cadr)) + (define third (polymorphic caddr)) + (define fourth (polymorphic cadddr)) + (define fifth (polymorphic (compose fourth cdr))) + (define sixth (polymorphic (compose fourth cddr))) + (define seventh (polymorphic (compose fourth cdddr))) + (define eighth (polymorphic (compose fourth cddddr))) + + (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 last-pair + (polymorphic + (lambda (l) + (if (pair? l) + (if (pair? (cdr l)) + (last-pair (cdr l)) + l) + (error 'last-pair "argument not a pair"))))) + + (define cons? pair?) + ) diff --git a/collects/mzlib/inflate.ss b/collects/mzlib/inflate.ss new file mode 100644 index 0000000..b627b5b --- /dev/null +++ b/collects/mzlib/inflate.ss @@ -0,0 +1,7 @@ + + +(require-library "inflateu.ss") + +(invoke-open-unit/sig mzlib:inflate@ #f) + + diff --git a/collects/mzlib/match.ss b/collects/mzlib/match.ss new file mode 100644 index 0000000..bac0b8a --- /dev/null +++ b/collects/mzlib/match.ss @@ -0,0 +1,2292 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Pattern Matching Syntactic Extensions for Scheme +;; +;; Specialized for MzScheme; works with define-struct +;; +;; Report bugs to wright@research.nj.nec.com. The most recent version of +;; this software can be obtained by anonymous FTP from ftp.nj.nec.com +;; in file pub/wright/match.tar.Z. Be sure to set "type binary" when +;; transferring this file. +;; +;; Written by Andrew K. Wright, 1993 (wright@research.nj.nec.com). +;; Adapted from code originally written by Bruce F. Duba, 1991. +;; This package also includes a modified version of Kent Dybvig's +;; define-structure (see Dybvig, R.K., The Scheme Programming Language, +;; Prentice-Hall, NJ, 1987). +;; +;; This software is in the public domain. Feel free to copy, +;; distribute, and modify this software as desired. No warranties +;; nor guarantees of any kind apply. Please return any improvements +;; or bug fixes to wright@research.nj.nec.com so that they may be included +;; in future releases. +;; +;; This macro package extends Scheme with several new expression forms. +;; Following is a brief summary of the new forms. See the associated +;; LaTeX documentation for a full description of their functionality. +;; +;; +;; match expressions: +;; +;; exp ::= ... +;; | (match exp clause ...) +;; | (match-lambda clause ...) +;; | (match-lambda* clause ...) +;; | (match-let ((pat exp) ...) body) +;; | (match-let* ((pat exp) ...) body) +;; | (match-letrec ((pat exp) ...) body) +;; | (match-define> pat exp) +;; +;; clause ::= (pat body) | (pat => exp) +;; +;; patterns: matches: +;; +;; pat ::= identifier anything, and binds identifier +;; | _ anything +;; | () the empty list +;; | #t #t +;; | #f #f +;; | string a string +;; | number a number +;; | character a character +;; | 'sexp an s-expression +;; | 'symbol a symbol (special case of s-expr) +;; | (pat_1 ... pat_n) list of n elements +;; | (pat_1 ... pat_n . pat_{n+1}) list of n or more +;; | (pat_1 ... pat_n pat_n+1 ooo) list of n or more, each element +;; of remainder must match pat_n+1 +;; | #(pat_1 ... pat_n) vector of n elements +;; | #(pat_1 ... pat_n pat_n+1 ooo) vector of n or more, each element +;; of remainder must match pat_n+1 +;; | #&pat box +;; | ($ struct-name pat_1 ... pat_n) a structure +;; | (and pat_1 ... pat_n) if all of pat_1 thru pat_n match +;; | (or pat_1 ... pat_n) if any of pat_1 thru pat_n match +;; | (not pat_1 ... pat_n) if all pat_1 thru pat_n don't match +;; | (? predicate pat_1 ... pat_n) if predicate true and all of +;; pat_1 thru pat_n match +;; | (set! identifier) anything, and binds setter +;; | (get! identifier) anything, and binds getter +;; | `qp a quasi-pattern +;; +;; ooo ::= ... zero or more +;; | ___ zero or more +;; | ..k k or more +;; | __k k or more +;; +;; quasi-patterns: matches: +;; +;; qp ::= () the empty list +;; | #t #t +;; | #f #f +;; | string a string +;; | number a number +;; | character a character +;; | identifier a symbol +;; | (qp_1 ... qp_n) list of n elements +;; | (qp_1 ... qp_n . qp_{n+1}) list of n or more +;; | (qp_1 ... qp_n qp_n+1 ooo) list of n or more, each element +;; of remainder must match qp_n+1 +;; | #(qp_1 ... qp_n) vector of n elements +;; | #(qp_1 ... qp_n qp_n+1 ooo) vector of n or more, each element +;; of remainder must match qp_n+1 +;; | #&qp box +;; | ,pat a pattern +;; | ,@pat a pattern +;; +;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $, +;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variables. +;; +;; +;; structure expressions: +;; +;; exp ::= ... +;; | (define-structure (id_0 id_1 ... id_n)) +;; | (define-structure (id_0 id_1 ... id_n) +;; ((id_{n+1} exp_1) ... (id_{n+m} exp_m))) +;; | (define-const-structure (id_0 arg_1 ... arg_n)) +;; | (define-const-structure (id_0 arg_1 ... arg_n) +;; ((arg_{n+1} exp_1) ... (arg_{n+m} exp_m))) +;; +;; arg ::= id | (! id) +;; +;; +;; match:error-control controls what code is generated for failed matches. +;; Possible values: +;; 'unspecified - do nothing, ie., evaluate (cond [#f #f]) +;; 'fail - call match:error, or die at car or cdr +;; 'error - call match:error with the unmatched value +;; 'match - call match:error with the unmatched value _and_ +;; the quoted match expression +;; match:error-control is set by calling match:set-error-control with +;; the new value. +;; Added by Matthew: +;; match:error-control-param is a system parameter for this value +;; +;; match:error is called for a failed match. +;; match:error is set by calling match:set-error with the new value. +;; +;; match:structure-control controls the uniqueness of structures +;; (does not exist for Scheme 48 version). +;; Possible values: +;; 'vector - (default) structures are vectors with a symbol in position 0 +;; 'disjoint - structures are fully disjoint from all other values +;; match:structure-control is set by calling match:set-structure-control +;; with the new value. +;; +;; match:runtime-structures controls whether local structure declarations +;; generate new structures each time they are reached +;; (does not exist for Scheme 48 version). +;; Possible values: +;; #t - (default) each runtime occurrence generates a new structure +;; #f - each lexical occurrence generates a new structure +;; +;; End of user visible/modifiable stuff. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(reference-library "refer.ss") + +(begin-elaboration-time +(invoke-open-unit +(unit +(import) +(export match:set-error match:set-error-control match:error-control-param +match:error match match-lambda match-lambda* +match-letrec match-let match-let*) + +(define match:version "Version 1.10mz, Feb 5, 1996") + +(define-struct (exn:misc:match struct:exn:misc) (value)) + +(define match:error +(case-lambda +[(val) (raise +(make-exn:misc:match +(format "match: no matching clause for ~s" val) +((debug-info-handler)) +val))] +[(val expr) (raise +(make-exn:misc:match +(format "match: no matching clause for ~s: ~s" val expr) +((debug-info-handler)) +val))])) + +(define match:syntax-err (lambda (obj msg) (error 'match (string-append msg " ~a") obj))) +(define match:set-error (lambda (v) (set! match:error v))) +(define match:error-control-param +(case-lambda +[() match:error-control] +[(v) (match:set-error-control v)])) +(define match:error-control 'error) +(define match:set-error-control +(lambda (v) +(if (memq v '(unspecified fail error match)) +(set! match:error-control v) +(error 'match:set-error-control "invalid setting: ~s" v)))) +(define match:disjoint-predicates +(cons 'null +'(pair? +symbol? +boolean? +number? +string? +char? +procedure? +vector? +box?))) +(define match:vector-structures '()) +(define match:expanders +(letrec ((genmatch (lambda (x clauses match-expr) +(let* ((length>= (gensym)) +(eb-errf (error-maker match-expr)) +(blist (car eb-errf)) +(plist (map (lambda (c) +(let* ((x (bound +(validate-pattern +(car c)))) +(p (car x)) +(bv (cadr x)) +(bindings (caddr x)) +(code (gensym)) +(fail (and (pair? +(cdr c)) +(pair? +(cadr c)) +(eq? (caadr +c) +'=>) +(symbol? +(cadadr +c)) +(pair? +(cdadr +c)) +(null? +(cddadr +c)) +(pair? +(cddr c)) +(cadadr +c))) +(bv2 (if fail +(cons fail +bv) +bv)) +(body (if fail +(cddr c) +(cdr c)))) +(set! blist +(cons `(,code +(lambda ,bv2 +,@body)) +(append +bindings +blist))) +(list p +code +bv +(and fail +(gensym)) +#f))) +clauses)) +(code (gen x +'() +plist +(cdr eb-errf) +length>= +(gensym)))) +(unreachable plist match-expr) +(inline-let +`(let ((,length>= (lambda (n) +(lambda (l) +(>= (length l) n)))) +,@blist) +,code))))) +(genletrec (lambda (pat exp body match-expr) +(let* ((length>= (gensym)) +(eb-errf (error-maker match-expr)) +(x (bound (validate-pattern pat))) +(p (car x)) +(bv (cadr x)) +(bindings (caddr x)) +(code (gensym)) +(plist (list (list p code bv #f #f))) +(x (gensym)) +(m (gen x +'() +plist +(cdr eb-errf) +length>= +(gensym))) +(gs (map (lambda (_) (gensym)) bv))) +(unreachable plist match-expr) +`(letrec ((,length>= (lambda (n) +(lambda (l) +(>= (length l) n)))) +,@(map (lambda (v) `(,v #f)) bv) +(,x ,exp) +(,code (lambda ,gs +,@(map (lambda (v g) +`(set! ,v ,g)) +bv +gs) +,@body)) +,@bindings +,@(car eb-errf)) +,m)))) +(gendefine (lambda (pat exp match-expr) +(let* ((length>= (gensym)) +(eb-errf (error-maker match-expr)) +(x (bound (validate-pattern pat))) +(p (car x)) +(bv (cadr x)) +(bindings (caddr x)) +(code (gensym)) +(plist (list (list p code bv #f #f))) +(x (gensym)) +(m (gen x +'() +plist +(cdr eb-errf) +length>= +(gensym))) +(gs (map (lambda (_) (gensym)) bv))) +(unreachable plist match-expr) +`(begin ,@(map (lambda (v) `(define ,v #f)) +bv) +,(inline-let +`(let ((,length>= (lambda (n) +(lambda (l) +(>= (length +l) +n)))) +(,x ,exp) +(,code (lambda ,gs +,@(map (lambda (v +g) +`(set! ,v +,g)) +bv +gs) +(cond (#f #f)))) +,@bindings +,@(car eb-errf)) +,m)))))) +(pattern-var? (lambda (x) +(and (symbol? x) +(not (dot-dot-k? x)) +(not (memq x +'(quasiquote +quote +unquote +unquote-splicing +? +_ +$ +and +or +not +set! +get! +... +___)))))) +(dot-dot-k? (lambda (s) +(and (symbol? s) +(if (memq s '(... ___)) +0 +(let* ((s (symbol->string s)) +(n (string-length s))) +(and (<= 3 n) +(memq (string-ref s 0) +'(#\. #\_)) +(memq (string-ref s 1) +'(#\. #\_)) +(andmap +char-numeric? +(string->list +(substring s 2 n))) +(string->number +(substring s 2 n)))))))) +(error-maker (lambda (match-expr) +(cond +((eq? match:error-control 'unspecified) (cons '() +(lambda (x) +`(cond +(#f #f))))) +((memq match:error-control '(error fail)) (cons '() +(lambda (x) +`((#%global-defined-value 'match:error) +,x)))) +((eq? match:error-control 'match) (let ((errf (gensym)) +(arg (gensym))) +(cons `((,errf +(lambda (,arg) +((#%global-defined-value 'match:error) +,arg +',match-expr)))) +(lambda (x) +`(,errf +,x))))) +(else (match:syntax-err +'(unspecified error fail match) +"invalid value for match:error-control, legal values are"))))) +(unreachable (lambda (plist match-expr) +(for-each +(lambda (x) +(if (not (car (cddddr x))) +(begin (display +"Warning: unreachable pattern ") +(display (car x)) +(display " in ") +(display match-expr) +(newline)))) +plist))) +(validate-pattern (lambda (pattern) +(letrec ((simple? (lambda (x) +(or (string? x) +(boolean? x) +(char? x) +(number? x) +(null? x)))) +(ordinary (lambda (p) +(let ((g204 (lambda (x +y) +(cons (ordinary +x) +(ordinary +y))))) +(if (simple? p) +((lambda (p) +p) +p) +(if (equal? +p +'_) +((lambda () +'_)) +(if (pattern-var? +p) +((lambda (p) +p) +p) +(if (pair? +p) +(if (equal? +(car p) +'quasiquote) +(if (and (pair? +(cdr p)) +(null? +(cddr p))) +((lambda (p) +(quasi +p)) +(cadr p)) +(g204 (car p) +(cdr p))) +(if (equal? +(car p) +'quote) +(if (and (pair? +(cdr p)) +(null? +(cddr p))) +((lambda (p) +p) +p) +(g204 (car p) +(cdr p))) +(if (equal? +(car p) +'?) +(if (and (pair? +(cdr p)) +(list? +(cddr p))) +((lambda (pred +ps) +`(? ,pred +,@(map ordinary +ps))) +(cadr p) +(cddr p)) +(g204 (car p) +(cdr p))) +(if (equal? +(car p) +'and) +(if (and (list? +(cdr p)) +(pair? +(cdr p))) +((lambda (ps) +`(and ,@(map ordinary +ps))) +(cdr p)) +(g204 (car p) +(cdr p))) +(if (equal? +(car p) +'or) +(if (and (list? +(cdr p)) +(pair? +(cdr p))) +((lambda (ps) +`(or ,@(map ordinary +ps))) +(cdr p)) +(g204 (car p) +(cdr p))) +(if (equal? +(car p) +'not) +(if (and (list? +(cdr p)) +(pair? +(cdr p))) +((lambda (ps) +`(not ,@(map ordinary +ps))) +(cdr p)) +(g204 (car p) +(cdr p))) +(if (equal? +(car p) +'$) +(if (and (pair? +(cdr p)) +(symbol? +(cadr p)) +(list? +(cddr p))) +((lambda (r +ps) +`($ ,r +,@(map ordinary +ps))) +(cadr p) +(cddr p)) +(g204 (car p) +(cdr p))) +(if (equal? +(car p) +'set!) +(if (and (pair? +(cdr p)) +(pattern-var? +(cadr p)) +(null? +(cddr p))) +((lambda (p) +p) +p) +(g204 (car p) +(cdr p))) +(if (equal? +(car p) +'get!) +(if (and (pair? +(cdr p)) +(pattern-var? +(cadr p)) +(null? +(cddr p))) +((lambda (p) +p) +p) +(g204 (car p) +(cdr p))) +(if (equal? +(car p) +'unquote) +(g204 (car p) +(cdr p)) +(if (equal? +(car p) +'unquote-splicing) +(g204 (car p) +(cdr p)) +(if (and (pair? +(cdr p)) +(dot-dot-k? +(cadr p)) +(null? +(cddr p))) +((lambda (p +ddk) +`(,(ordinary +p) +,ddk)) +(car p) +(cadr p)) +(g204 (car p) +(cdr p)))))))))))))) +(if (vector? +p) +((lambda (p) +(let* ((pl (vector->list +p)) +(rpl (reverse +pl))) +(apply +vector +(if (dot-dot-k? +(car rpl)) +(reverse +(cons (car rpl) +(map ordinary +(cdr rpl)))) +(map ordinary +pl))))) +p) +(if (box? p) +((lambda (p) +(box (ordinary +(unbox +p)))) +p) + +((lambda () +(match:syntax-err +pattern +"syntax error in pattern")))))))))))) +(quasi (lambda (p) +(let ((g193 (lambda (x +y) +(cons (quasi +x) +(quasi +y))))) +(if (simple? p) +((lambda (p) p) +p) +(if (symbol? p) +((lambda (p) +`',p) +p) +(if (pair? +p) +(if (equal? +(car p) +'unquote) +(if (and (pair? +(cdr p)) +(null? +(cddr p))) +((lambda (p) +(ordinary +p)) +(cadr p)) +(g193 (car p) +(cdr p))) +(if (and (pair? +(car p)) +(equal? +(caar p) +'unquote-splicing) +(pair? +(cdar p)) +(null? +(cddar +p))) +(if (null? +(cdr p)) +((lambda (p) +(ordinary +p)) +(cadar +p)) +((lambda (p +y) +(append +(ordlist +p) +(quasi +y))) +(cadar +p) +(cdr p))) +(if (and (pair? +(cdr p)) +(dot-dot-k? +(cadr p)) +(null? +(cddr p))) +((lambda (p +ddk) +`(,(quasi +p) +,ddk)) +(car p) +(cadr p)) +(g193 (car p) +(cdr p))))) +(if (vector? +p) +((lambda (p) +(let* ((pl (vector->list +p)) +(rpl (reverse +pl))) +(apply +vector +(if (dot-dot-k? +(car rpl)) +(reverse +(cons (car rpl) +(map quasi +(cdr rpl)))) +(map ordinary +pl))))) +p) +(if (box? p) +((lambda (p) +(box (quasi +(unbox +p)))) +p) +((lambda () +(match:syntax-err +pattern +"syntax error in pattern"))))))))))) +(ordlist (lambda (p) +(cond +((null? p) '()) +((pair? p) (cons (ordinary +(car p)) +(ordlist +(cdr p)))) +(else (match:syntax-err +pattern +"invalid use of unquote-splicing in pattern")))))) +(ordinary pattern)))) +(bound (lambda (pattern) +(letrec ((pred-bodies '()) +(bound (lambda (p a k) +(cond +((eq? '_ p) (k p a)) +((symbol? p) (if (memq p a) +(match:syntax-err +pattern +"duplicate variable in pattern")) +(k p (cons p a))) +((and (pair? p) +(eq? 'quote (car p))) (k p +a)) +((and (pair? p) +(eq? '? (car p))) (cond +((not (null? +(cddr p))) (bound +`(and (? ,(cadr p)) +,@(cddr p)) +a +k)) +((or (not (symbol? +(cadr p))) +(memq (cadr p) +a)) (let ((g (gensym))) +(set! pred-bodies +(cons `(,g ,(cadr p)) +pred-bodies)) +(k `(? ,g) +a))) +(else (k p +a)))) +((and (pair? p) +(eq? 'and (car p))) (bound* +(cdr p) +a +(lambda (p +a) +(k `(and ,@p) +a)))) +((and (pair? p) +(eq? 'or (car p))) (bound +(cadr p) +a +(lambda (first-p +first-a) +(let or* ((plist (cddr p)) +(k (lambda (plist) +(k `(or ,first-p +,@plist) +first-a)))) +(if (null? +plist) +(k plist) +(bound +(car plist) +a +(lambda (car-p +car-a) +(if (not (permutation +car-a +first-a)) +(match:syntax-err +pattern +"variables of or-pattern differ in")) +(or* (cdr plist) +(lambda (cdr-p) +(k (cons car-p +cdr-p))))))))))) +((and (pair? p) +(eq? 'not (car p))) (cond +((not (null? +(cddr p))) (bound +`(not (or ,@(cdr p))) +a +k)) +(else (bound +(cadr p) +a +(lambda (p2 +a2) +(if (not (permutation +a +a2)) +(match:syntax-err +p +"no variables allowed in")) +(k `(not ,p2) +a)))))) +((and (pair? p) +(pair? (cdr p)) +(dot-dot-k? (cadr p))) (bound +(car p) +a +(lambda (q +b) +(let ((bvars (find-prefix +b +a))) +(k `(,q ,(cadr p) +,bvars +,(gensym) +,(gensym) +,(map (lambda (_) +(gensym)) +bvars)) +b))))) +((and (pair? p) +(eq? '$ (car p))) (bound* +(cddr p) +a +(lambda (p1 +a) +(k `($ ,(cadr p) +,@p1) +a)))) +((and (pair? p) +(eq? 'set! (car p))) (if (memq (cadr p) +a) +(k p +a) +(k p +(cons (cadr p) +a)))) +((and (pair? p) +(eq? 'get! (car p))) (if (memq (cadr p) +a) +(k p +a) +(k p +(cons (cadr p) +a)))) +((pair? p) (bound +(car p) +a +(lambda (car-p a) +(bound +(cdr p) +a +(lambda (cdr-p +a) +(k (cons car-p +cdr-p) +a)))))) +((vector? p) (boundv +(vector->list +p) +a +(lambda (pl a) +(k (list->vector +pl) +a)))) +((box? p) (bound +(unbox p) +a +(lambda (p a) +(k (box p) +a)))) +(else (k p a))))) +(boundv (lambda (plist a k) +(let ((g187 (lambda () +(k plist a)))) +(if (pair? plist) +(if (and (pair? +(cdr plist)) +(dot-dot-k? +(cadr plist)) +(null? +(cddr plist))) +((lambda () +(bound +plist +a +k))) +(if (null? plist) +(g187) +((lambda (x y) +(bound +x +a +(lambda (car-p +a) +(boundv +y +a +(lambda (cdr-p +a) +(k (cons car-p +cdr-p) +a)))))) +(car plist) +(cdr plist)))) +(if (null? plist) +(g187) +((#%global-defined-value 'match:error) +plist)))))) +(bound* (lambda (plist a k) +(if (null? plist) +(k plist a) +(bound +(car plist) +a +(lambda (car-p a) +(bound* +(cdr plist) +a +(lambda (cdr-p a) +(k (cons car-p +cdr-p) +a)))))))) +(find-prefix (lambda (b a) +(if (eq? b a) +'() +(cons (car b) +(find-prefix +(cdr b) +a))))) +(permutation (lambda (p1 p2) +(and (= (length p1) +(length p2)) +(andmap +(lambda (x1) +(memq x1 p2)) +p1))))) +(bound +pattern +'() +(lambda (p a) +(list p (reverse a) pred-bodies)))))) +(inline-let (lambda (let-exp) +(letrec ((occ (lambda (x e) +(let loop ((e e)) +(cond +((pair? e) (+ (loop (car e)) +(loop (cdr e)))) +((eq? x e) 1) +(else 0))))) +(subst (lambda (e old new) +(let loop ((e e)) +(cond +((pair? e) (cons (loop (car e)) +(loop (cdr e)))) +((eq? old e) new) +(else e))))) +(const? (lambda (sexp) +(or (symbol? sexp) +(boolean? sexp) +(string? sexp) +(char? sexp) +(number? sexp) +(null? sexp) +(and (pair? sexp) +(eq? (car sexp) +'quote) +(pair? (cdr sexp)) +(symbol? +(cadr sexp)) +(null? +(cddr sexp)))))) +(isval? (lambda (sexp) +(or (const? sexp) +(and (pair? sexp) +(memq (car sexp) +'(lambda quote +match-lambda +match-lambda*)))))) +(small? (lambda (sexp) +(or (const? sexp) +(and (pair? sexp) +(eq? (car sexp) +'lambda) +(pair? (cdr sexp)) +(pair? (cddr sexp)) +(const? +(caddr sexp)) +(null? +(cdddr sexp))))))) +(let loop ((b (cadr let-exp)) +(new-b '()) +(e (caddr let-exp))) +(cond +((null? b) (if (null? new-b) +e +`(let ,(reverse new-b) +,e))) +((isval? (cadr (car b))) (let* ((x (caar b)) +(n (occ x +e))) +(cond +((= 0 n) (loop (cdr b) +new-b +e)) +((or (= 1 +n) +(small? +(cadr (car b)))) (loop (cdr b) +new-b +(subst +e +x +(cadr (car b))))) +(else (loop (cdr b) +(cons (car b) +new-b) +e))))) +(else (loop (cdr b) +(cons (car b) new-b) +e))))))) +(gen (lambda (x sf plist erract length>= eta) +(if (null? plist) +(erract x) +(let* ((v '()) +(val (lambda (x) (cdr (assq x v)))) +(fail (lambda (sf) +(gen x +sf +(cdr plist) +erract +length>= +eta))) +(success (lambda (sf) +(set-car! +(cddddr (car plist)) +#t) +(let* ((code (cadr (car plist))) +(bv (caddr (car plist))) +(fail-sym (cadddr +(car plist)))) +(if fail-sym +(let ((ap `(,code +,fail-sym +,@(map val +bv)))) +`(call-with-current-continuation +(lambda (,fail-sym) +(let ((,fail-sym (lambda () +;; Changed CF 9.24.96 for multiple value returns +(call-with-values +(lambda () ,(fail sf)) +,fail-sym)))) +,ap)))) +`(,code +,@(map val bv))))))) +(let next ((p (caar plist)) +(e x) +(sf sf) +(kf fail) +(ks success)) +(cond +((eq? '_ p) (ks sf)) +((symbol? p) (set! v (cons (cons p e) v)) +(ks sf)) +((null? p) (emit `(null? ,e) sf kf ks)) +((string? p) (emit `(equal? ,e ,p) +sf +kf +ks)) +((boolean? p) (emit `(equal? ,e ,p) +sf +kf +ks)) +((char? p) (emit `(equal? ,e ,p) sf kf ks)) +((number? p) (emit `(equal? ,e ,p) +sf +kf +ks)) +((and (pair? p) (eq? 'quote (car p))) (emit `(equal? +,e +,p) +sf +kf +ks)) +((and (pair? p) (eq? '? (car p))) (let ((tst `(,(cadr p) +,e))) +(emit tst +sf +kf +ks))) +((and (pair? p) (eq? 'and (car p))) (let loop ((p (cdr p)) +(sf sf)) +(if (null? +p) +(ks sf) +(next (car p) +e +sf +kf +(lambda (sf) +(loop (cdr p) +sf)))))) +((and (pair? p) (eq? 'or (car p))) (let ((or-v v)) +(let loop ((p (cdr p)) +(sf sf)) +(if (null? +p) +(kf sf) +(begin (set! v +or-v) +(next (car p) +e +sf +(lambda (sf) +(loop (cdr p) +sf)) +ks)))))) +((and (pair? p) (eq? 'not (car p))) (next (cadr p) +e +sf +ks +kf)) +((and (pair? p) (eq? '$ (car p))) (let* ((tag (cadr p)) +(fields (cdr p)) +(rlen (length +fields)) +(tst `(,(symbol-append +tag +'?) +,e))) +(emit tst +sf +kf +(let rloop ((n 1)) +(lambda (sf) +(if (= n +rlen) +(ks sf) +(next (list-ref +fields +n) +`(struct-ref +,e +,(sub1 n)) +sf +kf +(rloop +(+ 1 +n))))))))) +((and (pair? p) (eq? 'set! (car p))) (set! v +(cons (cons (cadr p) +(setter +e +p)) +v)) +(ks sf)) +((and (pair? p) (eq? 'get! (car p))) (set! v +(cons (cons (cadr p) +(getter +e +p)) +v)) +(ks sf)) +((and (pair? p) +(pair? (cdr p)) +(dot-dot-k? (cadr p))) (emit `(list? +,e) +sf +kf +(lambda (sf) +(let* ((k (dot-dot-k? +(cadr p))) +(ks (lambda (sf) +(let ((bound (list-ref +p +2))) +(cond +((eq? (car p) +'_) (ks sf)) +((null? +bound) (let* ((ptst (next (car p) +eta +sf +(lambda (sf) +#f) +(lambda (sf) +#t))) +(tst (if (and (pair? +ptst) +(symbol? +(car ptst)) +(pair? +(cdr ptst)) +(eq? eta +(cadr ptst)) +(null? +(cddr ptst))) +(car ptst) +`(lambda (,eta) +,ptst)))) +(assm `(andmap +,tst +,e) +(kf sf) +(ks sf)))) +((and (symbol? +(car p)) +(equal? +(list (car p)) +bound)) (next (car p) +e +sf +kf +ks)) +(else (let* ((gloop (list-ref +p +3)) +(ge (list-ref +p +4)) +(fresh (list-ref +p +5)) +(p1 (next (car p) +`(car ,ge) +sf +kf +(lambda (sf) +`(,gloop +(cdr ,ge) +,@(map (lambda (b +f) +`(cons ,(val b) +,f)) +bound +fresh)))))) +(set! v +(append +(map cons +bound +(map (lambda (x) +`(reverse +,x)) +fresh)) +v)) +`(let ,gloop +((,ge ,e) +,@(map (lambda (x) +`(,x '())) +fresh)) +(if (null? +,ge) +,(ks sf) +,p1))))))))) +(case k +((0) (ks sf)) +((1) (emit `(pair? +,e) +sf +kf +ks)) +(else (emit `((,length>= +,k) +,e) +sf +kf +ks))))))) +((pair? p) (emit `(pair? ,e) +sf +kf +(lambda (sf) +(next (car p) +(add-a e) +sf +kf +(lambda (sf) +(next (cdr p) +(add-d +e) +sf +kf +ks)))))) +((and (vector? p) +(>= (vector-length p) 6) +(dot-dot-k? +(vector-ref +p +(- (vector-length p) 5)))) (let* ((vlen (- (vector-length +p) +6)) +(k (dot-dot-k? +(vector-ref +p +(+ vlen +1)))) +(minlen (+ vlen +k)) +(bound (vector-ref +p +(+ vlen +2)))) +(emit `(vector? +,e) +sf +kf +(lambda (sf) +(assm `(>= (vector-length +,e) +,minlen) +(kf sf) +((let vloop ((n 0)) +(lambda (sf) +(cond +((not (= n +vlen)) (next (vector-ref +p +n) +`(vector-ref +,e +,n) +sf +kf +(vloop +(+ 1 +n)))) +((eq? (vector-ref +p +vlen) +'_) (ks sf)) +(else (let* ((gloop (vector-ref +p +(+ vlen +3))) +(ind (vector-ref +p +(+ vlen +4))) +(fresh (vector-ref +p +(+ vlen +5))) +(p1 (next (vector-ref +p +vlen) +`(vector-ref +,e +,ind) +sf +kf +(lambda (sf) +`(,gloop +(- ,ind +1) +,@(map (lambda (b +f) +`(cons ,(val b) +,f)) +bound +fresh)))))) +(set! v +(append +(map cons +bound +fresh) +v)) +`(let ,gloop +((,ind (- (vector-length +,e) +1)) +,@(map (lambda (x) +`(,x '())) +fresh)) +(if (> ,minlen +,ind) +,(ks sf) +,p1))))))) +sf)))))) +((vector? p) (let ((vlen (vector-length p))) +(emit `(vector? ,e) +sf +kf +(lambda (sf) +(emit `(equal? +(vector-length +,e) +,vlen) +sf +kf +(let vloop ((n 0)) +(lambda (sf) +(if (= n +vlen) +(ks sf) +(next (vector-ref +p +n) +`(vector-ref +,e +,n) +sf +kf +(vloop +(+ 1 +n))))))))))) +((box? p) (emit `(box? ,e) +sf +kf +(lambda (sf) +(next (unbox p) +`(unbox ,e) +sf +kf +ks)))) +(else (display +"FATAL ERROR IN PATTERN MATCHER") +(newline) +(error #f "THIS NEVER HAPPENS")))))))) +(emit (lambda (tst sf kf ks) +(cond +((in tst sf) (ks sf)) +((in `(not ,tst) sf) (kf sf)) +(else (let* ((e (cadr tst)) +(implied (cond +((eq? (car tst) 'equal?) (let ((p (caddr +tst))) +(cond +((string? +p) `((string? +,e))) +((boolean? +p) `((boolean? +,e))) +((char? +p) `((char? +,e))) +((number? +p) `((number? +,e))) +((and (pair? +p) +(eq? 'quote +(car p))) `((symbol? +,e))) +(else '())))) +((eq? (car tst) 'null?) `((list? +,e))) +((vec-structure? tst) `((vector? +,e))) +(else '()))) +(not-imp (case (car tst) +((list?) `((not (null? +,e)))) +(else '()))) +(s (ks (cons tst (append implied sf)))) +(k (kf (cons `(not ,tst) +(append not-imp sf))))) +(assm tst k s)))))) +(assm (lambda (tst f s) +(cond +((equal? s f) s) +((and (eq? s #t) (eq? f #f)) tst) +((and (eq? (car tst) 'pair?) +(memq match:error-control +'(unspecified fail)) +(memq (car f) '(cond match:error)) +(guarantees s (cadr tst))) s) +((and (pair? s) +(eq? (car s) 'if) +(equal? (cadddr s) f)) (if (eq? (car (cadr s)) +'and) +`(if (and ,tst +,@(cdr (cadr s))) +,(caddr s) +,f) +`(if (and ,tst +,(cadr s)) +,(caddr s) +,f))) + +;; ### OLD call-with-current-continuation test was here + +((and #f +(pair? s) +(equal? (car s) 'let) +(pair? (cdr s)) +(pair? (cadr s)) +(pair? (caadr s)) +(pair? (cdaadr s)) +(pair? (car (cdaadr s))) +(equal? (caar (cdaadr s)) 'lambda) +(pair? (cdar (cdaadr s))) +(null? (cadar (cdaadr s))) +(pair? (cddar (cdaadr s))) +(null? (cdddar (cdaadr s))) +(null? (cdr (cdaadr s))) +(null? (cdadr s)) +(pair? (cddr s)) +(null? (cdddr s)) +(equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr +s)) +(s2 (caddr +s))) +`(let ((,fail (lambda () +,f))) +,(assm tst +`(,fail) +s2)))) +(else `(if ,tst ,s ,f))))) +(guarantees (lambda (code x) +(let ((a (add-a x)) (d (add-d x))) +(let loop ((code code)) +(cond +((not (pair? code)) #f) +((memq (car code) '(cond match:error)) #t) +((or (equal? code a) (equal? code d)) #t) +((eq? (car code) 'if) (or (loop (cadr code)) +(and (loop (caddr +code)) +(loop (cadddr +code))))) +((eq? (car code) 'lambda) #f) +((and (eq? (car code) 'let) +(symbol? (cadr code))) #f) +(else (or (loop (car code)) +(loop (cdr code))))))))) +(in (lambda (e l) +(or (member e l) +(and (eq? (car e) 'list?) +(or (member `(null? ,(cadr e)) l) +(member `(pair? ,(cadr e)) l))) +(and (eq? (car e) 'not) +(let* ((srch (cadr e)) +(const-class (equal-test? srch))) +(cond +(const-class (let mem ((l l)) +(if (null? l) +#f +(let ((x (car l))) +(or (and (equal? +(cadr x) +(cadr srch)) +(disjoint? +x) +(not (equal? +const-class +(car x)))) +(equal? +x +`(not (,const-class +,(cadr srch)))) +(and (equal? +(cadr x) +(cadr srch)) +(equal-test? +x) +(not (equal? +(caddr +srch) +(caddr +x)))) +(mem (cdr l))))))) +((disjoint? srch) (let mem ((l l)) +(if (null? l) +#f +(let ((x (car l))) +(or (and (equal? +(cadr x) +(cadr srch)) +(disjoint? +x) +(not (equal? +(car x) +(car srch)))) +(mem (cdr l))))))) +((eq? (car srch) 'list?) (let mem ((l l)) +(if (null? l) +#f +(let ((x (car l))) +(or (and (equal? +(cadr x) +(cadr srch)) +(disjoint? +x) +(not (memq (car x) +'(list? +pair? +null?)))) +(mem (cdr l))))))) +((vec-structure? srch) (let mem ((l l)) +(if (null? l) +#f +(let ((x (car l))) +(or (and (equal? +(cadr x) +(cadr srch)) +(or (disjoint? +x) +(vec-structure? +x)) +(not (equal? +(car x) +'vector?)) +(not (equal? +(car x) +(car srch)))) +(equal? +x +`(not (vector? +,(cadr srch)))) +(mem (cdr l))))))) +(else #f))))))) +(equal-test? (lambda (tst) +(and (eq? (car tst) 'equal?) +(let ((p (caddr tst))) +(cond +((string? p) 'string?) +((boolean? p) 'boolean?) +((char? p) 'char?) +((number? p) 'number?) +((and (pair? p) +(pair? (cdr p)) +(null? (cddr p)) +(eq? 'quote (car p)) +(symbol? (cadr p))) 'symbol?) +(else #f)))))) +(disjoint? (lambda (tst) +(memq (car tst) match:disjoint-predicates))) +(vec-structure? (lambda (tst) +(memq (car tst) match:vector-structures))) +(add-a (lambda (a) +(let ((new (and (pair? a) (assq (car a) c---rs)))) +(if new (cons (cadr new) (cdr a)) `(car ,a))))) +(add-d (lambda (a) +(let ((new (and (pair? a) (assq (car a) c---rs)))) +(if new (cons (cddr new) (cdr a)) `(cdr ,a))))) +(c---rs '((car caar . cdar) +(cdr cadr . cddr) +(caar caaar . cdaar) +(cadr caadr . cdadr) +(cdar cadar . cddar) +(cddr caddr . cdddr) +(caaar caaaar . cdaaar) +(caadr caaadr . cdaadr) +(cadar caadar . cdadar) +(caddr caaddr . cdaddr) +(cdaar cadaar . cddaar) +(cdadr cadadr . cddadr) +(cddar caddar . cdddar) +(cdddr cadddr . cddddr))) +(setter (lambda (e p) +(let ((mk-setter (lambda (s) +(symbol-append 'set- s '!)))) +(cond +((not (pair? e)) (match:syntax-err +p +"unnested set! pattern")) +((eq? (car e) 'vector-ref) `(let ((x ,(cadr e))) +(lambda (y) +(vector-set! +x +,(caddr +e) +y)))) +((eq? (car e) 'unbox) `(let ((x ,(cadr e))) +(lambda (y) +(set-box! x y)))) +((eq? (car e) 'car) `(let ((x ,(cadr e))) +(lambda (y) +(set-car! x y)))) +((eq? (car e) 'cdr) `(let ((x ,(cadr e))) +(lambda (y) +(set-cdr! x y)))) +((let ((a (assq (car e) get-c---rs))) +(and a +`(let ((x (,(cadr a) ,(cadr e)))) +(lambda (y) +(,(mk-setter (cddr a)) +x +y)))))) +(else `(let ((x ,(cadr e))) +(lambda (y) +(,(mk-setter (car e)) x y)))))))) +(getter (lambda (e p) +(cond +((not (pair? e)) (match:syntax-err +p +"unnested get! pattern")) +((eq? (car e) 'vector-ref) `(let ((x ,(cadr e))) +(lambda () +(vector-ref +x +,(caddr +e))))) +((eq? (car e) 'unbox) `(let ((x ,(cadr e))) +(lambda () (unbox x)))) +((eq? (car e) 'car) `(let ((x ,(cadr e))) +(lambda () (car x)))) +((eq? (car e) 'cdr) `(let ((x ,(cadr e))) +(lambda () (cdr x)))) +((let ((a (assq (car e) get-c---rs))) +(and a +`(let ((x (,(cadr a) ,(cadr e)))) +(lambda () (,(cddr a) x)))))) +(else `(let ((x ,(cadr e))) +(lambda () (,(car e) x))))))) +(get-c---rs '((caar car . car) +(cadr cdr . car) +(cdar car . cdr) +(cddr cdr . cdr) +(caaar caar . car) +(caadr cadr . car) +(cadar cdar . car) +(caddr cddr . car) +(cdaar caar . cdr) +(cdadr cadr . cdr) +(cddar cdar . cdr) +(cdddr cddr . cdr) +(caaaar caaar . car) +(caaadr caadr . car) +(caadar cadar . car) +(caaddr caddr . car) +(cadaar cdaar . car) +(cadadr cdadr . car) +(caddar cddar . car) +(cadddr cdddr . car) +(cdaaar caaar . cdr) +(cdaadr caadr . cdr) +(cdadar cadar . cdr) +(cdaddr caddr . cdr) +(cddaar cdaar . cdr) +(cddadr cdadr . cdr) +(cdddar cddar . cdr) +(cddddr cdddr . cdr))) +(symbol-append (lambda l +(string->symbol +(apply +string-append +(map (lambda (x) +(cond +((symbol? x) (symbol->string +x)) +((number? x) (number->string +x)) +(else x))) +l))))) +(rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) +(rdc (lambda (l) +(if (null? (cdr l)) '() (cons (car l) (rdc (cdr l))))))) +(list genmatch genletrec gendefine pattern-var?))) +(define match +(lambda args +(cond +((and (list? args) +(<= 1 (length args)) +(andmap +(lambda (y) (and (list? y) (<= 2 (length y)))) +(cdr args))) (let* ((exp (car args)) +(clauses (cdr args)) +(e (if (symbol? exp) exp (gensym)))) +(if (symbol? exp) +((car match:expanders) +e +clauses +`(match ,@args)) +`(let ((,e ,exp)) +,((car match:expanders) +e +clauses +`(match ,@args)))))) +(else (match:syntax-err `(match ,@args) "syntax error in"))))) +(define match-lambda +(lambda args +(if (and (list? args) +(andmap +(lambda (g184) +(if (and (pair? g184) (list? (cdr g184))) +(pair? (cdr g184)) +#f)) +args)) +((lambda () +(let ((e (gensym))) `(lambda (,e) (match ,e ,@args))))) +((lambda () +(match:syntax-err +`(match-lambda ,@args) +"syntax error in")))))) +(define match-lambda* +(lambda args +(if (and (list? args) +(andmap +(lambda (g176) +(if (and (pair? g176) (list? (cdr g176))) +(pair? (cdr g176)) +#f)) +args)) +((lambda () +(let ((e (gensym))) `(lambda ,e (match ,e ,@args))))) +((lambda () +(match:syntax-err +`(match-lambda* ,@args) +"syntax error in")))))) +(define match-let +(lambda args +(let ((g154 (cadddr match:expanders)) +(g153 (lambda (pat exp body) `(match ,exp (,pat ,@body)))) +(g149 (lambda (p1 e1 p2 e2 body) +(let ((g1 (gensym)) (g2 (gensym))) +`(let ((,g1 ,e1) (,g2 ,e2)) +(match (cons ,g1 ,g2) ((,p1 . ,p2) ,@body)))))) +(g145 (lambda (pat exp body) +(let ((g (map (lambda (x) (gensym)) pat)) +(vpattern (list->vector pat))) +`(let ,(map list g exp) +(match (vector ,@g) (,vpattern ,@body)))))) +(g137 (lambda () +(match:syntax-err `(match-let ,@args) "syntax error in")))) +(if (pair? args) +(if (symbol? (car args)) +(if (and (pair? (cdr args)) (list? (cadr args))) +(let g163 ((g162 (cadr args)) (g161 '()) (g160 '())) +(if (null? g162) +(if (and (list? (cddr args)) (pair? (cddr args))) +((lambda (name pat exp body) +(if (andmap +(cadddr match:expanders) +pat) +`(let ,@args) +`(letrec ((,name (match-lambda* +(,pat ,@body)))) +(,name ,@exp)))) +(car args) +(reverse g160) +(reverse g161) +(cddr args)) +(g137)) +(if (and (pair? (car g162)) +(pair? (cdar g162)) +(null? (cddar g162))) +(g163 (cdr g162) +(cons (cadar g162) g161) +(cons (caar g162) g160)) +(g137)))) +(g137)) +(if (list? (car args)) +(if (andmap +(lambda (g168) +(if (and (pair? g168) +(g154 (car g168)) +(pair? (cdr g168))) +(null? (cddr g168)) +#f)) +(car args)) +(if (and (list? (cdr args)) (pair? (cdr args))) +((lambda () `(let ,@args))) +(let g141 ((g140 (car args)) +(g139 '()) +(g138 '())) +(if (null? g140) +(g137) +(if (and (pair? (car g140)) +(pair? (cdar g140)) +(null? (cddar g140))) +(g141 (cdr g140) +(cons (cadar g140) g139) +(cons (caar g140) g138)) +(g137))))) +(if (and (pair? (car args)) +(pair? (caar args)) +(pair? (cdaar args)) +(null? (cddaar args))) +(if (null? (cdar args)) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g153 (caaar args) +(cadaar args) +(cdr args)) +(let g141 ((g140 (car args)) +(g139 '()) +(g138 '())) +(if (null? g140) +(g137) +(if (and (pair? (car g140)) +(pair? (cdar g140)) +(null? (cddar g140))) +(g141 (cdr g140) +(cons (cadar g140) g139) +(cons (caar g140) g138)) +(g137))))) +(if (and (pair? (cdar args)) +(pair? (cadar args)) +(pair? (cdadar args)) +(null? (cdr (cdadar args))) +(null? (cddar args))) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g149 (caaar args) +(cadaar args) +(caadar args) +(car (cdadar args)) +(cdr args)) +(let g141 ((g140 (car args)) +(g139 '()) +(g138 '())) +(if (null? g140) +(g137) +(if (and (pair? (car g140)) +(pair? (cdar g140)) +(null? (cddar g140))) +(g141 (cdr g140) +(cons (cadar g140) +g139) +(cons (caar g140) +g138)) +(g137))))) +(let g141 ((g140 (car args)) +(g139 '()) +(g138 '())) +(if (null? g140) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g145 (reverse g138) +(reverse g139) +(cdr args)) +(g137)) +(if (and (pair? (car g140)) +(pair? (cdar g140)) +(null? (cddar g140))) +(g141 (cdr g140) +(cons (cadar g140) g139) +(cons (caar g140) g138)) +(g137)))))) +(let g141 ((g140 (car args)) +(g139 '()) +(g138 '())) +(if (null? g140) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g145 (reverse g138) +(reverse g139) +(cdr args)) +(g137)) +(if (and (pair? (car g140)) +(pair? (cdar g140)) +(null? (cddar g140))) +(g141 (cdr g140) +(cons (cadar g140) g139) +(cons (caar g140) g138)) +(g137)))))) +(if (pair? (car args)) +(if (and (pair? (caar args)) +(pair? (cdaar args)) +(null? (cddaar args))) +(if (null? (cdar args)) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g153 (caaar args) +(cadaar args) +(cdr args)) +(let g141 ((g140 (car args)) +(g139 '()) +(g138 '())) +(if (null? g140) +(g137) +(if (and (pair? (car g140)) +(pair? (cdar g140)) +(null? (cddar g140))) +(g141 (cdr g140) +(cons (cadar g140) g139) +(cons (caar g140) g138)) +(g137))))) +(if (and (pair? (cdar args)) +(pair? (cadar args)) +(pair? (cdadar args)) +(null? (cdr (cdadar args))) +(null? (cddar args))) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g149 (caaar args) +(cadaar args) +(caadar args) +(car (cdadar args)) +(cdr args)) +(let g141 ((g140 (car args)) +(g139 '()) +(g138 '())) +(if (null? g140) +(g137) +(if (and (pair? (car g140)) +(pair? (cdar g140)) +(null? (cddar g140))) +(g141 (cdr g140) +(cons (cadar g140) +g139) +(cons (caar g140) +g138)) +(g137))))) +(let g141 ((g140 (car args)) +(g139 '()) +(g138 '())) +(if (null? g140) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g145 (reverse g138) +(reverse g139) +(cdr args)) +(g137)) +(if (and (pair? (car g140)) +(pair? (cdar g140)) +(null? (cddar g140))) +(g141 (cdr g140) +(cons (cadar g140) g139) +(cons (caar g140) g138)) +(g137)))))) +(let g141 ((g140 (car args)) +(g139 '()) +(g138 '())) +(if (null? g140) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g145 (reverse g138) +(reverse g139) +(cdr args)) +(g137)) +(if (and (pair? (car g140)) +(pair? (cdar g140)) +(null? (cddar g140))) +(g141 (cdr g140) +(cons (cadar g140) g139) +(cons (caar g140) g138)) +(g137))))) +(g137)))) +(g137))))) +(define match-let* +(lambda args +(let ((g123 (lambda () +(match:syntax-err +`(match-let* ,@args) +"syntax error in")))) +(if (pair? args) +(if (null? (car args)) +(if (and (list? (cdr args)) (pair? (cdr args))) +((lambda (body) `(let* ,@args)) (cdr args)) +(g123)) +(if (and (pair? (car args)) +(pair? (caar args)) +(pair? (cdaar args)) +(null? (cddaar args)) +(list? (cdar args)) +(list? (cdr args)) +(pair? (cdr args))) +((lambda (pat exp rest body) +(if ((cadddr match:expanders) pat) +`(let ((,pat ,exp)) (match-let* ,rest ,@body)) +`(match ,exp (,pat (match-let* ,rest ,@body))))) +(caaar args) +(cadaar args) +(cdar args) +(cdr args)) +(g123))) +(g123))))) +(define match-letrec +(lambda args +(let ((g115 (cadddr match:expanders)) +(g114 (lambda (pat exp body) +((cadr match:expanders) +pat +exp +body +`(match-letrec ((,pat ,exp)) ,@body)))) +(g110 (lambda (p1 e1 p2 e2 body) +`(match-letrec (((p1 . p2) (cons e1 e2))) ,@body))) +(g106 (lambda (pat exp body) +`(match-letrec +((,(list->vector pat) (vector ,@exp))) +,@body))) +(g98 (lambda () +(match:syntax-err +`(match-letrec ,@args) +"syntax error in")))) +(if (pair? args) +(if (list? (car args)) +(if (andmap +(lambda (g121) +(if (and (pair? g121) +(g115 (car g121)) +(pair? (cdr g121))) +(null? (cddr g121)) +#f)) +(car args)) +(if (and (list? (cdr args)) (pair? (cdr args))) +((lambda () `(letrec ,@args))) +(let g102 ((g101 (car args)) (g100 '()) (g99 '())) +(if (null? g101) +(g98) +(if (and (pair? (car g101)) +(pair? (cdar g101)) +(null? (cddar g101))) +(g102 (cdr g101) +(cons (cadar g101) g100) +(cons (caar g101) g99)) +(g98))))) +(if (and (pair? (car args)) +(pair? (caar args)) +(pair? (cdaar args)) +(null? (cddaar args))) +(if (null? (cdar args)) +(if (and (list? (cdr args)) (pair? (cdr args))) +(g114 (caaar args) (cadaar args) (cdr args)) +(let g102 ((g101 (car args)) +(g100 '()) +(g99 '())) +(if (null? g101) +(g98) +(if (and (pair? (car g101)) +(pair? (cdar g101)) +(null? (cddar g101))) +(g102 (cdr g101) +(cons (cadar g101) g100) +(cons (caar g101) g99)) +(g98))))) +(if (and (pair? (cdar args)) +(pair? (cadar args)) +(pair? (cdadar args)) +(null? (cdr (cdadar args))) +(null? (cddar args))) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g110 (caaar args) +(cadaar args) +(caadar args) +(car (cdadar args)) +(cdr args)) +(let g102 ((g101 (car args)) +(g100 '()) +(g99 '())) +(if (null? g101) +(g98) +(if (and (pair? (car g101)) +(pair? (cdar g101)) +(null? (cddar g101))) +(g102 (cdr g101) +(cons (cadar g101) g100) +(cons (caar g101) g99)) +(g98))))) +(let g102 ((g101 (car args)) +(g100 '()) +(g99 '())) +(if (null? g101) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g106 (reverse g99) +(reverse g100) +(cdr args)) +(g98)) +(if (and (pair? (car g101)) +(pair? (cdar g101)) +(null? (cddar g101))) +(g102 (cdr g101) +(cons (cadar g101) g100) +(cons (caar g101) g99)) +(g98)))))) +(let g102 ((g101 (car args)) (g100 '()) (g99 '())) +(if (null? g101) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g106 (reverse g99) +(reverse g100) +(cdr args)) +(g98)) +(if (and (pair? (car g101)) +(pair? (cdar g101)) +(null? (cddar g101))) +(g102 (cdr g101) +(cons (cadar g101) g100) +(cons (caar g101) g99)) +(g98)))))) +(if (pair? (car args)) +(if (and (pair? (caar args)) +(pair? (cdaar args)) +(null? (cddaar args))) +(if (null? (cdar args)) +(if (and (list? (cdr args)) (pair? (cdr args))) +(g114 (caaar args) (cadaar args) (cdr args)) +(let g102 ((g101 (car args)) +(g100 '()) +(g99 '())) +(if (null? g101) +(g98) +(if (and (pair? (car g101)) +(pair? (cdar g101)) +(null? (cddar g101))) +(g102 (cdr g101) +(cons (cadar g101) g100) +(cons (caar g101) g99)) +(g98))))) +(if (and (pair? (cdar args)) +(pair? (cadar args)) +(pair? (cdadar args)) +(null? (cdr (cdadar args))) +(null? (cddar args))) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g110 (caaar args) +(cadaar args) +(caadar args) +(car (cdadar args)) +(cdr args)) +(let g102 ((g101 (car args)) +(g100 '()) +(g99 '())) +(if (null? g101) +(g98) +(if (and (pair? (car g101)) +(pair? (cdar g101)) +(null? (cddar g101))) +(g102 (cdr g101) +(cons (cadar g101) g100) +(cons (caar g101) g99)) +(g98))))) +(let g102 ((g101 (car args)) +(g100 '()) +(g99 '())) +(if (null? g101) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g106 (reverse g99) +(reverse g100) +(cdr args)) +(g98)) +(if (and (pair? (car g101)) +(pair? (cdar g101)) +(null? (cddar g101))) +(g102 (cdr g101) +(cons (cadar g101) g100) +(cons (caar g101) g99)) +(g98)))))) +(let g102 ((g101 (car args)) (g100 '()) (g99 '())) +(if (null? g101) +(if (and (list? (cdr args)) +(pair? (cdr args))) +(g106 (reverse g99) +(reverse g100) +(cdr args)) +(g98)) +(if (and (pair? (car g101)) +(pair? (cdar g101)) +(null? (cddar g101))) +(g102 (cdr g101) +(cons (cadar g101) g100) +(cons (caar g101) g99)) +(g98))))) +(g98))) +(g98))))) +(define match-define +(lambda args +(let ((g94 (cadddr match:expanders)) +(g92 (lambda () +(match:syntax-err +`(match-define ,@args) +"syntax error in")))) +(if (pair? args) +(if (g94 (car args)) +(if (and (pair? (cdr args)) (null? (cddr args))) +((lambda () `(begin (define ,@args)))) +(g92)) +(if (and (pair? (cdr args)) (null? (cddr args))) +((lambda (pat exp) +((caddr match:expanders) +pat +exp +`(match-define ,@args))) +(car args) +(cadr args)) +(g92))) +(g92)))))))) + + +(define-macro match match) +(define-macro match-lambda match-lambda) +(define-macro match-lambda* match-lambda*) +(define-macro match-letrec match-letrec) +(define-macro match-let match-let) +(define-macro match-let* match-let*) diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss new file mode 100644 index 0000000..7574216 --- /dev/null +++ b/collects/mzlib/pretty.ss @@ -0,0 +1,5 @@ + +(require-library "prettyu.ss") + +(invoke-open-unit/sig mzlib:pretty-print@ #f) + diff --git a/collects/mzlib/shared.ss b/collects/mzlib/shared.ss new file mode 100644 index 0000000..16b268c --- /dev/null +++ b/collects/mzlib/shared.ss @@ -0,0 +1,141 @@ + +(require-library "function.ss") + +#| + +(require-library "spidey.ss") + +(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-macro shared + (let () + (define-struct twople (left right)) + (define-struct cons-rhs (id car cdr)) + (define-struct vector-rhs (id args)) + (define-struct box-rhs (id arg)) + (define-struct weak-box-rhs (id let arg)) + (define-struct trans (rhs lets set!s)) + (lambda (defns . body) + (letrec ([bad (lambda (s sexp) + (error 'shared (string-append s ": ~a") sexp))] + [build-args + (lambda (args howmany) + (cond + [(null? args) '()] + [(pair? args) (cons (car args) + (build-args (cdr args) + (if (number? howmany) + (sub1 howmany) + howmany)))] + [else (bad "args" args)]))] + [build-args1 + (lambda (x) + (cond + [(and (pair? x) (null? (cdr x))) (list (car x))] + [else (bad "args" x)]))] + [build-args2 + (lambda (x) + (if (pair? x) + (let ((xcdr (cdr x))) + (if (pair? xcdr) + (let ((xcdrcdr (cdr xcdr))) + (if (null? xcdrcdr) + (list (car x) (car xcdr)) + (bad "args" x))) + (bad "args" x))) + (bad "args" x)))] + [build-defn + (lambda (x) + (unless (and (pair? x) + (symbol? (car x))) + (bad "bad binding" x)) + (if (not (and (pair? (cdr x)) + (pair? (cadr x)) + (symbol? (caadr x)))) + (make-trans x '() '()) + (let ([id (car x)] + [constructor (caadr x)] + [args (cdadr x)]) + (case constructor + [(list) (let ([args (build-args args 'whatever)]) + (if (null? args) + (make-trans `(,id (list)) + '() + '()) + (make-cons-rhs id (car args) `(list ,@(cdr args)))))] + [(vector) (let ([args (build-args args 'whatever)]) + (make-vector-rhs id args))] + [(box) (let ([args (build-args1 args)]) + (make-box-rhs id (car args)))] + ; [(make-weak-box) (let ([args (build-args1 args)]) + ; (make-weak-box-rhs id (car args)))] + [(cons) (let ([args (build-args2 args)]) + (make-cons-rhs id (car args) (cadr args)))] + [else (make-trans x '() '())]))))] + [build-defns + (lambda (x) + (cond + [(null? x) '()] + [(pair? x) (cons (build-defn (car x)) + (build-defns (cdr x)))] + [else (bad "defns list" x)]))] + [transform + (lambda (binding) + (cond + [(vector-rhs? binding) + (define-struct b&s (bind set!)) + (let* ([id (vector-rhs-id binding)]) + (let ([elems + (twople-left + (foldl (lambda (x data) + (let ([list (twople-left data)] + [i (twople-right data)] + [eid (gensym)]) + (make-twople (cons (make-b&s `(,eid ,x) + `(vector-set! ,id ,i ,eid)) + list) + (+ i 1)))) + (make-twople '() 0) + (vector-rhs-args binding)))]) + (make-trans `(,id (vector ,@(map (lambda (x) '(void)) + (vector-rhs-args binding)))) + (map b&s-bind elems) + (map b&s-set! elems))))] + [(box-rhs? binding) + (let ([id (box-rhs-id binding)] + [eid (gensym)]) + (make-trans `(,id (box (void))) + (list `(,eid ,(box-rhs-arg binding))) + (list `(set-box! ,id ,eid))))] + [(weak-box-rhs? binding) + (let ([id (weak-box-rhs-id binding)] + [eid (gensym)]) + (make-trans `(,id (make-weak-box (void))) + (list `(,eid ,(weak-box-rhs-arg binding))) + (list `(set-weak-box! ,id ,eid))))] + [(cons-rhs? binding) + (let ([id (cons-rhs-id binding)] + [car-id (gensym)] + [cdr-id (gensym)]) + (make-trans `(,id (cons (void) (void))) + (list `(,car-id ,(cons-rhs-car binding)) + `(,cdr-id ,(cons-rhs-cdr binding))) + (list `(set-car! ,id ,car-id) + `(set-cdr! ,id ,cdr-id))))] + [(trans? binding) binding] + [else (bad "internal error:" binding)]))] + [transformed-defns (map transform (build-defns defns))]) + (list 'letrec* + (map trans-rhs transformed-defns) + (list 'let (apply append (map trans-lets transformed-defns)) + (cons 'begin + (append (apply append (map trans-set!s transformed-defns)) + body)))))))) + diff --git a/collects/mzlib/string.ss b/collects/mzlib/string.ss new file mode 100644 index 0000000..78dfb34 --- /dev/null +++ b/collects/mzlib/string.ss @@ -0,0 +1,5 @@ + +(require-library "stringu.ss") + +(invoke-open-unit/sig mzlib:string@ #f) + diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss new file mode 100644 index 0000000..11676a6 --- /dev/null +++ b/collects/mzlib/unitsig.ss @@ -0,0 +1,2 @@ + +;; Obsolete