From 8ce8d72fe93816f71f9fa89ace67e51ad5d1ce34 Mon Sep 17 00:00:00 2001 From: cvs2git Date: Wed, 15 Oct 1997 16:52:55 +0000 Subject: [PATCH] This commit was manufactured by cvs2git to create branch 'countdown'. Sprout from master 1997-10-15 16:43:43 UTC Robby Findler 'Initial revision' Cherrypick from master 1997-10-15 16:52:54 UTC Robby Findler 'Initial revision': collects/countdwn/README Delete: collects/backward/sparamr.ss collects/backward/sparams.ss collects/cogen/ariesr.ss collects/cogen/ariess.ss collects/drscheme-jr/drscheme-jr.el collects/drscheme-jr/drscheme-jr.elc collects/drscheme-jr/drscheme-jr.ss collects/drscheme-jr/openbugs collects/drscheme/app.ss collects/drscheme/basis.ss collects/drscheme/cunit.ss collects/drscheme/donkstub.ss collects/drscheme/drsig.ss collects/drscheme/edit.ss collects/drscheme/export.ss collects/drscheme/face.ss collects/drscheme/frame.ss collects/drscheme/history collects/drscheme/icons.ss collects/drscheme/info.ss collects/drscheme/init.ss collects/drscheme/intrface.ss collects/drscheme/language.ss collects/drscheme/link.ss collects/drscheme/main.ss collects/drscheme/openbugs collects/drscheme/params.ss collects/drscheme/phooks.ss collects/drscheme/prefs.ss collects/drscheme/prog.ss collects/drscheme/rep.ss collects/drscheme/setup.ss collects/drscheme/sig.ss collects/drscheme/snip.ss collects/drscheme/spidstub.ss collects/drscheme/tool.ss collects/drscheme/tools/analysis/unit.ss collects/drscheme/tools/debug/unit.ss collects/drscheme/tools/syncheck/unit.ss collects/drscheme/toy.ss collects/drscheme/unit.ss collects/drscheme/zlink.ss collects/drscheme/zodiac.ss collects/graphics/TREADME collects/graphics/graphic.ss collects/graphics/graphicr.ss collects/graphics/graphics.ss collects/graphics/graphicu.ss collects/graphics/turex.ss collects/graphics/turtle.ss collects/graphics/turtler.ss collects/graphics/turtles.ss collects/graphics/turtlmr.ss collects/gusrspce/gusrspcr.ss collects/gusrspce/gusrspcs.ss collects/hierarchy/classr.ss collects/hierarchy/hierr.ss collects/hierarchy/m3r.ss collects/hierarchy/unitr.ss collects/hierlist/doc.txt collects/hierlist/hierlist.ss collects/hierlist/hierlistr.ss collects/hierlist/hierlists.ss collects/mred/autoload.ss collects/mred/autosave.ss collects/mred/canvas.ss collects/mred/connect.ss collects/mred/console.ss collects/mred/constant.ss collects/mred/containr.ss collects/mred/contfram.ss collects/mred/contkids.ss collects/mred/contpanl.ss collects/mred/cparens.ss collects/mred/cppmode.ss collects/mred/edframe.ss collects/mred/edit.ss collects/mred/exit.ss collects/mred/exn.ss collects/mred/fileutil.ss collects/mred/finder.ss collects/mred/findstr.ss collects/mred/frame.ss collects/mred/graph.ss collects/mred/group.ss collects/mred/guiutils.ss collects/mred/html.ss collects/mred/hyper.ss collects/mred/hypersig.ss collects/mred/hyprdial.ss collects/mred/hypredit.ss collects/mred/hyprfram.ss collects/mred/icon.ss collects/mred/keys.ss collects/mred/link.ss collects/mred/mcache.ss collects/mred/menu.ss collects/mred/mode.ss collects/mred/panel.ss collects/mred/paren.ss collects/mred/prefs.ss collects/mred/project.ss collects/mred/sig.ss collects/mred/sparen.ss collects/mred/ssmode.ss collects/mred/stdrs.ss collects/mred/stlink.ss collects/mred/stprims.ss collects/mred/strun.ss collects/mred/stsigs.ss collects/mred/testable.ss collects/mred/url.ss collects/mred/version.ss collects/mred/wxr.ss collects/mred/wxs.ss collects/mzlib/awk.ss collects/mzlib/awkc.ss collects/mzlib/compat.ss collects/mzlib/compatc.ss collects/mzlib/compatr.ss collects/mzlib/compats.ss collects/mzlib/compatu.ss collects/mzlib/compile.ss collects/mzlib/compilec.ss collects/mzlib/compiler.ss collects/mzlib/compiles.ss collects/mzlib/compileu.ss collects/mzlib/constan.ss collects/mzlib/constanc.ss collects/mzlib/constant.ss collects/mzlib/core.ss collects/mzlib/corec.ss collects/mzlib/corer.ss collects/mzlib/cores.ss collects/mzlib/coreu.ss collects/mzlib/date.ss collects/mzlib/datec.ss collects/mzlib/dater.ss collects/mzlib/dates.ss collects/mzlib/dateu.ss collects/mzlib/defstru.ss collects/mzlib/defstruc.ss collects/mzlib/file.ss collects/mzlib/filec.ss collects/mzlib/filer.ss collects/mzlib/files.ss collects/mzlib/fileu.ss collects/mzlib/functio.ss collects/mzlib/functioc.ss collects/mzlib/function.ss collects/mzlib/functior.ss collects/mzlib/functios.ss collects/mzlib/functiou.ss collects/mzlib/inflate.ss collects/mzlib/inflatec.ss collects/mzlib/inflater.ss collects/mzlib/inflates.ss collects/mzlib/inflateu.ss collects/mzlib/letplsrc.ss collects/mzlib/letplus.ss collects/mzlib/macro.ss collects/mzlib/macroc.ss collects/mzlib/macrox.ss collects/mzlib/match.ss collects/mzlib/matchc.ss collects/mzlib/mzlib.ss collects/mzlib/mzlibc.ss collects/mzlib/mzlibr.ss collects/mzlib/mzlibs.ss collects/mzlib/mzlibu.ss collects/mzlib/pconver.ss collects/mzlib/pconverc.ss collects/mzlib/pconverr.ss collects/mzlib/pconvers.ss collects/mzlib/pconvert.ss collects/mzlib/pconveru.ss collects/mzlib/pretty.ss collects/mzlib/prettyc.ss collects/mzlib/prettyr.ss collects/mzlib/prettys.ss collects/mzlib/prettyu.ss collects/mzlib/refer.ss collects/mzlib/referc.ss collects/mzlib/referf.ss collects/mzlib/sfunctor.ss collects/mzlib/shared.ss collects/mzlib/sharedc.ss collects/mzlib/spidey.ss collects/mzlib/spideyc.ss collects/mzlib/string.ss collects/mzlib/stringc.ss collects/mzlib/stringr.ss collects/mzlib/strings.ss collects/mzlib/stringu.ss collects/mzlib/synrule.ss collects/mzlib/synrulec.ss collects/mzlib/thread.ss collects/mzlib/threadc.ss collects/mzlib/threadr.ss collects/mzlib/threads.ss collects/mzlib/threadu.ss collects/mzlib/trace.ss collects/mzlib/tracec.ss collects/mzlib/trigger.ss collects/mzlib/triggerc.ss collects/mzlib/triggerr.ss collects/mzlib/triggers.ss collects/mzlib/triggeru.ss collects/mzlib/unitsig.ss collects/mzlib/unitsigc.ss collects/mzlib/zmath.ss collects/mzlib/zmathc.ss collects/mzlib/zmathr.ss collects/mzlib/zmaths.ss collects/mzlib/zmathu.ss collects/net/cgi.ss collects/net/cgir.ss collects/net/cgis.ss collects/net/cgiu.ss collects/net/nntp.sd collects/net/nntp.ss collects/net/nntpr.ss collects/net/nntps.ss collects/net/nntpu.ss collects/system/app.ss collects/system/compsys.ss collects/system/debug.ss collects/system/history collects/system/info.ss collects/system/invoke.ss collects/system/noconsle.ss collects/system/nuapp.ss collects/system/openbugs collects/system/splash.ss collects/system/system.ss collects/system/timesys.ss collects/tests/mred/sixlib.ss collects/userspce/paramr.ss collects/userspce/ricedef.ss collects/userspce/ricedefr.ss collects/userspce/ricedefs.ss collects/userspce/userspcr.ss collects/userspce/userspcs.ss collects/zodiac/back.ss collects/zodiac/basestr.ss collects/zodiac/corelate.ss collects/zodiac/invoke.ss collects/zodiac/link.ss collects/zodiac/load.ss collects/zodiac/make.ss collects/zodiac/misc.ss collects/zodiac/namedarg.ss collects/zodiac/pattern.ss collects/zodiac/qq.ss collects/zodiac/quasi.ss collects/zodiac/reader.ss collects/zodiac/readstr.ss collects/zodiac/scanner.ss collects/zodiac/scanparm.ss collects/zodiac/scanstr.ss collects/zodiac/scm-core.ss collects/zodiac/scm-hanc.ss collects/zodiac/scm-main.ss collects/zodiac/scm-obj.ss collects/zodiac/scm-ou.ss collects/zodiac/scm-spdy.ss collects/zodiac/scm-unit.ss collects/zodiac/sexp.ss collects/zodiac/sigs.ss collects/zodiac/x.ss collects/zodiac/zsigs.ss man/man1/DrScheme.1 man/man1/drscheme.1 man/man1/mred.1 man/man1/mzscheme.1 tests/mred/sixlib.ss original commit: 96b3c4f6aa05997ef10ca7fe72ce11ea011cd352 --- collects/mzlib/awk.ss | 183 ---- collects/mzlib/compat.ss | 11 - collects/mzlib/date.ss | 13 - collects/mzlib/file.ss | 13 - collects/mzlib/functior.ss | 263 ----- collects/mzlib/inflate.ss | 7 - collects/mzlib/match.ss | 1949 ------------------------------------ collects/mzlib/pretty.ss | 5 - collects/mzlib/shared.ss | 141 --- collects/mzlib/string.ss | 5 - collects/mzlib/thread.ss | 7 - collects/mzlib/trace.ss | 266 ----- collects/mzlib/unitsig.ss | 2 - 13 files changed, 2865 deletions(-) delete mode 100644 collects/mzlib/awk.ss delete mode 100644 collects/mzlib/compat.ss delete mode 100644 collects/mzlib/date.ss delete mode 100644 collects/mzlib/file.ss delete mode 100644 collects/mzlib/functior.ss delete mode 100644 collects/mzlib/inflate.ss delete mode 100644 collects/mzlib/match.ss delete mode 100644 collects/mzlib/pretty.ss delete mode 100644 collects/mzlib/shared.ss delete mode 100644 collects/mzlib/string.ss delete mode 100644 collects/mzlib/thread.ss delete mode 100644 collects/mzlib/trace.ss delete mode 100644 collects/mzlib/unitsig.ss diff --git a/collects/mzlib/awk.ss b/collects/mzlib/awk.ss deleted file mode 100644 index d130a90..0000000 --- a/collects/mzlib/awk.ss +++ /dev/null @@ -1,183 +0,0 @@ - -(reference-library "refer.ss") - -(begin-elaboration-time -(invoke-open-unit - (unit - (import) - (export awk match:start match:end match:substring regexp-exec) - - (define awk - (lambda (get-next-record . rest) - (let*-values ([(user-fields rest) (values (car rest) (cdr rest))] - [(counter rest) (if (and (pair? rest) (symbol? (car rest))) - (values (car rest) (cdr rest)) - (values (gensym) rest))] - [(user-state-var-decls rest) (values (car rest) (cdr rest))] - [(continue rest) (if (and (pair? rest) (symbol? (car rest))) - (values (car rest) (cdr rest)) - (values (gensym) rest))] - [(user-state-vars) (map car user-state-var-decls)] - [(local-user-state-vars) (map gensym user-state-vars)] - [(first) (car user-fields)] - [(clauses) rest] - [(loop) (gensym)] - [(remainder) (gensym)] - [(extras) (gensym)] - [(arg) (gensym)] - [(else-ready?) (gensym)] - [(orig-on?) (gensym)] - [(post-on-on?) (gensym)] - [(escape) (gensym)] - [(initvars) null]) - (letrec ([get-after-clauses - (lambda () - (let loop ([l clauses][afters null]) - (cond - [(null? l) (if (null? afters) - `((values ,@user-state-vars)) - afters)] - [(eq? (caar l) 'after) - (loop (cdr l) (append afters (cdar l)))] - [else - (loop (cdr l) afters)])))] - [wrap-state - (lambda (e) - (if (eq? (car e) '=>) - `(=> - (lambda (,arg) - ,@(wrap-state `((,(cadr e) ,arg))))) - `((call-with-values - (lambda () ,@e) - (lambda ,(append local-user-state-vars extras) - (set! ,else-ready? #f) - (set!-values ,user-state-vars - (values ,@local-user-state-vars)))))))] - [make-range - (lambda (include-on? include-off? body rest) - (let* ([on? (gensym)]) - (set! initvars (cons `(,on? #f) initvars)) - (cons - `(let ([,orig-on? ,on?]) - (unless ,on? (set! ,on? ,(make-test (car body)))) - (let ([,post-on-on? ,on?]) - (when ,on? (set! ,on? (not ,(make-test (cadr body))))) - (when ,(if include-on? - (if include-off? - post-on-on? - on?) - (if include-off? - orig-on? - `(and ,orig-on? ,on?))) - ,@(wrap-state (cddr body))))) - rest)))] - [make-test - (lambda (test) - (cond - [(string? test) - (let ([g (gensym)]) - (set! initvars (cons `(,g (regexp ,test)) initvars)) - `(regexp-exec ,g ,first))] - [(number? test) - `(= ,test ,counter)] - [else test]))] - [get-testing-clauses - (lambda () - (let loop ([l clauses]) - (if (null? l) - null - (let* ([clause (car l)] - [test (car clause)] - [body (cdr clause)] - [rest (loop (cdr l))]) - (cond - [(or (string? test) (number? test)) - (cons - `(cond [,(make-test test) - ,@(wrap-state body)] - [else (void)]) - rest)] - [(eq? test 'else) - (cons - `(when ,else-ready? - ,@(wrap-state body)) - (cons - `(set! ,else-ready? #t) - rest))] - [(eq? test 'range) - (make-range #f #f body rest)] - [(eq? test ':range) - (make-range #t #f body rest)] - [(eq? test 'range:) - (make-range #f #t body rest)] - [(eq? test ':range:) - (make-range #t #t body rest)] - [(eq? test 'after) - rest] - [(eq? test '/) - (let ([g (gensym)] - [re (car body)] - [vars (append (map (lambda (s) - (or s (gensym))) - (caddr body)) - (gensym))] - [body (cdddr body)]) - (set! initvars (cons `(,g (regexp ,re)) initvars)) - (cons - `(cond - [(regexp-match ,re ,first) - => (lambda (,arg) - (apply - (lambda ,vars ,@(wrap-state body)) - ,arg))] - [else (void)]) - rest))] - [else - (cons - `(cond (,test ,@(wrap-state body)) (else (void))) - rest)])))))]) - (let ([testing-clauses (get-testing-clauses)]) - `(let (,@user-state-var-decls ,@initvars) - (let ,loop ([,counter 1]) - (call-with-values - (lambda () ,get-next-record) - (lambda ,user-fields - (if (eof-object? ,first) - (begin - ,@(get-after-clauses)) - (let ([,else-ready? #t]) - (let/ec ,escape - (let ([,continue - (lambda ,(append local-user-state-vars extras) - (set!-values ,user-state-vars - (values ,@local-user-state-vars)) - (,escape))]) - ,@testing-clauses)) - (,loop (add1 ,counter))))))))))))) - - (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))))))) - -(define-macro awk awk) diff --git a/collects/mzlib/compat.ss b/collects/mzlib/compat.ss deleted file mode 100644 index 2e2533d..0000000 --- a/collects/mzlib/compat.ss +++ /dev/null @@ -1,11 +0,0 @@ - -(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 deleted file mode 100644 index 1c4b43e..0000000 --- a/collects/mzlib/date.ss +++ /dev/null @@ -1,13 +0,0 @@ - -(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 deleted file mode 100644 index df44498..0000000 --- a/collects/mzlib/file.ss +++ /dev/null @@ -1,13 +0,0 @@ - -(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 deleted file mode 100644 index 8dadffe..0000000 --- a/collects/mzlib/functior.ss +++ /dev/null @@ -1,263 +0,0 @@ -(unit/sig - mzlib:function^ - (import) - - (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) - (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 l . ls) (fold-n f init (cons l 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 l . ls) (fold-n f init (cons l ls))])))) - - (define first (polymorphic (lambda (x) - (unless (pair? x) - (raise-type-error 'first "non-empty list" x)) - (car x)))) - (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 rest (polymorphic (lambda (x) - (unless (pair? x) - (raise-type-error 'rest "non-empty list" x)) - (cdr x)))) - - (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 deleted file mode 100644 index b627b5b..0000000 --- a/collects/mzlib/inflate.ss +++ /dev/null @@ -1,7 +0,0 @@ - - -(require-library "inflateu.ss") - -(invoke-open-unit/sig mzlib:inflate@ #f) - - diff --git a/collects/mzlib/match.ss b/collects/mzlib/match.ss deleted file mode 100644 index 868a6a7..0000000 --- a/collects/mzlib/match.ss +++ /dev/null @@ -1,1949 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; 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 (and (not (null? rpl)) -(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/ec -(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 deleted file mode 100644 index 7574216..0000000 --- a/collects/mzlib/pretty.ss +++ /dev/null @@ -1,5 +0,0 @@ - -(require-library "prettyu.ss") - -(invoke-open-unit/sig mzlib:pretty-print@ #f) - diff --git a/collects/mzlib/shared.ss b/collects/mzlib/shared.ss deleted file mode 100644 index 16b268c..0000000 --- a/collects/mzlib/shared.ss +++ /dev/null @@ -1,141 +0,0 @@ - -(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 deleted file mode 100644 index 78dfb34..0000000 --- a/collects/mzlib/string.ss +++ /dev/null @@ -1,5 +0,0 @@ - -(require-library "stringu.ss") - -(invoke-open-unit/sig mzlib:string@ #f) - diff --git a/collects/mzlib/thread.ss b/collects/mzlib/thread.ss deleted file mode 100644 index 5c7f93e..0000000 --- a/collects/mzlib/thread.ss +++ /dev/null @@ -1,7 +0,0 @@ - - -(require-library "threadu.ss") - -(invoke-open-unit/sig mzlib:thread@ #f) - - diff --git a/collects/mzlib/trace.ss b/collects/mzlib/trace.ss deleted file mode 100644 index 0a2ee62..0000000 --- a/collects/mzlib/trace.ss +++ /dev/null @@ -1,266 +0,0 @@ -; Time-stamp: <97/08/19 15:07:32 shriram> -; Time-stamp: <97/07/12 12:44:01 shriram> - -; Differences from the Chez implementation: - -; - The code does not respect tail-calls. -; - If the library is loaded more than once, especially in the middle -; of a trace, the behavior is not well-defined. - -(define-signature mzlib:trace^ - (-:trace-level -:trace-print-args -:trace-print-results - -:trace-table - -:make-traced-entry -:traced-entry-original-proc -:traced-entry-trace-proc - trace untrace)) - -(reference-library "prettyu.ss") - -(define mzlib:trace@ - (unit/sig mzlib:trace^ - (import mzlib:pretty-print^) - -(define max-dash-space-depth 10) -(define number-nesting-depth 6) - -(define as-spaces - (lambda (s) - (let ((n (string-length s))) - (apply string-append - (let loop ((k n)) - (if (zero? k) '("") - (cons " " (loop (sub1 k))))))))) - -(define-struct prefix-entry (for-first for-rest)) - -(define prefixes (make-vector 20 #f)) -(define prefix-vector-length 20) - -(define lookup-prefix - (lambda (n) - (and (< n prefix-vector-length) - (vector-ref prefixes n)))) - -(define insert-prefix - (lambda (n first rest) - (if (>= n prefix-vector-length) - (let ((v (make-vector (* 2 prefix-vector-length) #f))) - (let loop ((k 0)) - (when (< k prefix-vector-length) - (vector-set! v k (vector-ref prefixes k)) - (loop (add1 k)))) - (set! prefixes v) - (set! prefix-vector-length (* 2 prefix-vector-length)) - (insert-prefix n first rest)) - (vector-set! prefixes n (make-prefix-entry first rest))))) - -(define construct-prefixes - (lambda (level) - (let loop ((n level) - (first '("|")) - (rest '(" "))) - (if (>= n max-dash-space-depth) - (let-values (((pre-first pre-rest) - (build-prefixes number-nesting-depth))) - (let ((s (number->string level))) - (values - (apply string-append - (cons pre-first (cons "[" (cons s (cons "]" '()))))) - (apply string-append - (cons pre-rest (cons " " (cons (as-spaces s) - (cons " " '())))))))) - (cond - ((= n 0) (values (apply string-append (reverse first)) - (apply string-append (reverse rest)))) - ((= n 1) (loop (- n 1) - (cons '" " first) - (cons '" " rest))) - (else (loop (- n 2) - (cons " |" first) - (cons " " rest)))))))) - -(define build-prefixes - (lambda (level) - (let ((p (lookup-prefix level))) - (if p - (values (prefix-entry-for-first p) - (prefix-entry-for-rest p)) - (let-values (((first rest) - (construct-prefixes level))) - (insert-prefix level first rest) - (values first rest)))))) - -(define -:trace-level -1) - -(define -:trace-print-args - (lambda (name args) - (let-values (((first rest) - (build-prefixes -:trace-level))) - (parameterize ((pretty-print-print-line - (lambda (n port offset width) - (display - (if n - (if (zero? n) first - (format "~n~a" rest)) - (format "~n")) - port) - (if n - (if (zero? n) - (string-length first) - (string-length rest)) - 0)))) - (pretty-print (cons name args)))))) - -(define -:trace-print-results - (lambda (name results) - (let-values (((first rest) - (build-prefixes -:trace-level))) - (parameterize ((pretty-print-print-line - (lambda (n port offset width) - (display - (if n - (if (zero? n) first - (format "~n~a" rest)) - (format "~n")) - port) - (if n - (if (zero? n) - (string-length first) - (string-length rest)) - 0)))) - (cond - ((null? results) - (pretty-display "*** no values ***")) - ((null? (cdr results)) - (pretty-print (car results))) - (else - (pretty-print (car results)) - (parameterize ((pretty-print-print-line - (lambda (n port offset width) - (display - (if n - (if (zero? n) rest - (format "~n~a" rest)) - (format "~n")) - port) - (if n - (string-length rest) - 0)))) - (for-each pretty-print (cdr results))))))))) - -(define-struct traced-entry (original-proc trace-proc)) - -(define -:make-traced-entry make-traced-entry) -(define -:traced-entry-original-proc traced-entry-original-proc) -(define -:traced-entry-trace-proc traced-entry-trace-proc) - -(define -:trace-table - (make-hash-table)) - -(define trace - (lambda ids - (let loop ((ids ids)) - (unless (null? ids) - (unless (symbol? (car ids)) - (error 'trace "~s not a name" (car ids))) - (loop (cdr ids)))) - `(#%begin - ,@(map - (lambda (id) - `(#%with-handlers ((#%exn:variable? - (#%lambda (exn) - (#%if (#%eq? (#%exn:variable-id exn) ',id) - (#%error 'trace - "~s is not bound" ',id) - (#%raise exn))))) - (#%let ((global (#%global-defined-value ',id))) - (#%unless (#%procedure? global) - (#%error 'trace - "the top-level value of ~s is not a procedure" ',id))))) - ids) - ,@(map - (lambda (id) - (let ((traced-name (string->symbol - (string-append "traced-" - (symbol->string id)))) - (table-entry (gensym 'table-entry)) - (real-value (gensym 'real-value)) - (global-value (gensym 'global-value))) - `(#%let ((,global-value (#%global-defined-value ',id))) - (#%let ((,table-entry (#%hash-table-get -:trace-table ',id - (#%lambda () #f)))) - (#%unless (#%and ,table-entry - (#%eq? ,global-value - (-:traced-entry-trace-proc ,table-entry))) - (#%let* ((,real-value ,global-value) - (,traced-name - (#%lambda args - (#%dynamic-wind - (lambda () - (#%set! -:trace-level - (#%add1 -:trace-level))) - (lambda () - (-:trace-print-args ',id args) - (#%call-with-values - (#%lambda () - (#%apply ,real-value args)) - (#%lambda results - (flush-output) - (-:trace-print-results ',id - results) - (#%apply #%values results)))) - (lambda () - (#%set! -:trace-level - (#%sub1 -:trace-level))))))) - (#%hash-table-put! -:trace-table ',id - (-:make-traced-entry ,real-value ,traced-name)) - (#%global-defined-value ',id ,traced-name))))))) - ids) - (#%quote ,ids)))) - -(define untrace - (lambda ids - (let loop ((ids ids)) - (unless (null? ids) - (unless (symbol? (car ids)) - (error 'untrace "~s not an identifier" (car ids))) - (loop (cdr ids))) - `(#%apply #%append - (#%list - ,@(map (lambda (id) - `(let ((entry (#%hash-table-get -:trace-table - ',id (#%lambda () #f)))) - (#%if (#%and entry - (#%eq? (#%global-defined-value ',id) - (-:traced-entry-trace-proc entry))) - (#%begin - (#%hash-table-put! -:trace-table - ',id #f) - (#%global-defined-value ',id - (-:traced-entry-original-proc entry)) - (#%list ',id)) - '()))) - ids)))))) - -)) - -(invoke-open-unit/sig - (compound-unit/sig - (import) - (link - (PRETTY : mzlib:pretty-print^ - (mzlib:pretty-print@)) - (TRACE : mzlib:trace^ - (mzlib:trace@ PRETTY))) - (export - (open TRACE))) - #f) - -(define-macro trace trace) -(define-macro untrace untrace) - -(keyword-name '-:trace-print-args) -(keyword-name '-:trace-print-results) -(keyword-name '-:trace-table) -(keyword-name '-:make-traced-entry) -(keyword-name '-:traced-entry-original-proc) -(keyword-name '-:traced-entry-trace-proc) diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss deleted file mode 100644 index 11676a6..0000000 --- a/collects/mzlib/unitsig.ss +++ /dev/null @@ -1,2 +0,0 @@ - -;; Obsolete