This commit was manufactured by cvs2git to create branch 'countdown'.
Sprout from master 1997-10-15 16:43:43 UTC Robby Findler <robby@racket-lang.org> 'Initial revision'
Cherrypick from master 1997-10-15 16:52:54 UTC Robby Findler <robby@racket-lang.org> '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
This commit is contained in:
cvs2git
parent
81b5e77831
commit
8ce8d72fe9
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
@ -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?)
|
||||
)
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
|
||||
|
||||
(require-library "inflateu.ss")
|
||||
|
||||
(invoke-open-unit/sig mzlib:inflate@ #f)
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,5 +0,0 @@
|
|||
|
||||
(require-library "prettyu.ss")
|
||||
|
||||
(invoke-open-unit/sig mzlib:pretty-print@ #f)
|
||||
|
||||
|
|
@ -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))))))))
|
||||
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
|
||||
(require-library "stringu.ss")
|
||||
|
||||
(invoke-open-unit/sig mzlib:string@ #f)
|
||||
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
|
||||
|
||||
(require-library "threadu.ss")
|
||||
|
||||
(invoke-open-unit/sig mzlib:thread@ #f)
|
||||
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
|
||||
;; Obsolete
|
||||
Loading…
Reference in New Issue
Block a user