suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve macro stepper output, and some more ,stx outputs.

Browse Source 
(cherry picked from commit 8109299ec8)
This commit is contained in:
Eli Barzilay 2011-07-19 00:36:08 -04:00
parent 36a0fea0cc
commit c7bf34d387
1 changed files with 21 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/xrepl/xrepl.rkt
View File

@ -961,7 +961,7 @@
(namespace-require init) (namespace-require init)
(hash-set! namespaces name (cons (current-namespace) init)))) (hash-set! namespaces name (cons (current-namespace) init))))
(when (and name (not (eq? name (current-namespace-name)))) (when (and name (not (eq? name (current-namespace-name))))
(printf "; *** switching to the `~s' namespace ***\n" name) (printf "; *** Switching to the `~s' namespace ***\n" name)
(let ([x (hash-ref namespaces (current-namespace-name))]) (let ([x (hash-ref namespaces (current-namespace-name))])
(unless (eq? (car x) old-namespace) (unless (eq? (car x) old-namespace)
(printf "; (note: saving current namespace for `~s')\n" (printf "; (note: saving current namespace for `~s')\n"
@ -1000,6 +1000,19 @@
(map (λ (s) (namespace-symbol->identifier (car s))) (map (λ (s) (namespace-symbol->identifier (car s)))
(cdr (assq 0 stxs))))))) (cdr (assq 0 stxs)))))))
(λ (id) (not (ormap (λ (s) (free-identifier=? id s)) base-stxs)))))) (λ (id) (not (ormap (λ (s) (free-identifier=? id s)) base-stxs))))))
(define (macro-stepper . args)
(define-values [i o] (make-pipe))
(parameterize ([current-output-port o])
(thread (λ () (apply expand/step-text args) (close-output-port o))))
(let loop ()
(define l (read-line i))
(unless (eof-object? l)
;; hack: beautify the stepper's output -- remove empty line, indent code
(unless (equal? "" l)
(printf (if (regexp-match? #px"^[A-Z][a-z]+\\b" l)
"; ---- ~a ----\n" "; ~a\n")
l))
(loop))))
(defcommand (syntax stx st) "[<expr>] [<flag> ...]" (defcommand (syntax stx st) "[<expr>] [<flag> ...]"
"set syntax object to inspect, and control it" "set syntax object to inspect, and control it"
["With no arguments, will show the previously set (or expanded) syntax" ["With no arguments, will show the previously set (or expanded) syntax"
@ -1017,22 +1030,22 @@
(define args (getarg 'syntax 'list)) (define args (getarg 'syntax 'list))
(for ([stx (in-list (if (null? args) '(#f) args))]) (for ([stx (in-list (if (null? args) '(#f) args))])
(define (show/set label stx) (define (show/set label stx)
(printf "~a\n" label) (printf "; ~a\n" label)
(current-syntax stx) (current-syntax stx)
(pretty-write (syntax->datum stx))) (display "; ") (pretty-write (syntax->datum stx)))
(define (cur) (or (current-syntax) (cmderror "no syntax set yet"))) (define (cur) (or (current-syntax) (cmderror "no syntax set yet")))
(case (and stx (if (identifier? stx) (syntax-e stx) '--none--)) (case (and stx (if (identifier? stx) (syntax-e stx) '--none--))
[(#f) (show/set "current syntax:" (cur))] [(#f) (show/set "Current syntax:" (cur))]
[(^) (if (last-input-syntax) [(^) (if (last-input-syntax)
(show/set "using last expression:" (last-input-syntax)) (show/set "Using last expression:" (last-input-syntax))
(cmderror "no expression entered yet"))] (cmderror "no expression entered yet"))]
[(+) (show/set "expand-once ->" (expand-once (cur)))] [(+) (show/set "expand-once ->" (expand-once (cur)))]
[(!) (show/set "expand ->" (expand (cur)))] [(!) (show/set "expand ->" (expand (cur)))]
[(*) (printf "stepper:\n") (expand/step-text (cur) (not-in-base))] [(*) (printf "; Stepper:\n") (macro-stepper (cur) (not-in-base))]
[(**) (printf "stepper:\n") (expand/step-text (cur))] [(**) (printf "; Stepper:\n") (macro-stepper (cur))]
[else [else
(if (syntax? stx) (if (syntax? stx)
(begin (printf "syntax set\n") (current-syntax stx)) (begin (printf "; Syntax set\n") (current-syntax stx))
(cmderror "internal error: ~s ~s" stx (syntax? stx)))]))) (cmderror "internal error: ~s ~s" stx (syntax? stx)))])))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------