Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 22:59:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Documentation updates, making (chibi repl) history persistent.

Browse source
This commit is contained in:
Alex Shinn 2011-05-23 02:09:24 -07:00
parent cf54a161fa
commit 357684a730
8 changed files with 193 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

86
lib/chibi/repl.scm
View file

@ -1,8 +1,17 @@
;;;; repl.scm - friendlier repl with line editing and signal handling
;;
;; repl.scm - friendlier repl with line editing and signal handling
;; Copyright (c) 2011 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;> A user-friendly REPL with line editing and signal handling.
;;> The default REPL provided by chibi-scheme is very minimal,
;;> meant primarily to be small and work on any platform. This
;;> module provides an advanced REPL that handles vt100 line
;;> editing and signal handling, so that C-c will interrupt a
;;> computation and bring you back to the REPL prompt. To use
;;> this repl, run
;;> @command{chibi-scheme -mchibi.repl -e'(repl)'}
;;> from the command line or within Emacs.
(define (with-signal-handler sig handler thunk)
(let ((old-handler #f))
(dynamic-wind
@ -29,14 +38,60 @@
(define module? vector?)
(define (module-env mod) (vector-ref mod 1))
;;> Runs an interactive REPL. Repeatedly displays a prompt,
;;> then Reads an expression, Evaluates the expression, Prints
;;> the result then Loops. Terminates when the end of input is
;;> reached or the @scheme|{@exit}| command is given.
;;>
;;> Basic Emacs-style line editing with persistent history
;;> completion is provided. C-c can be used to interrupt the
;;> current computation and drop back to the prompt. The
;;> following keyword arguments customize the REPL:
;;>
;;> @itemlist[
;;> @item{@scheme{in:} - the input port (default @scheme{(current-input-port)})}
;;> @item{@scheme{out:} - the output port (default @scheme{(current-output-port)})}
;;> @item{@scheme{module:} - the initial module (default @scheme{(interaction-environment)})}
;;> @item{@scheme{escape:} - the command escape character (default @scheme|{#\@}|)}
;;> @item{@scheme{history:} - the initial command history}
;;> @item{@scheme{history-file:} - the file to save history to (default ~/.chibi-repl-history)}
;;> ]
;;>
;;> REPL commands in the style of @hyperlink["http://s48.org/"]{Scheme48}
;;> are available to control out-of-band properties. By default a command
;;> is written as an identifier beginning with an "@" character (which
;;> would not be a portable identifier), but this can be customized with
;;> the @scheme{escape:} keyword. The following commands are available:
;;>
;;> @itemlist[
;;> @item{@scheme|{@in [<module>]}| - switch to @var{<module>}, or the @scheme{interaction-environment} if @var{<module>} is not specified}
;;> @item{@scheme|{@config <expr>}| - evaluate @var{<expr>} in the @scheme{(config)} module}
;;> @item{@scheme|{@config-module-is <module>}| - switch the config module to @var{<module>}}
;;> @item{@scheme|{@exit}| - exit the REPL}
;;> ]
(define (repl . o)
(let* ((module (cond ((memq 'module: o) => cadr) (else #f)))
(let* ((in (cond ((memq 'in: o) => cadr) (else (current-input-port))))
(out (cond ((memq 'out: o) => cadr) (else (current-output-port))))
(escape (cond ((memq 'escape: o) => cadr) (else #\@)))
(module (cond ((memq 'module: o) => cadr) (else #f)))
(env (if module
(module-env (if (module? module)
(module-env
(if (module? module)
module
(eval `(load-module ',module) *config-env*)))
(interaction-environment)))
(history (cond ((memq 'history: o) => cadr) (else (make-history))))
(history-file
(cond ((memq 'history-file: o) => cadr)
(else (string-append (get-environment-variable "HOME")
"/.chibi-repl-history"))))
(history
(cond ((memq 'history: o) => cadr)
(else
(or (guard (exn (else #f))
(list->history
(call-with-input-file history-file read)))
(make-history)))))
(raw? (cond ((memq 'raw?: o) => cadr)
(else (member (get-environment-variable "TERM")
'("emacs" "dumb"))))))
@ -46,11 +101,11 @@
(line
(cond
(raw?
(display prompt)
(flush-output)
(read-line))
(display prompt out)
(flush-output out)
(read-line in))
(else
(edit-line
(edit-line in out
'prompt: prompt
'history: history
'complete?: buffer-complete-sexp?)))))
@ -60,7 +115,7 @@
(else
(history-commit! history line)
(cond
((and (> (string-length line) 0) (eqv? #\@ (string-ref line 0)))
((and (> (string-length line) 0) (eqv? escape (string-ref line 0)))
(let meta ((env env)
(line (substring line 1 (string-length line)))
(continue lp))
@ -84,8 +139,9 @@
((config)
(let ((expr (read/ss in)))
(cond
((and (symbol? expr)
(eqv? #\@ (string-ref (symbol->string expr) 0)))
((and
(symbol? expr)
(eqv? escape (string-ref (symbol->string expr) 0)))
(meta config-env
(substring line 6 (string-length line))
(lambda _ (continue module env config-env))))
@ -99,6 +155,7 @@
=> (lambda (m) (lp module env (module-env m))))
(else
(fail "couldn't find module:" name)))))
((exit))
(else
(fail "unknown repl command:" op))))))))
(else
@ -123,4 +180,7 @@
(display "Interrupt\n" (current-error-port))
(thread-terminate! thread))
(lambda () (thread-join! (thread-start! thread))))))
(lp module env config-env)))))))))
(lp module env config-env)))))))
(if history-file
(call-with-output-file history-file
(lambda (out) (write (history->list history) out))))))

7
lib/chibi/scribble.scm
View file

@ -1,3 +1,10 @@
;; scribble.scm - scribble parsing
;; Copyright (c) 2011 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;> A library used for parsing "scribble" format, introduced
;;> by @hyperlink["http://www.racket-lang.org/"]{Racket} and
;;> the format used to write this manual.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; general character utils

25
lib/chibi/stty.scm
View file

@ -1,3 +1,7 @@
;; Copyright (c) 2011 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;> A high-level interface to stty and ioctl.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; symbolic representation of attributes
@ -160,6 +164,14 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; high-level interface
;;> @subsubsubsection{@scheme{(stty [port] args ...)}}
;;> Set the terminal attributes for @var{port} (default
;;> @scheme{(current-output-port)}) to @var{attrs}.
;;> Attributes are specified symbolically using the
;;> names from the @rawcode{stty(1)} command. In addition,
;;> (not args ...) may be used to negate the listed symbols.
(define (stty . args)
(let* ((port (if (and (pair? args) (port? (car args)))
(car args)
@ -213,6 +225,10 @@
(else
(return iflag oflag cflag lflag))))))
;;> Run @var{thunk} with the @scheme{stty} @var{setting}s in effect
;;> during its dynamic extent, resetting the original settings
;;> when it returns.
(define (with-stty setting thunk . o)
(let* ((port (if (pair? o) (car o) (current-input-port)))
(orig-attrs (get-terminal-attributes port)))
@ -221,13 +237,22 @@
thunk
(lambda () (set-terminal-attributes! port TCSANOW orig-attrs)))))
;;> Run @var{thunk} with the "raw" (no canonical or echo) options
;;> needed for a terminal application.
(define (with-raw-io port thunk)
(with-stty '(not icanon echo) thunk port))
;;> Returns the current terminal width in characters of @var{x},
;;> which must be a port or a file descriptor.
(define (get-terminal-width x)
(let ((ws (ioctl x TIOCGWINSZ)))
(and ws (winsize-col ws))))
;;> Returns the current terminal dimensions, as a list of character width
;;> and height, of @var{x}, which must be a port or a file descriptor.
(define (get-terminal-dimensions x)
(let ((ws (ioctl x TIOCGWINSZ)))
(and ws (list (winsize-col ws) (winsize-row ws)))))

23
lib/chibi/system.stub
View file

@ -3,6 +3,12 @@
(c-system-include "pwd.h")
(c-system-include "sys/types.h")
;;> @subsubsubsection{@scheme{(user-information name-or-id)}}
;;> Returns the password entry for the given user. @var{name-or-id}
;;> should be a string indicating the user name, or an integer
;;> for the user id.
(define-c-struct passwd
predicate: user?
(string pw_name user-name)
@ -13,6 +19,10 @@
(string pw_dir user-home)
(string pw_shell user-shell))
;;> Accessors for the password entry structure returned by
;;> @scheme{user-information}.
;;/
(define-c uid_t (current-user-id "getuid") ())
(define-c gid_t (current-group-id "getgid") ())
(define-c uid_t (current-effective-user-id "geteuid") ())
@ -23,9 +33,22 @@
(define-c errno (set-current-group-id! "setgid") (gid_t))
(define-c errno (set-current-effective-group-id! "setegid") (gid_t))
;;> Accessors for the current user credentials.
;;/
;;> Returns the session id of the specified process,
;;> defaulting to the current process.
(define-c pid_t (current-session-id "getsid") ((default 0 pid_t)))
;;> Creates a new session.
(define-c pid_t (create-session "setsid") ())
;;> Set @var{string} to be the new root directory, so that
;;> paths beginning with "/" are resolved relative to the
;;> new root.
(define-c errno (set-root-directory! "chroot") (string))
(define-c errno getpwuid_r

2
lib/chibi/term/edit-line.module
View file

@ -1,6 +1,6 @@
(module (chibi term edit-line)
(export edit-line edit-line-repl make-history history-insert! history-commit!
buffer->string)
history->list list->history buffer->string)
(import-immutable (scheme) (chibi stty) (srfi 9))
(include "edit-line.scm"))

3
lib/chibi/term/edit-line.scm
View file

@ -42,6 +42,9 @@
(let ((past (history-past h)) (future (history-future h)))
(if (pair? past) (cons (car past) (append future (cdr past))) future)))
(define (list->history ls)
(%make-history (max maximum-history-size (length ls)) ls '()))
(define (history-flatten! h)
(history-past-set! h (history->list h))
(history-future-set! h '()))

4
lib/chibi/test.module
View file

@ -3,8 +3,8 @@
(export
test test-error test-assert test-not test-values
test-group current-test-group
test-begin test-end test-syntax-error test-info
test-vars test-run ;;test-exit
test-begin test-end ;; test-syntax-error ;; test-info
;; test-vars test-run ;; test-exit
current-test-verbosity current-test-epsilon current-test-comparator
current-test-applier current-test-handler current-test-skipper
current-test-group-reporter test-failure-count)

83
lib/chibi/test.scm
View file

@ -1,23 +1,12 @@
;;;; test.scm -- testing framework
;;
;; Easy to use test suite adapted from the Chicken "test" module.
;;
;; Copyright (c) 2010 Alex Shinn. All rights reserved.
;; Copyright (c) 2010-2011 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;> Simple testing framework adapted from the Chicken @scheme{test}
;;> module.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exception utilities
;; from SRFI-12, pending stabilization of an exception library for WG1
(define-syntax handle-exceptions
(syntax-rules ()
((handle-exceptions exn handler body ...)
(call-with-current-continuation
(lambda (return)
(with-exception-handler
(lambda (exn) (return handler))
(lambda () body ...)))))))
(define (warning msg . args)
(display msg (current-error-port))
(for-each (lambda (x)
@ -53,6 +42,12 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; test interface
;;> @subsubsubsection{@scheme{(test [name] expect expr)}}
;;> Evaluate @var{expr} and check that it is @scheme{equal?}
;;> to @var{expect}. @var{name} is used in reporting, and
;;> defaults to a printed summary of @var{expr}.
(define-syntax test
(syntax-rules ()
((test expect expr)
@ -70,6 +65,10 @@
(test-syntax-error 'test "2 or 3 arguments required"
(test a ...)))))
;;> @subsubsubsection{@scheme{(test-assert [name] expr)}}
;;> Like @scheme{test} but evaluates @var{expr} and checks that it's true.
(define-syntax test-assert
(syntax-rules ()
((_ expr)
@ -80,11 +79,20 @@
(test-syntax-error 'test-assert "1 or 2 arguments required"
(test a ...)))))
;;> @subsubsubsection{@scheme{(test-not [name] expr)}}
;;> Like @scheme{test} but evaluates @var{expr} and checks that it's false.
(define-syntax test-not
(syntax-rules ()
((_ expr) (test-assert (not expr)))
((_ name expr) (test-assert name (not expr)))))
;;> @subsubsubsection{@scheme{(test-values [name] expect expr)}}
;;> Like @scheme{test} but @var{expect} and @var{expr} can both
;;> return multiple values.
(define-syntax test-values
(syntax-rules ()
((_ expect expr)
@ -93,6 +101,11 @@
(test name (call-with-values (lambda () expect) (lambda results results))
(call-with-values (lambda () expr) (lambda results results))))))
;;> @subsubsubsection{@scheme{(test-error [name] expr)}}
;;> Like @scheme{test} but evaluates @var{expr} and checks that it
;;> raises an error.
(define-syntax test-error
(syntax-rules ()
((_ expr)
@ -106,6 +119,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; group interface
;;> Wraps @var{body} as a single test group, which can be filtered
;;> and summarized separately.
(define-syntax test-group
(syntax-rules ()
((_ name-expr body ...)
@ -114,13 +130,13 @@
(if (not (string? name))
(error "a name is required, got " 'name-expr name))
(test-begin name)
(handle-exceptions
exn
(begin
(guard
(exn
(else
(warning "error in group outside of tests")
(print-exception e (current-error-port))
(test-group-inc! (current-test-group) 'count)
(test-group-inc! (current-test-group) 'ERROR))
(test-group-inc! (current-test-group) 'ERROR)))
body ...)
(test-end name)
(current-test-group old-group)))))
@ -320,21 +336,21 @@
(display (make-string indent #\space)))
(test-print-name info indent)
(let ((expect-val
(handle-exceptions
exn
(begin
(guard
(exn
(else
(warning "bad expect value")
(print-exception exn (current-error-port))
#f)
#f))
(expect))))
(handle-exceptions
exn
(begin
(guard
(exn
(else
((current-test-handler)
(if (assq-ref info 'expect-error) 'PASS 'ERROR)
expect
expr
(append `((exception . ,exn)) info)))
(append `((exception . ,exn)) info))))
(let ((res (expr)))
(let ((status
(if (and (not (assq-ref info 'expect-error))
@ -528,6 +544,8 @@
(display (make-string (max 0 (- (current-column-width) len)) #\-))
(newline)))
;;> Begin testing a new group until the closing @scheme{(test-end)}.
(define (test-begin . o)
(let* ((name (if (pair? o) (car o) ""))
(group (make-test-group name))
@ -557,6 +575,9 @@
(not (every (lambda (f) (f group)) (current-test-group-filters)))))
(current-test-group group)))
;;> Ends testing group introduced with @scheme{(test-begin)}, and
;;> summarizes the results.
(define (test-end . o)
(cond
((current-test-group)
@ -625,14 +646,14 @@
(cond
((get-environment-variable name)
=> (lambda (s)
(handle-exceptions
exn
(begin
(guard
(exn
(else
(warning
(string-append "invalid filter '" s
"' from environment variable: " name))
(print-exception exn (current-error-port))
'())
'()))
(let ((f (proc s)))
(list (if (and (pair? o) (car o))
(lambda (x) (not (f x)))