;; -*- scheme -*- #| Written by Eli Barzilay This file provides some useful facilities for interactive use of mzscheme. It is best used as (or loaded from) a ".mzschemerc" file or "mzschemerc.ss" on Windows (evaluate `(find-system-path 'init-file)' to know where this file is on your system). Some highlights are: * Defines a 'debug module (can also be used as '* for brevity) that provides a few useful utilities for use in code while debugging: > (eprintf fmt arg ...) Like `printf', but uses the current error port. > (eeprintf fmt arg ...) Like `eprintf', but the original error port. Useful for printouts from code where `current-error-port' might be redirected. > (warn ...) Same as `error', but only prints the error message. > *** > (*** value) > (*** fmt args ...) This is macro that is useful for debugging printouts: the first form prints (on stderr) the source file and line number, the second also prints a value (and returns it), and the third uses a format string. For example, to see where a problem happens in a function, you spread ***s around, and the printout will show a trace of location (and possibly values). > (define*** (name args ...) ...) Macro that defines `name' as a traced function. (The idea is that you append a `***' to `define' for functions that you want to trace.) This is a cheap hack: it kills tail-recursiveness. The `***' is supposed to be a token that stands out textually in *your* code while you're debugging it, so it is customizable: set the `MZ_DEBUGGER_TOKEN' environment variable to whatever you want -- for example, set it to "@@" and you'll get bindings for `@@' and `define@@' instead of the above. The following REPL functionality is used only when the REPL is actually used, so non-interactive use (eg, scripts) are not affected (but note that .mzschemerc is not read in such cases anyway (by default)). * Uses the readline library if you're running in an xterm (and if it's present). (Again, triggered by repl interaction.) * Toplevel commands, in the form of ",cmd". These commands make it convenient to perform many otherwise-tedious operations in MzScheme. Use ",h" for a list of available commands and for help on a specific command. Note that some of these commands look similar to existing mzscheme functionality, but are extended. Most commands consume arguments, ,help will tell you about the relevant syntax. Note that arguments usually do not need to be quoted, for example ",cd .." goes up a directory; this is also relevant for commands that consume an expression, a require specification, a symbol, etc. Some highlights: - ,time: improved timing output, and can run an expression multiple times - ,require: if you use it with an argument that looks like a file, it will do the right thing to require that file - ,syntax: not only is this a poor man's syntax stepper -- it can actually use the real syntax stepper - ,apropos: search the available bindings - ,describe: tell you how you got to have some binding - ,require-reloadable ,reload ,enter: require a module so it can be reloaded later, and a convenient command for `enter!' (with the prompt showing you where you are) - ,trace ,untrace ,errortrace ,profile: convenient commands for those features you always knew how to use but was lazy to actually type what's needed. * Previous toplevel results are accessible: `^' is the last result, `^^' is the second to last (or the second value of the last multiple-value result) etc. This is done in a way that is trying to avoid clobbering a binding that you already have for these identifiers. |# ;; ============================================================================ ;; convenient debugging utilities (module debug scheme/base (require (for-syntax scheme/base)) ;; either change this line, or set the "MZ_DEBUGGER_TOKEN" environment var (define-for-syntax debug-token (or (getenv "MZ_DEBUGGER_TOKEN") "***")) (provide eprintf eeprintf warn) (define (eprintf fmt . args) (apply fprintf (current-error-port) fmt args)) (define eeprintf (let ([e (current-error-port)]) (lambda (fmt . args) (apply fprintf e fmt args)))) (define (warn who . fmt/args) (parameterize ([current-output-port (current-error-port)]) (display who) (when (pair? fmt/args) (if (symbol? who) (begin (display ": ") (apply printf fmt/args)) (for ([x fmt/args]) (printf " ~s" x)))) (newline))) (define token (let-syntax ([token (lambda (stx) (datum->syntax stx debug-token stx))]) token)) (define-syntax (define-debug-syntax stx) (syntax-case stx () [(_ (pfx stx) body ...) #'(define-debug-syntax pfx (lambda (stx) body ...))] [(_ pfx expr) (identifier? #'pfx) (with-syntax ([id (datum->syntax #'pfx (string->symbol (string-append (symbol->string (syntax-e #'pfx)) debug-token)) #'pfx)]) #'(begin (provide id) (define-syntax id expr)))])) (define-debug-syntax (|| stx) (syntax-case stx () [(_ fmt arg ...) (string? (syntax-e #'fmt)) #`(dprint '#,(syntax-source stx) '#,(syntax-position stx) '#,(syntax-line stx) fmt (list (lambda () arg) ...) '(arg ...))] [(_ arg ...) #`(dprint '#,(syntax-source stx) '#,(syntax-position stx) '#,(syntax-line stx) #f (list (lambda () arg) ...) '(arg ...))] [else #`(dprint '#,(syntax-source stx) '#,(syntax-position stx) '#,(syntax-line stx) #f '() '())])) (define-debug-syntax define (syntax-rules () [(_ (name x ...) body ...) (define (name x ...) (indent) (eprintf "{~a~a~a\n" 'name token (string-append (format " ~s" x) ...)) (let ([r (parameterize ([indentation (cons " " (indentation))]) body ...)]) (indent) (eprintf " ~a~a -> ~s}\n" 'name token r) r))])) (define indentation (make-parameter '())) (define (indent) (for-each eprintf (indentation))) (define (dprint source pos line fmt thunks exprs) (define error? #f) (define retval (void)) (define args (map (lambda (thunk) (with-handlers ([void (lambda (e) (set! error? (or error? e)) (format "ERROR(~a)" (exn-message e)))]) (let ([r (thunk)]) (set! retval r) r))) thunks)) (indent) (let* ([source (cond [(symbol? source) source] [source (regexp-replace #rx"^.*/" (if (string? source) source (format "~a" source)) "")] [else #f])] [marker (cond [(and source line) (format "~a~a:~a" token source line)] [(and source pos) (format "~a~a:#~a" token source pos)] [source (format "~a~a" token source)] [else token])] [line (if fmt (apply format fmt args) args)]) (parameterize ([current-output-port (current-error-port)]) (display marker) (unless (null? line) (display ">") (parameterize ([error-print-width 30]) (if (pair? line) (for ([x args] [expr exprs]) (display " ") (when (or (symbol? expr) (and (pair? expr) (not (memq (car expr) '(quasiquote quote))))) (printf "~e=" expr)) (write x)) (begin (display " ") (display line))))) (printf "\n"))) (if error? (raise error?) retval)) ) ;; usee '* as a convenient alias (module * scheme/base (require 'debug) (provide (all-from-out 'debug))) ;; ============================================================================ (module interactive scheme/base ;; ---------------------------------------------------------------------------- ;; configuration (define toplevel-prompt (make-parameter #"-")) ; when not in a module (define saved-values-number (make-parameter 5)) (define saved-values-char (make-parameter #\^)) ;; you may want to disable inlining to allow redefinitions ;; (compile-enforce-module-constants #f) ;; ---------------------------------------------------------------------------- (require scheme/string scheme/list scheme/function scheme/promise scheme/enter 'debug) (provide (all-from-out 'debug)) ; can't specify the names of debug tokens (define-syntax defautoload (syntax-rules () [(defautoload id libspec) (define id (let ([id (delay (dynamic-require 'libspec 'id))]) (lambda args (apply (force id) args))))])) ;; ---------------------------------------------------------------------------- ;; slightly more convenient require spec (define (process-require-spec spec0) ;; translates names that are paths to the necessary specs (let* ([spec (if (syntax? spec0) (syntax->datum spec0) spec0)] [spec (and (symbol? spec) (symbol->string spec))] [spec (and spec (file-exists? spec) spec)] [spec (and spec (if (absolute-path? spec) `(file ,spec) spec))] [spec (and spec (if (syntax? spec0) (datum->syntax spec0 spec spec0) spec))]) (or spec spec0))) ;; ---------------------------------------------------------------------------- ;; toplevel "," commands (define prompt (toplevel-prompt)) (define-struct command (names blurb desc handler)) (define commands (make-hasheq)) (define commands-list '()) ; for help displays, in definition order (define current-command (make-parameter #f)) (define (register-command! names blurb desc handler) (let* ([names (if (list? names) names (list names))] [cmd (make-command names blurb desc handler)]) (for ([n names]) (if (hash-ref commands n #f) (error 'defcommand "duplicate command name: ~s" n) (hash-set! commands n cmd))) (set! commands-list (cons cmd commands-list)))) (define-syntax-rule (defcommand cmd+aliases blurb (desc ...) body0 body ...) (register-command! `cmd+aliases `blurb `(desc ...) (lambda () body0 body ...))) (define (getarg kind0 [flag #f]) (define (missing) (error (or (current-command) 'getarg) "missing ~a argument" kind0)) (define (translate arg convert) (and arg (if (list? arg) (map convert arg) (convert arg)))) (define (use-reader read) (let loop ([flag flag]) (case flag [(#f) (let ([x (read)]) (if (eof-object? x) (missing) x))] [(opt) (and (not (memq (peek-char) '(#\newline #\return))) ; imm. EOLs (not (regexp-try-match #rx"^[ \t]*?\r?\n" (current-input-port))) (loop #f))] [(list) (parameterize ([current-input-port (open-input-string (read-line))]) (let loop ([r '()]) (let ([x (read)]) (if (eof-object? x) (reverse r) (loop (cons x r))))))]))) (unless (memq flag '(#f opt list)) (error 'getarg "unknown flag: ~e" flag)) (let loop ([kind kind0]) (case kind ;; strings etc; read rest of line, empty (or all spaces) => no args [(string) (let* ([arg (read-line)] [arg (regexp-replace #rx"^[ \t]+" arg "")] [arg (regexp-replace #rx"[ \t]+$" arg "")] [arg (and (not (equal? "" arg)) arg)]) (case flag [(opt) arg] [(#f) (or arg (missing))] [(list) (if arg (regexp-split #rx"[ \t]+" arg) '())]))] [(path) (translate (loop 'string) expand-user-path)] ;; sexprs etc; a list means everything on the current line [(sexpr) (use-reader read)] [(syntax) (translate (use-reader read-syntax) namespace-syntax-introduce)] [(modspec) (translate (loop 'syntax) process-require-spec)] [else (error 'getarg "unknown arg kind: ~e" kind)]))) (define (run-command command) (let ([cmd (hash-ref commands command #f)]) (if cmd (parameterize ([current-command command]) ((command-handler cmd))) (eprintf "Unknown command: ~s\n" command)))) ;; like `eval', but accepts any number of expressions (define (eval* . exprs) (let loop ([r (list (void))] [exprs exprs]) (if (null? exprs) (apply values r) (loop (call-with-values (lambda () (eval (car exprs))) list) (cdr exprs))))) (defcommand (help h ?) "display available commands" (> "[]" "Lists known commands and their help; use with a command name to get" "additional information for that command.") (let* ([arg (getarg 'sexpr 'opt)] [cmd (and arg (hash-ref commands arg (lambda () (printf "*** Unknown command: `~s'\n" arg) #f)))]) (define (show-cmd cmd) (let* ([names (command-names cmd)] [name (car names)] [aliases (cdr names)] [blurb (command-blurb cmd)] [header (format " ~a~a:" name (if (pair? aliases) (format " ~a" aliases) ""))] [blurb (if (and (string? blurb) (< 70 (+ (string-length blurb) (string-length header)))) (list blurb) blurb)]) (if (list? blurb) (begin (printf "~a\n" header) (for ([h blurb]) (printf " ~a\n" h))) (printf "~a ~a\n" header blurb)))) (if cmd (let ([desc (command-desc cmd)]) (show-cmd cmd) (let loop ([ds (if (list? desc) desc (list desc))]) (when (pair? ds) (loop (if (eq? (car ds) '>) (begin (printf " > ,~a ~a\n" arg (cadr ds)) (cddr ds)) (begin (printf " ~a\n" (car ds)) (cdr ds))))))) (begin (printf "Available commands:\n") (for-each show-cmd (reverse commands-list)))))) (defcommand (exit quit ex) "Exit MzScheme" (> "[]" "Optional argument specifies exit code.") (cond [(getarg 'sexpr 'opt) => exit] [else (exit)])) (defcommand cd "change the current directory" (> "[]" "Sets `current-directory'; expands user paths. With no arguments, goes" "to your home directory.") (let ([arg (or (getarg 'path 'opt) (find-system-path 'home-dir))]) (if (directory-exists? arg) (current-directory arg) (warn 'cd "no such directory: ~a" arg)) (printf "Now in ~a\n" (current-directory)))) (defcommand pwd "read the current directory" (> "" "Simply shows the value of `current-directory'.") (printf "~a\n" (current-directory))) (defautoload system scheme/system) (defcommand (shell sh ls cp mv rm md rd svn) "run a shell command" (> "" "`sh' runs a shell command (via `system'), the aliases run a few useful" "unix commands. (Note: `ls' has some default arguments set.)") (let ([arg (getarg 'string 'opt)] [cmd (current-command)]) (case cmd [(ls) (set! cmd "ls -F --color")] [(shell) (set! cmd 'sh)]) (let ([cmd (cond [(eq? 'sh cmd) #f] [(symbol? cmd) (symbol->string cmd)] [else cmd])]) (system (cond [(and (not cmd) (not arg)) (getenv "SHELL")] [(not cmd) arg] [(not arg) cmd] [else (string-append cmd " " arg)]))))) (defcommand (apropos ap) "look for a binding" (> " ..." "An argument can be used to restrict matches shown (it is a simple" "string search, no regexps).") (let* ([arg (map (compose regexp regexp-quote) (getarg 'string 'list))] [arg (and (pair? arg) (lambda (str) (andmap (lambda (rx) (regexp-match? rx str)) arg)))] [syms (map (lambda (sym) (cons sym (symbol->string sym))) (namespace-mapped-symbols))] [syms (if arg (filter (compose arg cdr) syms) syms)] [syms (sort syms stringname setup/private/path-utils) (defcommand (describe desc id) "describe a (bound) identifier" (> "[] " "For a bound identifier, describe where is it coming from. You can use" "this command with several identifiers. You can provide a numeric" "argument first to use a different phase identifier.") (define ids (getarg 'syntax 'list)) (define level 0) (when (and (pair? ids) (number? (syntax-e (car ids)))) (set! level (syntax-e (car ids))) (set! ids (cdr ids))) (for ([id ids]) (define b (if (identifier? id) (identifier-binding id level) (error 'describe-command "not an identifier: ~s" (syntax->datum id)))) (define s (syntax->datum id)) (cond [(not b) (printf "`~s' is a toplevel (or unbound) identifier\n" s)] [(eq? b 'lexical) (printf "`~s' is a lexical identifier\n" s)] [(or (not (list? b)) (not (= 7 (length b)))) (error "internal error, mzscheme changed on me")] [else (let-values ([(source-mod source-id nominal-source-mod nominal-source-id source-phase import-phase nominal-export-phase) (apply values b)]) (define (mpi* mpi) (let ([p (resolved-module-path-name (module-path-index-resolve mpi))]) (if (path? p) (path->name p) p))) (let ([source-mod (mpi* source-mod)] [nominal-source-mod (mpi* nominal-source-mod)]) (for-each display `("`",s"' is a bound identifier," "\n" " defined" ,(case source-phase [(0) ""] [(1) "-for-syntax"] [else (error "internal error")]) " in \"",source-mod"\"" ,(if (not (eq? s source-id)) (format " as `~s'" source-id) "") "\n" " required" ,(case import-phase [(0) ""] [(1) "-for-syntax"] [else (error "internal error")]) " " ,(if (equal? source-mod nominal-source-mod) "directly" (format "through \"~a\"~a" nominal-source-mod (if (not (eq? s nominal-source-id)) (format " where it is defined as `~s'" nominal-source-id) ""))) "\n" ,(case nominal-export-phase [(0) ""] [(1) (format " (exported-for-syntax)\n")] [else (error "internal error")])))))]))) (define last-require-modspecs #f) ; last arg to ,require (defcommand (require req r) "require a module" (> " ..." "The arguments are usually passed to `require', unless an argument" "specifies an existing filename -- in that case, it's like using a" "\"string\" or a (file \"...\") in `require'. (Note: this does not" "work in subforms.)") (let ([specs (getarg 'modspec 'list)]) (set! last-require-modspecs specs) (make-new-input #`(require #,@specs)))) (defcommand (require-reloadable reqr rr) "require a module, make it reloadable" (> " ..." "This is the same as ,require but the module is required in a way that" "makes it possible to reload later (by setting the" "`compile-enforce-module-constants' parameter). Note that this usually" "makes code run slower, since the compiler cannot inline things as" "usual.") (let ([specs (getarg 'modspec 'list)]) (set! last-require-modspecs specs) (let ([prev (eval #`(compile-enforce-module-constants))]) (make-new-input (if prev #`(begin (compile-enforce-module-constants #f) (require #,@specs) (compile-enforce-module-constants #,prev)) #`(require #,@specs)))))) (defcommand (reload) "reload a module" (> "[ ...]" "An argument is optional, if missing then the default is the last" "argument(s) used with ,require or ,require-reloadable.") (let* ([specs (getarg 'modspec 'list)] [specs (if (pair? specs) specs (or last-require-modspecs (error 'reload-command "no arguments and no previous ,require")))] [specs (map syntax->datum specs)]) (parameterize ([compile-enforce-module-constants #f]) (for ([spec specs]) (if (not (module-path? spec)) (printf " skipping invalid module-path ~s\n" spec) (let* ([rmp ((current-module-name-resolver) spec #f #f)] [path (resolved-module-path-name rmp)]) (printf " reloading ~a\n" path) (parameterize ([current-module-declare-name rmp]) (load/use-compiled path)))))))) (defcommand (enter en) "require a module and go into its namespace" (> "[]" "Uses `enter!' to go into the module's namespace; the module name is" "optional, without it you go back to the toplevel. A module name can" "specify an existing file as with the ,require command.") (let ([spec (getarg 'modspec 'opt)]) (eval (if spec #`(enter! #,spec) #`(enter! #f))) (set! prompt (if spec (let ([s (syntax->datum spec)]) (string->bytes/utf-8 (if (and (list? s) (= 2 (length s)) (eq? 'quote (car s))) (format "'~s" (cadr s)) (format "~s" s)))) (toplevel-prompt))))) (defcommand (toplevel top) "go back to the toplevel" (> "" "Go back to the toplevel, same as ,enter with no arguments.") (eval #`(enter! #f)) (set! prompt (toplevel-prompt))) (defcommand (load ld) "load a file" (> " ..." "Uses `load' to load the specified file(s)") (make-new-input #`(begin #,@(map (lambda (name) #`(load #,name)) (getarg 'path 'list))))) (provide time*) (define (time* thunk times) (define throw (if (<= times 0) (error 'time-command "bad count: ~e" times) (floor (* times 2/7)))) (define results #f) (define timings '()) (define (run n) (when (<= n times) (when (> times 1) (printf ";; run #~a..." n) (flush-output)) (collect-garbage) (collect-garbage) (let ([r (call-with-values (lambda () (time-apply thunk '())) list)]) (set! results (car r)) (set! timings (cons (cdr r) timings)) (when (> times 1) (printf " ->") (if (null? results) (printf " (0 values returned)") (begin (for ([r results]) (printf " ~s" r)) (newline)))) (run (add1 n))))) (run 1) (set! timings (sort timings < #:key car)) ; sort by cpu-time (set! timings (drop timings throw)) ; throw extreme bests (set! timings (take timings (- (length timings) throw))) ; and worsts (set! timings (let ([n (length timings)]) ; average (map (lambda (x) (round (/ x n))) (apply map + timings)))) (let-values ([(cpu real gc) (apply values timings)]) (when (> times 1) (printf ";; ~a runs, ~a best/worst removed, ~a left for average:\n" times throw (- times throw throw))) (printf ";; cpu time: ~sms = ~sms + ~sms gc; real time: ~sms\n" cpu (- cpu gc) gc real)) (apply values results)) (defcommand time "time an expression" (> "[] " "Times execution of an expression, similar to `time' but prints a" "little easier to read information. You can provide an initial number" "that specifies how many times to run the expression -- in this case," "the expression will be executed that many times, extreme results are" "be removed (top and bottom 2/7ths), and the remaining results will" "be averaged. Two garbage collections are triggered before each run;" "the resulting value(s) are from the last run.") (let* ([x (getarg 'syntax)] [n (and (integer? (syntax-e x)) x)] [expr (if n (getarg 'syntax) x)]) (make-new-input #`(time* (lambda () #,expr) #,(or n #'1))))) (defcommand (trace tr) "trace a function" (> " ..." "Traces a function (or functions), using the mzlib/trace library.") (eval* #`(require mzlib/trace) `(trace ,@(getarg 'syntax 'list)))) (defcommand (untrace untr) "untrace a function" (> " ..." "Untraces functions that were traced with ,trace.") (eval* #`(require mzlib/trace) `(untrace ,@(getarg 'syntax 'list)))) (defautoload profiling-enabled errortrace) (defautoload instrumenting-enabled errortrace) (defautoload clear-profile-results errortrace) (defautoload output-profile-results errortrace) (defcommand (errortrace errt inst) "errortrace instrumentation control" (> "[]" "An argument is used to perform a specific operation:" " + : turn errortrace instrumentation on (effective only for code that" " is evaluated from now on)" " - : turn it off (also only for future evaluations)" " ? : show status without changing it" "With no arguments, toggles instrumentation.") (case (getarg 'sexpr 'opt) [(#f) (instrumenting-enabled (not (instrumenting-enabled)))] [(-) (instrumenting-enabled #f)] [(+) (instrumenting-enabled #t)] [else (error 'errortrace-command "unknown subcommand")]) (printf "errortrace instrumentation is ~a\n" (if (instrumenting-enabled) "on" "off"))) (defcommand (profile prof) "profiler control" (> "[ ...]" "An argument is used to perform a specific operation:" " + : turn the profiler on (effective only for code that is evaluated" " from now on)" " - : turn the profiler off (also only for future evaluations)" " * : show profiling results" " ! : clear profiling results" "Multiple commands can be combined, for example \",prof *!-\" will show" "profiler results, clear them, and turn it off." "With no arguments, turns the profiler on (if it's off), shows results" "unless it was off, and clears them." "Note: using *any* of these turns errortrace instrumentation on, even" "a \",prof -\". Use the ,errortrace command to turn it off.") (instrumenting-enabled #t) (for ([cmd (cond [(getarg 'string 'opt) => (lambda (str) (regexp-replace* #rx"[ \t]+" str ""))] [else '(#f)])]) (case cmd [(#\+) (profiling-enabled #t)] [(#\-) (profiling-enabled #f)] [(#\*) (output-profile-results #f #t)] [(#\!) (clear-profile-results)] [(#f) (when (profiling-enabled) (output-profile-results #f #t) (clear-profile-results)) (profiling-enabled #t)] [else (error 'profile-command "unknown subcommand")]))) (define current-syntax #f) (define last-syntax #f) ; set by the repl at the bottom (defautoload pretty-print scheme/pretty) (defautoload expand/step-text macro-debugger/stepper-text) (define expand-pred (delay (let ([base-stxs ;; all ids that are bound to a syntax in scheme/base (let ([ns (make-base-namespace)] [tag "tag"]) (parameterize ([current-namespace ns]) (filter-map (lambda (s) (and (eq? tag (namespace-variable-value s #t (lambda () tag))) (namespace-symbol->identifier s))) (namespace-mapped-symbols))))]) (lambda (id) (not (ormap (lambda (s) (free-identifier=? id s)) base-stxs)))))) (defcommand (syntax stx st) "set syntax object to inspect, and control it" (> "[] [ ...]" "With no arguments, will show the previously set (or expande) syntax" "additional arguments serve as an operation to perform:" "- `^' sets the syntax from the last expression evaluated" "- `+' will `expand-once' the syntax and show the result" "- `!' will `expand' the syntax and show the result" "- `*' will use the syntax stepper to show expansion steps, leaving" " macros from scheme/base intact (does not change the currently" " set syntax)" "- `**' similar to `*', but expanding everything") (for ([stx (getarg 'syntax 'list)]) (define (show/set label stx) (printf "~a\n" label) (set! current-syntax stx) (pretty-print (syntax->datum stx))) (define (cur) (or current-syntax (error 'syntax-command "no syntax set yet"))) (case (and stx (if (identifier? stx) (syntax-e stx) '--none--)) [(#f) (show/set "current syntax:" (cur))] [(^) (if last-syntax (show/set "using last expression:" last-syntax) (error 'syntax-command "no expression entered yet"))] [(+) (show/set "expand-once ->" (expand-once (cur)))] [(!) (show/set "expand ->" (expand (cur)))] [(*) (printf "stepper:\n") (expand/step-text (cur) (force expand-pred))] [(**) (printf "stepper:\n") (expand/step-text (cur))] [else (if (syntax? stx) (begin (printf "syntax set\n") (set! current-syntax stx)) (error 'syntax-command "internal error ~e ~e" stx (syntax? stx)))]))) ;; ---------------------------------------------------------------------------- ;; eval hook that keep track of recent evaluation results ;; saved interaction values (define saved-values '()) (define (save-values! xs) (let ([xs (filter (negate void?) xs)]) ; do not save void values (unless (null? xs) ;; `^' is always last value, `^^' is 2nd-to-last or the second value of the ;; last interaction (set! saved-values (append xs saved-values)) (let ([n (saved-values-number)]) (when (< n (length saved-values)) (set! saved-values (take saved-values n))))))) ;; make saved values available through bindings, but do this in a way that ;; doesn't interfere with users using these binders in some way -- set only ids ;; that were void, and restore them to void afterwards (define last-saved-values-state #f) (define last-saved-names #f) (define (saved-names) (unless (equal? last-saved-values-state (cons (saved-values-number) (saved-values-char))) (set! last-saved-names (for/list ([i (in-range (saved-values-number))]) (string->symbol (make-string (add1 i) (saved-values-char))))) (set! last-saved-values-state (cons (saved-values-number) (saved-values-char)))) last-saved-names) (define (with-saved-values thunk) (let* ([saved-names (saved-names)] [vs (map (lambda (id) (box (namespace-variable-value id #f void))) saved-names)] [res #f]) (dynamic-wind (lambda () (for ([id saved-names] [saved saved-values] [v vs]) ;; set only ids that are void, and remember these values (if (void? (unbox v)) (begin (namespace-set-variable-value! id saved) (set-box! v saved)) (set-box! v (void))))) (lambda () (call-with-values thunk (lambda vs (set! res vs) (apply values vs)))) (lambda () (for ([id saved-names] [v vs]) ;; restore the names to void so we can set them next time (when (and (not (void? (unbox v))) ; restore if we set this id above (eq? (unbox v) ; and if it didn't change (namespace-variable-value id #f void))) (namespace-set-variable-value! id (void)))) (when res (save-values! res)))))) (define orig-eval (current-eval)) (define (new-eval expr) (with-saved-values (lambda () (orig-eval expr)))) (current-eval new-eval) ;; ---------------------------------------------------------------------------- ;; capture ",..." and run the commands, use readline/rep when possible ;; used to signal a result from a command that is an expression to evaluate (define (make-new-input stx) (cons make-new-input stx)) (define (new-input x) (and (pair? x) (eq? make-new-input (car x)) (cdr x))) (provide make-repl-reader) (define (make-repl-reader builtin-reader) (let* ([reader ; plain reader with no readline (lambda (prefix) (when prefix (display prefix)) (builtin-reader))] [term? (and (eq? 'stdin (object-name (current-input-port))) (terminal-port? (current-input-port)) (regexp-match? #rx"term" (or (getenv "TERM") "")))] [reader (if (not term?) reader ;; readline reader (parameterize ([current-prompt-read ; protect against changes below (current-prompt-read)]) (with-handlers ([exn? (lambda (e) (eprintf "Warning: no readline support (~a)\n" (exn-message e)) reader)]) (when (terminal-port? (current-output-port)) (port-count-lines! (current-output-port))) (dynamic-require 'readline/rep-start #f) (let ([p (dynamic-require 'readline/pread 'current-prompt)] [r (current-prompt-read)]) (if (eq? r builtin-reader) (begin (eprintf "Warning: problems initializing readline\n") reader) ;; finally -- this is the actual readline reader (lambda (prefix) (if prefix (parameterize ([p (bytes-append prefix (p))]) (r)) (r))))))))]) (define (loop) (let ([stx (reader prompt)]) (syntax-case stx () [(uq cmd) (eq? 'unquote (syntax-e #'uq)) (let ([r (with-handlers ([void (lambda (e) (if (exn? e) (eprintf "~a\n" (exn-message e)) (eprintf "~s\n" e)))]) (run-command (syntax->datum #'cmd)))]) (or (new-input r) ; returns new input if it is one (loop)))] [_ (begin (set! last-syntax stx) stx)]))) loop)) ) ;; ============================================================================ ;; make this available for toplevel (require 'debug) ;; ============================================================================ ;; use the interactive module only when there is an interaction (current-prompt-read (let ([old (current-prompt-read)]) (lambda () (current-prompt-read ;; load and create the new reader ((dynamic-require ''interactive 'make-repl-reader) old)))))