This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=a653d32a8d02c90a426232de5b432e60fc33c1da The branch, master has been updated via a653d32a8d02c90a426232de5b432e60fc33c1da (commit) via 8fdd85f834aa1e0ed76542cdc8ce63d323dc6c1e (commit) from 6349a556298edc3e11b88bb45a59c545823a0755 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit a653d32a8d02c90a426232de5b432e60fc33c1da Author: Andreas Rottmann <[email protected]> Date: Sat Nov 20 18:40:30 2010 +0100 Fix missing port-table locking and bytevector output port segfault * libguile/r6rs-ports.c (make_bip, make_cbip, make_bop, make_cbop): Lock the port table. * libguile/r6rs-ports.c (make_bop): Let the returned extraction procedure refer to the port's buffer instead of the port itself. This fixes a segfault if the port is closed before the extraction procedure is called. (bop_proc_apply): Adapt accordingly. * test-suite/tests/r6rs-ports.test (8.2.10 Output ports): Add testcase for extraction after close. Signed-off-by: Ludovic Courtès <[email protected]> commit 8fdd85f834aa1e0ed76542cdc8ce63d323dc6c1e Author: Andreas Rottmann <[email protected]> Date: Sat Nov 20 23:14:05 2010 +0100 Allow user-defined meta-commands Besides allowing user-defined meta-commands, this change also refactors the meta-command machinery to split reading a command's arguments from the procedure actually implementing it, and hence allows nesting meta-commands. As an example of such a command, ",in" is added as a new meta-command. * module/system/repl/command.scm: Export `define-meta-command'. (*command-module*): Replaced by the hash table `*command-infos*'. (command-info, make-command-info, command-info-procedure) (command-info-arguments-reader): New procedures, encapsulating the information about a meta-command. (command-procedure): Adapted to use the `command-info' lookup procedure. (read-command-arguments): New auxiliary procedure invoking a command's argument reader procedure. (meta-command): Adapted to the split of reading arguments and executing a command. (add-meta-command!): New auxiliary procedure, registers a meta command's procedure and argument reader into `*command-infos* and `*command-table*. (define-meta-command): Extended to allow specification of the command's category; split the argument reader and actual command procedure. (guile:apropos, guile:load, guile:compile-file, guile:gc): Remove these aliases, they are unnecessary as we now use a hash table instead of the module to store the commands. (in): New meta-command, which evaluates an expression, or alternatively executes another meta-command, in the context of a specific module. * doc/ref/scheme-using.texi (Module Commands): Document the `in' meta-command. Signed-off-by: Ludovic Courtès <[email protected]> ----------------------------------------------------------------------- Summary of changes: doc/ref/scheme-using.texi | 7 ++ libguile/r6rs-ports.c | 24 +++++-- module/system/repl/command.scm | 135 ++++++++++++++++++++++++++------------ test-suite/tests/r6rs-ports.test | 8 ++ 4 files changed, 127 insertions(+), 47 deletions(-) diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 223295c..7700cbe 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -227,6 +227,13 @@ Load a file in the current module. List current bindings. @end deffn +...@deffn {REPL Command} in module expression +...@deffnx {REPL Command} in module command [args ...] +Evaluate an expression, or alternatively, execute another meta-command +in the context of a module. For example, @samp{,in (foo bar) ,binding} +will show the bindings in the module @code{(foo bar)}. +...@end deffn + @node Language Commands @subsubsection Language Commands diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 968b329..ea6200f 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -84,6 +84,8 @@ make_bip (SCM bv) scm_t_port *c_port; const unsigned long mode_bits = SCM_OPN | SCM_RDNG; + scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex); + port = scm_new_port_table_entry (bytevector_input_port_type); /* Prevent BV from being GC'd. */ @@ -101,6 +103,8 @@ make_bip (SCM bv) /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */ SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits); + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + return port; } @@ -305,6 +309,8 @@ make_cbip (SCM read_proc, SCM get_position_proc, SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc); SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc); + scm_i_pthread_mutex_lock (&scm_i_port_table_mutex); + port = scm_new_port_table_entry (custom_binary_input_port_type); /* Attach it the method vector. */ @@ -319,6 +325,8 @@ make_cbip (SCM read_proc, SCM get_position_proc, /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */ SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits); + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + return port; } @@ -812,6 +820,8 @@ make_bop (void) scm_t_bop_buffer *buf; const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + scm_i_pthread_mutex_lock (&scm_i_port_table_mutex); + port = scm_new_port_table_entry (bytevector_output_port_type); buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP); @@ -826,9 +836,10 @@ make_bop (void) /* Mark PORT as open and writable. */ SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits); + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + /* Make the bop procedure. */ - SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, - SCM_PACK (port)); + SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf); return (scm_values (scm_list_2 (port, bop_proc))); } @@ -889,11 +900,10 @@ bop_seek (SCM port, scm_t_off offset, int whence) SCM_SMOB_APPLY (bytevector_output_port_procedure, bop_proc_apply, 0, 0, 0, (SCM bop_proc)) { - SCM port, bv; + SCM bv; scm_t_bop_buffer *buf, result_buf; - port = SCM_PACK (SCM_SMOB_DATA (bop_proc)); - buf = SCM_BOP_BUFFER (port); + buf = (scm_t_bop_buffer *) SCM_SMOB_DATA (bop_proc); result_buf = *buf; bop_buffer_init (buf); @@ -966,6 +976,8 @@ make_cbop (SCM write_proc, SCM get_position_proc, SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc); SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc); + scm_i_pthread_mutex_lock (&scm_i_port_table_mutex); + port = scm_new_port_table_entry (custom_binary_output_port_type); /* Attach it the method vector. */ @@ -979,6 +991,8 @@ make_cbop (SCM write_proc, SCM get_position_proc, /* Mark PORT as open, writable and unbuffered. */ SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits); + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + return port; } diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 94bb863..08f1c9e 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -41,7 +41,7 @@ #:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp))) #:use-module ((system vm inspect) #:select ((inspect . %inspect))) #:use-module (statprof) - #:export (meta-command)) + #:export (meta-command define-meta-command)) ;;; @@ -50,7 +50,7 @@ (define *command-table* '((help (help h) (show) (apropos a) (describe d)) - (module (module m) (import use) (load l) (binding b)) + (module (module m) (import use) (load l) (binding b) (in)) (language (language L)) (compile (compile c) (compile-file cc) (disassemble x) (disassemble-file xx)) @@ -74,12 +74,22 @@ (define (group-name g) (car g)) (define (group-commands g) (cdr g)) -(define *command-module* (current-module)) +(define *command-infos* (make-hash-table)) (define (command-name c) (car c)) (define (command-abbrevs c) (cdr c)) -(define (command-procedure c) (module-ref *command-module* (command-name c))) +(define (command-info c) (hashq-ref *command-infos* (command-name c))) +(define (command-procedure c) (command-info-procedure (command-info c))) (define (command-doc c) (procedure-documentation (command-procedure c))) +(define (make-command-info proc arguments-reader) + (cons proc arguments-reader)) + +(define (command-info-procedure info) + (car info)) + +(define (command-info-arguments-reader info) + (cdr info)) + (define (command-usage c) (let ((doc (command-doc c))) (substring doc 0 (string-index doc #\newline)))) @@ -148,6 +158,9 @@ (force-output) *unspecified*))) +(define (read-command-arguments c repl) + ((command-info-arguments-reader (command-info c)) repl)) + (define (meta-command repl) (let ((command (read-command repl))) (cond @@ -155,40 +168,56 @@ ((not (symbol? command)) (format #t "Meta-command not a symbol: ~s~%" command)) ((lookup-command command) - => (lambda (c) ((command-procedure c) repl))) + => (lambda (c) + (and=> (read-command-arguments c repl) + (lambda (args) (apply (command-procedure c) repl args))))) (else (format #t "Unknown meta command: ~A~%" command))))) +(define (add-meta-command! name category proc argument-reader) + (hashq-set! *command-infos* name (make-command-info proc argument-reader)) + (if category + (let ((entry (assq category *command-table*))) + (if entry + (set-cdr! entry (append (cdr entry) (list (list name)))) + (set! *command-table* + (append *command-table* + (list (list category (list name))))))))) + (define-syntax define-meta-command (syntax-rules () - ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...) - (define (name repl) - docstring - (define (handle-read-error form-name key args) - (pmatch args - ((,subr ,msg ,args . ,rest) - (format #t "Throw to key `~a' while reading ~...@[argument `~A' of ~]command `~A':\n" - key form-name 'name) - (display-error #f (current-output-port) subr msg args rest)) - (else - (format #t "Throw to key `~a' with args `~s' while reading ~...@[ argument `~A' of ~]command `~A'.\n" - key args form-name 'name))) - (abort)) - - (% (let* ((expression0 - (catch #t - (lambda () - (repl-reader - "" - (lambda* (#:optional (port (current-input-port))) - ((language-reader (repl-language repl)) - port (current-module))))) - (lambda (k . args) - (handle-read-error 'expression0 k args)))) - ...) - (apply (lambda* datums - b0 b1 ...) + ((_ ((name category) repl (expression0 ...) . datums) docstring b0 b1 ...) + (add-meta-command! + 'name + 'category + (lambda* (repl expression0 ... . datums) + docstring + b0 b1 ...) + (lambda (repl) + (define (handle-read-error form-name key args) + (pmatch args + ((,subr ,msg ,args . ,rest) + (format #t "Throw to key `~a' while reading ~...@[argument `~A' of ~]command `~A':\n" + key form-name 'name) + (display-error #f (current-output-port) subr msg args rest)) + (else + (format #t "Throw to key `~a' with args `~s' while reading ~...@[ argument `~A' of ~]command `~A'.\n" + key args form-name 'name))) + (abort)) + (% (let* ((expression0 (catch #t + (lambda () + (repl-reader + "" + (lambda* (#:optional (port (current-input-port))) + ((language-reader (repl-language repl)) + port (current-module))))) + (lambda (k . args) + (handle-read-error 'expression0 k args)))) + ...) + (append + (list expression0 ...) + (catch #t (lambda () (let ((port (open-input-string (read-line)))) (let lp ((out '())) @@ -198,10 +227,18 @@ (lp (cons x out))))))) (lambda (k . args) (handle-read-error #f k args))))) - (lambda (k) #f)))) ; the abort handler + (lambda (k) #f))))) ; the abort handler + + ((_ ((name category) repl . datums) docstring b0 b1 ...) + (define-meta-command ((name category) repl () . datums) + docstring b0 b1 ...)) + + ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...) + (define-meta-command ((name #f) repl (expression0 ...) . datums) + docstring b0 b1 ...)) ((_ (name repl . datums) docstring b0 b1 ...) - (define-meta-command (name repl () . datums) + (define-meta-command ((name #f) repl () . datums) docstring b0 b1 ...)))) @@ -292,11 +329,10 @@ Version information." (display *version*) (newline)) -(define guile:apropos apropos) (define-meta-command (apropos repl regexp) "apropos REGEXP Find bindings/modules/packages." - (guile:apropos (->string regexp))) + (apropos (->string regexp))) (define-meta-command (describe repl (form)) "describe OBJ @@ -350,11 +386,10 @@ Import modules / List those imported." (for-each puts (map module-name (module-uses (current-module)))) (for-each use args)))) -(define guile:load load) (define-meta-command (load repl file) "load FILE Load a file in the current module." - (guile:load (->string file))) + (load (->string file))) (define-meta-command (binding repl) "binding @@ -362,6 +397,24 @@ List current bindings." (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v)) (current-module))) +(define-meta-command (in repl module command-or-expression . args) + "in MODULE COMMAND-OR-EXPRESSION +Evaluate an expression or command in the context of module." + (let ((m (resolve-module module #:ensure #f))) + (if m + (pmatch command-or-expression + (('unquote ,command) (guard (lookup-command command)) + (save-module-excursion + (lambda () + (set-current-module m) + (apply (command-procedure (lookup-command command)) repl args)))) + (,expression + (guard (null? args)) + (repl-print repl (eval expression m))) + (else + (format #t "Invalid arguments to `in': expected a single expression or a command.\n"))) + (format #t "No such module: ~s\n" module)))) + ;;; ;;; Language commands @@ -388,11 +441,10 @@ Generate compiled code." (cond ((objcode? x) (guile:disassemble x)) (else (repl-print repl x))))) -(define guile:compile-file compile-file) (define-meta-command (compile-file repl file . opts) "compile-file FILE Compile a file." - (guile:compile-file (->string file) #:opts opts)) + (compile-file (->string file) #:opts opts)) (define (guile:disassemble x) ((@ (language assembly disassemble) disassemble) x)) @@ -775,11 +827,10 @@ Pretty-print the result(s) of evaluating EXP." ;;; System commands ;;; -(define guile:gc gc) (define-meta-command (gc repl) "gc Garbage collection." - (guile:gc)) + (gc)) (define-meta-command (statistics repl) "statistics diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 7d80ed7..56ecbb6 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -395,6 +395,14 @@ (put-bytevector port source) (and (bytevector=? (get-content) source) (bytevector=? (get-content) (make-bytevector 0)))))) + + (pass-if "open-bytevector-output-port [extract after close]" + (let-values (((port get-content) + (open-bytevector-output-port))) + (let ((source (make-bytevector 12345 #xFE))) + (put-bytevector port source) + (close-port port) + (bytevector=? (get-content) source)))) (pass-if "open-bytevector-output-port [put-u8]" (let-values (((port get-content) hooks/post-receive -- GNU Guile
