From 5f82d4f74e62b570a5d282acabf92285328499a4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 4 Dec 1997 21:33:56 +0000 Subject: [PATCH] release original commit: 4b4c42956c48426afdeb8a73e47c2d4970a7e6d4 --- collects/mzlib/awk.ss | 179 +------------------------------------ collects/mzlib/functior.ss | 19 ++++ collects/mzlib/traceld.ss | 30 +++---- 3 files changed, 33 insertions(+), 195 deletions(-) diff --git a/collects/mzlib/awk.ss b/collects/mzlib/awk.ss index d130a90..1b8e55d 100644 --- a/collects/mzlib/awk.ss +++ b/collects/mzlib/awk.ss @@ -1,183 +1,6 @@ (reference-library "refer.ss") -(begin-elaboration-time -(invoke-open-unit - (unit - (import) - (export awk match:start match:end match:substring regexp-exec) +(begin-elaboration-time (invoke-open-unit (reference "awkr.ss"))) - (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/functior.ss b/collects/mzlib/functior.ss index 8dadffe..f13a406 100644 --- a/collects/mzlib/functior.ss +++ b/collects/mzlib/functior.ss @@ -83,6 +83,25 @@ (lambda (item list) (remove item list eqv?)))) + (define remove* + (polymorphic + (case-lambda + [(l r equal?) + (if (null? l) + r + (remove* (cdr l) (remove (car l) r equal?)))] + [(l r) (remove* l r equal?)]))) + + (define remq* + (polymorphic + (lambda (l r) + (remove* l r eq?)))) + + (define remv* + (polymorphic + (lambda (l r) + (remove* l r eqv?)))) + (define dynamic-disable-break (polymorphic (lambda (thunk) diff --git a/collects/mzlib/traceld.ss b/collects/mzlib/traceld.ss index 512563f..cdca246 100644 --- a/collects/mzlib/traceld.ss +++ b/collects/mzlib/traceld.ss @@ -1,10 +1,4 @@ -(define-macro time - (lambda (expr) - `(begin0 - ,expr - (fprintf (current-output-port) "done ~a~n" (current-process-milliseconds))))) - (let ([load (current-load)] [load-extension (current-load-extension)] [tab ""]) @@ -12,32 +6,34 @@ (lambda (load) (lambda (filename) (fprintf (current-error-port) - "~aloading ~a~n" - tab filename) + "~aloading ~a at ~a~n" + tab filename (current-process-milliseconds)) (begin0 (let ([s tab]) (dynamic-wind (lambda () (set! tab (string-append " " tab))) (lambda () (if (regexp-match "_loader" filename) - (let ([f (time (load filename))]) + (let ([f (load filename)]) (lambda (sym) (fprintf (current-error-port) "~atrying ~a~n" tab sym) - (let ([loader (time (f sym))]) + (let ([loader (f sym)]) (and loader (lambda () (fprintf (current-error-port) - "~astarting ~a~n" tab sym) + "~astarting ~a at ~a~n" tab sym + (current-process-milliseconds)) (begin0 - (time (loader)) + (loader) (fprintf (current-error-port) - "~adone ~a~n" - tab sym))))))) - (time (load filename)))) + "~adone ~a at ~a~n" + tab sym + (current-process-milliseconds)))))))) + (load filename))) (lambda () (set! tab s)))) (fprintf (current-error-port) - "~adone ~a~n" - tab filename))))]) + "~adone ~a at ~a~n" + tab filename (current-process-milliseconds)))))]) (current-load (mk-chain load)) (current-load-extension (mk-chain load-extension))))