[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-94-ga653d32

[Ludovic Courtès]

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 <address@hidden>
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 <address@hidden>

commit 8fdd85f834aa1e0ed76542cdc8ce63d323dc6c1e
Author: Andreas Rottmann <address@hidden>
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 <address@hidden>

-----------------------------------------------------------------------

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
 
address@hidden {REPL Command} in module expression
address@hidden {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)}.
address@hidden 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 address@hidden `~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 
address@hidden 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 address@hidden `~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 
address@hidden 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