diff --git a/collects/macro-debugger/model/reductions-config.rkt b/collects/macro-debugger/model/reductions-config.rkt index cb3cfcb..283167a 100644 --- a/collects/macro-debugger/model/reductions-config.rkt +++ b/collects/macro-debugger/model/reductions-config.rkt @@ -286,11 +286,11 @@ ;; Only bad effect should be missed subterms (usually at phase1). (STRICT-CHECKS (fprintf (current-error-port) - "from:\n~e\n\nto:\n~e\n\n" + "from:\n~.s\n\nto:\n~.s\n\n" (stx->datum from) (stx->datum to)) (fprintf (current-error-port) - "original from:\n~e\n\noriginal to:\n~e\n\n" + "original from:\n~.s\n\noriginal to:\n~.s\n\n" (stx->datum from0) (stx->datum to0)) (error 'add-to-renames-table)) diff --git a/collects/macro-debugger/model/reductions-engine.rkt b/collects/macro-debugger/model/reductions-engine.rkt index f02f088..c51b318 100644 --- a/collects/macro-debugger/model/reductions-engine.rkt +++ b/collects/macro-debugger/model/reductions-engine.rkt @@ -289,9 +289,9 @@ [(R** f v p s ws [#:print-state msg] . more) #'(begin (printf "** ~s\n" msg) - (printf "f = ~e\n" (stx->datum f)) - (printf "v = ~e\n" (stx->datum v)) - (printf "s = ~e\n" (stx->datum s)) + (printf "f = ~.s\n" (stx->datum f)) + (printf "v = ~.s\n" (stx->datum v)) + (printf "s = ~.s\n" (stx->datum s)) (R** f v p s ws . more))] ;; ** Multi-pass reductions ** @@ -365,10 +365,10 @@ [fills fills-e]) (DEBUG (printf "Run (multi, vis=~s)\n" (visibility)) - (printf " f: ~e\n" (stx->datum f)) - (printf " v: ~e\n" (stx->datum v)) - (printf " p: ~e\n" 'p) - (printf " hole: ~e\n" '(hole :::)) + (printf " f: ~.s\n" (stx->datum f)) + (printf " v: ~.s\n" (stx->datum v)) + (printf " p: ~.s\n" 'p) + (printf " hole: ~.s\n" '(hole :::)) (print-viable-subterms v)) (if (visibility) (let ([vctx (CC (hole :::) v p)] @@ -381,10 +381,10 @@ [fctx (CC hole f p)]) (DEBUG (printf "Run (single, vis=~s)\n" (visibility)) - (printf " f: ~e\n" (stx->datum f)) - (printf " v: ~e\n" (stx->datum v)) - (printf " p: ~e\n" 'p) - (printf " hole: ~e\n" 'hole) + (printf " f: ~.s\n" (stx->datum f)) + (printf " v: ~.s\n" (stx->datum v)) + (printf " p: ~.s\n" 'p) + (printf " hole: ~.s\n" 'hole) (print-viable-subterms v)) (if (visibility) (let ([vctx (CC hole v p)] @@ -396,8 +396,8 @@ (define (run-one reducer init-e fctx vsub vctx fill s ws k) (DEBUG (printf "run-one\n") - (printf " fctx: ~e\n" (stx->datum (fctx #'HOLE))) - (printf " vctx: ~e\n" (stx->datum (vctx #'HOLE)))) + (printf " fctx: ~.s\n" (stx->datum (fctx #'HOLE))) + (printf " vctx: ~.s\n" (stx->datum (vctx #'HOLE)))) (RSbind (with-context vctx ((reducer fill) init-e vsub s ws)) (lambda (f2 v2 s2 ws2) (k (fctx f2) (vctx v2) s2 ws2)))) @@ -406,12 +406,12 @@ (define (run-multiple/visible reducer init-e1s fctx vsubs vctx fills s ws k) (DEBUG (printf "run-multiple/visible\n") - (printf " fctx: ~e\n" (stx->datum (fctx (for/list ([dummy init-e1s]) #'HOLE)))) - (printf " vctx: ~e\n" (stx->datum (vctx (for/list ([dummy init-e1s]) #'HOLE)))) + (printf " fctx: ~.s\n" (stx->datum (fctx (for/list ([dummy init-e1s]) #'HOLE)))) + (printf " vctx: ~.s\n" (stx->datum (vctx (for/list ([dummy init-e1s]) #'HOLE)))) (unless (= (length fills) (length init-e1s)) - (printf " fills(~s): ~e\n" (length fills) fills) - (printf " init-e1s: ~s\n" (stx->datum init-e1s)) - (printf " vsubs: ~s\n" (stx->datum vsubs)))) + (printf " fills(~s): ~.s\n" (length fills) fills) + (printf " init-e1s: ~.s\n" (stx->datum init-e1s)) + (printf " vsubs: ~.s\n" (stx->datum vsubs)))) (let loop ([fills fills] [prefix null] [vprefix null] [suffix init-e1s] [vsuffix vsubs] [s s] [ws ws]) (cond [(pair? fills) @@ -432,10 +432,10 @@ (define (run-multiple/nonvisible reducer init-e1s fctx v fills s ws k) (DEBUG (printf "run-multiple/nonvisible\n") - (printf " fctx: ~e\n" (stx->datum (fctx (for/list ([dummy init-e1s]) #'HOLE))))) + (printf " fctx: ~.s\n" (stx->datum (fctx (for/list ([dummy init-e1s]) #'HOLE))))) (let loop ([fills fills] [prefix null] [suffix init-e1s] [v v] [s s] [ws ws]) (DEBUG - (printf " v: ~e\n" (stx->datum (datum->syntax #f v)))) + (printf " v: ~.s\n" (stx->datum (datum->syntax #f v)))) (cond [(pair? fills) (RSbind ((reducer (car fills)) (car suffix) v s ws) @@ -468,7 +468,7 @@ (cond [(and (not new-visible?) (or (visibility) reset-subterms?)) (begin (DEBUG - (printf "hide => seek: ~e\n" (stx->datum stx))) + (printf "hide => seek: ~.s\n" (stx->datum stx))) (current-pass-hides? #t) (let* ([subterms (gather-proper-subterms stx)] [marking (marking-table)] @@ -496,11 +496,11 @@ (k vstx) (let ([paths (table-get (subterms-table) stx)]) (cond [(null? paths) - (DEBUG (printf "seek-point: failed on ~e\n" (stx->datum stx))) + (DEBUG (printf "seek-point: failed on ~.s\n" (stx->datum stx))) (k vstx)] [(null? (cdr paths)) (let ([path (car paths)]) - (DEBUG (printf "seek => hide: ~e\n" (stx->datum stx))) + (DEBUG (printf "seek => hide: ~.s\n" (stx->datum stx))) (let ([ctx (lambda (x) (path-replace vstx path x))]) (RScase (parameterize ((visibility #t) (subterms-table #f) @@ -538,16 +538,16 @@ [same-form? (equal? actual-datum expected-datum)]) (if same-form? (fprintf (current-error-port) - "same form but wrong wrappings:\n~e\nwrongness:\n~e\n" + "same form but wrong wrappings:\n~.s\nwrongness:\n~.s\n" actual-datum (wrongness actual expected)) (fprintf (current-error-port) - "got:\n~s\n\nexpected:\n~e\n" + "got:\n~.s\n\nexpected:\n~.s\n" actual-datum expected-datum)) (for ([d derivs]) (fprintf (current-error-port) - "\n~e\n" d)) + "\n~.s\n" d)) (error function (if same-form? "wrong starting point (wraps)!"