From 65f188723afa8217ab9a87098ed501d7e56583a2 Mon Sep 17 00:00:00 2001 From: Guillaume Marceau Date: Mon, 3 Apr 2006 05:53:25 +0000 Subject: [PATCH] trimmed base.ss svn: r2578 --- .../demos/dijkstra/heap-speed-mztake.ss | 9 + collects/mztake/demos/dijkstra/heap.ss | 14 +- collects/mztake/engine.ss | 9 +- collects/mztake/more-useful-code.ss | 259 +----------------- collects/mztake/mztake-structs.ss | 1 + collects/mztake/mztake.ss | 30 +- 6 files changed, 38 insertions(+), 284 deletions(-) create mode 100644 collects/mztake/demos/dijkstra/heap-speed-mztake.ss diff --git a/collects/mztake/demos/dijkstra/heap-speed-mztake.ss b/collects/mztake/demos/dijkstra/heap-speed-mztake.ss new file mode 100644 index 0000000000..fe0c44639d --- /dev/null +++ b/collects/mztake/demos/dijkstra/heap-speed-mztake.ss @@ -0,0 +1,9 @@ +(require (lib "mztake.ss" "mztake")) +(set-main! "heap.ss") + +(define start (current-milliseconds)) +(set-running! #t) +(exited?) +(- (hold (map-e (lambda (e) (current-milliseconds)) + (changes (exited?)))) start) + diff --git a/collects/mztake/demos/dijkstra/heap.ss b/collects/mztake/demos/dijkstra/heap.ss index 8665cd9e4c..89fea19f45 100644 --- a/collects/mztake/demos/dijkstra/heap.ss +++ b/collects/mztake/demos/dijkstra/heap.ss @@ -1,13 +1,12 @@ (module heap mzscheme (require (lib "etc.ss") - "base-gm.ss" - "dv.ss") + "dv.ss") (provide make-heap heap-empty? heap-size heap-insert heap-pop heap-peak heap-remove heap-find - heap-contains heap-resort heap-tostring) + heap-contains heap-resort) @@ -121,14 +120,7 @@ (heap-remove heap item) (heap-insert heap item)) - (define (heap-tostring heap . fns) - (let* ((data (t-data heap)) - (data-list (let loop ((i 1)) - (if (> i (heap-last heap)) empty - (cons (dv:ref data i) (loop (+ i 1))))))) - - (string-append "heap: sz " (number->string (heap-size heap)) ", " - (apply to-string (cons data-list fns))))) + (define (test) (define f (make-heap > eq?)) diff --git a/collects/mztake/engine.ss b/collects/mztake/engine.ss index 6c7d3e1644..d703bd40ef 100644 --- a/collects/mztake/engine.ss +++ b/collects/mztake/engine.ss @@ -1,5 +1,7 @@ (module engine mzscheme (require "marks.ss" + (lib "etc.ss") + (lib "list.ss") (prefix frp: (lib "lang-ext.ss" "frtime")) (rename (lib "frp-core.ss" "frtime") frp:signal-thunk signal-thunk) @@ -162,6 +164,7 @@ (let* ([t (first traces)] [e (apply (trace-struct-thunk t) vals)]) (frp:send-synchronous-event (trace-struct-evnt-rcvr t) e))] + [no-traces? (void)] [else (frp:send-synchronous-events (traces->events traces vals))]) ;; With a where event to generate @@ -211,8 +214,10 @@ (cons (first lst) (head (rest lst) (sub1 n))))) (define (dir-contains? dir filename) - (let ([dir-lst (unbuild-path dir)]) - (equal? dir-lst (head (unbuild-path filename) (length dir-lst))))) + (let ([dir-lst (unbuild-path dir)] + [file-lst (unbuild-path filename)]) + (and (< (length dir-lst) (length file-lst)) + (equal? dir-lst (head file-lst (length dir-lst)))))) (define (map-policy-tag tag) (cond [(eq? tag 'fast) false] diff --git a/collects/mztake/more-useful-code.ss b/collects/mztake/more-useful-code.ss index 9b20adb31d..428d84828e 100644 --- a/collects/mztake/more-useful-code.ss +++ b/collects/mztake/more-useful-code.ss @@ -1,31 +1,8 @@ (module more-useful-code mzscheme (require (lib "list.ss") - (lib "pretty.ss") (lib "etc.ss")) - (require-for-syntax (lib "list.ss")) - - (provide assert - cons-to-end - assoc-get - debug - debug-x - make-to-string - make-debug - to-string - member-eq? - string->char - last - member-str? - quicksort-vector! - struct->list/deep - make-for-each - begin0/rtn - with-handlers/finally - pretty-print-syntax - with-semaphore - - make-hash + (provide make-hash hash? hash-get hash-put! @@ -40,241 +17,9 @@ hash-values hash-pairs hash-add-all! - hash-get-or-define! - - (all-from (lib "list.ss")) - (all-from (lib "etc.ss"))) - - (define-struct (exn:assert exn) ()) - - (define-syntax (assert stx) - (syntax-case stx () - [(src-assert bool) #'(src-assert bool "")] - [(src-assert bool msg ...) - (with-syntax ([src-text (datum->syntax-object - (syntax src-assert) - (format "~a:~a:~a: assertion failed: " - (syntax-source (syntax bool)) - (syntax-line (syntax bool)) - (syntax-column (syntax bool))))]) - #'(unless bool - (raise (make-exn:assert (apply string-append - (cons src-text - (map (lambda (item) - (string-append (to-string item) " ")) - (list msg ...)))) - (current-continuation-marks)))))])) - - (define-syntax (begin0/rtn stx) - (syntax-case stx () - [(begin0/rtn body bodies ...) - (with-syntax ([rtn (datum->syntax-object (syntax begin0/rtn) 'rtn)]) - (syntax (let ([rtn body]) bodies ... rtn)))])) - - (define-syntax with-handlers/finally - (syntax-rules () - [(_ (handler ...) body finally) - (let ([finally-fn (lambda () finally)]) - (begin0 - (with-handlers - (handler ... - [(lambda (exn) #t) - (lambda (exn) (finally-fn) (raise exn))]) - body) - (finally-fn)))])) - - (define (make-for-each . iterator-fns) - (lambda (obj fn) - (cond ((list? obj) (for-each fn obj)) - ((vector? obj) (let loop ((x 0)) - (if (< x (vector-length obj)) - (begin (fn (vector-ref obj x)) (loop (+ x 1)))))) - ((hash-table? obj) (hash-for-each obj (lambda (key val) (fn key)))) - (true (let loop ((cur iterator-fns)) - (if (empty? cur) - (if (struct? obj) (error "for-each: no iterator for struct `" (struct-name obj) "' value:" obj) - (error "for-each: no iterator for value:" obj)) - (or ((first cur) obj fn) - (loop (rest cur))))))))) - - - (define (quicksort-vector! v less-than) - (let ([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))))))))) - v) + hash-get-or-define!) - - (define (member-str? s ls) - (cond - ((empty? ls) false) - ((string=? s (first ls)) true) - (else (member-str? s (rest ls))))) - - (define (last ls) - (cond - ((empty? ls) (error "took a last but it was emptry")) - ((empty? (rest ls)) (first ls)) - (else (last (rest ls))))) - - (define (string->char s) - (first (string->list s))) - - (define (member-eq? x ls) - (not (empty? (filter (lambda (y) (eq? x y)) ls)))) - - (define (to-string arg . extra-printers) - (let ([on-stack-ids (make-hash)] - [used-ids (make-hash)] - [free-id 0]) - (let loop ((arg arg)) - (if (hash-mem? on-stack-ids arg) - (begin - (hash-put! used-ids arg true) - (format "#~a#" (hash-get on-stack-ids arg))) - (let ([my-id free-id]) - (hash-put! on-stack-ids arg my-id) - (set! free-id (add1 free-id)) - (let ([result - (or - (let printer-loop ([printers extra-printers]) - (if (empty? printers) - false - (or (if (procedure-arity-includes? (car printers) 2) - ((car printers) arg (lambda (arg) (apply to-string (cons arg extra-printers)))) - ((car printers) arg)) - (printer-loop (cdr printers))))) - (cond - [(not arg) "#f"] - [(void? arg) "#"] - [(eq? arg #t) "#t"] - [(char? arg) (list->string (list arg))] - [(string? arg) (format "\"~a\"" arg)] - [(symbol? arg) (symbol->string arg)] - [(number? arg) (number->string arg)] - [(vector? arg) (string-append "#" (loop (vector->list arg)))] - [(box? arg) (string-append "#&" (loop (unbox arg)))] - [(empty? arg) "empty"] - [(list? arg) - (apply - string-append - `("(" ,@(cons (loop (first arg)) - (map (lambda (item) (string-append " " (loop item))) (rest arg))) - ")"))] - [(cons? arg) (format "(~a . ~a)" - (loop (first arg)) - (loop (rest arg)))] - - [(hash-table? arg) - (apply - string-append - `("[hash:" - ,@(map (lambda (item) (string-append " " (loop item))) (hash-pairs arg)) - "]"))] - - [(syntax? arg) - (format "[syntax: ~a:~a]" (syntax-line arg) (syntax-column arg))] - - [(struct? arg) - (let ([as-list (vector->list (struct->vector arg))]) - (apply - string-append - `("[" ,@(cons (loop (first as-list)) - (map (lambda (item) (string-append " " (loop item))) - (rest as-list))) "]")))] - - [else - (format "~a" arg)]))]) - (hash-remove! on-stack-ids arg) - (if (hash-mem? used-ids arg) - (format "#~a=~a" my-id result) - result))))))) - - (define-syntax (debug-x stx) - (syntax-case stx () - [(_ rest ... expr) - #`(let ([result expr]) - (printf "~a:~a ~a: ~a ~a~n" - #,(syntax-line stx) - #,(syntax-column stx) - '#,(if (syntax->list #'expr) - (syntax-e (first (syntax->list #'expr))) - (syntax-e #'expr)) - result - (list rest ...)) - result)])) - - ;; make-debug: usage example: (define debug-f (make-debug (make-to-string `([,is-type? ,type-to-string])))) - ;; The printers have to take two arguments: the item to converts and the to-string function for subitems - (define (make-debug to-string-fn) - (lambda args - (for-each (lambda (x) - (display (if (string? x) x (to-string-fn x))) - (display " ")) - args) - (newline))) - - (define debug (make-debug to-string)) - - (define (make-to-string predicate-printer-pairs) - (let ([printers (map (lambda (pair) (lambda (arg printer) - (cond [(not ((first pair) arg)) false] - [(procedure-arity-includes? (second pair) 2) - ((second pair) arg printer)] - [else ((second pair) arg)]))) - predicate-printer-pairs)]) - (case-lambda - [(arg) (apply to-string arg printers)] - [(arg extra-printers) (apply to-string (append (list arg) printers extra-printers))]))) - - (define (assoc-get label ls) - (cond - ((empty? ls) (error (string-append "failed to find " (to-string label)))) - ((eq? label (first (first ls))) - (first ls)) - (else (assoc-get label (rest ls))))) - - (define (cons-to-end a ls) - (cond - ((empty? ls) (cons a ls)) - (else (cons (first ls) - (cons-to-end a (rest ls)))))) - - (define (struct->list/deep item) - (cond [(struct? item) (map struct->list/deep (vector->list (struct->vector item)))] - [(list? item) (map struct->list/deep item)] - [(vector? item) (list->vector (map struct->list/deep (vector->list item)))] - [else item])) - - (define (struct-name s) (vector-ref (struct->vector s) 0)) - - (define (pretty-print-syntax width stx) - (pretty-print-columns width) - (pretty-print (syntax-object->datum stx))) - - (define (with-semaphore sem proc) - (semaphore-wait sem) - (let ([result (proc)]) - (semaphore-post sem) - result)) - (define make-hash make-hash-table) (define hash? hash-table?) (define hash-get hash-table-get) diff --git a/collects/mztake/mztake-structs.ss b/collects/mztake/mztake-structs.ss index 4baf96fa7c..c0fc4ae21d 100644 --- a/collects/mztake/mztake-structs.ss +++ b/collects/mztake/mztake-structs.ss @@ -1,5 +1,6 @@ (module mztake-structs mzscheme (require (lib "match.ss") + (lib "etc.ss") (lib "more-useful-code.ss" "mztake")) (provide (all-defined)) diff --git a/collects/mztake/mztake.ss b/collects/mztake/mztake.ss index f48fcff90d..3bfed60c86 100644 --- a/collects/mztake/mztake.ss +++ b/collects/mztake/mztake.ss @@ -111,14 +111,16 @@ [(_ loc body ...) (trace* (current-process) loc (lambda () body ...))])) - (define (mztake-top* name thunk ) - (with-handlers - ([exn:fail? - (lambda (exn) - (with-handlers - ([exn:fail? (lambda (exn2) (raise exn))]) - (bind* (current-process) name)))]) - (thunk))) + (define (mztake-top* name thunk) + (if (debug-process-marks (current-process)) + (with-handlers + ([exn:fail? + (lambda (exn) + (with-handlers + ([exn:fail? (lambda (exn2) (raise exn2))]) + (bind* (current-process) name)))]) + (thunk)) + (thunk))) (define-syntax (mztake-top stx) (syntax-case stx () @@ -127,12 +129,12 @@ (define (lookup-in-top-level p name) (let/ec success - (for-each - (lambda (m) - (let/ec fail - (let ([fail* (lambda () (fail false))]) - (success (hash-get (hash-get (debug-process-top-level p) m fail*) name fail*))))) - (map mark-module-name (debug-process-marks p))) + (define (try m) + (let/ec fail + (define (fail*) (fail false)) + (success (hash-get (hash-get (debug-process-top-level p) m fail*) name fail*)))) + (for-each try (map mark-module-name (debug-process-marks p))) + (hash-for-each (debug-process-top-level p) (lambda (m ns) (try m))) (error 'bind "variable `~a' not found in target at the current location" name))) (define (bind* p name)