From 3bdc8f4d17a5506b0e5d21917c2bb5f942562a54 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 19 Sep 2003 01:06:14 +0000 Subject: [PATCH 001/239] * tests/popen.test: New file. * Makefile.am (SCM_TESTS): Add it. --- test-suite/Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 4a34bd868..3b990378e 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -23,6 +23,7 @@ SCM_TESTS = tests/alist.test \ tests/numbers.test \ tests/optargs.test \ tests/options.test \ + tests/popen.test \ tests/ports.test \ tests/posix.test \ tests/r4rs.test \ From 9b4bbf4752c9f877b1f52df24df142e8e2c16c4e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 19 Sep 2003 01:19:48 +0000 Subject: [PATCH 002/239] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 210613912..9b3809aa3 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2003-09-19 Kevin Ryde + + * popen.scm (open-process): Correction to previous fdes closing + change, need to watch out for stdin==stderr or stdout==stderr. + 2003-09-15 Marius Vollmer * format.scm (format): Rewritten as a big letrec to make it From 518a07ad841ca3216a685f6357963d8eb9321055 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 19 Sep 2003 01:29:17 +0000 Subject: [PATCH 003/239] *** empty log message *** --- test-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 35500f904..788505d35 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2003-09-19 Kevin Ryde + + * tests/popen.test: New file. + * Makefile.am (SCM_TESTS): Add it. + 2003-09-17 Dirk Herrmann * tests/numbers.test (equal?): Added tests. From 69fc37da2982158bbb099a1ca4e8d2450d9d46f4 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 19 Sep 2003 01:30:54 +0000 Subject: [PATCH 004/239] Add ice-9 popen duplicate pipe fd fix. --- NEWS | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/NEWS b/NEWS index a0f3a9e98..bea090b6d 100644 --- a/NEWS +++ b/NEWS @@ -468,6 +468,13 @@ chapter in the reference manual. There is no replacement for undefine. +** (ice-9 popen) duplicate pipe fd fix + +open-pipe, open-input-pipe and open-output-pipe left an extra copy of +their pipe file descriptor in the child, which was normally harmless, +but it can prevent the parent seeing eof or a broken pipe immediately +and has now been fixed. + ** source-properties and set-source-properties! fix Properties set with set-source-properties! can now be read back From ad1c1f1808757c496ea0b2d3c033302d22e0480d Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 21 Sep 2003 01:18:26 +0000 Subject: [PATCH 005/239] (File System): In access?, reword a bit, clarify real versus effective ID handling, cross reference glibc on that, and recommend against access tests in library functions. --- doc/ref/posix.texi | 42 +++++++++++++++++++++++++++++------------- 1 file changed, 29 insertions(+), 13 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index e70357f8a..ede58ca1b 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -538,29 +538,45 @@ contents; syncing the file system and creating special files. @deffn {Scheme Procedure} access? path how @deffnx {C Function} scm_access (path, how) -Return @code{#t} if @var{path} corresponds to an existing file -and the current process has the type of access specified by -@var{how}, otherwise @code{#f}. @var{how} should be specified -using the values of the variables listed below. Multiple -values can be combined using a bitwise or, in which case -@code{#t} will only be returned if all accesses are granted. +Test accessibility of a file under the real UID and GID of the calling +process. The return is @code{#t} if @var{path} exists and the +permissions requested by @var{how} are all allowed, or @code{#f} if +not. -Permissions are checked using the real id of the current -process, not the effective id, although it's the effective id -which determines whether the access would actually be granted. +@var{how} is an integer which is one of the following values, or a +bitwise-OR (@code{logior}) of multiple values. @defvar R_OK -test for read permission. +Test for read permission. @end defvar @defvar W_OK -test for write permission. +Test for write permission. @end defvar @defvar X_OK -test for execute permission. +Test for execute permission. @end defvar @defvar F_OK -test for existence of the file. +Test for existence of the file. This is implied by each of the other +tests, so there's no need to combine it with them. @end defvar + +It's important to note that @code{access?} does not simply indicate +what will happen on attempting to read or write a file. In normal +circumstances it does, but in a set-UID or set-GID program it doesn't +because @code{access?} tests the real ID, whereas an open or execute +attempt uses the effective ID. + +A program which will never run set-UID/GID can ignore the difference +between real and effective IDs, but for maximum generality, especially +in library functions, it's generally best not to use @code{access?} to +predict the result of an open or execute, instead simply attempt that +and catch any exception. + +The main use for @code{access?} is to let a set-UID/GID program +determine what the invoking user would have been allowed to do, +without the greater (or perhaps lesser) privileges afforded by the +effective ID. For more on this, see @ref{Testing File Access,,, libc, +The GNU C Library Reference Manual}. @end deffn @findex fstat From a21ceb528dad5cd665d60f1efbeb74a70a31b0b3 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 21 Sep 2003 01:19:44 +0000 Subject: [PATCH 006/239] *** empty log message *** --- doc/ref/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index cae68f25b..a1e63aa4c 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,9 @@ +2003-09-21 Kevin Ryde + + * posix.texi (File System): In access?, reword a bit, clarify real + versus effective ID handling, cross reference glibc on that, and + recommend against access tests in library functions. + 2003-09-13 Kevin Ryde * posix.texi (File System): In stat:dev and stat:mode, clarify that From 1cd9ea691590c3e4ea7bc5ff7c68e427b7bc9354 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 21 Sep 2003 01:38:01 +0000 Subject: [PATCH 007/239] A tweak to: (File System): In access?, reword a bit, clarify real versus effective ID handling, cross reference glibc on that, and recommend against access tests in library functions. --- doc/ref/posix.texi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index ede58ca1b..1eb29f47d 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -568,9 +568,9 @@ attempt uses the effective ID. A program which will never run set-UID/GID can ignore the difference between real and effective IDs, but for maximum generality, especially -in library functions, it's generally best not to use @code{access?} to -predict the result of an open or execute, instead simply attempt that -and catch any exception. +in library functions, it's best not to use @code{access?} to predict +the result of an open or execute, instead simply attempt that and +catch any exception. The main use for @code{access?} is to let a set-UID/GID program determine what the invoking user would have been allowed to do, From f03314f9201704e8287f97f47a89db561ede7a93 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 21 Sep 2003 07:54:23 +0000 Subject: [PATCH 008/239] * numbers.h (SCM_INEXACTP): Removed uses of SCM_TYP16S. * tags.h, deprecated.h (SCM_TYP16S): Deprecated and moved from tags.h to deprecated.h. --- NEWS | 27 +++++++++++++++++++++++++++ libguile/ChangeLog | 7 +++++++ libguile/deprecated.h | 5 +++++ libguile/numbers.h | 6 ++++-- libguile/tags.h | 3 +-- 5 files changed, 44 insertions(+), 4 deletions(-) diff --git a/NEWS b/NEWS index bea090b6d..62ea3371a 100644 --- a/NEWS +++ b/NEWS @@ -637,6 +637,33 @@ Guile always defines scm_t_timespec +** The macro SCM_IFLAGP now only returns true for flags + +User code should never have used this macro anyway. And, you should not use +it in the future either. Thus, the following explanation is just for the +impropable case that your code actually made use of this macro, and that you +are willing to depend on internals which will probably change in the near +future. + +Formerly, SCM_IFLAGP also returned true for evaluator bytecodes created with +SCM_MAKSPCSYM (short instructions) and evaluator bytecodes created with +SCM_MAKISYM (short instructions). Now, SCM_IFLAG only returns true for +Guile's special constants created with SCM_MAKIFLAG. To achieve the old +behaviour, instead of + + SCM_IFLAGP(x) + +you would have to write + + (SCM_ISYMP(x) || SCM_IFLAGP(x)) + +** The macro SCM_TYP16S has been deprecated. + +This macro is not intended for public use. However, if you allocated types +with tc16 type codes in a way that you would have needed this macro, you are +expected to have a deep knowledge of Guile's type system. Thus, you should +know how to replace this macro. + ** The macro SCM_SLOPPY_INEXACTP has been deprecated. Use SCM_INEXACTP instead. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0c1445e19..b4f6e947d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2003-09-18 Dirk Herrmann + + * numbers.h (SCM_INEXACTP): Removed uses of SCM_TYP16S. + + * tags.h, deprecated.h (SCM_TYP16S): Deprecated and moved from + tags.h to deprecated.h. + 2003-09-18 Dirk Herrmann This set of patches introduces a new tc7 code scm_tc7_number for diff --git a/libguile/deprecated.h b/libguile/deprecated.h index c16ad93a2..1b76ae2ed 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -27,6 +27,11 @@ #if (SCM_ENABLE_DEPRECATED == 1) +/* From tags.h: Macro checking for two tc16 types that are allocated to differ + * only in the 's'-bit. Deprecated in guile 1.7.0 on 2003-09-21. */ +#define SCM_TYP16S(x) (0xfeff & SCM_CELL_TYPE (x)) + + /* From numbers.h: Macros checking for types, but avoiding a redundant check * for !SCM_IMP. These were deprecated in guile 1.7.0 on 2003-09-06. */ #define SCM_SLOPPY_INEXACTP(x) (SCM_TYP16S (x) == scm_tc16_real) diff --git a/libguile/numbers.h b/libguile/numbers.h index 10e8eddc9..8bf211d6f 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -126,12 +126,14 @@ * differ in one bit: This way, checking if an object is an inexact number can * be done quickly (using the TYP16S macro). */ -/* Number subtype 1 to 3 (note the dependency on the predicate SCM_NUMP) */ +/* Number subtype 1 to 3 (note the dependency on the predicates SCM_INEXACTP + * and SCM_NUMP) */ #define scm_tc16_big (scm_tc7_number + 1 * 256L) #define scm_tc16_real (scm_tc7_number + 2 * 256L) #define scm_tc16_complex (scm_tc7_number + 3 * 256L) -#define SCM_INEXACTP(x) (!SCM_IMP (x) && SCM_TYP16S (x) == scm_tc16_real) +#define SCM_INEXACTP(x) \ + (!SCM_IMP (x) && (0xfeff & SCM_CELL_TYPE (x)) == scm_tc16_real) #define SCM_REALP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_real) #define SCM_COMPLEXP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_complex) diff --git a/libguile/tags.h b/libguile/tags.h index aeff81300..d001a9d83 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -468,10 +468,9 @@ typedef unsigned long scm_t_bits; /* Definitions for tc16: */ #define SCM_TYP16(x) (0xffff & SCM_CELL_TYPE (x)) -#define SCM_TYP16S(x) (0xfeff & SCM_CELL_TYPE (x)) - #define SCM_TYP16_PREDICATE(tag, x) (!SCM_IMP (x) && SCM_TYP16 (x) == (tag)) + /* Here is the first smob subtype. */ /* scm_tc_free_cell is the 0th smob type. We place this in free cells to tell From 8aa28a916c8b387fa8bf4da3defd5d811f2cae61 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 22 Sep 2003 19:00:41 +0000 Subject: [PATCH 009/239] * guile-test: Wrapped in module (test-suite guile-test). (main data-file-name test-file-name): Exported. ((guile-user)::main): New function, wrapper for function (test-suite guile-test)::main. * tests/load.test: Wrapped in module (test-suite test-load). * tests/ports.test: Wrapped in module (test-suite test-ports). * tests/r4rs.test: Wrapped in module (test-suite test-r4rs). Added comments about the required structure of the file itself, since it is subject to some tests. Removed some now unnecessary undefine operations. * tests/syntax.test: Wrapped in module (test-suite test-syntax) --- test-suite/ChangeLog | 20 ++++++++++++++++++++ test-suite/guile-test | 17 +++++++++++------ test-suite/tests/load.test | 4 +++- test-suite/tests/ports.test | 8 +++++--- test-suite/tests/r4rs.test | 19 +++++++++++++------ test-suite/tests/syntax.test | 2 ++ 6 files changed, 54 insertions(+), 16 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 788505d35..6c55cd73a 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,23 @@ +2003-09-22 Dirk Herrmann + + * guile-test: Wrapped in module (test-suite guile-test). + + (main data-file-name test-file-name): Exported. + + ((guile-user)::main): New function, wrapper for function + (test-suite guile-test)::main. + + * tests/load.test: Wrapped in module (test-suite test-load). + + * tests/ports.test: Wrapped in module (test-suite test-ports). + + * tests/r4rs.test: Wrapped in module (test-suite test-r4rs). + Added comments about the required structure of the file itself, + since it is subject to some tests. Removed some now unnecessary + undefine operations. + + * tests/syntax.test: Wrapped in module (test-suite test-syntax) + 2003-09-19 Kevin Ryde * tests/popen.test: New file. diff --git a/test-suite/guile-test b/test-suite/guile-test index 9cdbb374b..226892a80 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -76,17 +76,22 @@ ;;;; change which Guile interpreter you're testing, you need to edit ;;;; the #! line at the top of this file, which is stupid. +(define (main . args) + (let ((module (resolve-module '(test-suite guile-test)))) + (apply (module-ref module 'main) args))) + +(define-module (test-suite guile-test) + :use-module (test-suite lib) + :use-module (ice-9 getopt-long) + :use-module (ice-9 and-let-star) + :use-module (ice-9 rdelim) + :export (main data-file-name test-file-name)) + ;;; User configurable settings: (define default-test-suite (string-append (getenv "HOME") "/bogus-path/test-suite")) - -(use-modules (test-suite lib) - (ice-9 getopt-long) - (ice-9 and-let-star) - (ice-9 rdelim)) - ;;; Variables that will receive their actual values later. (define test-suite default-test-suite) diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test index 6b0de7612..d6dff96b4 100644 --- a/test-suite/tests/load.test +++ b/test-suite/tests/load.test @@ -18,7 +18,9 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -(use-modules (test-suite lib)) +(define-module (test-suite test-load) + :use-module (test-suite lib) + :use-module (test-suite guile-test)) (define temp-dir (data-file-name "load-test.dir")) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index cc46ee855..9b9eb2f80 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -18,9 +18,11 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -(use-modules (test-suite lib) - (ice-9 popen) - (ice-9 rdelim)) +(define-module (test-suite test-ports) + :use-module (test-suite lib) + :use-module (test-suite guile-test) + :use-module (ice-9 popen) + :use-module (ice-9 rdelim)) (define (display-line . args) (for-each display args) diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test index 08065c62d..347d05dfa 100644 --- a/test-suite/tests/r4rs.test +++ b/test-suite/tests/r4rs.test @@ -15,6 +15,10 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +(define-module (test-suite test-r4rs) + :use-module (test-suite lib) + :use-module (test-suite guile-test)) + ;;;; ============= NOTE ============= @@ -62,7 +66,15 @@ ;;; send corrections or additions to jaffer@ai.mit.edu or ;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA +;; Note: The following two expressions are being read as part of the tests in +;; section (6 10 2). Those tests expect that above the following two +;; expressions there should be only one arbitrary s-expression (which is the +;; define-module expression). Further, the two expressions should be written +;; on one single line without a blank between them. If you change this, you +;; will also have to change the corresponding tests in section (6 10 2). + (define cur-section '())(define errs '()) + (define SECTION (lambda args (set! cur-section args) #t)) (define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) @@ -916,6 +928,7 @@ (SECTION 6 10 2) (test #\; peek-char this-file) (test #\; read-char this-file) +(read this-file) ;; skip define-module expression (test '(define cur-section '()) read this-file) (test #\( peek-char this-file) (test '(define errs '()) read this-file) @@ -988,12 +1001,6 @@ (test-delay) "last item in file" - -;; FIXME: We shouldn't create any global bindings in the test files or -;; alternatively execute every test file's code in a module of its own -(if (defined? 'x) (undefine x)) -(if (defined? 'y) (undefine y)) - (delete-file (data-file-name "tmp1")) (delete-file (data-file-name "tmp2")) (delete-file (data-file-name "tmp3")) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 6aa33eebb..38a77c3db 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -17,6 +17,8 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +(define-module (test-suite test-syntax) + :use-module (test-suite lib)) (define exception:bad-bindings (cons 'misc-error "^bad bindings")) From 79b1c5b67f7528f96829db0699c8edc41df5e5f6 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 25 Sep 2003 20:32:10 +0000 Subject: [PATCH 010/239] Work (in progress) on new debugging frontend. --- emacs/gds.el | 748 +++++++++++++++++++++++++++++++++++ ice-9/ChangeLog | 19 + ice-9/debugger.scm | 24 +- ice-9/debugger/Makefile.am | 2 +- ice-9/debugger/behaviour.scm | 43 +- ice-9/debugger/commands.scm | 19 +- ice-9/debugger/ui-client.scm | 242 ++++++++++++ ice-9/debugger/ui-server.scm | 0 8 files changed, 1072 insertions(+), 25 deletions(-) create mode 100644 emacs/gds.el create mode 100644 ice-9/debugger/ui-client.scm create mode 100644 ice-9/debugger/ui-server.scm diff --git a/emacs/gds.el b/emacs/gds.el new file mode 100644 index 000000000..cd60498aa --- /dev/null +++ b/emacs/gds.el @@ -0,0 +1,748 @@ +;;; gds.el -- Guile debugging frontend + +;;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later +;;;; version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA + + +;;;; Prerequisites. + +(require 'widget) +(require 'wid-edit) + + +;;;; Debugging (of this code!). + +(defsubst dmessage (msg &rest args) + ;;(apply (function message) msg args) + ) + + +;;;; Customization group setup. + +(defgroup gds nil + "Customization options for Guile Debugging." + :group 'scheme) + + +;;;; Communication with the (ice-9 debugger ui-server) subprocess. + +;; The subprocess object. +(defvar gds-process nil) + +;; Subprocess output goes into the `*GDS Process*' buffer, and +;; is then read from there one form at a time. `gds-read-cursor' is +;; the buffer position of the start of the next unread form. +(defvar gds-read-cursor nil) + +;; Start (or restart) the subprocess. +(defun gds-start () + (if gds-process (gds-shutdown)) + (with-current-buffer (get-buffer-create "*GDS Process*") + (erase-buffer) + (setq gds-process + (let ((process-connection-type nil)) ; use a pipe + (start-process "gds" + (current-buffer) + "guile" + "-q" + "--debug" + "-e" + "run" + "-s" + "/home/neil/Guile/cvs/guile-core/ice-9/debugger/ui-server.scm")))) + (setq gds-read-cursor (point-min)) + (set-process-filter gds-process (function gds-filter)) + (set-process-sentinel gds-process (function gds-sentinel)) + (set-process-coding-system gds-process 'latin-1-unix)) + +;; Shutdown the subprocess and cleanup all associated data. +(defun gds-shutdown () + ;; Do cleanup for all clients. + (while gds-names + (gds-client-cleanup (caar gds-names))) + ;; Reset any remaining variables. + (setq gds-displayed-client nil + gds-waiting nil) + ;; If the timer is running, cancel it. + (if gds-timer + (cancel-timer gds-timer)) + (setq gds-timer nil) + ;; Kill the subprocess. + (process-kill-without-query gds-process) + (condition-case nil + (progn + (kill-process gds-process) + (accept-process-output gds-process 0 200)) + (error)) + (setq gds-process nil)) + +;; Subprocess output filter: inserts normally into the process buffer, +;; then tries to reread the output one form at a time and delegates +;; processing of each form to `gds-handle-input'. +(defun gds-filter (proc string) + (with-current-buffer (process-buffer proc) + (save-excursion + (goto-char (process-mark proc)) + (insert-before-markers string)) + (goto-char gds-read-cursor) + (while (let ((form (condition-case nil + (read (current-buffer)) + (error nil)))) + (if form + (save-excursion + (gds-handle-input form))) + form) + (setq gds-read-cursor (point))))) + +;; Subprocess sentinel: do nothing. (Currently just here to avoid +;; inserting un-`read'able process status messages into the process +;; buffer.) +(defun gds-sentinel (proc event) + ) + +;; Send input to the subprocess. +(defun gds-send (string) + (process-send-string gds-process string)) + + +;;;; Multiple application scheduling. + +;; At any moment one Guile application has the focus of the frontend +;; code. `gds-displayed-client' holds the port number of that client. +;; If there are no Guile applications wanting the focus - that is, +;; ready for debugging instructions - `gds-displayed-client' is nil. +(defvar gds-displayed-client nil) + +;; The list of other Guile applications waiting for focus, referenced +;; by their port numbers. +(defvar gds-waiting nil) + +;; An idle timer that we use to avoid confusing any user work when +;; popping up debug buffers. `gds-timer' is non-nil whenever the +;; timer is running and nil whenever it is not running. +(defvar gds-timer nil) + +;; Debug the specified client. If it already has the focus, do so +;; immediately, but using the idle timer to ensure that it doesn't +;; confuse any work the user may be doing. Non-structural work is +;; delegated to `gds-display-state'. +(defun gds-debug (&optional client) + (dmessage "gds-debug") + ;; If `client' is specified, add it to the end of `gds-waiting', + ;; unless that client is already the current client or it is already + ;; in the waiting list. + (if (and client + (not (eq client gds-displayed-client)) + (not (memq client gds-waiting))) + (setq gds-waiting (append gds-waiting (list client)))) + ;; Now update `client' to be the next client in the list. + (setq client (or gds-displayed-client (car gds-waiting))) + ;; If conditions are right, start the idle timer. + (if (and client + (or (null gds-displayed-client) + (eq gds-displayed-client client))) + (gds-display-state (or gds-displayed-client + (prog1 (car gds-waiting) + (setq gds-waiting + (cdr gds-waiting))))))) + +;; Give up focus because debugging is done for now. Display detail in +;; case of no waiting clients is delegated to `gds-clear-display'. +(defun gds-focus-done () + (gds-clear-display) + (gds-debug)) + +;; Although debugging of this client isn't done, yield focus to the +;; next waiting client. +(defun gds-focus-yield () + (interactive) + (if (and (null gds-waiting) + (y-or-n-p "No other clients waiting - bury *Guile Debug* buffer? ")) + (bury-buffer) + (or (memq gds-displayed-client gds-waiting) + (setq gds-waiting (append gds-waiting (list gds-displayed-client)))) + (gds-focus-done))) + + +;;;; Per-client state information. + +;; Alist mapping client port numbers to application names. The names +;; in this list have been uniquified by `gds-uniquify'. +(defvar gds-names nil) + +;; Return unique form of NAME. +(defun gds-uniquify (name) + (let ((count 1) + (maybe-unique name)) + (while (member maybe-unique (mapcar (function cdr) gds-names)) + (setq count (1+ count) + maybe-unique (concat name "<" (number-to-string count) ">"))) + maybe-unique)) + +;; Alist mapping client port numbers to last known status. +;; +;; Status is one of the following symbols. +;; +;; `running' - application is running. +;; +;; `waiting-for-input' - application is blocked waiting for +;; instruction from the frontend. +;; +;; `ready-for-input' - application is not blocked but can also +;; accept asynchronous instructions from the frontend. +;; +(defvar gds-statuses nil) + +;; Alist mapping client port numbers to last printed outputs. +(defvar gds-outputs nil) + +;; Alist mapping client port numbers to last known stacks. +(defvar gds-stacks nil) + +;; Alist mapping client port numbers to module information. This +;; looks like: +;; +;; ((4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...) ...) +;; +;; So, for example: +;; +;; (assq client gds-modules) +;; => +;; (4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...) +;; +;; The t or nil after the module name indicates whether the module is +;; displayed in expanded form (that is, showing the bindings in that +;; module). +;; +;; The syms are actually all strings, because some Guile symbols are +;; not readable by Emacs. +(defvar gds-modules nil) + + +;;;; Handling debugging instructions. + +;; General dispatch function called by the subprocess filter. +(defun gds-handle-input (form) + (dmessage "Form: %S" form) + (let ((client (car form))) + (cond ((eq client '*)) + (t + (let ((proc (cadr form))) + + (cond ((eq proc 'name) + ;; (name ...) - Application's name. + (setq gds-names + (cons (cons client (gds-uniquify (caddr form))) + gds-names))) + + ((eq proc 'stack) + ;; (stack ...) - Stack at an error or breakpoint. + (gds-set gds-stacks client (cddr form))) + + ((eq proc 'modules) + ;; (modules ...) - Application's loaded modules. + (gds-set gds-modules client + (mapcar (function list) (cddr form)))) + + ((eq proc 'output) + ;; (output ...) - Last printed output. + (gds-set gds-outputs client (caddr form))) + + ((eq proc 'status) + ;; (status ...) - Application status indication. + (let ((status (caddr form))) + (gds-set gds-statuses client status) + (cond ((eq status 'waiting-for-input) + (gds-debug client)) + ((eq status 'running) + (if (eq client gds-displayed-client) + (gds-display-state client))) + (t + (error "Unexpected status: %S" status))))) + + ((eq proc 'module) + ;; (module MODULE ...) - The specified module's bindings. + (let* ((modules (assq client gds-modules)) + (minfo (assoc (caddr form) modules))) + (if minfo + (setcdr (cdr minfo) (cdddr form))))) + + ((eq proc 'closed) + ;; (closed) - Client has gone away. + (gds-client-cleanup client)) + + )))))) + +;; Store latest status, stack or module list for the specified client. +(defmacro gds-set (alist client val) + `(let ((existing (assq ,client ,alist))) + (if existing + (setcdr existing ,val) + (setq ,alist + (cons (cons client ,val) ,alist))))) + +;; Cleanup processing when CLIENT goes away. +(defun gds-client-cleanup (client) + (if (eq client gds-displayed-client) + (gds-focus-done)) + (setq gds-names + (delq (assq client gds-names) gds-names)) + (setq gds-stacks + (delq (assq client gds-stacks) gds-stacks)) + (setq gds-modules + (delq (assq client gds-modules) gds-modules))) + + +;;;; Displaying debugging information. + +(defvar gds-client-buffer nil) + +(define-derived-mode gds-mode + fundamental-mode + "Guile Debugging" + "Major mode for Guile debugging information buffers.") + +(defun gds-set-client-buffer (&optional client) + (if (and gds-client-buffer + (buffer-live-p gds-client-buffer)) + (set-buffer gds-client-buffer) + (setq gds-client-buffer (get-buffer-create "*Guile Debug*")) + (set-buffer gds-client-buffer) + (gds-mode)) + ;; Rename to something we don't want first. Otherwise, if the + ;; buffer is already correctly named, we get a confusing change + ;; from, say, `*Guile Debug: REPL*' to `*Guile Debug: REPL*<2>'. + (rename-buffer "*Guile Debug Fake Buffer Name*" t) + (rename-buffer (if client + (concat "*Guile Debug: " + (cdr (assq client gds-names)) + "*") + "*Guile Debug*") + t) ; Rename uniquely if needed, + ; although it shouldn't be. + (force-mode-line-update t)) + +(defun gds-clear-display () + ;; Clear the client buffer. + (gds-set-client-buffer) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert "Stack:\nNo clients ready for debugging.\n") + (goto-char (point-min))) + (setq gds-displayed-stack 'no-clients) + (setq gds-displayed-modules nil) + (setq gds-displayed-client nil) + (bury-buffer)) + +;; Determine whether the client display buffer is visible in the +;; currently selected frame (i.e. where the user is editing). +(defun gds-buffer-visible-in-selected-frame-p () + (let ((visible-p nil)) + (walk-windows (lambda (w) + (if (eq (window-buffer w) gds-client-buffer) + (setq visible-p t)))) + visible-p)) + +;; Cached display variables for `gds-display-state'. +(defvar gds-displayed-stack nil) +(defvar gds-displayed-modules nil) + +;; Types of display areas in the *Guile Debug* buffer. +(defvar gds-display-types '("Status" "Stack" "Modules")) +(defvar gds-display-type-regexp + (concat "^\\(" + (substring (apply (function concat) + (mapcar (lambda (type) + (concat "\\|" type)) + gds-display-types)) + 2) + "\\):")) + +(defun gds-maybe-delete-region (type) + (let ((beg (save-excursion + (goto-char (point-min)) + (and (re-search-forward (concat "^" + (regexp-quote type) + ":") + nil t) + (match-beginning 0))))) + (if beg + (delete-region beg + (save-excursion + (goto-char beg) + (end-of-line) + (or (and (re-search-forward gds-display-type-regexp + nil t) + (match-beginning 0)) + (point-max))))))) + +(defun gds-maybe-skip-region (type) + (if (looking-at (regexp-quote type)) + (if (re-search-forward gds-display-type-regexp nil t 2) + (beginning-of-line) + (goto-char (point-max))))) + +(defun gds-display-state (client) + (dmessage "gds-display-state") + ;; Avoid continually popping up the last associated source buffer + ;; unless it really is still current. + (setq gds-selected-frame-source-buffer nil) + (gds-set-client-buffer client) + (let ((stack (cdr (assq client gds-stacks))) + (modules (cdr (assq client gds-modules))) + (inhibit-read-only t) + (p (if (eq client gds-displayed-client) + (point) + (point-min))) + stack-changed) + ;; Start at top of buffer. + (goto-char (point-min)) + ;; Display status; too simple to be worth caching. + (gds-maybe-delete-region "Status") + (widget-insert "Status: " + (cdr (assq (cdr (assq client gds-statuses)) + '((running . "running") + (waiting-for-input . "waiting for input") + (ready-for-input . "ready for input")))) + "\n\n") + (let ((output (cdr (assq client gds-outputs)))) + (if (> (length output) 0) + (widget-insert output "\n\n"))) + ;; Display stack. + (dmessage "insert stack") + (if (equal stack gds-displayed-stack) + (gds-maybe-skip-region "Stack") + ;; Note that stack has changed. + (if stack (setq stack-changed t)) + ;; Delete existing stack. + (gds-maybe-delete-region "Stack") + ;; Insert new stack. + (if stack (gds-insert-stack stack)) + ;; Record displayed stack. + (setq gds-displayed-stack stack)) + ;; Display module list. + (dmessage "insert modules") + (if (equal modules gds-displayed-modules) + (gds-maybe-skip-region "Modules") + ;; Delete existing module list. + (gds-maybe-delete-region "Modules") + ;; Insert new list. + (if modules (gds-insert-modules modules)) + ;; Record displayed list. + (setq gds-displayed-modules (copy-tree modules))) + ;; Finish off. + (dmessage "widget-setup") + (widget-setup) + (if stack-changed + ;; Stack is being seen for the first time, so make sure top of + ;; buffer is visible. + (progn + (goto-char (point-min)) + (re-search-forward "^Stack:") + (forward-line (+ 1 (cadr stack)))) + ;; Restore point from before buffer was redrawn. + (goto-char p))) + (setq gds-displayed-client client) + (dmessage "consider display") + (if (eq (window-buffer (selected-window)) gds-client-buffer) + ;; *Guile Debug* buffer already selected. + (gds-display-buffers) + (dmessage "Running GDS timer") + (setq gds-timer + (run-with-idle-timer 0.5 + nil + (lambda () + (setq gds-timer nil) + (gds-display-buffers)))))) + +(defun gds-display-buffers () + ;; If there's already a window showing the *Guile Debug* buffer, use + ;; it. + (let ((window (get-buffer-window gds-client-buffer t))) + (if window + (progn + (make-frame-visible (window-frame window)) + (raise-frame (window-frame window)) + (select-frame (window-frame window)) + (select-window window)) + (switch-to-buffer gds-client-buffer))) + ;; If there is an associated source buffer, display it as well. + (if gds-selected-frame-source-buffer + (let ((window (display-buffer gds-selected-frame-source-buffer))) + (set-window-point window + (overlay-start gds-selected-frame-source-overlay)))) + ;; Force redisplay. + (sit-for 0)) + +(defun old-stuff () + (if (gds-buffer-visible-in-selected-frame-p) + ;; Buffer already visible enough. + nil + ;; Delete any views of the buffer in other frames - we don't want + ;; views all over the place. + (delete-windows-on gds-client-buffer) + ;; Run idle timer to display the buffer as soon as user isn't in + ;; the middle of something else. + )) + +(defun gds-insert-stack (stack) + (let ((frames (car stack)) + (index (cadr stack)) + (flags (caddr stack)) + frame items) + (widget-insert "Stack: " (prin1-to-string flags) "\n") + (let ((i -1)) + (gds-show-selected-frame (caddr (nth index frames))) + (while frames + (setq frame (car frames) + frames (cdr frames) + i (+ i 1) + items (cons (list 'item + (let ((s (cadr frame))) + (put-text-property 0 1 'index i s) + s)) + items)))) + (setq items (nreverse items)) + (apply (function widget-create) + 'radio-button-choice + :value (cadr (nth index items)) + :notify (function gds-select-stack-frame) + items) + (widget-insert "\n"))) + +(defun gds-select-stack-frame (widget &rest ignored) + (let* ((s (widget-value widget)) + (ind (memq 'index (text-properties-at 0 s)))) + (gds-send (format "(%S debugger-command frame %d)\n" + gds-displayed-client + (cadr ind))))) + +;; Overlay used to highlight the source expression corresponding to +;; the selected frame. +(defvar gds-selected-frame-source-overlay nil) + +;; Buffer containing source for the selected frame. +(defvar gds-selected-frame-source-buffer nil) + +(defun gds-show-selected-frame (source) + ;; Highlight the frame source, if possible. + (if (and source + (file-readable-p (car source))) + (with-current-buffer (find-file-noselect (car source)) + (if gds-selected-frame-source-overlay + nil + (setq gds-selected-frame-source-overlay (make-overlay 0 0)) + (overlay-put gds-selected-frame-source-overlay 'face 'highlight)) + ;; Move to source line. Note that Guile line numbering is + ;; 0-based, while Emacs numbering is 1-based. + (save-restriction + (widen) + (goto-line (+ (cadr source) 1)) + (move-to-column (caddr source)) + (move-overlay gds-selected-frame-source-overlay + (point) + (if (not (looking-at ")")) + (save-excursion (forward-sexp 1) (point)) + ;; It seems that the source coordinates for + ;; backquoted expressions are at the end of + ;; the sexp rather than the beginning... + (save-excursion (forward-char 1) + (backward-sexp 1) (point))) + (current-buffer))) + (setq gds-selected-frame-source-buffer (current-buffer))) + (if gds-selected-frame-source-overlay + (move-overlay gds-selected-frame-source-overlay 0 0)))) + +(defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil)) + "Specification of which Guile modules the debugger should display. +This is a list with structure (DEFAULT EXCEPTION EXCEPTION...), where +DEFAULT is `t' or `nil' and each EXCEPTION has the structure (SYMBOL +DEFAULT EXCEPTION EXCEPTION...). + +A Guile module name `(x y z)' is matched against this filter as +follows. If one of the top level EXCEPTIONs has SYMBOL `x', continue +by matching the rest of the module name, in this case `(y z)', against +that SYMBOL's DEFAULT and next level EXCEPTION list. Otherwise, if +the current DEFAULT is `t' display the module, and if the current +DEFAULT is `nil', don't display it. + +This variable is usually set to exclude Guile system modules that are +not of primary interest when debugging application code." + :type 'sexp + :group 'gds) + +(defun gds-show-module-p (name) + ;; Determine whether to display the NAMEd module by matching NAME + ;; against `gds-module-filter'. + (let ((default (car gds-module-filter)) + (exceptions (cdr gds-module-filter))) + (let ((exception (assq (car name) exceptions))) + (if exception + (let ((gds-module-filter (cdr exception))) + (gds-show-module-p (cdr name))) + default)))) + +(defun gds-insert-modules (modules) + (insert "Modules:\n") + (while modules + (let ((minfo (car modules))) + (if (gds-show-module-p (car minfo)) + (let ((w (widget-create 'push-button + :notify (function gds-module-notify) + (if (and (cdr minfo) + (cadr minfo)) + "-" "+")))) + (widget-put w :module (cons client (car minfo))) + (widget-insert " " (prin1-to-string (car minfo)) "\n") + (if (cadr minfo) + (let ((syms (cddr minfo))) + (while syms + (widget-insert " > " (car syms) "\n") + (setq syms (cdr syms)))))))) + (setq modules (cdr modules)))) + +(defun gds-module-notify (w &rest ignore) + (let* ((module (widget-get w :module)) + (client (car module)) + (name (cdr module)) + (modules (assq client gds-modules)) + (minfo (assoc name modules))) + (if (cdr minfo) + ;; Just toggle expansion state. + (progn + (setcar (cdr minfo) (not (cadr minfo))) + (gds-display-state client)) + ;; Set flag to indicate module expanded. + (setcdr minfo (list t)) + ;; Get symlist from Guile. + (gds-send (format "(%S query-module %S)\n" client name))))) + + +;;;; Guile Debugging keymap. + +(set-keymap-parent gds-mode-map widget-keymap) +(define-key gds-mode-map "g" (function gds-go)) +(define-key gds-mode-map "b" (function gds-set-breakpoint)) +(define-key gds-mode-map "q" (function gds-quit)) +(define-key gds-mode-map "y" (function gds-yield)) +(define-key gds-mode-map " " (function gds-next)) +(define-key gds-mode-map "e" (function gds-evaluate)) +(define-key gds-mode-map "i" (function gds-step-in)) +(define-key gds-mode-map "o" (function gds-step-out)) +(define-key gds-mode-map "t" (function gds-trace-finish)) + +(defun gds-client-waiting () + (eq (cdr (assq gds-displayed-client gds-statuses)) 'waiting-for-input)) + +(defun gds-go () + (interactive) + (gds-send (format "(%S debugger-command continue)\n" gds-displayed-client))) + +(defun gds-quit () + (interactive) + (if (gds-client-waiting) + (if (y-or-n-p "Client is waiting for instruction - tell it to continue? ") + (gds-go))) + (gds-yield)) + +(defun gds-yield () + (interactive) + (if (gds-client-waiting) + (gds-focus-yield) + (gds-focus-done))) + +(defun gds-next () + (interactive) + (gds-send (format "(%S debugger-command next 1)\n" gds-displayed-client))) + +(defun gds-evaluate (expr) + (interactive "sEvaluate (in this stack frame): ") + (gds-send (format "(%S debugger-command evaluate %s)\n" + gds-displayed-client + (prin1-to-string expr)))) + +(defun gds-step-in () + (interactive) + (gds-send (format "(%S debugger-command step 1)\n" gds-displayed-client))) + +(defun gds-step-out () + (interactive) + (gds-send (format "(%S debugger-command finish)\n" gds-displayed-client))) + +(defun gds-trace-finish () + (interactive) + (gds-send (format "(%S debugger-command trace-finish)\n" + gds-displayed-client))) + +(defun gds-set-breakpoint () + (interactive) + (cond ((gds-in-source-buffer) + (gds-set-source-breakpoint)) + ((gds-in-stack) + (gds-set-stack-breakpoint)) + ((gds-in-modules) + (gds-set-module-breakpoint)) + (t + (error "No way to set a breakpoint from here")))) + +(defun gds-in-source-buffer () + ;; Not yet worked out what will be available in Scheme source + ;; buffers. + nil) + +(defun gds-in-stack () + (and (eq (current-buffer) gds-client-buffer) + (save-excursion + (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t) + (looking-at "Stack"))))) + +(defun gds-in-modules () + (and (eq (current-buffer) gds-client-buffer) + (save-excursion + (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t) + (looking-at "Modules"))))) + +(defun gds-set-module-breakpoint () + (let ((sym (save-excursion + (beginning-of-line) + (and (looking-at " > \\([^ \n\t]+\\)") + (match-string 1)))) + (module (save-excursion + (and (re-search-backward "^\\[[+---]\\] \\(([^)]+)\\)" nil t) + (match-string 1))))) + (or sym + (error "Couldn't find procedure name on current line")) + (or module + (error "Couldn't find module name for current line")) + (let ((behaviour + (completing-read + (format "Behaviour for breakpoint at %s:%s (default debug-here): " + module sym) + '(("debug-here") + ("trace-here") + ("trace-subtree")) + nil + t + nil + nil + "debug-here"))) + (gds-send (format "(%S set-breakpoint %s %s %s)\n" + gds-displayed-client + module + sym + behaviour))))) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 9b3809aa3..684d81d71 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,22 @@ +2003-09-25 Neil Jerram + + * debugger/ui-client.scm, debugger/ui-server.scm: New (work in + progress on new debugging front end). + +2003-09-24 Neil Jerram + + * debugger.scm (default-default-lazy-handler, debug-on-error): + New. + + * debugger/behaviour.scm (debug-if-flag-set): Display debug entry + messages through (debugger-output-port). + (after-exit-frame-hook): Trace through (debugger-output-port). + (trace-here): Trace through (debugger-output-port). + + * debugger/commands.scm (evaluate): If supplied expression is a + string, read from it before evaluating. + (evaluate): Change output format to "EXPR => VALUE". + 2003-09-19 Kevin Ryde * popen.scm (open-process): Correction to previous fdes closing diff --git a/ice-9/debugger.scm b/ice-9/debugger.scm index fb00c534b..f02af1de7 100644 --- a/ice-9/debugger.scm +++ b/ice-9/debugger.scm @@ -19,6 +19,7 @@ (define-module (ice-9 debugger) #:use-module (ice-9 debugger command-loop) #:use-module (ice-9 debugger state) + #:use-module (ice-9 debugger ui-client) #:use-module (ice-9 debugger utils) #:use-module (ice-9 format) #:export (debug-stack @@ -27,7 +28,8 @@ debugger-error debugger-quit debugger-input-port - debugger-output-port) + debugger-output-port + debug-on-error) #:no-backtrace) ;;; The old (ice-9 debugger) has been factored into its constituent @@ -119,7 +121,9 @@ Indicates that the debugger should display an introductory message. (display "There is 1 frame on the stack.\n\n") (format #t "There are ~A frames on the stack.\n\n" ssize)))) (write-state-short state) - (debugger-command-loop state)))))))) + (if (ui-connected?) + (ui-command-loop state) + (debugger-command-loop state))))))))) (define (debug) "Invoke the Guile debugger to explore the context of the last error." @@ -152,4 +156,20 @@ Indicates that the debugger should display an introductory message. (lambda () output-port) (lambda (port) (set! output-port port))))) +;;; {Debug on Error} + +(define default-default-lazy-handler default-lazy-handler) + +(define (debug-on-error syms) + "Enable or disable debug on error." + (set! default-lazy-handler + (if syms + (lambda (key . args) + (or (memq key syms) + (debug-stack (make-stack #t lazy-handler-dispatch) + #:with-introduction + #:continuable)) + (apply default-default-lazy-handler key args)) + default-default-lazy-handler))) + ;;; (ice-9 debugger) ends here. diff --git a/ice-9/debugger/Makefile.am b/ice-9/debugger/Makefile.am index 0697378b4..21019ee45 100644 --- a/ice-9/debugger/Makefile.am +++ b/ice-9/debugger/Makefile.am @@ -25,7 +25,7 @@ SUBDIRS = breakpoints # These should be installed and distributed. ice9_debugger_sources = behaviour.scm breakpoints.scm command-loop.scm \ - commands.scm state.scm trap-hooks.scm trc.scm utils.scm + commands.scm state.scm trap-hooks.scm trc.scm utils.scm ui-client.scm subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/ice-9/debugger subpkgdata_DATA = $(ice9_debugger_sources) diff --git a/ice-9/debugger/behaviour.scm b/ice-9/debugger/behaviour.scm index 86e9f12cf..ddd14c466 100644 --- a/ice-9/debugger/behaviour.scm +++ b/ice-9/debugger/behaviour.scm @@ -88,7 +88,9 @@ (define (debug-if-flag-set) (if *debug-flag* (begin - (for-each display (reverse! *debug-entry-messages*)) + (for-each (lambda (msg) + (display msg (debugger-output-port))) + (reverse! *debug-entry-messages*)) (set! *debug-entry-messages* '()) (debug-stack (make-stack *cont*) #:continuable)))) @@ -99,15 +101,16 @@ (add-hook! after-exit-frame-hook (lambda () (if *trace-retval* - (begin - (let indent ((td *trace-depths*)) - (cond ((null? td)) - (else (display "| ") - (indent (cdr td))))) - (display "| ") - (write *retval*) - (newline) - (set! *trace-retval* #f))) + (with-output-to-port (debugger-output-port) + (lambda () + (let indent ((td *trace-depths*)) + (cond ((null? td)) + (else (display "| ") + (indent (cdr td))))) + (display "| ") + (write *retval*) + (newline) + (set! *trace-retval* #f)))) (debug-if-flag-set))) (define (frame-depth frame) @@ -250,15 +253,17 @@ (else (loop (+ frame-number 1))))))) (if push-current-depth (set! *trace-depths* (cons *depth* *trace-depths*))) - (let indent ((td *trace-depths*)) - (cond ((null? td)) - (else - (display "| ") - (indent (cdr td))))) - ((if *expr* - write-frame-short/expression - write-frame-short/application) *frame*) - (newline) + (with-output-to-port (debugger-output-port) + (lambda () + (let indent ((td *trace-depths*)) + (cond ((null? td)) + (else + (display "| ") + (indent (cdr td))))) + ((if *expr* + write-frame-short/expression + write-frame-short/application) *frame*) + (newline))) (if push-current-depth (at-exit (lambda () (set! *trace-depths* (cdr *trace-depths*)) diff --git a/ice-9/debugger/commands.scm b/ice-9/debugger/commands.scm index 8fb711bad..632d328f0 100644 --- a/ice-9/debugger/commands.scm +++ b/ice-9/debugger/commands.scm @@ -84,9 +84,22 @@ however it may be continued over multiple lines." (lambda () (lazy-catch #t (lambda () - (let* ((env (memoized-environment source)) - (value (local-eval expression env))) - (display ";value: ") + (let* ((expr + ;; We assume that no one will + ;; really want to evaluate a + ;; string (since it is + ;; self-evaluating); so if we + ;; have a string here, read the + ;; expression to evaluate from + ;; it. + (if (string? expression) + (with-input-from-string expression + read) + expression)) + (env (memoized-environment source)) + (value (local-eval expr env))) + (write expr) + (display " => ") (write value) (newline))) eval-handler)) diff --git a/ice-9/debugger/ui-client.scm b/ice-9/debugger/ui-client.scm new file mode 100644 index 000000000..77eb742fa --- /dev/null +++ b/ice-9/debugger/ui-client.scm @@ -0,0 +1,242 @@ +;;;; Guile Debugger UI client + +;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 2.1 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (ice-9 debugger ui-client) + #:use-module (ice-9 debugger) + #:use-module (ice-9 debugger behaviour) + #:use-module (ice-9 debugger breakpoints) + #:use-module (ice-9 debugger breakpoints procedural) + #:use-module (ice-9 debugger state) + #:use-module (ice-9 debugger utils) + #:use-module (ice-9 optargs) + #:use-module (ice-9 session) + #:use-module (ice-9 string-fun) + #:export (ui-port-number + ui-connected? + ui-connect + ui-command-loop) + #:no-backtrace) + +;; The TCP port number that the UI server listens for application +;; connections on. +(define ui-port-number 8333) + +;; Once connected, the TCP socket port to the UI server. +(define ui-port #f) + +(define* (ui-connect name #:optional host) + "Connect to the debug UI server as @var{name}, a string that should +be sufficient to describe the calling application to the debug UI +user. The optional @var{host} arg specifies the hostname or dotted +decimal IP address where the UI server is running; default is +127.0.0.1." + (if (ui-connected?) + (error "Already connected to UI server!")) + ;; Connect to debug server. + (set! ui-port + (let ((s (socket PF_INET SOCK_STREAM 0)) + (SOL_TCP 6) + (TCP_NODELAY 1)) + (setsockopt s SOL_TCP TCP_NODELAY 1) + (connect s AF_INET (inet-aton (or host "127.0.0.1")) ui-port-number) + s)) + ;; Set debugger-output-port so that stuff written to it is + ;; accumulated for sending to the debug server. + (set! (debugger-output-port) + (make-soft-port (vector accumulate-output + accumulate-output + #f #f #f #f) + "w")) + ;; Write initial context to debug server. + (write-form (list 'name name)) + (write-form (cons 'modules (map module-name (loaded-modules)))) + (debug-stack (make-stack #t ui-connect) #:continuable) +; (ui-command-loop #f) + ) + +(define accumulated-output '()) + +(define (accumulate-output obj) + (set! accumulated-output + (cons (if (string? obj) obj (make-string 1 obj)) + accumulated-output))) + +(define (get-accumulated-output) + (let ((s (apply string-append (reverse! accumulated-output)))) + (set! accumulated-output '()) + s)) + +(define (ui-connected?) + "Return @code{#t} if a UI server connected has been made; else @code{#f}." + (not (not ui-port))) + +(define (ui-command-loop state) + "Interact with the UI frontend." + (or (ui-connected?) + (error "Not connected to UI server.")) + (catch 'exit-debugger + (lambda () + (let loop ((state state)) + ;; Write accumulated debugger output. + (write-form (list 'output + (sans-surrounding-whitespace + (get-accumulated-output)))) + ;; Write current state to the frontend. + (if state (write-stack state)) + ;; Tell the frontend that we're waiting for input. + (write-status 'waiting-for-input) + ;; Read next instruction, act on it, and loop with + ;; updated state. + (loop (handle-instruction state (read ui-port))))) + (lambda args *unspecified*))) + +(define (write-stack state) + ;; Write Emacs-readable representation of current state to UI + ;; frontend. + (let ((frames (stack->emacs-readable (state-stack state))) + (index (index->emacs-readable (state-index state))) + (flags (flags->emacs-readable (state-flags state)))) + (if (memq 'backwards (debug-options)) + (write-form (list 'stack + frames + index + flags)) + ;; Calculate (length frames) here because `reverse!' will make + ;; the original `frames' invalid. + (let ((nframes (length frames))) + (write-form (list 'stack + (reverse! frames) + (- nframes index 1) + flags)))))) + +(define (write-form form) + ;; Write any form FORM to UI frontend. + (write form ui-port) + (newline ui-port) + (force-output ui-port)) + +(define (stack->emacs-readable stack) + ;; Return Emacs-readable representation of STACK. + (map (lambda (index) + (frame->emacs-readable (stack-ref stack index))) + (iota (stack-length stack)))) + +(define (frame->emacs-readable frame) + ;; Return Emacs-readable representation of FRAME. + (if (frame-procedure? frame) + (list 'application + (with-output-to-string + (lambda () + (display (if (frame-real? frame) " " "T ")) + (write-frame-short/application frame))) + (source->emacs-readable (frame-source frame))) + (list 'evaluation + (with-output-to-string + (lambda () + (display (if (frame-real? frame) " " "T ")) + (write-frame-short/expression frame))) + (source->emacs-readable (frame-source frame))))) + +(define (source->emacs-readable source) + ;; Return Emacs-readable representation of the filename, line and + ;; column source properties of SOURCE. + (if (and source + (string? (source-property source 'filename))) + (list (source-property source 'filename) + (source-property source 'line) + (source-property source 'column)) + 'nil)) + +(define (index->emacs-readable index) + ;; Return Emacs-readable representation of INDEX (the current stack + ;; index). + index) + +(define (flags->emacs-readable flags) + ;; Return Emacs-readable representation of FLAGS passed to + ;; debug-stack. + (map keyword->symbol flags)) + +(define the-ice-9-debugger-commands-module + (resolve-module '(ice-9 debugger commands))) + +(define (handle-instruction state ins) + ;; Handle instruction from the UI frontend, and return updated state. + (case (car ins) + ((query-module) + (let ((name (cadr ins))) + (write-form `(module ,name + ,(or (loaded-module-source name) "(no source file)") + ,@(sort (module-map (lambda (key value) + (symbol->string key)) + (resolve-module name)) + stringstring (car reverse-name))) + (dir-hint-module-name (reverse (cdr reverse-name))) + (dir-hint (apply string-append + (map (lambda (elt) + (string-append (symbol->string elt) "/")) + dir-hint-module-name)))) + (%search-load-path (in-vicinity dir-hint name)))) + +(define (loaded-modules) + ;; Return list of all loaded modules sorted by name. + (sort (apropos-fold-all (lambda (module acc) (cons module acc)) '()) + (lambda (m1 m2) + (symliststring (car l1)) (symbol->string (car l2)))))) + +;;; (ice-9 debugger ui-client) ends here. diff --git a/ice-9/debugger/ui-server.scm b/ice-9/debugger/ui-server.scm new file mode 100644 index 000000000..e69de29bb From 5a825ad439c71b43f93824a37daa743535db2641 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 27 Sep 2003 10:08:26 +0000 Subject: [PATCH 011/239] Two fixes to Guile tutorial. --- THANKS | 1 + doc/tutorial/ChangeLog | 7 +++++++ doc/tutorial/guile-tut.texi | 6 +++--- 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/THANKS b/THANKS index 49342212b..0bbb3f42f 100644 --- a/THANKS +++ b/THANKS @@ -40,6 +40,7 @@ For fixes or providing information which led to a fix: Han-Wen Nienhuys Jan Nieuwenhuizen Pieter Pareit + Jack Pavlovsky Arno Peters Ron Peterson David Pirotte diff --git a/doc/tutorial/ChangeLog b/doc/tutorial/ChangeLog index 86a9dc6a2..7dd52f5d7 100644 --- a/doc/tutorial/ChangeLog +++ b/doc/tutorial/ChangeLog @@ -1,3 +1,10 @@ +2003-09-27 Neil Jerram + + * guile-tut.texi (Using Guile to program in Scheme): Fix result of + `(reverse ls)', and change `squaring function' example to use `(* + n n)' instead of `(expt n n)'. Thanks to Jack Pavlovsky for + pointing these out. + 2003-05-27 Dirk Herrmann * guile-tut.texi: Fix example, where a vector constant is used diff --git a/doc/tutorial/guile-tut.texi b/doc/tutorial/guile-tut.texi index 9379f6ee8..d38638b10 100644 --- a/doc/tutorial/guile-tut.texi +++ b/doc/tutorial/guile-tut.texi @@ -523,7 +523,7 @@ guile> @kbd{(caddr ls)} guile> @kbd{(append ls (list 8 9 10))} @result{} (1 2 3 4 5 6 7 8 9 10) guile> @kbd{(reverse ls)} - @result{} (10 9 8 7 6 5 4 3 2 1) + @result{} (7 6 5 4 3 2 1) ;; @r{ask if 12 is in the list --- it obviously is not} guile> @kbd{(memq 12 ls)} @result{} #f @@ -552,8 +552,8 @@ guile> @kbd{(map sin ls2)} @result{} (0.909297426825682 0.141120008059867 -0.756802495307928) ;; @r{make a list in which the squaring function has been} ;; @r{applied to all elements of @code{ls}} -guile> @kbd{(map (lambda (n) (expt n n)) ls)} - @result{} (1 4 27 256 3125 46656 823543) +guile> @kbd{(map (lambda (n) (* n n)) ls)} + @result{} (1 4 9 16 25 36 49) @end smalllisp @smalllisp From 88fd89ac40fcd95082dfe7ba16a052025e1a7656 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 1 Oct 2003 23:51:41 +0000 Subject: [PATCH 012/239] Add call-with-output-string no segv on closed port. --- NEWS | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/NEWS b/NEWS index 62ea3371a..14e74b595 100644 --- a/NEWS +++ b/NEWS @@ -468,6 +468,12 @@ chapter in the reference manual. There is no replacement for undefine. +** call-with-output-string doesn't segv on closed port + +Previously call-with-output-string would give a segmentation fault if +the string port was closed by the called function. An exception is +raised now. + ** (ice-9 popen) duplicate pipe fd fix open-pipe, open-input-pipe and open-output-pipe left an extra copy of From 930d3b37a81bcbae14d76fdc8facf64efdb0436f Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 2 Oct 2003 00:00:42 +0000 Subject: [PATCH 013/239] Fix a couple of typos in: New file. --- test-suite/tests/popen.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 33da12f71..01be63f69 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -99,7 +99,7 @@ (pass-if "port?" (port? (open-output-pipe "exit 0"))) - ;; exercise file descriptor setups when stdout is the same as stderr + ;; exercise file descriptor setups when stdin is the same as stderr (pass-if "stdin==stderr" (let ((port (open-file "/dev/null" "r+"))) (with-input-from-port port @@ -145,7 +145,7 @@ ;; close-pipe ;; -(with-test-prefix "open-output-pipe" +(with-test-prefix "close-pipe" (pass-if-exception "no args" exception:wrong-num-args (close-pipe)) From 184b85a394e686900b87d08cd718bc8c9e2c43d8 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 2 Oct 2003 00:04:26 +0000 Subject: [PATCH 014/239] (s_scm_call_with_output_string): scm_get_output_string rather than scm_strport_to_string, so as to guard against the port having been closed by the called procedure. Reported by Nic Ferrier. --- libguile/strports.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/strports.c b/libguile/strports.c index db43c3cf8..f718c07cb 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -333,7 +333,7 @@ SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0, FUNC_NAME); scm_call_1 (proc, p); - return scm_strport_to_string (p); + return scm_get_output_string (p); } #undef FUNC_NAME From 591924eb4cba623be5a2f16e7b36586889dcd7bd Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 2 Oct 2003 00:11:12 +0000 Subject: [PATCH 015/239] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b4f6e947d..da7b12c44 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2003-10-02 Kevin Ryde + + * strports.c (s_scm_call_with_output_string): scm_get_output_string + rather than scm_strport_to_string, so as to guard against the port + having been closed by the called procedure. Reported by Nic Ferrier. + 2003-09-18 Dirk Herrmann * numbers.h (SCM_INEXACTP): Removed uses of SCM_TYP16S. From ee6eedcde8e3306855c5bb3489873b831a74eef7 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 2 Oct 2003 00:17:16 +0000 Subject: [PATCH 016/239] (call-with-output-string): Test proc closing port. --- test-suite/tests/ports.test | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 9b9eb2f80..0c29e6d2a 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -303,6 +303,13 @@ (pass-if "output check" (string=? text result)))) +(with-test-prefix "call-with-output-string" + + ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't + ;; occur. + (pass-if-exception "proc closes port" exception:wrong-type-arg + (call-with-output-string close-port))) + ;;;; Soft ports. No tests implemented yet. From 39a963ee8109d2c8d116e06a05155d3e68cbb755 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 2 Oct 2003 00:17:50 +0000 Subject: [PATCH 017/239] *** empty log message *** --- test-suite/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 6c55cd73a..f8334e13a 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2003-10-02 Kevin Ryde + + * tests/ports.test (call-with-output-string): Test proc closing port. + 2003-09-22 Dirk Herrmann * guile-test: Wrapped in module (test-suite guile-test). From 0853a58069d4a8e9e56b34108643e4780fe1e7f8 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 2 Oct 2003 00:20:07 +0000 Subject: [PATCH 018/239] (String Ports): In call-with-output-string, note proc should not close the port. In get-output-string, note string must be gotten before closing the port. --- doc/ref/scheme-io.texi | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/doc/ref/scheme-io.texi b/doc/ref/scheme-io.texi index 3dc1dd4aa..54688c061 100644 --- a/doc/ref/scheme-io.texi +++ b/doc/ref/scheme-io.texi @@ -798,7 +798,7 @@ file port facilities: @deffnx {C Function} scm_call_with_output_string (proc) Calls the one-argument procedure @var{proc} with a newly created output port. When the function returns, the string composed of the characters -written into the port is returned. +written into the port is returned. @var{proc} should not close the port. @end deffn @deffn {Scheme Procedure} call-with-input-string string proc @@ -842,6 +842,9 @@ inaccessible. Given an output port created by @code{open-output-string}, return a string consisting of the characters that have been output to the port so far. + +@code{get-output-string} must be used before closing @var{port}, once +closed the string cannot be obtained. @end deffn A string port can be used in many procedures which accept a port From 8552a9c0ae0b95ffc897a53be691e208293e0090 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 2 Oct 2003 00:29:50 +0000 Subject: [PATCH 019/239] *** empty log message *** --- doc/ref/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index a1e63aa4c..7d45c6afb 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,9 @@ +2003-10-02 Kevin Ryde + + * scheme-io.texi (String Ports): In call-with-output-string, note proc + should not close the port. In get-output-string, note string must be + gotten before closing the port. + 2003-09-21 Kevin Ryde * posix.texi (File System): In access?, reword a bit, clarify real From 02b0c692891bb312902e3225e2f3fda98e087515 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 4 Oct 2003 20:03:51 +0000 Subject: [PATCH 020/239] Debugger UI asynchronous thread support. --- emacs/ChangeLog | 4 +++ emacs/gds.el | 17 ++++++++++-- ice-9/ChangeLog | 9 ++++++ ice-9/debugger/ui-client.scm | 53 +++++++++++++++++++++++++++++++++++- 4 files changed, 79 insertions(+), 4 deletions(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 4d7b0bf53..efa004269 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,7 @@ +2003-10-04 Neil Jerram + + * gds.el (gds-handle-input): Handle `ready-for-input' status. + 2003-08-20 Neil Jerram * guileint: New subdirectory. diff --git a/emacs/gds.el b/emacs/gds.el index cd60498aa..3b5923f03 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -269,7 +269,8 @@ (gds-set gds-statuses client status) (cond ((eq status 'waiting-for-input) (gds-debug client)) - ((eq status 'running) + ((or (eq status 'running) + (eq status 'ready-for-input)) (if (eq client gds-displayed-client) (gds-display-state client))) (t @@ -416,9 +417,9 @@ (gds-maybe-delete-region "Status") (widget-insert "Status: " (cdr (assq (cdr (assq client gds-statuses)) - '((running . "running") + '((running . "running (cannot accept input)") (waiting-for-input . "waiting for input") - (ready-for-input . "ready for input")))) + (ready-for-input . "running")))) "\n\n") (let ((output (cdr (assq client gds-outputs)))) (if (> (length output) 0) @@ -746,3 +747,13 @@ not of primary interest when debugging application code." module sym behaviour))))) + + +;;;; Evaluating code. + +;; The Scheme process to which code is sent is determined in the usual +;; cmuscheme.el way by the `scheme-buffer' variable (q.v.). +;; Customizations to the way that code is sent, for example pro- and +;; postlogs to set up and restore evaluation context correctly in the +;; Scheme process, are achieved (elsewhere than this file) by advising +;; `scheme-send-region' accordingly. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 684d81d71..024a9206c 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,12 @@ +2003-10-04 Neil Jerram + + * debugger/ui-client.scm (ui-disable-async-thread, + ui-continue-async-thread, start-async-ui-thread): New. + (ui-command-loop): Call ui-disable-async-thread and + ui-continue-async-thread. + (handle-instruction): Read terminating newline char so it doesn't + cause following select to pop immediately. + 2003-09-25 Neil Jerram * debugger/ui-client.scm, debugger/ui-server.scm: New (work in diff --git a/ice-9/debugger/ui-client.scm b/ice-9/debugger/ui-client.scm index 77eb742fa..8fbbe1646 100644 --- a/ice-9/debugger/ui-client.scm +++ b/ice-9/debugger/ui-client.scm @@ -26,6 +26,7 @@ #:use-module (ice-9 optargs) #:use-module (ice-9 session) #:use-module (ice-9 string-fun) + #:use-module (ice-9 threads) #:export (ui-port-number ui-connected? ui-connect @@ -62,6 +63,8 @@ decimal IP address where the UI server is running; default is accumulate-output #f #f #f #f) "w")) + ;; Start the asynchronous UI thread. + (start-async-ui-thread) ;; Write initial context to debug server. (write-form (list 'name name)) (write-form (cons 'modules (map module-name (loaded-modules)))) @@ -69,6 +72,50 @@ decimal IP address where the UI server is running; default is ; (ui-command-loop #f) ) +(define ui-disable-async-thread noop) +(define ui-continue-async-thread noop) + +(define (start-async-ui-thread) + (let ((mutex (make-mutex)) + (condition (make-condition-variable)) + (admin (pipe))) + ;; Start the asynchronous UI thread. + (begin-thread + (lock-mutex mutex) + ;;(write (cons admin ui-port)) + ;;(newline) + (let loop ((avail '())) + ;;(write avail) + ;;(newline) + (if (null? avail) + (begin + (write-status 'ready-for-input) + (loop (car (select (list ui-port (car admin)) '() '())))) + (let ((port (car avail))) + (if (eq? port ui-port) + (handle-instruction #f (read ui-port)) + (begin + ;; Notification from debugger that it wants to take + ;; over. Read the notification char. + (read-char (car admin)) + ;; Wait on condition variable - this allows the + ;; debugger thread to grab the mutex. + (wait-condition-variable condition mutex))) + ;; Loop. + (loop (cdr avail)))))) + ;; Redefine procs used by debugger thread to take control. + (set! ui-disable-async-thread + (lambda () + (write-char #\x (cdr admin)) + (force-output (cdr admin)) + ;;(display "ui-disable-async-thread: locking mutex...\n" + ;; (current-error-port)) + (lock-mutex mutex))) + (set! ui-continue-async-thread + (lambda () + (unlock-mutex mutex) + (signal-condition-variable condition))))) + (define accumulated-output '()) (define (accumulate-output obj) @@ -89,6 +136,7 @@ decimal IP address where the UI server is running; default is "Interact with the UI frontend." (or (ui-connected?) (error "Not connected to UI server.")) + (ui-disable-async-thread) (catch 'exit-debugger (lambda () (let loop ((state state)) @@ -103,7 +151,8 @@ decimal IP address where the UI server is running; default is ;; Read next instruction, act on it, and loop with ;; updated state. (loop (handle-instruction state (read ui-port))))) - (lambda args *unspecified*))) + (lambda args *unspecified*)) + (ui-continue-async-thread)) (define (write-stack state) ;; Write Emacs-readable representation of current state to UI @@ -176,6 +225,8 @@ decimal IP address where the UI server is running; default is (resolve-module '(ice-9 debugger commands))) (define (handle-instruction state ins) + ;; Read the newline that always follows an instruction. + (read-char ui-port) ;; Handle instruction from the UI frontend, and return updated state. (case (car ins) ((query-module) From 3446b6ef074a08d1a64bcb2aef05e01c0b1f8c3b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 6 Oct 2003 19:24:15 +0000 Subject: [PATCH 021/239] * scheme-memory.texi: Added a short explanation of the GC and the conservative stack scanning. (scm_gc_protect_object, scm_gc_unprotect_object, scm_permanent_object): New. * data-rep.texi, scheme-memory.texi (scm_remember_upto_here_1, scm_remember_upto_here_2): Moved from data-rep.texi to scheme-memory.texi. --- doc/ref/data-rep.texi | 21 +------ doc/ref/scheme-memory.texi | 125 ++++++++++++++++++++++++++++++++++--- 2 files changed, 117 insertions(+), 29 deletions(-) diff --git a/doc/ref/data-rep.texi b/doc/ref/data-rep.texi index daa22b303..09acbe054 100644 --- a/doc/ref/data-rep.texi +++ b/doc/ref/data-rep.texi @@ -18,7 +18,7 @@ @c essay @ifinfo @c essay Data Representation in Guile -@c essay Copyright (C) 1998, 1999, 2000 Free Software Foundation +@c essay Copyright (C) 1998, 1999, 2000, 2003 Free Software Foundation @c essay Permission is granted to make and distribute verbatim copies of @c essay this manual provided the copyright notice and this permission notice @@ -46,7 +46,7 @@ @c essay @sp 10 @c essay @comment The title is printed in a large font. @c essay @title Data Representation in Guile -@c essay @subtitle $Id: data-rep.texi,v 1.14 2003-08-29 23:32:21 kryde Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.15 2003-10-06 19:24:15 mvo Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation @@ -1908,23 +1908,6 @@ It's important that a smob is visible to the garbage collector whenever its contents are being accessed. Otherwise it could be freed while code is still using it. -@c NOTE: The varargs scm_remember_upto_here is deliberately not -@c documented, because we don't think it can be implemented as a nice -@c inline compiler directive or asm block. New _3, _4 or whatever -@c forms could certainly be added though, if needed. - -@deftypefn {C Macro} void scm_remember_upto_here_1 (SCM obj) -@deftypefnx {C Macro} void scm_remember_upto_here_2 (SCM obj1, SCM obj2) -Create a reference to the given object or objects, so they're certain -to be present on the stack or in a register and hence will not be -freed by the garbage collector before this point. - -Note that these functions can only be applied to ordinary C local -variables (ie.@: ``automatics''). Objects held in global or static -variables or some malloced block or the like cannot be protected with -this mechanism. -@end deftypefn - For example, consider a procedure to convert image data to a list of pixel values. diff --git a/doc/ref/scheme-memory.texi b/doc/ref/scheme-memory.texi index 6ea74886e..73cf3d4c1 100644 --- a/doc/ref/scheme-memory.texi +++ b/doc/ref/scheme-memory.texi @@ -6,16 +6,12 @@ Guile uses a @emph{garbage collector} to manage most of its objects. This means that the memory used to store a Scheme string, say, is automatically reclaimed when no one is using this string any longer. This can work because Guile knows enough about its objects at run-time -to be able to trace all references between them. Thus, it can find -all 'live' objects (objects that are still in use) by starting from a -known set of 'root' objects and following the links that these objects -have to other objects, and so on. The objects that are not reached by -this recursive process can be considered 'dead' and their memory can -be reused for new objects. - -When you are programming in Scheme, you don't need to worry about the -garbage collector. When programming in C, there are a few rules that -you must follow so that the garbage collector can do its job. +to be able to trace all references between them. Thus, it can find all +'live' objects (objects that are still in use) by starting from a known +set of 'root' objects and following the links that these objects have to +other objects, and so on. The objects that are not reached by this +recursive process can be considered 'dead' and their memory can be +reused for new objects. @menu * Garbage Collection:: @@ -28,6 +24,72 @@ you must follow so that the garbage collector can do its job. @node Garbage Collection @section Garbage Collection +The general process of collecting dead objects outlined above relies on +the fact that the garbage collector is able to find all references to +SCM objects that might be used by the program in the future. When you +are programming in Scheme, you don't need to worry about this: The +collector is automatically aware of all objects in use by Scheme code. + +When programming in C, you must help the garbage collector a bit so that +it can find all objects that are accessible from C. You do this when +writing a SMOB mark function, for example. By calling this function, +the garbage collector learns about all references that your SMOB has to +other SCM objects. + +Other references to SCM objects, such as global variables of type SCM or +other random data structures in the heap that contain fields of type +SCM, can be made visible to the garbage collector by calling the +functions @code{scm_gc_protect} or @code{scm_permanent_object}. You +normally use these funtions for long lived objects such as a hash table +that is stored in a global variable. For temporary references in local +variables or function arguments, using these functions would be too +expensive. + +These references are handled differently: Local variables (and function +arguments) of type SCM are automatically visible to the garbage +collector. This works because the collector scans the stack for +potential references to SCM objects and considers all referenced objects +to be alive. The scanning considers each and every word of the stack, +regardless of what it is actually used for, and then decides whether it +could possible be a reference to a SCM object. Thus, the scanning is +guaranteed to find all actual references, but it might also find words +that only accidentally look like references. These `false positives' +might keep SCM objects alive that would otherwise be considered dead. +While this might waste memory, keeping an object around longer than it +strictly needs to is harmless. This is why this technique is called +``conservative garbage collection''. In practice, the wasted memory +seems to be no problem. + +The stack of every thread is scanned in this way and the registers of +the CPU and all other memory locations where local variables or function +parameters might show up are included in this scan as well. + +The consequence of the conservative scanning is that you can just +declare local variables and function parameters of type SCM and be sure +that the garbage collector will not free the corresponding objects. + +However, a local variable or function parameter is only protected as +long as it is really on the stack (or in some register). As an +optimization, the C compiler might reuse its location for some other +value and the SCM object would no longer be protected. Normally, this +leads to exactly the right behabvior: the compiler will only overwrite a +reference when it is no longer needed and thus the object becomes +unprotected precisely when the reference disappears, just as wanted. + +There are situations, however, where a SCM object needs to be around +longer than its reference from a local variable or function parameter. +This happens, for example, when you retrieve the array of characters +from a Scheme string and work on that array directly. The reference to +the SCM string object might be dead after the character array has been +retrieved, but the array itself is still in use and thus the string +object must be protected. The compiler does not know about this +connection and might overwrite the SCM reference too early. + +To get around this problem, you can use @code{scm_remember_upto_here_1} +and its cousins. It will keep the compiler from overwriting the +reference. For an example of its use, see @ref{Remembering During +Operations}. + @deffn {Scheme Procedure} gc @deffnx {C Function} scm_gc () Scans all of SCM objects and reclaims for further use those that are @@ -35,6 +97,49 @@ no longer accessible. You normally don't need to call this function explicitly. It is called automatically when appropriate. @end deffn +@deftypefn {C Function} SCM scm_gc_protect_object (SCM @var{obj}) +Protects @var{obj} from being freed by the garbage collector, when it +otherwise might be. When you are done with the object, call +@code{scm_gc_unprotect_object} on the object. Calls to +@code{scm_gc_protect}/@code{scm_gc_unprotect_object} can be nested, and +the object remains protected until it has been unprotected as many times +as it was protected. It is an error to unprotect an object more times +than it has been protected. Returns the SCM object it was passed. +@end deftypefn + +@deftypefn {C Function} SCM scm_gc_unprotect_object (SCM @var{obj}) + +Unprotects an object from the garbage collector which was protected by +@code{scm_gc_unprotect_object}. Returns the SCM object it was passed. +@end deftypefn + +@deftypefn {C Function} SCM scm_permanent_object (SCM @var{obj}) + +Similar to @code{scm_gc_protect_object} in that it causes the +collector to always mark the object, except that it should not be +nested (only call @code{scm_permanent_object} on an object once), and +it has no corresponding unpermanent function. Once an object is +declared permanent, it will never be freed. Returns the SCM object it +was passed. +@end deftypefn + +@c NOTE: The varargs scm_remember_upto_here is deliberately not +@c documented, because we don't think it can be implemented as a nice +@c inline compiler directive or asm block. New _3, _4 or whatever +@c forms could certainly be added though, if needed. + +@deftypefn {C Macro} void scm_remember_upto_here_1 (SCM obj) +@deftypefnx {C Macro} void scm_remember_upto_here_2 (SCM obj1, SCM obj2) +Create a reference to the given object or objects, so they're certain +to be present on the stack or in a register and hence will not be +freed by the garbage collector before this point. + +Note that these functions can only be applied to ordinary C local +variables (ie.@: ``automatics''). Objects held in global or static +variables or some malloced block or the like cannot be protected with +this mechanism. +@end deftypefn + @deffn {Scheme Procedure} gc-stats @deffnx {C Function} scm_gc_stats () Return an association list of statistics about Guile's current From 6b5dc4ee3317da33fdb880caab1330c966cf93d3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 6 Oct 2003 19:25:05 +0000 Subject: [PATCH 022/239] *** empty log message *** --- doc/ref/ChangeLog | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 7d45c6afb..fa07f613b 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,14 @@ +2003-10-06 Marius Vollmer + + * scheme-memory.texi: Added a short explanation of the GC and the + conservative stack scanning. + (scm_gc_protect_object, scm_gc_unprotect_object, + scm_permanent_object): New. + + * data-rep.texi, scheme-memory.texi (scm_remember_upto_here_1, + scm_remember_upto_here_2): Moved from data-rep.texi to + scheme-memory.texi. + 2003-10-02 Kevin Ryde * scheme-io.texi (String Ports): In call-with-output-string, note proc From 41a80feb8a4ad30807be0c2f45c94301e40af2e5 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 6 Oct 2003 20:33:02 +0000 Subject: [PATCH 023/239] UI frontend work: eval support. --- emacs/ChangeLog | 4 - emacs/gds.el | 300 ++++++++++++++++++++++++++++++++--- ice-9/ChangeLog | 6 + ice-9/debugger/ui-client.scm | 45 ++++++ 4 files changed, 330 insertions(+), 25 deletions(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index efa004269..4d7b0bf53 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,7 +1,3 @@ -2003-10-04 Neil Jerram - - * gds.el (gds-handle-input): Handle `ready-for-input' status. - 2003-08-20 Neil Jerram * guileint: New subdirectory. diff --git a/emacs/gds.el b/emacs/gds.el index 3b5923f03..c9d53575f 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -1,4 +1,4 @@ -;;; gds.el -- Guile debugging frontend +;;; gds.el -- frontend for Guile development in Emacs ;;;; Copyright (C) 2003 Free Software Foundation, Inc. ;;;; @@ -23,6 +23,7 @@ (require 'widget) (require 'wid-edit) +(require 'scheme) ;;;; Debugging (of this code!). @@ -35,7 +36,7 @@ ;;;; Customization group setup. (defgroup gds nil - "Customization options for Guile Debugging." + "Customization options for Guile Emacs frontend." :group 'scheme) @@ -49,8 +50,9 @@ ;; the buffer position of the start of the next unread form. (defvar gds-read-cursor nil) -;; Start (or restart) the subprocess. (defun gds-start () + "Start (or restart, if already running) the GDS subprocess." + (interactive) (if gds-process (gds-shutdown)) (with-current-buffer (get-buffer-create "*GDS Process*") (erase-buffer) @@ -72,6 +74,8 @@ ;; Shutdown the subprocess and cleanup all associated data. (defun gds-shutdown () + "Shut down the GDS subprocess." + (interactive) ;; Do cleanup for all clients. (while gds-names (gds-client-cleanup (caar gds-names))) @@ -125,7 +129,7 @@ ;; At any moment one Guile application has the focus of the frontend ;; code. `gds-displayed-client' holds the port number of that client. ;; If there are no Guile applications wanting the focus - that is, -;; ready for debugging instructions - `gds-displayed-client' is nil. +;; ready for instructions - `gds-displayed-client' is nil. (defvar gds-displayed-client nil) ;; The list of other Guile applications waiting for focus, referenced @@ -172,7 +176,7 @@ (defun gds-focus-yield () (interactive) (if (and (null gds-waiting) - (y-or-n-p "No other clients waiting - bury *Guile Debug* buffer? ")) + (y-or-n-p "No other clients waiting - bury *Guile* buffer? ")) (bury-buffer) (or (memq gds-displayed-client gds-waiting) (setq gds-waiting (append gds-waiting (list gds-displayed-client)))) @@ -287,8 +291,26 @@ ;; (closed) - Client has gone away. (gds-client-cleanup client)) + ((eq proc 'eval-results) + ;; (eval-results ...) - Results of evaluation. + (gds-display-results client (cddr form))) + )))))) +(defun gds-display-results (client results) + (let ((buf (get-buffer-create "*Guile Results*"))) + (save-excursion + (set-buffer buf) + (erase-buffer) + (while results + (insert (car results)) + (mapcar (function (lambda (value) + (insert " => " value "\n"))) + (cadr results)) + (insert "\n") + (setq results (cddr results)))) + (pop-to-buffer buf))) + ;; Store latest status, stack or module list for the specified client. (defmacro gds-set (alist client val) `(let ((existing (assq ,client ,alist))) @@ -315,25 +337,25 @@ (define-derived-mode gds-mode fundamental-mode - "Guile Debugging" - "Major mode for Guile debugging information buffers.") + "Guile" + "Major mode for Guile information buffers.") (defun gds-set-client-buffer (&optional client) (if (and gds-client-buffer (buffer-live-p gds-client-buffer)) (set-buffer gds-client-buffer) - (setq gds-client-buffer (get-buffer-create "*Guile Debug*")) + (setq gds-client-buffer (get-buffer-create "*Guile*")) (set-buffer gds-client-buffer) (gds-mode)) ;; Rename to something we don't want first. Otherwise, if the ;; buffer is already correctly named, we get a confusing change - ;; from, say, `*Guile Debug: REPL*' to `*Guile Debug: REPL*<2>'. - (rename-buffer "*Guile Debug Fake Buffer Name*" t) + ;; from, say, `*Guile: REPL*' to `*Guile: REPL*<2>'. + (rename-buffer "*Guile Fake Buffer Name*" t) (rename-buffer (if client - (concat "*Guile Debug: " + (concat "*Guile: " (cdr (assq client gds-names)) "*") - "*Guile Debug*") + "*Guile*") t) ; Rename uniquely if needed, ; although it shouldn't be. (force-mode-line-update t)) @@ -363,7 +385,7 @@ (defvar gds-displayed-stack nil) (defvar gds-displayed-modules nil) -;; Types of display areas in the *Guile Debug* buffer. +;; Types of display areas in the *Guile* buffer. (defvar gds-display-types '("Status" "Stack" "Modules")) (defvar gds-display-type-regexp (concat "^\\(" @@ -461,7 +483,7 @@ (setq gds-displayed-client client) (dmessage "consider display") (if (eq (window-buffer (selected-window)) gds-client-buffer) - ;; *Guile Debug* buffer already selected. + ;; *Guile* buffer already selected. (gds-display-buffers) (dmessage "Running GDS timer") (setq gds-timer @@ -472,7 +494,7 @@ (gds-display-buffers)))))) (defun gds-display-buffers () - ;; If there's already a window showing the *Guile Debug* buffer, use + ;; If there's already a window showing the *Guile* buffer, use ;; it. (let ((window (get-buffer-window gds-client-buffer t))) (if window @@ -751,9 +773,245 @@ not of primary interest when debugging application code." ;;;; Evaluating code. -;; The Scheme process to which code is sent is determined in the usual -;; cmuscheme.el way by the `scheme-buffer' variable (q.v.). -;; Customizations to the way that code is sent, for example pro- and -;; postlogs to set up and restore evaluation context correctly in the -;; Scheme process, are achieved (elsewhere than this file) by advising -;; `scheme-send-region' accordingly. +;; The following commands send code for evaluation through the GDS TCP +;; connection, receive the result and any output generated through the +;; same connection, and display the result and output to the user. +;; +;; Where there are multiple Guile applications known to GDS, GDS by +;; default sends code to the one that holds the debugging focus, +;; i.e. `gds-displayed-client'. Where no application has the focus, +;; or the command is invoked `C-u', GDS asks the user which +;; application is intended. + +(defun gds-read-client () + (let* ((def (if gds-displayed-client + (cdr (assq gds-displayed-client gds-names)))) + (prompt (if def + (concat "Application for eval (default " + def + "): ") + "Application for eval: ")) + (name + (completing-read prompt + (mapcar (function cdr) gds-names) + nil t nil nil + def))) + (let (client (names gds-names)) + (while (and names (not client)) + (if (string-equal (cadar names) name) + (setq client (caar names))) + (setq names (cdr names)))))) + +(defun gds-choose-client (client) + (or ;; If client is an integer, it is the port number of the + ;; intended client. + (if (integerp client) client) + ;; Any other non-nil value indicates invocation with a prefix + ;; arg, which forces asking the user which application is + ;; intended. + (if client (gds-read-client)) + ;; If ask not forced, and there is a client with the focus, + ;; default to that one. + gds-displayed-client + ;; Last resort - ask the user. + (gds-read-client) + ;; Signal an error. + (error "No application chosen."))) + +(defcustom gds-default-module-name '(guile-user) + "Name of the default module for GDS code evaluation, as list of symbols. +This module is used when there is no `define-module' form in the +buffer preceding the code to be evaluated." + :type 'sexp + :group 'gds) + +(defun gds-module-name (start end) + "Determine and return the name of the module that governs the +specified region. The module name is returned as a list of symbols." + (interactive "r") ; why not? + (save-excursion + (goto-char start) + (let (module-name) + (while (and (not module-name) + (beginning-of-defun-raw 1)) + (if (looking-at "(define-module ") + (setq module-name + (progn + (goto-char (match-end 0)) + (read (current-buffer)))))) + module-name))) + +(defun gds-port-name (start end) + "Return port name for the specified region of the current buffer. +The name will be used by Guile as the port name when evaluating that +region's code." + (or (buffer-file-name) + (concat "Emacs buffer: " (buffer-name)))) + +(defun gds-eval-region (start end &optional client) + "Evaluate the current region." + (interactive "r\nP") + (setq client (gds-choose-client client)) + (let ((module (gds-module-name start end)) + (port-name (gds-port-name start end)) + line column) + (save-excursion + (goto-char start) + (setq column (current-column)) ; 0-based + (beginning-of-line) + (setq line (count-lines (point-min) (point)))) ; 0-based + (gds-send (format "(%S eval %s %S %d %d %S)\n" + client + (if module (prin1-to-string module) "#f") + port-name line column + (buffer-substring-no-properties start end))))) + +(defun gds-eval-expression (expr &optional client) + "Evaluate the supplied EXPR (a string)." + (interactive "sEvaluate expression: \nP") + (setq client (gds-choose-client client)) + (gds-send (format "(%S eval #f \"Emacs expression\" 0 0 %S)\n" + client expr))) + +(defun gds-eval-defun (&optional client) + "Evaluate the defun (top-level form) at point." + (interactive "P") + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (gds-eval-region (point) end client)))) + +(defun gds-eval-last-sexp (&optional client) + "Evaluate the sexp before point." + (interactive "P") + (gds-eval-region (save-excursion (backward-sexp) (point)) (point) client)) + +(defcustom gds-source-modes '(scheme-mode) + "*Used to determine if a buffer contains Scheme source code. +If it's loaded into a buffer that is in one of these major modes, it's +considered a scheme source file by `gds-load-file'." + :type '(repeat function) + :group 'gds) + +(defvar gds-prev-load-dir/file nil + "Holds the last (directory . file) pair passed to `gds-load-file'. +Used for determining the default for the next `gds-load-file'.") + +(defun gds-load-file (file-name &optional client) + "Load a Scheme file into the inferior Scheme process." + (interactive (list (car (comint-get-source "Load Scheme file: " + gds-prev-load-dir/file + gds-source-modes t)) + ; T because LOAD needs an + ; exact name + current-prefix-arg)) + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq gds-prev-load-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (setq client (gds-choose-client client)) + (gds-send (format "(%S load %S)\n" client file-name))) + +;; Install the process communication commands in the scheme-mode keymap. +(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention +(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention +(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-defun) +(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region) +(define-key scheme-mode-map "\C-c\C-l" 'gds-load-file) + + +;;;; Menu bar entries. + +(defvar gds-debug-menu nil + "GDS debugging menu.") +(if gds-debug-menu + nil + (setq gds-debug-menu (make-sparse-keymap "Debug")) + (define-key gds-debug-menu [go] + '(menu-item "Go" gds-go)) + (define-key gds-debug-menu [trace-finish] + '(menu-item "Trace This Frame" gds-trace-finish)) + (define-key gds-debug-menu [step-out] + '(menu-item "Finish This Frame" gds-step-out)) + (define-key gds-debug-menu [next] + '(menu-item "Next" gds-next)) + (define-key gds-debug-menu [step-in] + '(menu-item "Single Step" gds-step-in)) + (define-key gds-debug-menu [eval] + '(menu-item "Eval In This Frame..." gds-evaluate))) + +(defvar gds-eval-menu nil + "GDS evaluation menu.") +(if gds-eval-menu + nil + (setq gds-eval-menu (make-sparse-keymap "Evaluate")) + (define-key gds-eval-menu [load-file] + '(menu-item "Load Scheme File" gds-load-file)) + (define-key gds-eval-menu [defun] + '(menu-item "Defun At Point" gds-eval-defun)) + (define-key gds-eval-menu [region] + '(menu-item "Region" gds-eval-region)) + (define-key gds-eval-menu [last-sexp] + '(menu-item "Sexp Before Point" gds-eval-last-sexp)) + (define-key gds-eval-menu [expr] + '(menu-item "Expression..." gds-eval-expression))) + +(defvar gds-help-menu nil + "GDS help menu.") +(if gds-help-menu + nil + (setq gds-help-menu (make-sparse-keymap "Help")) + (define-key gds-help-menu [apropos] + '(menu-item "Apropos..." gds-apropos)) + (define-key gds-help-menu [sym-here] + '(menu-item "Symbol At Point" gds-help-symbol-here)) + (define-key gds-help-menu [sym] + '(menu-item "Symbol..." gds-help-symbol))) + +(defvar gds-advanced-menu nil + "Menu of rarely needed GDS operations.") +(if gds-advanced-menu + nil + (setq gds-advanced-menu (make-sparse-keymap "Advanced")) + (define-key gds-advanced-menu [restart-gds] + '(menu-item "Restart IDE" gds-start :enable gds-process)) + (define-key gds-advanced-menu [kill-gds] + '(menu-item "Shutdown IDE" gds-shutdown :enable gds-process)) + (define-key gds-advanced-menu [start-gds] + '(menu-item "Start IDE" gds-start :enable (not gds-process)))) + +(defvar gds-menu nil + "Global menu for GDS commands.") +(if gds-menu + nil + (setq gds-menu (make-sparse-keymap "Guile")) + (define-key gds-menu [advanced] + (cons "Advanced" gds-advanced-menu)) + (define-key gds-menu [separator-1] + '("--")) + (define-key gds-menu [help] + `(menu-item "Help" ,gds-help-menu :enable gds-names)) + (define-key gds-menu [eval] + `(menu-item "Evaluate" ,gds-eval-menu :enable gds-names)) + (define-key gds-menu [debug] + `(menu-item "Debug" ,gds-debug-menu :enable (and gds-displayed-client + (gds-client-waiting)))) + (setq menu-bar-final-items + (cons 'guile menu-bar-final-items)) + (define-key global-map [menu-bar guile] + (cons "Guile" gds-menu))) + +;;;; Autostarting the GDS server. + +(defcustom gds-autostart-server t + "Whether to automatically start the GDS server when `gds.el' is loaded." + :type 'boolean + :group 'gds) + +(if (and gds-autostart-server + (not gds-process)) + (gds-start)) + +(provide 'gds) + +;;; gds.el ends here. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 024a9206c..e6b2d3905 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2003-10-06 Neil Jerram + + * debugger/ui-client.scm (handle-instruction): Add evaluation + support. + (ui-eval): New. + 2003-10-04 Neil Jerram * debugger/ui-client.scm (ui-disable-async-thread, diff --git a/ice-9/debugger/ui-client.scm b/ice-9/debugger/ui-client.scm index 8fbbe1646..f7fc7b0e2 100644 --- a/ice-9/debugger/ui-client.scm +++ b/ice-9/debugger/ui-client.scm @@ -259,8 +259,53 @@ decimal IP address where the UI server is running; default is (debug-here)))) (module-ref (resolve-module (cadr ins)) (caddr ins))) state) + ((eval) + (apply (lambda (module port-name line column code) + (with-input-from-string code + (lambda () + (set-port-filename! (current-input-port) port-name) + (set-port-line! (current-input-port) line) + (set-port-column! (current-input-port) column) + (let ((m (and module (resolve-module module)))) + (let loop ((results '()) (x (read))) + (if (eof-object? x) + (write-form `(eval-results ,@results)) + (loop (append results (ui-eval x m)) + (read)))))))) + (cdr ins)) + state) (else state))) +(define (ui-eval x m) + ;; Consumer to accept possibly multiple values and present them for + ;; Emacs as a list of strings. + (define (value-consumer . values) + (if (unspecified? (car values)) + '() + (map (lambda (value) + (with-output-to-string (lambda () (write value)))) + values))) + (let ((value #f)) + (let ((output + (with-output-to-string + (lambda () + (if m + (begin + (display "Evaluating in module ") + (write (module-name m)) + (newline) + (set! value + (call-with-values (lambda () (eval x m)) + value-consumer))) + (begin + (display "Evaluating in current module ") + (write (module-name (current-module))) + (newline) + (set! value + (call-with-values (lambda () (primitive-eval x)) + value-consumer)))))))) + (list output value)))) + (define (write-status status) (write-form (list 'status status))) From da0e6c2baff68dda2abb721e72bdec2972157eb8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 7 Oct 2003 15:58:19 +0000 Subject: [PATCH 024/239] Make type names char const * instead of char *. Thanks to Paul Jarc! --- libguile/ChangeLog | 5 +++++ libguile/goops.c | 4 ++-- libguile/objects.h | 2 +- libguile/smob.c | 2 +- libguile/smob.h | 2 +- 5 files changed, 10 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index da7b12c44..a8dd7ee33 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-10-07 Marius Vollmer + + * goops.c, objects.h, smob.c, smob.h: Make type names char + const * instead of char *. Thanks to Paul Jarc! + 2003-10-02 Kevin Ryde * strports.c (s_scm_call_with_output_string): scm_get_output_string diff --git a/libguile/goops.c b/libguile/goops.c index 44da20efe..cccdf205a 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2435,7 +2435,7 @@ create_standard_classes (void) **********************************************************************/ static SCM -make_class_from_template (char *template, char *type_name, SCM supers, int applicablep) +make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep) { SCM class, name; if (type_name) @@ -2462,7 +2462,7 @@ make_class_from_template (char *template, char *type_name, SCM supers, int appli } SCM -scm_make_extended_class (char *type_name, int applicablep) +scm_make_extended_class (char const *type_name, int applicablep) { return make_class_from_template ("<%s>", type_name, diff --git a/libguile/objects.h b/libguile/objects.h index d500c9ada..3217df025 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -197,7 +197,7 @@ SCM_API SCM *scm_smob_class; SCM_API SCM scm_no_applicable_method; /* Goops functions. */ -SCM_API SCM scm_make_extended_class (char *type_name, int applicablep); +SCM_API SCM scm_make_extended_class (char const *type_name, int applicablep); SCM_API void scm_i_inherit_applicable (SCM c); SCM_API void scm_make_port_classes (long ptobnum, char *type_name); SCM_API void scm_change_object_class (SCM, SCM, SCM); diff --git a/libguile/smob.c b/libguile/smob.c index c73b2a9ca..8153d44bb 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -269,7 +269,7 @@ scm_smob_apply_3_error (SCM smob, scm_t_bits -scm_make_smob_type (char *name, size_t size) +scm_make_smob_type (char const *name, size_t size) #define FUNC_NAME "scm_make_smob_type" { long new_smob; diff --git a/libguile/smob.h b/libguile/smob.h index 279e0cbf5..3ca8de8a4 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -30,7 +30,7 @@ typedef struct scm_smob_descriptor { - char *name; + char const *name; size_t size; SCM (*mark) (SCM); size_t (*free) (SCM); From d6e04e7c4a01d0981b102cb028a11dc019ea22dd Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 7 Oct 2003 22:00:05 +0000 Subject: [PATCH 025/239] * lib.scm (exception:missing-expression): New. * tests/dynamic-scope.test, tests/eval.test, tests/r5rs_pitfall.test, tests/srfi-17.test, tests/syncase.test: Wrap tests in module (test-suite test-), following a practice that was used on a couple of files already. * tests/dynamic-scope.test (exception:duplicate-binding, exception:bad-binding): New. * tests/dynamic-scope.test, tests/srfi-17.test, tests/syntax.test: Execute syntactically wrong tests using eval. With the upcoming new memoizer this is necessary in order to postpone the syntax check to the actual evaluation of the syntactically wrong form. * tests/syntax.test: Added some test cases and modified one test case. --- test-suite/ChangeLog | 20 +++ test-suite/lib.scm | 7 +- test-suite/tests/dynamic-scope.test | 29 ++-- test-suite/tests/eval.test | 4 +- test-suite/tests/r5rs_pitfall.test | 4 +- test-suite/tests/srfi-17.test | 7 +- test-suite/tests/syncase.test | 13 +- test-suite/tests/syntax.test | 231 +++++++++++++++++++--------- 8 files changed, 218 insertions(+), 97 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index f8334e13a..26d166b00 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,23 @@ +2003-10-07 Dirk Herrmann + + * lib.scm (exception:missing-expression): New. + + * tests/dynamic-scope.test, tests/eval.test, + tests/r5rs_pitfall.test, tests/srfi-17.test, tests/syncase.test: + Wrap tests in module (test-suite test-), + following a practice that was used on a couple of files already. + + * tests/dynamic-scope.test (exception:duplicate-binding, + exception:bad-binding): New. + + * tests/dynamic-scope.test, tests/srfi-17.test, tests/syntax.test: + Execute syntactically wrong tests using eval. With the upcoming + new memoizer this is necessary in order to postpone the syntax + check to the actual evaluation of the syntactically wrong form. + + * tests/syntax.test: Added some test cases and modified one test + case. + 2003-10-02 Kevin Ryde * tests/ports.test (call-with-output-string): Test proc closing port. diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 90b0837e4..bf27d9621 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -22,6 +22,7 @@ :export ( ;; Exceptions which are commonly being tested for. + exception:missing-expression exception:out-of-range exception:unbound-var exception:wrong-num-args exception:wrong-type-arg @@ -32,14 +33,14 @@ ;; Naming groups of tests in a regular fashion. with-test-prefix with-test-prefix* current-test-prefix + format-test-name ;; Reporting results in various ways. register-reporter unregister-reporter reporter-registered? make-count-reporter print-counts make-log-reporter full-reporter - user-reporter - format-test-name)) + user-reporter)) ;;;; If you're using Emacs's Scheme mode: @@ -232,6 +233,8 @@ ;;;; ;;; Define some exceptions which are commonly being tested for. +(define exception:missing-expression + (cons 'misc-error "^missing or extra expression")) (define exception:out-of-range (cons 'out-of-range "^Argument .*out of range")) (define exception:unbound-var diff --git a/test-suite/tests/dynamic-scope.test b/test-suite/tests/dynamic-scope.test index bb7e1adda..89f43ae6f 100644 --- a/test-suite/tests/dynamic-scope.test +++ b/test-suite/tests/dynamic-scope.test @@ -18,7 +18,14 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -(use-modules (test-suite lib)) +(define-module (test-suite test-dynamic-scope) + :use-module (test-suite lib)) + + +(define exception:duplicate-binding + (cons 'misc-error "^duplicate bindings")) +(define exception:bad-binding + (cons 'misc-error "^bad bindings")) (define global-a 0) (define (fetch-global-a) global-a) @@ -35,20 +42,24 @@ (= global-a 0))) (pass-if-exception "duplicate @binds" - (cons 'misc-error "^duplicate bindings") - (@bind ((a 1) (a 2)) (+ a a))) + exception:duplicate-binding + (eval '(@bind ((a 1) (a 2)) (+ a a)) + (interaction-environment))) (pass-if-exception "@bind missing expression" - (cons 'misc-error "^missing or extra expression") - (@bind ((global-a 1)))) + exception:missing-expression + (eval '(@bind ((global-a 1))) + (interaction-environment))) (pass-if-exception "@bind bad bindings" - (cons 'misc-error "^bad bindings") - (@bind (a) #f)) + exception:bad-binding + (eval '(@bind (a) #f) + (interaction-environment))) (pass-if-exception "@bind bad bindings" - (cons 'misc-error "^bad bindings") - (@bind ((a)) #f)) + exception:bad-binding + (eval '(@bind ((a)) #f) + (interaction-environment))) (pass-if "@bind and dynamic-wind" (letrec ((co-routine #f) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index ca07686bc..06f42ae28 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -15,7 +15,9 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -(use-modules (ice-9 documentation)) +(define-module (test-suite test-eval) + :use-module (test-suite lib) + :use-module (ice-9 documentation)) ;;; diff --git a/test-suite/tests/r5rs_pitfall.test b/test-suite/tests/r5rs_pitfall.test index 30edb479a..4c4bce6c4 100644 --- a/test-suite/tests/r5rs_pitfall.test +++ b/test-suite/tests/r5rs_pitfall.test @@ -5,9 +5,9 @@ ;; http://sisc.sourceforge.net/r5rs_pitfal.scm and the 'should-be' ;; macro has been modified to fit into our test suite machinery. ;; -;; Tests 1.1 and 2.1 fail, but we expect that. +;; Test 1.1 fails, but we expect that. -(define-module (r5rs-pitfall-test) +(define-module (test-suite test-r5rs-pitfall) :use-syntax (ice-9 syncase) :use-module (test-suite lib)) diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test index dc6fd7e06..f39489db7 100644 --- a/test-suite/tests/srfi-17.test +++ b/test-suite/tests/srfi-17.test @@ -17,7 +17,10 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -(use-modules (srfi srfi-17)) +(define-module (test-suite test-srfi-17) + :use-module (test-suite lib) + :use-module (srfi srfi-17)) + (with-test-prefix "set!" @@ -29,4 +32,4 @@ (pass-if-exception "(set! '#f 1)" exception:wrong-type-arg - (set! '#f 1)))) + (eval '(set! '#f 1) (interaction-environment))))) diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test index 88667ea06..3a9574cb6 100644 --- a/test-suite/tests/syncase.test +++ b/test-suite/tests/syncase.test @@ -20,18 +20,17 @@ ;; These tests are in a module so that the syntax transformer does not ;; affect code outside of this file. ;; -(define-module (syncase-test)) - -(use-modules (test-suite lib)) +(define-module (test-suite test-syncase) + :use-module (test-suite lib)) (pass-if "(ice-9 syncase) loads" - (false-if-exception - (begin (eval '(use-syntax (ice-9 syncase)) (current-module)) - #t))) + (false-if-exception + (begin (eval '(use-syntax (ice-9 syncase)) (current-module)) + #t))) (define-syntax plus (syntax-rules () ((plus x ...) (+ x ...)))) (pass-if "basic syncase macro" - (= (plus 1 2 3) (+ 1 2 3))) + (= (plus 1 2 3) (+ 1 2 3))) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 38a77c3db..3261ea1f6 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -40,6 +40,20 @@ (with-test-prefix "expressions" + (with-test-prefix "Bad argument list" + + (pass-if-exception "improper argument list of length 1" + exception:wrong-num-args + (eval '(let ((foo (lambda (x y) #t))) + (foo . 1)) + (interaction-environment))) + + (pass-if-exception "improper argument list of length 2" + exception:wrong-num-args + (eval '(let ((foo (lambda (x y) #t))) + (foo 1 . 2)) + (interaction-environment)))) + (with-test-prefix "missing or extra expression" ;; R5RS says: @@ -51,7 +65,8 @@ ;; Fixed on 2001-3-3 (pass-if-exception "empty parentheses \"()\"" exception:missing/extra-expr - ()))) + (eval '() + (interaction-environment))))) (with-test-prefix "quote" #t) @@ -87,15 +102,18 @@ (pass-if-exception "(lambda)" exception:bad-formals - (lambda)) + (eval '(lambda) + (interaction-environment))) (pass-if-exception "(lambda . \"foo\")" exception:bad-formals - (lambda . "foo")) + (eval '(lambda . "foo") + (interaction-environment))) (pass-if-exception "(lambda \"foo\")" exception:bad-formals - (lambda "foo")) + (eval '(lambda "foo") + (interaction-environment))) (pass-if-exception "(lambda \"foo\" #f)" exception:bad-formals @@ -104,37 +122,44 @@ (pass-if-exception "(lambda (x 1) 2)" exception:bad-formals - (lambda (x 1) 2)) + (eval '(lambda (x 1) 2) + (interaction-environment))) (pass-if-exception "(lambda (1 x) 2)" exception:bad-formals - (lambda (1 x) 2)) + (eval '(lambda (1 x) 2) + (interaction-environment))) (pass-if-exception "(lambda (x \"a\") 2)" exception:bad-formals - (lambda (x "a") 2)) + (eval '(lambda (x "a") 2) + (interaction-environment))) (pass-if-exception "(lambda (\"a\" x) 2)" exception:bad-formals - (lambda ("a" x) 2))) + (eval '(lambda ("a" x) 2) + (interaction-environment)))) (with-test-prefix "duplicate formals" ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x) 1)" exception:duplicate-formals - (lambda (x x) 1)) + (eval '(lambda (x x) 1) + (interaction-environment))) ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x x) 1)" exception:duplicate-formals - (lambda (x x x) 1))) + (eval '(lambda (x x x) 1) + (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(lambda ())" exception:bad-body - (lambda ())))) + (eval '(lambda ()) + (interaction-environment))))) (with-test-prefix "let" @@ -148,33 +173,40 @@ (pass-if-exception "(let)" exception:bad-bindings - (let)) + (eval '(let) + (interaction-environment))) (pass-if-exception "(let 1)" exception:bad-bindings - (let 1)) + (eval '(let 1) + (interaction-environment))) (pass-if-exception "(let (x))" exception:bad-bindings - (let (x))) + (eval '(let (x)) + (interaction-environment))) ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? ;; (Even although the body is bad as well...) (pass-if-exception "(let ((x)))" exception:bad-body - (let ((x)))) + (eval '(let ((x))) + (interaction-environment))) (pass-if-exception "(let (x) 1)" exception:bad-bindings - (let (x) 1)) + (eval '(let (x) 1) + (interaction-environment))) (pass-if-exception "(let ((x)) 3)" exception:bad-bindings - (let ((x)) 3)) + (eval '(let ((x)) 3) + (interaction-environment))) (pass-if-exception "(let ((x 1) y) x)" exception:bad-bindings - (let ((x 1) y) x)) + (eval '(let ((x 1) y) x) + (interaction-environment))) (pass-if-exception "(let ((1 2)) 3)" exception:bad-var @@ -185,17 +217,20 @@ (pass-if-exception "(let ((x 1) (x 2)) x)" exception:duplicate-bindings - (let ((x 1) (x 2)) x))) + (eval '(let ((x 1) (x 2)) x) + (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let ())" exception:bad-body - (let ())) + (eval '(let ()) + (interaction-environment))) (pass-if-exception "(let ((x 1)))" exception:bad-body - (let ((x 1)))))) + (eval '(let ((x 1))) + (interaction-environment))))) (with-test-prefix "named let" @@ -209,17 +244,20 @@ (pass-if-exception "(let x (y))" exception:bad-bindings - (let x (y)))) + (eval '(let x (y)) + (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let x ())" exception:bad-body - (let x ())) + (eval '(let x ()) + (interaction-environment))) (pass-if-exception "(let x ((y 1)))" exception:bad-body - (let x ((y 1)))))) + (eval '(let x ((y 1))) + (interaction-environment))))) (with-test-prefix "let*" @@ -237,27 +275,33 @@ (pass-if-exception "(let*)" exception:bad-bindings - (let*)) + (eval '(let*) + (interaction-environment))) (pass-if-exception "(let* 1)" exception:bad-bindings - (let* 1)) + (eval '(let* 1) + (interaction-environment))) (pass-if-exception "(let* (x))" exception:bad-bindings - (let* (x))) + (eval '(let* (x)) + (interaction-environment))) (pass-if-exception "(let* (x) 1)" exception:bad-bindings - (let* (x) 1)) + (eval '(let* (x) 1) + (interaction-environment))) (pass-if-exception "(let* ((x)) 3)" exception:bad-bindings - (let* ((x)) 3)) + (eval '(let* ((x)) 3) + (interaction-environment))) (pass-if-exception "(let* ((x 1) y) x)" exception:bad-bindings - (let* ((x 1) y) x)) + (eval '(let* ((x 1) y) x) + (interaction-environment))) (pass-if-exception "(let* x ())" exception:bad-bindings @@ -278,11 +322,13 @@ (pass-if-exception "(let* ())" exception:bad-body - (let* ())) + (eval '(let* ()) + (interaction-environment))) (pass-if-exception "(let* ((x 1)))" exception:bad-body - (let* ((x 1)))))) + (eval '(let* ((x 1))) + (interaction-environment))))) (with-test-prefix "letrec" @@ -297,27 +343,33 @@ (pass-if-exception "(letrec)" exception:bad-bindings - (letrec)) + (eval '(letrec) + (interaction-environment))) (pass-if-exception "(letrec 1)" exception:bad-bindings - (letrec 1)) + (eval '(letrec 1) + (interaction-environment))) (pass-if-exception "(letrec (x))" exception:bad-bindings - (letrec (x))) + (eval '(letrec (x)) + (interaction-environment))) (pass-if-exception "(letrec (x) 1)" exception:bad-bindings - (letrec (x) 1)) + (eval '(letrec (x) 1) + (interaction-environment))) (pass-if-exception "(letrec ((x)) 3)" exception:bad-bindings - (letrec ((x)) 3)) + (eval '(letrec ((x)) 3) + (interaction-environment))) (pass-if-exception "(letrec ((x 1) y) x)" exception:bad-bindings - (letrec ((x 1) y) x)) + (eval '(letrec ((x 1) y) x) + (interaction-environment))) (pass-if-exception "(letrec x ())" exception:bad-bindings @@ -338,17 +390,20 @@ (pass-if-exception "(letrec ((x 1) (x 2)) x)" exception:duplicate-bindings - (letrec ((x 1) (x 2)) x))) + (eval '(letrec ((x 1) (x 2)) x) + (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(letrec ())" exception:bad-body - (letrec ())) + (eval '(letrec ()) + (interaction-environment))) (pass-if-exception "(letrec ((x 1)))" exception:bad-body - (letrec ((x 1)))))) + (eval '(letrec ((x 1))) + (interaction-environment))))) (with-test-prefix "if" @@ -370,42 +425,57 @@ (pass-if-exception "(cond)" exception:bad/missing-clauses - (cond)) + (eval '(cond) + (interaction-environment))) (pass-if-exception "(cond #t)" exception:bad/missing-clauses - (cond #t)) + (eval '(cond #t) + (interaction-environment))) (pass-if-exception "(cond 1)" exception:bad/missing-clauses - (cond 1)) + (eval '(cond 1) + (interaction-environment))) (pass-if-exception "(cond 1 2)" exception:bad/missing-clauses - (cond 1 2)) + (eval '(cond 1 2) + (interaction-environment))) (pass-if-exception "(cond 1 2 3)" exception:bad/missing-clauses - (cond 1 2 3)) + (eval '(cond 1 2 3) + (interaction-environment))) (pass-if-exception "(cond 1 2 3 4)" exception:bad/missing-clauses - (cond 1 2 3 4)) + (eval '(cond 1 2 3 4) + (interaction-environment))) (pass-if-exception "(cond ())" exception:bad/missing-clauses - (cond ())) + (eval '(cond ()) + (interaction-environment))) (pass-if-exception "(cond () 1)" exception:bad/missing-clauses - (cond () 1)) + (eval '(cond () 1) + (interaction-environment))) (pass-if-exception "(cond (1) 1)" exception:bad/missing-clauses - (cond (1) 1)))) + (eval '(cond (1) 1) + (interaction-environment))))) (with-test-prefix "cond =>" + (with-test-prefix "cond is hygienic" + + (expect-fail "bound '=> is handled correctly" + (false-if-exception + (eq? (let ((=> #f)) (cond (#t => 'ok))) 'ok)))) + (with-test-prefix "else is handled correctly" (pass-if "else =>" @@ -416,11 +486,11 @@ (let* ((=> 'foo)) (eq? (cond (else => identity)) identity)))) - (with-test-prefix "bad formals" + (with-test-prefix "wrong number of arguments" - (pass-if-exception "=> (lambda (x 1) 2)" - exception:bad-formals - (cond (1 => (lambda (x 1) 2)))))) + (pass-if-exception "=> (lambda (x y) #t)" + exception:wrong-num-args + (cond (1 => (lambda (x y) #t)))))) (with-test-prefix "case" @@ -428,35 +498,43 @@ (pass-if-exception "(case)" exception:bad/missing-clauses - (case)) + (eval '(case) + (interaction-environment))) (pass-if-exception "(case . \"foo\")" exception:bad/missing-clauses - (case . "foo")) + (eval '(case . "foo") + (interaction-environment))) (pass-if-exception "(case 1)" exception:bad/missing-clauses - (case 1)) + (eval '(case 1) + (interaction-environment))) (pass-if-exception "(case 1 . \"foo\")" exception:bad/missing-clauses - (case 1 . "foo")) + (eval '(case 1 . "foo") + (interaction-environment))) (pass-if-exception "(case 1 \"foo\")" exception:bad/missing-clauses - (case 1 "foo")) + (eval '(case 1 "foo") + (interaction-environment))) (pass-if-exception "(case 1 ())" exception:bad/missing-clauses - (case 1 ())) + (eval '(case 1 ()) + (interaction-environment))) (pass-if-exception "(case 1 (\"foo\"))" exception:bad/missing-clauses - (case 1 ("foo"))) + (eval '(case 1 ("foo")) + (interaction-environment))) (pass-if-exception "(case 1 (\"foo\" \"bar\"))" exception:bad/missing-clauses - (case 1 ("foo" "bar"))) + (eval '(case 1 ("foo" "bar")) + (interaction-environment))) ;; According to R5RS, the following one is syntactically correct. ;; (pass-if-exception "(case 1 (() \"bar\"))" @@ -465,19 +543,23 @@ (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")" exception:bad/missing-clauses - (case 1 ((2) "bar") . "foo")) + (eval '(case 1 ((2) "bar") . "foo") + (interaction-environment))) - (pass-if-exception "(case 1 (else #f) ((1) #t))" + (pass-if-exception "(case 1 ((2) \"bar\") (else))" exception:bad/missing-clauses - (case 1 ((2) "bar") (else))) + (eval '(case 1 ((2) "bar") (else)) + (interaction-environment))) (pass-if-exception "(case 1 (else #f) . \"foo\")" exception:bad/missing-clauses - (case 1 (else #f) . "foo")) + (eval '(case 1 (else #f) . "foo") + (interaction-environment))) (pass-if-exception "(case 1 (else #f) ((1) #t))" exception:bad/missing-clauses - (case 1 (else #f) ((1) #t))))) + (eval '(case 1 (else #f) ((1) #t)) + (interaction-environment))))) (with-test-prefix "define" @@ -491,7 +573,8 @@ (pass-if-exception "(define)" exception:missing/extra-expr - (define)))) + (eval '(define) + (interaction-environment))))) (with-test-prefix "set!" @@ -558,10 +641,6 @@ (define (unreachable) (error "unreachable code has been reached!")) - ;; an environment with no bindings at all - (define empty-environment - (make-module 1)) - ;; Return a new procedure COND which when called (COND) will return #t the ;; first N times, then #f, then any further call is an error. N=0 is ;; allowed, in which case #f is returned by the first call. @@ -578,7 +657,7 @@ (pass-if-exception "too few args" exception:wrong-num-args - (while)) + (eval '(while) (interaction-environment))) (with-test-prefix "empty body" (do ((n 0 (1+ n))) @@ -594,7 +673,11 @@ #t) (with-test-prefix "in empty environment" - + + ;; an environment with no bindings at all + (define empty-environment + (make-module 1)) + (pass-if "empty body" (eval `(,while #f) empty-environment) From df5af69a91db93c8b881c8f02e1596ee820568ac Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 7 Oct 2003 22:03:26 +0000 Subject: [PATCH 026/239] * smob.h (scm_make_smob_type): Made the declaration match the definition. --- libguile/ChangeLog | 5 +++++ libguile/smob.h | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a8dd7ee33..38124521f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-10-08 Dirk Herrmann + + * smob.h (scm_make_smob_type): Made the declaration match the + definition. + 2003-10-07 Marius Vollmer * goops.c, objects.h, smob.c, smob.h: Make type names char diff --git a/libguile/smob.h b/libguile/smob.h index 3ca8de8a4..97af67a0b 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -114,7 +114,7 @@ SCM_API int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate); * values using `scm_set_smob_xxx'. */ -SCM_API scm_t_bits scm_make_smob_type (char *name, size_t size); +SCM_API scm_t_bits scm_make_smob_type (char const *name, size_t size); SCM_API void scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM)); SCM_API void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM)); From d6532dd1cf51fa065564f2c9a5ff99a6d0a3561c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 8 Oct 2003 22:57:52 +0000 Subject: [PATCH 027/239] (funcq-assoc): Rewrite, don't assume '() is false, and actually traverse the given alist. --- ice-9/poe.scm | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/ice-9/poe.scm b/ice-9/poe.scm index bd7f2422d..2f3879b9e 100644 --- a/ice-9/poe.scm +++ b/ice-9/poe.scm @@ -58,16 +58,20 @@ (cdr arg-list)))))) it)) +;; return true if lists X and Y are the same length and each element is `eq?' +(define (eq?-list x y) + (if (null? x) + (null? y) + (and (not (null? y)) + (eq? (car x) (car y)) + (eq?-list (cdr x) (cdr y))))) + (define (funcq-assoc arg-list alist) - (let ((it (and alist - (let and-map ((key arg-list) - (entry (caar alist))) - (or (and (and (not key) (not entry)) - (car alist)) - (and key entry - (eq? (car key) (car entry)) - (and-map (cdr key) (cdr entry)))))))) - it)) + (if (null? alist) + #f + (if (eq?-list arg-list (caar alist)) + (car alist) + (funcq-assoc arg-list (cdr alist))))) From ff6ea7b951529beff8f7c94afe97f8d32a08e658 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 8 Oct 2003 23:00:37 +0000 Subject: [PATCH 028/239] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ libguile/ChangeLog | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index e6b2d3905..084705d49 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2003-10-09 Kevin Ryde + + * poe.scm (funcq-assoc): Rewrite, don't assume '() is false, and + actually traverse the given alist. + 2003-10-06 Neil Jerram * debugger/ui-client.scm (handle-instruction): Add evaluation diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 38124521f..4c7d698b4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -10,7 +10,7 @@ 2003-10-02 Kevin Ryde - * strports.c (s_scm_call_with_output_string): scm_get_output_string + * strports.c (scm_call_with_output_string): scm_get_output_string rather than scm_strport_to_string, so as to guard against the port having been closed by the called procedure. Reported by Nic Ferrier. From f33f103c955abedab4ba5b668dc5b575382f5b00 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 8 Oct 2003 23:03:29 +0000 Subject: [PATCH 029/239] New file. --- test-suite/tests/poe.test | 81 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 81 insertions(+) create mode 100644 test-suite/tests/poe.test diff --git a/test-suite/tests/poe.test b/test-suite/tests/poe.test new file mode 100644 index 000000000..b6022eb78 --- /dev/null +++ b/test-suite/tests/poe.test @@ -0,0 +1,81 @@ +;;;; poe.test --- exercise ice-9/poe.scm -*- scheme -*- +;;;; +;;;; Copyright 2003 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (test-suite test-ice-9-poe) + #:use-module (test-suite lib) + #:use-module (ice-9 poe)) + + +;; +;; pure-funcq +;; + + +;; +;; perfect-funcq +;; + +(with-test-prefix "perfect-funcq" + + (with-test-prefix "no args" + (define called #f) + (define (foo) + (set! called #t) + 'foo) + + (let ((func (perfect-funcq 31 foo))) + + (pass-if "called first" + (set! called #f) + (and (eq? 'foo (func)) + called)) + + (pass-if "not called second" + (set! called #f) + (and (eq? 'foo (func)) + (not called))))) + + (with-test-prefix "1 arg" + (define called #f) + (define (foo str) + (set! called #t) + (string->number str)) + + (let ((func (perfect-funcq 31 foo))) + (define s1 "123") + (define s2 "123") + + (pass-if "called first s1" + (set! called #f) + (and (= 123 (func s1)) + called)) + + (pass-if "not called second s1" + (set! called #f) + (and (= 123 (func s1)) + (not called))) + + (pass-if "called first s2" + (set! called #f) + (and (= 123 (func s2)) + called)) + + (pass-if "not called second s2" + (set! called #f) + (and (= 123 (func s2)) + (not called)))))) From c42605e954a34cbd8393abdac8b8c74d63e6d4fb Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 8 Oct 2003 23:05:12 +0000 Subject: [PATCH 030/239] * tests/poe.test: New file. * Makefile.am: Add it. --- test-suite/Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 3b990378e..d35a97fe4 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -23,6 +23,7 @@ SCM_TESTS = tests/alist.test \ tests/numbers.test \ tests/optargs.test \ tests/options.test \ + tests/poe.test \ tests/popen.test \ tests/ports.test \ tests/posix.test \ From b7be48bc3903ea517fa6459f600aebfe572a7bdf Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 8 Oct 2003 23:06:05 +0000 Subject: [PATCH 031/239] *** empty log message *** --- test-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 26d166b00..4b583ae3d 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2003-10-09 Kevin Ryde + + * tests/poe.test: New file. + * Makefile.am: Add it. + 2003-10-07 Dirk Herrmann * lib.scm (exception:missing-expression): New. From ea2b9c2f6be0f0a394dfacef010025e3eeefcf92 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 9 Oct 2003 00:14:38 +0000 Subject: [PATCH 032/239] (Hash Table Reference): Decribe rehashing, note no hashx-remove!, describe make-hash-table size parameter. --- doc/ref/scheme-compound.texi | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/doc/ref/scheme-compound.texi b/doc/ref/scheme-compound.texi index 2876017be..6064c8c52 100644 --- a/doc/ref/scheme-compound.texi +++ b/doc/ref/scheme-compound.texi @@ -2254,11 +2254,17 @@ with any set of functions, but it's imperative that just one set is then used consistently, or results will be unpredictable. @sp 1 -Hash tables are implemented as a vector indexed by an integer formed +Hash tables are implemented as a vector indexed by a hash value formed from the key, with an association list of key/value pairs for each bucket in case distinct keys hash together. Direct access to the pairs in those lists is provided by the @code{-handle-} functions. +When the number of table entries goes above a threshold the vector is +increased and the entries rehashed, to prevent the bucket lists +becoming too long and slowing down accesses. When the number of +entries goes below a threshold the vector is decreased to save space. + +@sp 1 For the @code{hashx-} ``extended'' routines, an application supplies a @var{hash} function producing an integer index like @code{hashq} etc below, and an @var{assoc} alist search function like @code{assq} etc @@ -2268,6 +2274,7 @@ functions implementing case-insensitive hashing of string keys, @example (use-modules (srfi srfi-1) (srfi srfi-13)) + (define (my-hash str size) (remainder (string-hash-ci str) size)) (define (my-assoc str alist) @@ -2281,21 +2288,27 @@ functions implementing case-insensitive hashing of string keys, @end example In a @code{hashx-} @var{hash} function the aim is to spread keys -across the vector, so bucket lists don't become long, but the actual -values are arbitrary (so long as they're in the range 0 to -@math{@var{size}-1}). Helpful functions for forming a hash value, in +across the vector, so bucket lists don't become long. But the actual +values are arbitrary as long as they're in the range 0 to +@math{@var{size}-1}. Helpful functions for forming a hash value, in addition to @code{hashq} etc below, include @code{symbol-hash} (@pxref{Symbol Keys}), @code{string-hash} and @code{string-hash-ci} (@pxref{SRFI-13 Comparison}), and @code{char-set-hash} (@pxref{SRFI-14 Predicates/Comparison}). +Note that currently, unfortunately, there's no @code{hashx-remove!} +function, which rather limits the usefulness of the @code{hashx-} +routines. + @sp 1 @deffn {Scheme Procedure} make-hash-table [size] -Create a new hash table, with an optional initial vector @var{size}. +Create a new hash table, with an optional minimum vector @var{size}. -@var{size} doesn't limit the entries in the table, merely gives a -starting size for the internal vector. A prime number bigger than the -expected number of entries would be a good choice. +When @var{size} is given, the table vector will still grow and shrink +automatically, as described above, but with @var{size} as a minimum. +If an application knows roughly how many entries the table will hold +then it can use @var{size} to avoid rehashing when initial entries are +added. @end deffn @deffn {Scheme Procedure} hash-ref table key [dflt] From f09fe637328587655678109434eb082054b069e6 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 9 Oct 2003 00:17:12 +0000 Subject: [PATCH 033/239] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index fa07f613b..021830819 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2003-10-09 Kevin Ryde + + * scheme-compound.texi (Hash Table Reference): Decribe rehashing, note + no hashx-remove!, describe make-hash-table size parameter. + 2003-10-06 Marius Vollmer * scheme-memory.texi: Added a short explanation of the GC and the From 2be24db4d77c78f06a4be60701e0ee7eaf103b0d Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 9 Oct 2003 00:38:51 +0000 Subject: [PATCH 034/239] (scm_inexact_to_exact): Don't depend on what double->long cast gives for values bigger than a long, or for nan or inf. --- libguile/numbers.c | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 6f9c60622..b0b5d36f3 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4337,14 +4337,26 @@ SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, return z; else if (SCM_REALP (z)) { - double u = floor (SCM_REAL_VALUE (z) + 0.5); - long lu = (long) u; - if (SCM_FIXABLE (lu)) - return SCM_MAKINUM (lu); - else if (!xisinf (u) && !xisnan (u)) - return scm_i_dbl2big (u); - else + /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both + powers of 2, so there's no rounding when making "double" values + from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could get + rounded on a 64-bit machine, hence the "+1". + + The use of floor() to force to an integer value ensures we get a + "numerically closest" value without depending on how a double->long + cast or how mpz_set_d will round. For reference, double->long + probably follows the hardware rounding mode, mpz_set_d truncates + towards zero. */ + + double u = SCM_REAL_VALUE (z); + if (xisinf (u) || xisnan (u)) scm_num_overflow (s_scm_inexact_to_exact); + u = floor (u + 0.5); + if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1) + && u >= (double) SCM_MOST_NEGATIVE_FIXNUM) + return SCM_MAKINUM ((long) u); + else + return scm_i_dbl2big (u); } else SCM_WRONG_TYPE_ARG (1, z); From 1259cb26f7567c2869d078ff45998db91f292213 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 9 Oct 2003 00:41:15 +0000 Subject: [PATCH 035/239] (inexact->exact): New tests. --- test-suite/tests/numbers.test | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 0040bd692..4e2fe5776 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -2072,6 +2072,24 @@ ;;; inexact->exact ;;; +(with-test-prefix "inexact->exact" + + (pass-if-exception exception:numerical-overflow "+inf" + (inexact->exact +.inf)) + + (pass-if-exception exception:numerical-overflow "-inf" + (inexact->exact -.inf)) + + (pass-if-exception exception:numerical-overflow "nan" + (inexact->exact +.nan)) + + (with-test-prefix "2.0**i to exact and back" + (do ((i 0 (1+ i)) + (n 1.0 (* 2.0 n))) + ((> i 100)) + (pass-if (list i n) + (= n (inexact->exact (exact->inexact n))))))) + ;;; ;;; integer-length ;;; From 9ddeb77696841a35aaf9b31fff911a1e98d6b61c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 9 Oct 2003 00:41:46 +0000 Subject: [PATCH 036/239] *** empty log message *** --- libguile/ChangeLog | 5 +++++ test-suite/ChangeLog | 2 ++ 2 files changed, 7 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4c7d698b4..ca42a037b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-10-09 Kevin Ryde + + * numbers.c (scm_inexact_to_exact): Don't depend on what double->long + cast gives for values bigger than a long, or for nan or inf. + 2003-10-08 Dirk Herrmann * smob.h (scm_make_smob_type): Made the declaration match the diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 4b583ae3d..d26c771b7 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,5 +1,7 @@ 2003-10-09 Kevin Ryde + * tests/numbers.test (inexact->exact): New tests. + * tests/poe.test: New file. * Makefile.am: Add it. From a409f865f02143ad09c378477d960335854af19c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 10 Oct 2003 14:32:11 +0000 Subject: [PATCH 037/239] (inexact->exact): Use corrent argument order for pass-if-exception. Use "+inf.0" instead of "+.inf", etc. --- test-suite/tests/numbers.test | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 4e2fe5776..5fe98bf06 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -2074,14 +2074,14 @@ (with-test-prefix "inexact->exact" - (pass-if-exception exception:numerical-overflow "+inf" - (inexact->exact +.inf)) + (pass-if-exception "+inf" exception:numerical-overflow + (inexact->exact +inf.0)) - (pass-if-exception exception:numerical-overflow "-inf" - (inexact->exact -.inf)) + (pass-if-exception "-inf" exception:numerical-overflow + (inexact->exact -inf.0)) - (pass-if-exception exception:numerical-overflow "nan" - (inexact->exact +.nan)) + (pass-if-exception "nan" exception:numerical-overflow + (inexact->exact +nan.0)) (with-test-prefix "2.0**i to exact and back" (do ((i 0 (1+ i)) From 7b0f1f2ae12c906c7e06a65f343dcc5b79998736 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 10 Oct 2003 14:32:19 +0000 Subject: [PATCH 038/239] *** empty log message *** --- test-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d26c771b7..5a3ff964c 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2003-10-10 Marius Vollmer + + * tests/numbers.test (inexact->exact): Use corrent argument order + for pass-if-exception. Use "+inf.0" instead of "+.inf", etc. + 2003-10-09 Kevin Ryde * tests/numbers.test (inexact->exact): New tests. From e6729603c0f9a1511aaf32001e808b5f97009176 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 10 Oct 2003 21:49:27 +0000 Subject: [PATCH 039/239] * libguile/eval.c (s_bad_expression, syntax_error_key, syntax_error, ASSERT_SYNTAX, ASSERT_SYNTAX_2): New static identifiers. (scm_m_and): Use ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing when creating the memoized code. * test-suite/lib.scm (run-test-exception): Handle syntax errors. --- libguile/ChangeLog | 8 +++ libguile/eval.c | 122 ++++++++++++++++++++++++++++++++++++++++--- test-suite/ChangeLog | 4 ++ test-suite/lib.scm | 7 +++ 4 files changed, 135 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ca42a037b..862c3a656 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2003-10-10 Dirk Herrmann + + * eval.c (s_bad_expression, syntax_error_key, syntax_error, + ASSERT_SYNTAX, ASSERT_SYNTAX_2): New static identifiers. + + (scm_m_and): Use ASSERT_SYNTAX to signal syntax errors. Avoid + unnecessary consing when creating the memoized code. + 2003-10-09 Kevin Ryde * numbers.c (scm_inexact_to_exact): Don't depend on what double->long diff --git a/libguile/eval.c b/libguile/eval.c index d52c84360..e91e2fbcc 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -60,6 +60,7 @@ char *alloca (); #include "libguile/eq.h" #include "libguile/continuations.h" #include "libguile/futures.h" +#include "libguile/strings.h" #include "libguile/throw.h" #include "libguile/smob.h" #include "libguile/macros.h" @@ -85,6 +86,106 @@ char *alloca (); +/* {Syntax Errors} + * + * This section defines the message strings for the syntax errors that can be + * detected during memoization and the functions and macros that shall be + * called by the memoizer code to signal syntax errors. */ + + +/* Syntax errors that can be detected during memoization: */ + +/* Circular or improper lists do not form valid scheme expressions. If a + * circular list or an improper list is detected in a place where a scheme + * expression is expected, a 'Bad expression' error is signalled. */ +static const char s_bad_expression[] = "Bad expression"; + + +/* Signal a syntax error. We distinguish between the form that caused the + * error and the enclosing expression. The error message will print out as + * shown in the following pattern. The file name and line number are only + * given when they can be determined from the erroneous form or from the + * enclosing expression. + * + * : In procedure memoization: + * : In file , line : in . */ + +SCM_SYMBOL (syntax_error_key, "syntax-error"); + +/* The prototype is needed to indicate that the function does not return. */ +static void +syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN; + +static void +syntax_error (const char* const msg, const SCM form, const SCM expr) +{ + const SCM msg_string = scm_makfrom0str (msg); + SCM filename = SCM_BOOL_F; + SCM linenr = SCM_BOOL_F; + const char *format; + SCM args; + + if (SCM_CONSP (form)) + { + filename = scm_source_property (form, scm_sym_filename); + linenr = scm_source_property (form, scm_sym_line); + } + + if (SCM_FALSEP (filename) && SCM_FALSEP (linenr) && SCM_CONSP (expr)) + { + filename = scm_source_property (expr, scm_sym_filename); + linenr = scm_source_property (expr, scm_sym_line); + } + + if (!SCM_UNBNDP (expr)) + { + if (!SCM_FALSEP (filename)) + { + format = "In file ~S, line ~S: ~A ~S in expression ~S."; + args = scm_list_5 (filename, linenr, msg_string, form, expr); + } + else if (!SCM_FALSEP (linenr)) + { + format = "In line ~S: ~A ~S in expression ~S."; + args = scm_list_4 (linenr, msg_string, form, expr); + } + else + { + format = "~A ~S in expression ~S."; + args = scm_list_3 (msg_string, form, expr); + } + } + else + { + if (!SCM_FALSEP (filename)) + { + format = "In file ~S, line ~S: ~A ~S."; + args = scm_list_4 (filename, linenr, msg_string, form); + } + else if (!SCM_FALSEP (linenr)) + { + format = "In line ~S: ~A ~S."; + args = scm_list_3 (linenr, msg_string, form); + } + else + { + format = "~A ~S."; + args = scm_list_2 (msg_string, form); + } + } + + scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F); +} + + +/* Shortcut macros to simplify syntax error handling. */ +#define ASSERT_SYNTAX(cond, message, form) \ + { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); } +#define ASSERT_SYNTAX_2(cond, message, form, expr) \ + { if (!(cond)) syntax_error (message, form, expr); } + + + /* {Ilocs} * * Ilocs are memoized references to variables in local environment frames. @@ -528,14 +629,23 @@ SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and); SCM_GLOBAL_SYMBOL (scm_sym_and, s_and); SCM -scm_m_and (SCM xorig, SCM env SCM_UNUSED) +scm_m_and (SCM expr, SCM env SCM_UNUSED) { - long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 0, s_test, s_and); - if (len >= 1) - return scm_cons (SCM_IM_AND, SCM_CDR (xorig)); + const SCM cdr_expr = SCM_CDR (expr); + const long length = scm_ilength (cdr_expr); + + ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); + + if (length == 0) + { + /* Special case: (and) is replaced by #t. */ + return SCM_BOOL_T; + } else - return SCM_BOOL_T; + { + SCM_SETCAR (expr, SCM_IM_AND); + return expr; + } } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 5a3ff964c..11364ea30 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2003-10-10 Dirk Herrmann + + * lib.scm (run-test-exception): Handle syntax errors. + 2003-10-10 Marius Vollmer * tests/numbers.test (inexact->exact): Use corrent argument order diff --git a/test-suite/lib.scm b/test-suite/lib.scm index bf27d9621..7248b3e96 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -323,6 +323,13 @@ (string-match (cdr exception) (apply simple-format #f message (car rest)))) #t) + ;; handle syntax errors which use `syntax-error' for key and don't + ;; yet format the message and args (we have to do it here). + ((and (eq? 'syntax-error (car exception)) + (list? rest) + (string-match (cdr exception) + (apply simple-format #f message (car rest)))) + #t) ;; unhandled; throw again (else (apply throw key proc message rest)))))))) From 2a6f7afe04884f562b343a82033c381fe859bd03 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 11 Oct 2003 00:57:25 +0000 Subject: [PATCH 040/239] * libguile/tags.h (SCM_IM_ELSE, SCM_IM_ARROW): New memoizer codes. * libguile/print.c (scm_isymnames): Add names for the new memoizer codes. * libguile/eval.c (s_missing_clauses, s_bad_case_clause, s_extra_case_clause, s_bad_case_labels, s_duplicate_case_label, literal_p): New static identifiers. (scm_m_case): Use ASSERT_SYNTAX to signal syntax errors. Be more specific about the kind of error that was detected. Check for duplicate case labels. Handle bound 'else. Avoid unnecessary consing when creating the memoized code. (scm_m_case, unmemocopy, SCM_CEVAL): Use SCM_IM_ELSE to memoize the syntactic keyword 'else. * test-suite/tests/syntax.test (exception:bad-expression, exception:missing-clauses, exception:bad-case-clause, exception:extra-case-clause, exception:bad-case-labels): New. Added some tests and adapted tests for 'case' to the new way of error reporting. --- libguile/ChangeLog | 18 ++++++ libguile/eval.c | 122 ++++++++++++++++++++++++++++++----- libguile/print.c | 2 + libguile/tags.h | 6 +- test-suite/ChangeLog | 9 +++ test-suite/tests/syntax.test | 46 +++++++++---- 6 files changed, 174 insertions(+), 29 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 862c3a656..90dec9bb1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,21 @@ +2003-10-11 Dirk Herrmann + + * tags.h (SCM_IM_ELSE, SCM_IM_ARROW): New memoizer codes. + + * print.c (scm_isymnames): Add names for the new memoizer codes. + + * eval.c (s_missing_clauses, s_bad_case_clause, + s_extra_case_clause, s_bad_case_labels, s_duplicate_case_label, + literal_p): New static identifiers. + + (scm_m_case): Use ASSERT_SYNTAX to signal syntax errors. Be more + specific about the kind of error that was detected. Check for + duplicate case labels. Handle bound 'else. Avoid unnecessary + consing when creating the memoized code. + + (scm_m_case, unmemocopy, SCM_CEVAL): Use SCM_IM_ELSE to memoize + the syntactic keyword 'else. + 2003-10-10 Dirk Herrmann * eval.c (s_bad_expression, syntax_error_key, syntax_error, diff --git a/libguile/eval.c b/libguile/eval.c index e91e2fbcc..25f435468 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -100,6 +100,35 @@ char *alloca (); * expression is expected, a 'Bad expression' error is signalled. */ static const char s_bad_expression[] = "Bad expression"; +/* Case or cond expressions must have at least one clause. If a case or cond + * expression without any clauses is detected, a 'Missing clauses' error is + * signalled. */ +static const char s_missing_clauses[] = "Missing clauses"; + +/* If a case clause is detected that is not in the format + * ( ...) + * a 'Bad case clause' error is signalled. */ +static const char s_bad_case_clause[] = "Bad case clause"; + +/* If there is an 'else' clause in a case statement, it must be the last + * clause. If after the 'else' case clause further clauses are detected, an + * 'Extra case clause' error is signalled. */ +static const char s_extra_case_clause[] = "Extra case clause"; + +/* If a case clause is detected where the element is neither a + * proper list nor (in case of the last clause) the syntactic keyword 'else', + * a 'Bad case labels' error is signalled. Note: If you encounter this error + * for an else-clause which seems to be syntactically correct, check if 'else' + * is really a syntactic keyword in that context. If 'else' is bound in the + * local or global environment, it is not considered a syntactic keyword, but + * will be treated as any other variable. */ +static const char s_bad_case_labels[] = "Bad case labels"; + +/* In a case statement all labels have to be distinct. If in a case statement + * a label occurs more than once, a 'Duplicate case label' error is + * signalled. */ +static const char s_duplicate_case_label[] = "Duplicate case label"; + /* Signal a syntax error. We distinguish between the form that caused the * error and the enclosing expression. The error message will print out as @@ -529,6 +558,22 @@ scm_lookupcar (SCM vloc, SCM genv, int check) return loc; } +/* Return true if the symbol is - from the point of view of a macro + * transformer - a literal in the sense specified in chapter "pattern + * language" of R5RS. In the code below, however, we don't match the + * definition of R5RS exactly: It returns true if the identifier has no + * binding or if it is a syntactic keyword. */ +static int +literal_p (const SCM symbol, const SCM env) +{ + const SCM x = scm_cons (symbol, SCM_UNDEFINED); + const SCM value = *scm_lookupcar (x, env, 0); + if (SCM_UNBNDP (value) || SCM_MACROP (value)) + return 1; + else + return 0; +} + #define unmemocar scm_unmemocar SCM_SYMBOL (sym_three_question_marks, "???"); @@ -653,10 +698,14 @@ SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin); SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin); SCM -scm_m_begin (SCM xorig, SCM env SCM_UNUSED) +scm_m_begin (SCM expr, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, s_expression, s_begin); - return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig)); + const SCM cdr_expr = SCM_CDR (expr); + + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + + SCM_SETCAR (expr, SCM_IM_BEGIN); + return expr; } @@ -664,23 +713,63 @@ SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case); SCM_GLOBAL_SYMBOL (scm_sym_case, s_case); SCM -scm_m_case (SCM xorig, SCM env SCM_UNUSED) +scm_m_case (SCM expr, SCM env) { SCM clauses; - SCM cdrx = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (cdrx) >= 2, s_clauses, s_case); - clauses = SCM_CDR (cdrx); + SCM all_labels = SCM_EOL; + + /* Check, whether 'else is a literal, i. e. not bound to a value. */ + const int else_literal_p = literal_p (scm_sym_else, env); + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_clauses, expr); + + clauses = SCM_CDR (cdr_expr); while (!SCM_NULLP (clauses)) { - SCM clause = SCM_CAR (clauses); - SCM_ASSYNT (scm_ilength (clause) >= 2, s_clauses, s_case); - SCM_ASSYNT (scm_ilength (SCM_CAR (clause)) >= 0 - || (SCM_EQ_P (scm_sym_else, SCM_CAR (clause)) - && SCM_NULLP (SCM_CDR (clauses))), - s_clauses, s_case); + SCM labels; + + const SCM clause = SCM_CAR (clauses); + ASSERT_SYNTAX_2 (scm_ilength (clause) >= 2, + s_bad_case_clause, clause, expr); + + labels = SCM_CAR (clause); + if (SCM_CONSP (labels)) + { + ASSERT_SYNTAX_2 (scm_ilength (labels) >= 0, + s_bad_case_labels, labels, expr); + all_labels = scm_append_x (scm_list_2 (labels, all_labels)); + } + else + { + ASSERT_SYNTAX_2 (SCM_EQ_P (labels, scm_sym_else) && else_literal_p, + s_bad_case_labels, labels, expr); + ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses)), + s_extra_case_clause, SCM_CDR (clauses), expr); + } + + /* build the new clause */ + if (SCM_EQ_P (labels, scm_sym_else)) + SCM_SETCAR (clause, SCM_IM_ELSE); + clauses = SCM_CDR (clauses); } - return scm_cons (SCM_IM_CASE, cdrx); + + /* Check whether all case labels are distinct. */ + for (; !SCM_NULLP (all_labels); all_labels = SCM_CDR (all_labels)) + { + const SCM label = SCM_CAR (all_labels); + SCM label_idx = SCM_CDR (all_labels); + for (; !SCM_NULLP (label_idx); label_idx = SCM_CDR (label_idx)) + { + ASSERT_SYNTAX_2 (!SCM_EQ_P (SCM_CAR (label_idx), label), + s_duplicate_case_label, label, expr); + } + } + + SCM_SETCAR (expr, SCM_IM_CASE); + return expr; } @@ -1762,6 +1851,9 @@ unmemocopy (SCM x, SCM env) case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED); goto loop; + case (SCM_ISYMNUM (SCM_IM_ELSE)): + ls = z = scm_cons (scm_sym_else, SCM_UNSPECIFIED); + goto loop; default: /* appease the Sun compiler god: */ ; } @@ -2297,7 +2389,7 @@ dispatch: { SCM clause = SCM_CAR (x); SCM labels = SCM_CAR (clause); - if (SCM_EQ_P (labels, scm_sym_else)) + if (SCM_EQ_P (labels, SCM_IM_ELSE)) { x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); diff --git a/libguile/print.c b/libguile/print.c index 50b969e24..4ff0aeb3e 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -98,6 +98,8 @@ char *scm_isymnames[] = "#@delay", "#@future", "#@call-with-values", + "#@else", + "#@arrow", /* Multi-language support */ "#@nil-cond", diff --git a/libguile/tags.h b/libguile/tags.h index d001a9d83..f58bf5853 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -584,11 +584,13 @@ SCM_API char *scm_isymnames[]; /* defined in print.c */ #define SCM_IM_DELAY SCM_MAKISYM (19) #define SCM_IM_FUTURE SCM_MAKISYM (20) #define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (21) +#define SCM_IM_ELSE SCM_MAKISYM (22) +#define SCM_IM_ARROW SCM_MAKISYM (23) /* Multi-language support */ -#define SCM_IM_NIL_COND SCM_MAKISYM (22) -#define SCM_IM_BIND SCM_MAKISYM (23) +#define SCM_IM_NIL_COND SCM_MAKISYM (24) +#define SCM_IM_BIND SCM_MAKISYM (25) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 11364ea30..d5f6646d0 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,12 @@ +2003-10-11 Dirk Herrmann + + * tests/syntax.test (exception:bad-expression, + exception:missing-clauses, exception:bad-case-clause, + exception:extra-case-clause, exception:bad-case-labels): New. + + Added some tests and adapted tests for 'case' to the new way of + error reporting. + 2003-10-10 Dirk Herrmann * lib.scm (run-test-exception): Handle syntax errors. diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 3261ea1f6..20e9a44a5 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -20,6 +20,9 @@ (define-module (test-suite test-syntax) :use-module (test-suite lib)) + +(define exception:bad-expression + (cons 'syntax-error "Bad expression")) (define exception:bad-bindings (cons 'misc-error "^bad bindings")) (define exception:duplicate-bindings @@ -30,10 +33,18 @@ (cons 'misc-error "^bad formals")) (define exception:duplicate-formals (cons 'misc-error "^duplicate formals")) +(define exception:missing-clauses + (cons 'syntax-error "Missing clauses")) (define exception:bad-var (cons 'misc-error "^bad variable")) (define exception:bad/missing-clauses (cons 'misc-error "^bad or missing clauses")) +(define exception:bad-case-clause + (cons 'syntax-error "Bad case clause")) +(define exception:extra-case-clause + (cons 'syntax-error "Extra case clause")) +(define exception:bad-case-labels + (cons 'syntax-error "Bad case labels")) (define exception:missing/extra-expr (cons 'misc-error "^missing or extra expression")) @@ -472,6 +483,10 @@ (with-test-prefix "cond is hygienic" + (expect-fail "bound 'else is handled correctly" + (false-if-exception + (eq? (let ((else 'ok)) (cond (else))) 'ok))) + (expect-fail "bound '=> is handled correctly" (false-if-exception (eq? (let ((=> #f)) (cond (#t => 'ok))) 'ok)))) @@ -494,45 +509,52 @@ (with-test-prefix "case" + (with-test-prefix "case is hygienic" + + (pass-if-exception "bound 'else is handled correctly" + exception:bad-case-labels + (eval '(let ((else #f)) (case 1 (else #f))) + (interaction-environment)))) + (with-test-prefix "bad or missing clauses" (pass-if-exception "(case)" - exception:bad/missing-clauses + exception:missing-clauses (eval '(case) (interaction-environment))) (pass-if-exception "(case . \"foo\")" - exception:bad/missing-clauses + exception:bad-expression (eval '(case . "foo") (interaction-environment))) (pass-if-exception "(case 1)" - exception:bad/missing-clauses + exception:missing-clauses (eval '(case 1) (interaction-environment))) (pass-if-exception "(case 1 . \"foo\")" - exception:bad/missing-clauses + exception:bad-expression (eval '(case 1 . "foo") (interaction-environment))) (pass-if-exception "(case 1 \"foo\")" - exception:bad/missing-clauses + exception:bad-case-clause (eval '(case 1 "foo") (interaction-environment))) (pass-if-exception "(case 1 ())" - exception:bad/missing-clauses + exception:bad-case-clause (eval '(case 1 ()) (interaction-environment))) (pass-if-exception "(case 1 (\"foo\"))" - exception:bad/missing-clauses + exception:bad-case-clause (eval '(case 1 ("foo")) (interaction-environment))) (pass-if-exception "(case 1 (\"foo\" \"bar\"))" - exception:bad/missing-clauses + exception:bad-case-labels (eval '(case 1 ("foo" "bar")) (interaction-environment))) @@ -542,22 +564,22 @@ ;; (case 1 (() "bar"))) (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")" - exception:bad/missing-clauses + exception:bad-expression (eval '(case 1 ((2) "bar") . "foo") (interaction-environment))) (pass-if-exception "(case 1 ((2) \"bar\") (else))" - exception:bad/missing-clauses + exception:bad-case-clause (eval '(case 1 ((2) "bar") (else)) (interaction-environment))) (pass-if-exception "(case 1 (else #f) . \"foo\")" - exception:bad/missing-clauses + exception:bad-expression (eval '(case 1 (else #f) . "foo") (interaction-environment))) (pass-if-exception "(case 1 (else #f) ((1) #t))" - exception:bad/missing-clauses + exception:extra-case-clause (eval '(case 1 (else #f) ((1) #t)) (interaction-environment))))) From 58a2510b07d9f9154544478e7b0a2bd1971a3c0c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 11 Oct 2003 01:52:25 +0000 Subject: [PATCH 041/239] * libguile/eval.c (scm_m_case): Allow empty lists of case labels. * test-suite/tests/syntax.test: Fixed and activated test of empty case label support. --- libguile/ChangeLog | 4 ++++ libguile/eval.c | 7 +++++++ test-suite/ChangeLog | 5 +++++ test-suite/tests/syntax.test | 8 +++----- 4 files changed, 19 insertions(+), 5 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 90dec9bb1..746842857 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2003-10-11 Dirk Herrmann + + * eval.c (scm_m_case): Allow empty lists of case labels. + 2003-10-11 Dirk Herrmann * tags.h (SCM_IM_ELSE, SCM_IM_ARROW): New memoizer codes. diff --git a/libguile/eval.c b/libguile/eval.c index 25f435468..ba3972043 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -741,6 +741,13 @@ scm_m_case (SCM expr, SCM env) s_bad_case_labels, labels, expr); all_labels = scm_append_x (scm_list_2 (labels, all_labels)); } + else if (SCM_NULLP (labels)) + { + /* The list of labels is empty. According to R5RS this is allowed. + * It means that the sequence of expressions will never be executed. + * Therefore, as an optimization, we could remove the whole + * clause. */ + } else { ASSERT_SYNTAX_2 (SCM_EQ_P (labels, scm_sym_else) && else_literal_p, diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d5f6646d0..17b5d572c 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2003-10-11 Dirk Herrmann + + * tests/syntax.test: Fixed and activated test of empty case label + support. + 2003-10-11 Dirk Herrmann * tests/syntax.test (exception:bad-expression, diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 20e9a44a5..c46d615df 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -509,6 +509,9 @@ (with-test-prefix "case" + (pass-if "clause with empty labels list" + (case 1 (() #f) (else #t))) + (with-test-prefix "case is hygienic" (pass-if-exception "bound 'else is handled correctly" @@ -558,11 +561,6 @@ (eval '(case 1 ("foo" "bar")) (interaction-environment))) - ;; According to R5RS, the following one is syntactically correct. - ;; (pass-if-exception "(case 1 (() \"bar\"))" - ;; exception:bad/missing-clauses - ;; (case 1 (() "bar"))) - (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")" exception:bad-expression (eval '(case 1 ((2) "bar") . "foo") From 609a8b86ae299e8d8d1fb9c4916bafe229ab0564 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 11 Oct 2003 10:40:19 +0000 Subject: [PATCH 042/239] * libguile/eval.c (s_extra_expression, s_misplaced_else_clause, s_bad_cond_clause, s_missing_recipient): New static identifiers. (s_extra_case_clause): Removed. (scm_m_case, scm_m_cond): If a clause appears after an else clause, report a misplaced else clause. (scm_m_cond): Use ASSERT_SYNTAX to signal syntax errors. Be more specific about the kind of error that was detected. Handle bound 'else and '=>. Avoid unnecessary consing when creating the memoized code. (scm_m_cond, unmemocopy, SCM_CEVAL): Use SCM_IM_ELSE to memoize the syntactic keyword 'else and SCM_IM_ARROW to memoize the syntactic keyword '=>. * test-suite/tests/syntax.test (exception:misplaced-else-clause, exception:bad-cond-clause): New. (exception:bad/missing-clauses, exception:extra-case-clause): Removed. Adapted tests for 'case' and 'cond' to the new way of error reporting. The tests that check if cond is hygienic pass now. --- libguile/ChangeLog | 19 ++++++++ libguile/eval.c | 92 ++++++++++++++++++++++++++---------- test-suite/ChangeLog | 13 +++++ test-suite/tests/syntax.test | 42 ++++++++-------- 4 files changed, 118 insertions(+), 48 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 746842857..91e68a5ec 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,22 @@ +2003-10-11 Dirk Herrmann + + * eval.c (s_extra_expression, s_misplaced_else_clause, + s_bad_cond_clause, s_missing_recipient): New static identifiers. + + (s_extra_case_clause): Removed. + + (scm_m_case, scm_m_cond): If a clause appears after an else + clause, report a misplaced else clause. + + (scm_m_cond): Use ASSERT_SYNTAX to signal syntax errors. Be more + specific about the kind of error that was detected. Handle bound + 'else and '=>. Avoid unnecessary consing when creating the + memoized code. + + (scm_m_cond, unmemocopy, SCM_CEVAL): Use SCM_IM_ELSE to memoize + the syntactic keyword 'else and SCM_IM_ARROW to memoize the + syntactic keyword '=>. + 2003-10-11 Dirk Herrmann * eval.c (scm_m_case): Allow empty lists of case labels. diff --git a/libguile/eval.c b/libguile/eval.c index ba3972043..38135b2c0 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -100,21 +100,25 @@ char *alloca (); * expression is expected, a 'Bad expression' error is signalled. */ static const char s_bad_expression[] = "Bad expression"; +/* If a form is detected that holds more expressions than are allowed in that + * contect, an 'Extra expression' error is signalled. */ +static const char s_extra_expression[] = "Extra expression in"; + /* Case or cond expressions must have at least one clause. If a case or cond * expression without any clauses is detected, a 'Missing clauses' error is * signalled. */ static const char s_missing_clauses[] = "Missing clauses"; +/* If there is an 'else' clause in a case or a cond statement, it must be the + * last clause. If after the 'else' case clause further clauses are detected, + * a 'Misplaced else clause' error is signalled. */ +static const char s_misplaced_else_clause[] = "Misplaced else clause"; + /* If a case clause is detected that is not in the format * ( ...) * a 'Bad case clause' error is signalled. */ static const char s_bad_case_clause[] = "Bad case clause"; -/* If there is an 'else' clause in a case statement, it must be the last - * clause. If after the 'else' case clause further clauses are detected, an - * 'Extra case clause' error is signalled. */ -static const char s_extra_case_clause[] = "Extra case clause"; - /* If a case clause is detected where the element is neither a * proper list nor (in case of the last clause) the syntactic keyword 'else', * a 'Bad case labels' error is signalled. Note: If you encounter this error @@ -129,6 +133,16 @@ static const char s_bad_case_labels[] = "Bad case labels"; * signalled. */ static const char s_duplicate_case_label[] = "Duplicate case label"; +/* If a cond clause is detected that is not in one of the formats + * ( ...) or (else ...) + * a 'Bad cond clause' error is signalled. */ +static const char s_bad_cond_clause[] = "Bad cond clause"; + +/* If a cond clause is detected that uses the alternate '=>' form, but does + * not hold a recipient element for the test result, a 'Missing recipient' + * error is signalled. */ +static const char s_missing_recipient[] = "Missing recipient in"; + /* Signal a syntax error. We distinguish between the form that caused the * error and the enclosing expression. The error message will print out as @@ -621,7 +635,6 @@ scm_eval_car (SCM pair, SCM env) * some memoized forms have different syntax */ -SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>"); SCM_GLOBAL_SYMBOL (scm_sym_else, "else"); SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote"); SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing"); @@ -753,7 +766,7 @@ scm_m_case (SCM expr, SCM env) ASSERT_SYNTAX_2 (SCM_EQ_P (labels, scm_sym_else) && else_literal_p, s_bad_case_labels, labels, expr); ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses)), - s_extra_case_clause, SCM_CDR (clauses), expr); + s_misplaced_else_clause, clause, expr); } /* build the new clause */ @@ -782,31 +795,53 @@ scm_m_case (SCM expr, SCM env) SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond); SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond); +SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>"); SCM -scm_m_cond (SCM xorig, SCM env SCM_UNUSED) +scm_m_cond (SCM expr, SCM env) { - SCM cdrx = SCM_CDR (xorig); - SCM clauses = cdrx; - SCM_ASSYNT (scm_ilength (clauses) >= 1, s_clauses, s_cond); - while (!SCM_NULLP (clauses)) + /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */ + const int else_literal_p = literal_p (scm_sym_else, env); + const int arrow_literal_p = literal_p (scm_sym_arrow, env); + + const SCM clauses = SCM_CDR (expr); + SCM clause_idx; + + ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr); + + for (clause_idx = clauses; + !SCM_NULLP (clause_idx); + clause_idx = SCM_CDR (clause_idx)) { - SCM clause = SCM_CAR (clauses); - long len = scm_ilength (clause); - SCM_ASSYNT (len >= 1, s_clauses, s_cond); - if (SCM_EQ_P (scm_sym_else, SCM_CAR (clause))) + SCM test; + + const SCM clause = SCM_CAR (clause_idx); + const long length = scm_ilength (clause); + ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr); + + test = SCM_CAR (clause); + if (SCM_EQ_P (test, scm_sym_else) && else_literal_p) { - int last_clause_p = SCM_NULLP (SCM_CDR (clauses)); - SCM_ASSYNT (len >= 2 && last_clause_p, "bad ELSE clause", s_cond); + const int last_clause_p = SCM_NULLP (SCM_CDR (clause_idx)); + ASSERT_SYNTAX_2 (length >= 2, + s_bad_cond_clause, clause, expr); + ASSERT_SYNTAX_2 (last_clause_p, + s_misplaced_else_clause, clause, expr); + SCM_SETCAR (clause, SCM_IM_ELSE); } - else if (len >= 2 && SCM_EQ_P (scm_sym_arrow, SCM_CADR (clause))) - { - SCM_ASSYNT (len > 2, "missing recipient", s_cond); - SCM_ASSYNT (len == 3, "bad recipient", s_cond); + else if (length >= 2 + && SCM_EQ_P (SCM_CADR (clause), scm_sym_arrow) + && arrow_literal_p) + { + ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr); + ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr); + SCM_SETCAR (SCM_CDR (clause), SCM_IM_ARROW); } - clauses = SCM_CDR (clauses); } - return scm_cons (SCM_IM_COND, cdrx); + + SCM_SETCAR (expr, SCM_IM_COND); + return expr; } @@ -1880,6 +1915,11 @@ loop: SCM_SETCDR (z, unmemocar (copy, env)); z = SCM_CDR (z); } + else if (SCM_EQ_P (form, SCM_IM_ARROW)) + { + SCM_SETCDR (z, scm_cons (scm_sym_arrow, SCM_UNSPECIFIED)); + z = SCM_CDR (z); + } x = SCM_CDR (x); } SCM_SETCDR (z, x); @@ -2424,7 +2464,7 @@ dispatch: while (!SCM_NULLP (x)) { SCM clause = SCM_CAR (x); - if (SCM_EQ_P (SCM_CAR (clause), scm_sym_else)) + if (SCM_EQ_P (SCM_CAR (clause), SCM_IM_ELSE)) { x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); @@ -2438,7 +2478,7 @@ dispatch: x = SCM_CDR (clause); if (SCM_NULLP (x)) RETURN (arg1); - else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow)) + else if (!SCM_EQ_P (SCM_CAR (x), SCM_IM_ARROW)) { PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 17b5d572c..5faba54cd 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,16 @@ +2003-10-11 Dirk Herrmann + + * tests/syntax.test (exception:misplaced-else-clause, + exception:bad-cond-clause): New. + + (exception:bad/missing-clauses, exception:extra-case-clause): + Removed. + + Adapted tests for 'case' and 'cond' to the new way of error + reporting. + + The tests that check if cond is hygienic pass now. + 2003-10-11 Dirk Herrmann * tests/syntax.test: Fixed and activated test of empty case label diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index c46d615df..048c6d8ef 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -35,16 +35,16 @@ (cons 'misc-error "^duplicate formals")) (define exception:missing-clauses (cons 'syntax-error "Missing clauses")) -(define exception:bad-var - (cons 'misc-error "^bad variable")) -(define exception:bad/missing-clauses - (cons 'misc-error "^bad or missing clauses")) +(define exception:misplaced-else-clause + (cons 'syntax-error "Misplaced else clause")) (define exception:bad-case-clause (cons 'syntax-error "Bad case clause")) -(define exception:extra-case-clause - (cons 'syntax-error "Extra case clause")) (define exception:bad-case-labels (cons 'syntax-error "Bad case labels")) +(define exception:bad-cond-clause + (cons 'syntax-error "Bad cond clause")) +(define exception:bad-var + (cons 'misc-error "^bad variable")) (define exception:missing/extra-expr (cons 'misc-error "^missing or extra expression")) @@ -435,47 +435,47 @@ (with-test-prefix "bad or missing clauses" (pass-if-exception "(cond)" - exception:bad/missing-clauses + exception:missing-clauses (eval '(cond) (interaction-environment))) (pass-if-exception "(cond #t)" - exception:bad/missing-clauses + exception:bad-cond-clause (eval '(cond #t) (interaction-environment))) (pass-if-exception "(cond 1)" - exception:bad/missing-clauses + exception:bad-cond-clause (eval '(cond 1) (interaction-environment))) (pass-if-exception "(cond 1 2)" - exception:bad/missing-clauses + exception:bad-cond-clause (eval '(cond 1 2) (interaction-environment))) (pass-if-exception "(cond 1 2 3)" - exception:bad/missing-clauses + exception:bad-cond-clause (eval '(cond 1 2 3) (interaction-environment))) (pass-if-exception "(cond 1 2 3 4)" - exception:bad/missing-clauses + exception:bad-cond-clause (eval '(cond 1 2 3 4) (interaction-environment))) (pass-if-exception "(cond ())" - exception:bad/missing-clauses + exception:bad-cond-clause (eval '(cond ()) (interaction-environment))) (pass-if-exception "(cond () 1)" - exception:bad/missing-clauses + exception:bad-cond-clause (eval '(cond () 1) (interaction-environment))) (pass-if-exception "(cond (1) 1)" - exception:bad/missing-clauses + exception:bad-cond-clause (eval '(cond (1) 1) (interaction-environment))))) @@ -483,13 +483,11 @@ (with-test-prefix "cond is hygienic" - (expect-fail "bound 'else is handled correctly" - (false-if-exception - (eq? (let ((else 'ok)) (cond (else))) 'ok))) + (pass-if "bound 'else is handled correctly" + (eq? (let ((else 'ok)) (cond (else))) 'ok)) - (expect-fail "bound '=> is handled correctly" - (false-if-exception - (eq? (let ((=> #f)) (cond (#t => 'ok))) 'ok)))) + (pass-if "bound '=> is handled correctly" + (eq? (let ((=> #f)) (cond (#t => 'ok))) 'ok))) (with-test-prefix "else is handled correctly" @@ -577,7 +575,7 @@ (interaction-environment))) (pass-if-exception "(case 1 (else #f) ((1) #t))" - exception:extra-case-clause + exception:misplaced-else-clause (eval '(case 1 (else #f) ((1) #t)) (interaction-environment))))) From cc56ba80627e7e4061ce4d54045d62af7c85eda4 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 11 Oct 2003 16:03:29 +0000 Subject: [PATCH 043/239] * libguile/eval.c (s_missing_expression, s_bad_variable): New static identifiers. (scm_m_define): Use ASSERT_SYNTAX to signal syntax errors. Prefer R5RS terminology for the naming of variables. Be more specific about the kind of error that was detected. Make sure file name, line number etc. are added to all freshly created expressions. Avoid unnecessary consing when creating the memoized code. * test-suite/tests/syntax.test (exception:missing-expr, exception:extra-expr): New. Adapted tests for 'begin' to the new way of error reporting. --- libguile/ChangeLog | 11 +++++++ libguile/eval.c | 64 +++++++++++++++++++++++++----------- test-suite/ChangeLog | 8 +++++ test-suite/tests/syntax.test | 14 ++++++-- 4 files changed, 75 insertions(+), 22 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 91e68a5ec..c9a32cb1f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2003-10-11 Dirk Herrmann + + * eval.c (s_missing_expression, s_bad_variable): New static + identifiers. + + (scm_m_define): Use ASSERT_SYNTAX to signal syntax errors. Prefer + R5RS terminology for the naming of variables. Be more specific + about the kind of error that was detected. Make sure file name, + line number etc. are added to all freshly created expressions. + Avoid unnecessary consing when creating the memoized code. + 2003-10-11 Dirk Herrmann * eval.c (s_extra_expression, s_misplaced_else_clause, diff --git a/libguile/eval.c b/libguile/eval.c index 38135b2c0..79dfc341f 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -100,6 +100,10 @@ char *alloca (); * expression is expected, a 'Bad expression' error is signalled. */ static const char s_bad_expression[] = "Bad expression"; +/* If a form is detected that holds less expressions than are required in that + * contect, a 'Missing expression' error is signalled. */ +static const char s_missing_expression[] = "Missing expression in"; + /* If a form is detected that holds more expressions than are allowed in that * contect, an 'Extra expression' error is signalled. */ static const char s_extra_expression[] = "Extra expression in"; @@ -143,6 +147,10 @@ static const char s_bad_cond_clause[] = "Bad cond clause"; * error is signalled. */ static const char s_missing_recipient[] = "Missing recipient in"; +/* If in a position where a variable name is required some other object is + * detected, a 'Bad variable' error is signalled. */ +static const char s_bad_variable[] = "Bad variable"; + /* Signal a syntax error. We distinguish between the form that caused the * error and the enclosing expression. The error message will print out as @@ -868,42 +876,60 @@ SCM_GLOBAL_SYMBOL(scm_sym_define, s_define); /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS * module that does not implement this extension. */ SCM -scm_m_define (SCM x, SCM env) +scm_m_define (SCM expr, SCM env) { - SCM name; - x = SCM_CDR (x); - SCM_ASSYNT (scm_ilength (x) >= 2, s_expression, s_define); - name = SCM_CAR (x); - x = SCM_CDR (x); - while (SCM_CONSP (name)) + SCM body; + SCM variable; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); + + body = SCM_CDR (cdr_expr); + variable = SCM_CAR (cdr_expr); + while (SCM_CONSP (variable)) { - /* This while loop realizes function currying by variable nesting. */ - SCM formals = SCM_CDR (name); - x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x)); - name = SCM_CAR (name); + /* This while loop realizes function currying by variable nesting. + * Variable is known to be a nested-variable. In every iteration of the + * loop another level of lambda expression is created, starting with the + * innermost one. */ + const SCM formals = SCM_CDR (variable); + const SCM tail = scm_cons (formals, body); + + /* Add source properties to each new lambda expression: */ + const SCM lambda = scm_cons_source (variable, scm_sym_lambda, tail); + + body = scm_list_1 (lambda); + variable = SCM_CAR (variable); } - SCM_ASSYNT (SCM_SYMBOLP (name), s_variable, s_define); - SCM_ASSYNT (scm_ilength (x) == 1, s_expression, s_define); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr); + if (SCM_TOP_LEVEL (env)) { SCM var; - x = scm_eval_car (x, env); + const SCM value = scm_eval_car (body, env); if (SCM_REC_PROCNAMES_P) { - SCM tmp = x; + SCM tmp = value; while (SCM_MACROP (tmp)) tmp = SCM_MACRO_CODE (tmp); if (SCM_CLOSUREP (tmp) /* Only the first definition determines the name. */ && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) - scm_set_procedure_property_x (tmp, scm_sym_name, name); + scm_set_procedure_property_x (tmp, scm_sym_name, variable); } - var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T); - SCM_VARIABLE_SET (var, x); + var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T); + SCM_VARIABLE_SET (var, value); return SCM_UNSPECIFIED; } else - return scm_cons2 (SCM_IM_DEFINE, name, x); + { + SCM_SETCAR (expr, SCM_IM_DEFINE); + SCM_SETCAR (cdr_expr, variable); + SCM_SETCDR (cdr_expr, body); + return expr; + } } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 5faba54cd..f5b0bc24e 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,11 @@ +2003-10-11 Dirk Herrmann + + * tests/syntax.test (exception:missing-expr, + exception:extra-expr): New. + + Adapted tests for 'begin' to the new way of error + reporting. + 2003-10-11 Dirk Herrmann * tests/syntax.test (exception:misplaced-else-clause, diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 048c6d8ef..2c6524744 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -23,6 +23,14 @@ (define exception:bad-expression (cons 'syntax-error "Bad expression")) + +(define exception:missing/extra-expr + (cons 'misc-error "^missing or extra expression")) +(define exception:missing-expr + (cons 'syntax-error "Missing expression")) +(define exception:extra-expr + (cons 'syntax-error "Extra expression")) + (define exception:bad-bindings (cons 'misc-error "^bad bindings")) (define exception:duplicate-bindings @@ -33,6 +41,7 @@ (cons 'misc-error "^bad formals")) (define exception:duplicate-formals (cons 'misc-error "^duplicate formals")) + (define exception:missing-clauses (cons 'syntax-error "Missing clauses")) (define exception:misplaced-else-clause @@ -43,10 +52,9 @@ (cons 'syntax-error "Bad case labels")) (define exception:bad-cond-clause (cons 'syntax-error "Bad cond clause")) + (define exception:bad-var (cons 'misc-error "^bad variable")) -(define exception:missing/extra-expr - (cons 'misc-error "^missing or extra expression")) (with-test-prefix "expressions" @@ -590,7 +598,7 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(define)" - exception:missing/extra-expr + exception:missing-expr (eval '(define) (interaction-environment))))) From 4c13270f34fdf250a42c8fa34f9d6cda15b67261 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 11 Oct 2003 22:24:34 +0000 Subject: [PATCH 044/239] (scm_append): Track argument number and use in error. --- libguile/list.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libguile/list.c b/libguile/list.c index 07a0d0dc3..74bb2cc3e 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -231,6 +231,7 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1, SCM res = SCM_EOL; SCM *lloc = &res; SCM arg = SCM_CAR (args); + int argnum = 1; args = SCM_CDR (args); while (!SCM_NULLP (args)) { while (SCM_CONSP (arg)) { @@ -238,9 +239,10 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1, lloc = SCM_CDRLOC (*lloc); arg = SCM_CDR (arg); } - SCM_VALIDATE_NULL_OR_NIL (SCM_ARGn, arg); + SCM_VALIDATE_NULL_OR_NIL (argnum, arg); arg = SCM_CAR (args); args = SCM_CDR (args); + argnum++; }; *lloc = arg; return res; From 9b9a35b6016b33d6a2c4c91781bea5ac809318d6 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 11 Oct 2003 22:25:28 +0000 Subject: [PATCH 045/239] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c9a32cb1f..646bda277 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2003-10-12 Kevin Ryde + + * list.c (scm_append): Track argument number and use in error. + 2003-10-11 Dirk Herrmann * eval.c (s_missing_expression, s_bad_variable): New static From 8ae95199fde1530be4f6d0c043c7f04c3741a517 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 12 Oct 2003 07:13:46 +0000 Subject: [PATCH 046/239] * eval.c (memoize_as_thunk_prototype): New static function. (scm_m_delay, scm_m_future): Use memoize_as_thunk_prototype. Avoid unnecessary consing when creating the memoized code. --- libguile/ChangeLog | 7 +++++++ libguile/eval.c | 35 +++++++++++++++++++++++++++-------- 2 files changed, 34 insertions(+), 8 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 646bda277..31e9ea189 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2003-10-11 Dirk Herrmann + + * eval.c (memoize_as_thunk_prototype): New static function. + + (scm_m_delay, scm_m_future): Use memoize_as_thunk_prototype. + Avoid unnecessary consing when creating the memoized code. + 2003-10-12 Kevin Ryde * list.c (scm_append): Track argument number and use in error. diff --git a/libguile/eval.c b/libguile/eval.c index 79dfc341f..d5bcf692e 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -101,11 +101,11 @@ char *alloca (); static const char s_bad_expression[] = "Bad expression"; /* If a form is detected that holds less expressions than are required in that - * contect, a 'Missing expression' error is signalled. */ + * context, a 'Missing expression' error is signalled. */ static const char s_missing_expression[] = "Missing expression in"; /* If a form is detected that holds more expressions than are allowed in that - * contect, an 'Extra expression' error is signalled. */ + * context, an 'Extra expression' error is signalled. */ static const char s_extra_expression[] = "Extra expression in"; /* Case or cond expressions must have at least one clause. If a case or cond @@ -933,6 +933,23 @@ scm_m_define (SCM expr, SCM env) } +/* This is a helper function for forms ( ) that are + * transformed into (#@ '() ) in order to allow + * for easy creation of a thunk (i. e. a closure without arguments) using the + * ('() ) tail of the memoized form. */ +static SCM +memoize_as_thunk_prototype (const SCM expr, const SCM env SCM_UNUSED) +{ + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); + + SCM_SETCDR (expr, scm_cons (SCM_EOL, cdr_expr)); + + return expr; +} + + SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay); SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); @@ -941,10 +958,11 @@ SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); * the empty list represents the empty parameter list. This representation * allows for easy creation of the closure during evaluation. */ SCM -scm_m_delay (SCM xorig, SCM env SCM_UNUSED) +scm_m_delay (SCM expr, SCM env) { - SCM_ASSYNT (scm_ilength (xorig) == 2, s_expression, s_delay); - return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig)); + const SCM new_expr = memoize_as_thunk_prototype (expr, env); + SCM_SETCAR (new_expr, SCM_IM_DELAY); + return new_expr; } @@ -1435,10 +1453,11 @@ SCM_GLOBAL_SYMBOL (scm_sym_future, s_future); * empty parameter list. This representation allows for easy creation * of the closure during evaluation. */ SCM -scm_m_future (SCM xorig, SCM env SCM_UNUSED) +scm_m_future (SCM expr, SCM env) { - SCM_ASSYNT (scm_ilength (xorig) == 2, s_expression, s_future); - return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, SCM_CDR (xorig)); + const SCM new_expr = memoize_as_thunk_prototype (expr, env); + SCM_SETCAR (new_expr, SCM_IM_FUTURE); + return new_expr; } From a954ce1d25e45b65f36dda4b0ada263889e62d11 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 12 Oct 2003 09:22:52 +0000 Subject: [PATCH 047/239] * eval.c (s_bad_bindings, s_bad_binding, s_bad_exit_clause): New static identifiers. (scm_m_do): Use ASSERT_SYNTAX to signal syntax errors. Be more specific about the kind of error that was detected. Avoid use of SCM_CDRLOC. Avoid unnecessary consing when creating the memoized code, this way also making sure that file name, line number information etc. remain available. --- libguile/ChangeLog | 11 +++++ libguile/eval.c | 115 ++++++++++++++++++++++++++++----------------- 2 files changed, 84 insertions(+), 42 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 31e9ea189..45c93c0ff 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2003-10-11 Dirk Herrmann + + * eval.c (s_bad_bindings, s_bad_binding, s_bad_exit_clause): New + static identifiers. + + (scm_m_do): Use ASSERT_SYNTAX to signal syntax errors. Be more + specific about the kind of error that was detected. Avoid use of + SCM_CDRLOC. Avoid unnecessary consing when creating the memoized + code, this way also making sure that file name, line number + information etc. remain available. + 2003-10-11 Dirk Herrmann * eval.c (memoize_as_thunk_prototype): New static function. diff --git a/libguile/eval.c b/libguile/eval.c index d5bcf692e..d582a12aa 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -151,6 +151,22 @@ static const char s_missing_recipient[] = "Missing recipient in"; * detected, a 'Bad variable' error is signalled. */ static const char s_bad_variable[] = "Bad variable"; +/* Bindings for forms like 'let' and 'do' have to be given in a proper, + * possibly empty list. If any other object is detected in a place where a + * list of bindings was required, a 'Bad bindings' error is signalled. */ +static const char s_bad_bindings[] = "Bad bindings"; + +/* Depending on the syntactic context, a binding has to be in the format + * ( ) or ( ). + * If anything else is detected in a place where a binding was expected, a + * 'Bad binding' error is signalled. */ +static const char s_bad_binding[] = "Bad binding"; + +/* If the exit form of a 'do' expression is not in the format + * ( ...) + * a 'Bad exit clause' error is signalled. */ +static const char s_bad_exit_clause[] = "Bad exit clause"; + /* Signal a syntax error. We distinguish between the form that caused the * error and the enclosing expression. The error message will print out as @@ -966,64 +982,79 @@ scm_m_delay (SCM expr, SCM env) } +SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do); +SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); + /* DO gets the most radically altered syntax. The order of the vars is * reversed here. In contrast, the order of the inits and steps is reversed * during the evaluation: (do (( ) - ( ) - ... ) - ( ) - ) + ( ) + ... ) + ( ) + ) ;; becomes (#@do ( ... ) - (varn ... var2 var1) - ( ) - () - ... ) ;; missing steps replaced by var + (varn ... var2 var1) + ( ) + () + ... ) ;; missing steps replaced by var */ - -SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do); -SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); - SCM -scm_m_do (SCM xorig, SCM env SCM_UNUSED) +scm_m_do (SCM expr, SCM env SCM_UNUSED) { - SCM bindings; - SCM x = SCM_CDR (xorig); - SCM vars = SCM_EOL; - SCM inits = SCM_EOL; - SCM *initloc = &inits; - SCM steps = SCM_EOL; - SCM *steploc = &steps; - SCM_ASSYNT (scm_ilength (x) >= 2, s_test, "do"); - bindings = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (bindings) >= 0, s_bindings, "do"); - while (!SCM_NULLP (bindings)) + SCM variables = SCM_EOL; + SCM init_forms = SCM_EOL; + SCM step_forms = SCM_EOL; + SCM binding_idx; + SCM cddr_expr; + SCM exit_clause; + SCM commands; + SCM tail; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); + + /* Collect variables, init and step forms. */ + binding_idx = SCM_CAR (cdr_expr); + ASSERT_SYNTAX_2 (scm_ilength (binding_idx) >= 0, + s_bad_bindings, binding_idx, expr); + for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx)) { - SCM binding = SCM_CAR (bindings); - long len = scm_ilength (binding); - SCM_ASSYNT (len == 2 || len == 3, s_bindings, "do"); + const SCM binding = SCM_CAR (binding_idx); + const long length = scm_ilength (binding); + ASSERT_SYNTAX_2 (length == 2 || length == 3, + s_bad_binding, binding, expr); + { - SCM name = SCM_CAR (binding); - SCM init = SCM_CADR (binding); - SCM step = (len == 2) ? name : SCM_CADDR (binding); - SCM_ASSYNT (SCM_SYMBOLP (name), s_variable, "do"); - vars = scm_cons (name, vars); - *initloc = scm_list_1 (init); - initloc = SCM_CDRLOC (*initloc); - *steploc = scm_list_1 (step); - steploc = SCM_CDRLOC (*steploc); - bindings = SCM_CDR (bindings); + const SCM name = SCM_CAR (binding); + const SCM init = SCM_CADR (binding); + const SCM step = (length == 2) ? name : SCM_CADDR (binding); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr); + variables = scm_cons (name, variables); + init_forms = scm_cons (init, init_forms); + step_forms = scm_cons (step, step_forms); } } - x = SCM_CDR (x); - SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, s_test, "do"); - x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps); - x = scm_cons2 (inits, vars, x); - return scm_cons (SCM_IM_DO, x); + init_forms = scm_reverse_x (init_forms, SCM_UNDEFINED); + step_forms = scm_reverse_x (step_forms, SCM_UNDEFINED); + + /* Memoize the test form and the exit sequence. */ + cddr_expr = SCM_CDR (cdr_expr); + exit_clause = SCM_CAR (cddr_expr); + ASSERT_SYNTAX_2 (scm_ilength (exit_clause) >= 1, + s_bad_exit_clause, exit_clause, expr); + + commands = SCM_CDR (cddr_expr); + tail = scm_cons2 (exit_clause, commands, step_forms); + tail = scm_cons2 (init_forms, variables, tail); + SCM_SETCAR (expr, SCM_IM_DO); + SCM_SETCDR (expr, tail); + return expr; } From 4610b011a7cca6483ac8bd2f20c98170acb5f012 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 12 Oct 2003 12:58:51 +0000 Subject: [PATCH 048/239] * libguile/eval.c (s_duplicate_binding): New static identifier. (scm_m_case): Call scm_c_memq instead of implementing it inline. (scm_m_define): Added comment about how we check for duplicate formals. (scm_m_do): Added check for duplicate bindings. (scm_m_if): Use ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing when creating the memoized code. (scm_c_improper_memq, c_improper_memq, scm_m_lambda): Renamed scm_c_improper_memq to c_improper_memq, since it is not exported. (transform_bindings): Call scm_c_memq rather than scm_c_improper_memq. (SCM_CEVAL): Simplified handling of SCM_IM_IF forms. * test-suite/tests/syntax.test (exception:missing/extra-expr-syntax): New, introduced temporarily until all memoizers use the new way of error reporting. Adapted tests for 'if' to the new way of error reporting. --- libguile/ChangeLog | 22 ++++++++++++++ libguile/eval.c | 57 +++++++++++++++++++++--------------- test-suite/ChangeLog | 8 +++++ test-suite/tests/syntax.test | 6 ++-- 4 files changed, 67 insertions(+), 26 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 45c93c0ff..035308e19 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2003-10-11 Dirk Herrmann + + * eval.c (s_duplicate_binding): New static identifier. + + (scm_m_case): Call scm_c_memq instead of implementing it inline. + + (scm_m_define): Added comment about how we check for duplicate + formals. + + (scm_m_do): Added check for duplicate bindings. + + (scm_m_if): Use ASSERT_SYNTAX to signal syntax errors. Avoid + unnecessary consing when creating the memoized code. + + (scm_c_improper_memq, c_improper_memq, scm_m_lambda): Renamed + scm_c_improper_memq to c_improper_memq, since it is not exported. + + (transform_bindings): Call scm_c_memq rather than + scm_c_improper_memq. + + (SCM_CEVAL): Simplified handling of SCM_IM_IF forms. + 2003-10-11 Dirk Herrmann * eval.c (s_bad_bindings, s_bad_binding, s_bad_exit_clause): New diff --git a/libguile/eval.c b/libguile/eval.c index d582a12aa..43f270ca8 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -63,6 +63,7 @@ char *alloca (); #include "libguile/strings.h" #include "libguile/throw.h" #include "libguile/smob.h" +#include "libguile/list.h" #include "libguile/macros.h" #include "libguile/procprop.h" #include "libguile/hashtab.h" @@ -162,6 +163,11 @@ static const char s_bad_bindings[] = "Bad bindings"; * 'Bad binding' error is signalled. */ static const char s_bad_binding[] = "Bad binding"; +/* Some syntactic forms don't allow variable names to appear more than once in + * a list of bindings. If such a situation is nevertheless detected, a + * 'Duplicate binding' error is signalled. */ +static const char s_duplicate_binding[] = "Duplicate binding"; + /* If the exit form of a 'do' expression is not in the format * ( ...) * a 'Bad exit clause' error is signalled. */ @@ -804,12 +810,8 @@ scm_m_case (SCM expr, SCM env) for (; !SCM_NULLP (all_labels); all_labels = SCM_CDR (all_labels)) { const SCM label = SCM_CAR (all_labels); - SCM label_idx = SCM_CDR (all_labels); - for (; !SCM_NULLP (label_idx); label_idx = SCM_CDR (label_idx)) - { - ASSERT_SYNTAX_2 (!SCM_EQ_P (SCM_CAR (label_idx), label), - s_duplicate_case_label, label, expr); - } + ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label, SCM_CDR (all_labels))), + s_duplicate_case_label, label, expr); } SCM_SETCAR (expr, SCM_IM_CASE); @@ -908,7 +910,8 @@ scm_m_define (SCM expr, SCM env) /* This while loop realizes function currying by variable nesting. * Variable is known to be a nested-variable. In every iteration of the * loop another level of lambda expression is created, starting with the - * innermost one. */ + * innermost one. Note that we don't check for duplicate formals here: + * This will be done by the memoizer of the lambda expression. */ const SCM formals = SCM_CDR (variable); const SCM tail = scm_cons (formals, body); @@ -986,8 +989,8 @@ SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do); SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); /* DO gets the most radically altered syntax. The order of the vars is - * reversed here. In contrast, the order of the inits and steps is reversed - * during the evaluation: + * reversed here. During the evaluation this allows for simple consing of the + * results of the inits and steps: (do (( ) ( ) @@ -1035,6 +1038,9 @@ scm_m_do (SCM expr, SCM env SCM_UNUSED) const SCM init = SCM_CADR (binding); const SCM step = (length == 2) ? name : SCM_CADDR (binding); ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr); + ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name, variables)), + s_duplicate_binding, name, expr); + variables = scm_cons (name, variables); init_forms = scm_cons (init, init_forms); step_forms = scm_cons (step, step_forms); @@ -1062,27 +1068,31 @@ SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if); SCM_GLOBAL_SYMBOL (scm_sym_if, s_if); SCM -scm_m_if (SCM xorig, SCM env SCM_UNUSED) +scm_m_if (SCM expr, SCM env SCM_UNUSED) { - long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 2 && len <= 3, s_expression, s_if); - return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); + const SCM cdr_expr = SCM_CDR (expr); + const long length = scm_ilength (cdr_expr); + ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr); + SCM_SETCAR (expr, SCM_IM_IF); + return expr; } SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda); SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda); -/* Return true if OBJ is `eq?' to one of the elements of LIST or to the - * cdr of the last cons. (Thus, LIST is not required to be a proper - * list and OBJ can also be found in the improper ending.) */ +/* A helper function for memoize_lambda to support checking for duplicate + * formal arguments: Return true if OBJ is `eq?' to one of the elements of + * LIST or to the cdr of the last cons. Therefore, LIST may have any of the + * forms that a formal argument can have: + * , ( ...), ( ... . ) */ static int -scm_c_improper_memq (SCM obj, SCM list) +c_improper_memq (SCM obj, SCM list) { for (; SCM_CONSP (list); list = SCM_CDR (list)) { if (SCM_EQ_P (SCM_CAR (list), obj)) - return 1; + return 1; } return SCM_EQ_P (list, obj); } @@ -1100,7 +1110,7 @@ scm_m_lambda (SCM xorig, SCM env SCM_UNUSED) { SCM formal = SCM_CAR (formals); SCM_ASSYNT (SCM_SYMBOLP (formal), s_formals, s_lambda); - if (scm_c_improper_memq (formal, SCM_CDR (formals))) + if (c_improper_memq (formal, SCM_CDR (formals))) scm_misc_error (s_lambda, s_duplicate_formals, SCM_EOL); formals = SCM_CDR (formals); } @@ -1129,7 +1139,7 @@ transform_bindings (SCM bindings, SCM *rvarloc, SCM *initloc, const char *what) SCM binding = SCM_CAR (bindings); SCM_ASSYNT (scm_ilength (binding) == 2, s_bindings, what); SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), s_variable, what); - if (scm_c_improper_memq (SCM_CAR (binding), rvars)) + if (!SCM_FALSEP (scm_c_memq (SCM_CAR (binding), rvars))) scm_misc_error (what, s_duplicate_bindings, SCM_EOL); rvars = scm_cons (SCM_CAR (binding), rvars); *initloc = scm_list_1 (SCM_CADR (binding)); @@ -2650,11 +2660,10 @@ dispatch: x = SCM_CDR (x); { SCM test_result = EVALCAR (x, env); - if (!SCM_FALSEP (test_result) && !SCM_NILP (test_result)) - x = SCM_CDR (x); - else + x = SCM_CDR (x); /* then expression */ + if (SCM_FALSEP (test_result) || SCM_NILP (test_result)) { - x = SCM_CDDR (x); + x = SCM_CDR (x); /* else expression */ if (SCM_NULLP (x)) RETURN (SCM_UNSPECIFIED); } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index f5b0bc24e..166e498df 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,11 @@ +2003-10-11 Dirk Herrmann + + * tests/syntax.test (exception:missing/extra-expr-syntax): New, + introduced temporarily until all memoizers use the new way of + error reporting. + + Adapted tests for 'if' to the new way of error reporting. + 2003-10-11 Dirk Herrmann * tests/syntax.test (exception:missing-expr, diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 2c6524744..80c431098 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -26,6 +26,8 @@ (define exception:missing/extra-expr (cons 'misc-error "^missing or extra expression")) +(define exception:missing/extra-expr-syntax + (cons 'syntax-error "^missing or extra expression")) (define exception:missing-expr (cons 'syntax-error "Missing expression")) (define exception:extra-expr @@ -429,12 +431,12 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(if)" - exception:missing/extra-expr + exception:missing/extra-expr-syntax (eval '(if) (interaction-environment))) (pass-if-exception "(if 1 2 3 4)" - exception:missing/extra-expr + exception:missing/extra-expr-syntax (eval '(if 1 2 3 4) (interaction-environment))))) From 4faa1ea0216407644154467fc2e8cf952b619ad9 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 12 Oct 2003 13:38:58 +0000 Subject: [PATCH 049/239] * tests/syntax.test (exception:missing/extra-expr-syntax): Fixed to be unaware of whether line number information is given or not. --- test-suite/ChangeLog | 5 +++++ test-suite/tests/syntax.test | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 166e498df..ca4482122 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2003-10-11 Dirk Herrmann + + * tests/syntax.test (exception:missing/extra-expr-syntax): Fixed + to be unaware of whether line number information is given or not. + 2003-10-11 Dirk Herrmann * tests/syntax.test (exception:missing/extra-expr-syntax): New, diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 80c431098..58fbc7feb 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -27,7 +27,7 @@ (define exception:missing/extra-expr (cons 'misc-error "^missing or extra expression")) (define exception:missing/extra-expr-syntax - (cons 'syntax-error "^missing or extra expression")) + (cons 'syntax-error "missing or extra expression")) (define exception:missing-expr (cons 'syntax-error "Missing expression")) (define exception:extra-expr From da14f3fbf839fc89b9777d570f3482c4aae59a54 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 12 Oct 2003 16:51:38 +0000 Subject: [PATCH 050/239] Added Paul Jarc. --- THANKS | 1 + 1 file changed, 1 insertion(+) diff --git a/THANKS b/THANKS index 0bbb3f42f..336b1aa62 100644 --- a/THANKS +++ b/THANKS @@ -33,6 +33,7 @@ For fixes or providing information which led to a fix: Sam Hocevar Peter Ivanyi Aubrey Jaffer + Paul Jarc Richard Kim Bruce Korb Matthias Köppe From eb041507a24d317101221c7ce9b93ef6377ab2ad Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 12 Oct 2003 16:52:12 +0000 Subject: [PATCH 051/239] (directory-files): Close dir-stream when done. Thanks to Paul Jarc! --- ice-9/ftw.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ice-9/ftw.scm b/ice-9/ftw.scm index 529a438b1..d8e1e12b3 100644 --- a/ice-9/ftw.scm +++ b/ice-9/ftw.scm @@ -1,6 +1,6 @@ ;;;; ftw.scm --- filesystem tree walk -;;;; Copyright (C) 2002 Free Software Foundation, Inc. +;;;; Copyright (C) 2002, 2003 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -197,7 +197,9 @@ (let loop ((new (readdir dir-stream)) (acc '())) (if (eof-object? new) - acc + (begin + (closedir dir-stream) + acc) (loop (readdir dir-stream) (if (or (string=? "." new) ;;; ignore (string=? ".." new)) ;;; ignore From e2de682cf8e6500782201f7db1c7b6edf9ed6a75 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 12 Oct 2003 16:53:24 +0000 Subject: [PATCH 052/239] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 084705d49..6dc941cca 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2003-10-12 Marius Vollmer + + * ftw.scm (directory-files): Close dir-stream when done. Thanks + to Paul Jarc! + 2003-10-09 Kevin Ryde * poe.scm (funcq-assoc): Rewrite, don't assume '() is false, and From 03a3e94134a300651f3f06db4cf83b3d3a11ce60 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 12 Oct 2003 20:47:32 +0000 Subject: [PATCH 053/239] * libguile/eval.c (s_bad_formals, s_bad_formal, s_duplicate_formal): New static identifiers. (s_clauses, s_formals, s_duplicate_formals): Removed. (scm_m_lambda): Use ASSERT_SYNTAX to signal syntax errors. Be more specific about the kind of error that was detected. Prepare for easier integration of changes for separated memoization. * test-suite/tests/syntax.test (define exception:bad-formal, define exception:duplicate-formal): New. (exception:duplicate-formals): Removed. (exception:bad-formals): Adapted to the new way of error reporting. Adapted tests for 'lambda' to the new way of error reporting. --- libguile/ChangeLog | 11 ++++++ libguile/eval.c | 65 ++++++++++++++++++++++++++---------- test-suite/ChangeLog | 12 +++++++ test-suite/tests/syntax.test | 28 ++++++++-------- 4 files changed, 86 insertions(+), 30 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 035308e19..f12cb87f8 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2003-10-12 Dirk Herrmann + + * eval.c (s_bad_formals, s_bad_formal, s_duplicate_formal): New + static identifiers. + + (s_clauses, s_formals, s_duplicate_formals): Removed. + + (scm_m_lambda): Use ASSERT_SYNTAX to signal syntax errors. Be more + specific about the kind of error that was detected. Prepare for + easier integration of changes for separated memoization. + 2003-10-11 Dirk Herrmann * eval.c (s_duplicate_binding): New static identifier. diff --git a/libguile/eval.c b/libguile/eval.c index 43f270ca8..d9299645e 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -173,6 +173,20 @@ static const char s_duplicate_binding[] = "Duplicate binding"; * a 'Bad exit clause' error is signalled. */ static const char s_bad_exit_clause[] = "Bad exit clause"; +/* The formal function arguments of a lambda expression have to be either a + * single symbol or a non-cyclic list. For anything else a 'Bad formals' + * error is signalled. */ +static const char s_bad_formals[] = "Bad formals"; + +/* If in a lambda expression something else than a symbol is detected at a + * place where a formal function argument is required, a 'Bad formal' error is + * signalled. */ +static const char s_bad_formal[] = "Bad formal"; + +/* If in the arguments list of a lambda expression an argument name occurs + * more than once, a 'Duplicate formal' error is signalled. */ +static const char s_duplicate_formal[] = "Duplicate formal"; + /* Signal a syntax error. We distinguish between the form that caused the * error and the enclosing expression. The error message will print out as @@ -382,9 +396,6 @@ static const char s_body[] = "bad body"; static const char s_bindings[] = "bad bindings"; static const char s_duplicate_bindings[] = "duplicate bindings"; static const char s_variable[] = "bad variable"; -static const char s_clauses[] = "bad or missing clauses"; -static const char s_formals[] = "bad formals"; -static const char s_duplicate_formals[] = "duplicate formals"; static const char s_splicing[] = "bad (non-list) result for unquote-splicing"; @@ -1098,27 +1109,47 @@ c_improper_memq (SCM obj, SCM list) } SCM -scm_m_lambda (SCM xorig, SCM env SCM_UNUSED) +scm_m_lambda (SCM expr, SCM env SCM_UNUSED) { SCM formals; - SCM x = SCM_CDR (xorig); + SCM formals_idx; - SCM_ASSYNT (SCM_CONSP (x), s_formals, s_lambda); + const SCM cdr_expr = SCM_CDR (expr); + const long length = scm_ilength (cdr_expr); + ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (length >= 2, s_missing_expression, expr); - formals = SCM_CAR (x); - while (SCM_CONSP (formals)) + /* Before iterating the list of formal arguments, make sure the formals + * actually are given as either a symbol or a non-cyclic list. */ + formals = SCM_CAR (cdr_expr); + if (SCM_CONSP (formals)) { - SCM formal = SCM_CAR (formals); - SCM_ASSYNT (SCM_SYMBOLP (formal), s_formals, s_lambda); - if (c_improper_memq (formal, SCM_CDR (formals))) - scm_misc_error (s_lambda, s_duplicate_formals, SCM_EOL); - formals = SCM_CDR (formals); + /* Dirk:FIXME:: We should check for a cyclic list of formals, and if + * detected, report a 'Bad formals' error. */ + } + else + { + ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals) || SCM_NULLP (formals), + s_bad_formals, formals, expr); } - if (!SCM_NULLP (formals) && !SCM_SYMBOLP (formals)) - scm_misc_error (s_lambda, s_formals, SCM_EOL); - return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x), - scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda)); + /* Now iterate the list of formal arguments to check if all formals are + * symbols, and that there are no duplicates. */ + formals_idx = formals; + while (SCM_CONSP (formals_idx)) + { + const SCM formal = SCM_CAR (formals_idx); + const SCM next_idx = SCM_CDR (formals_idx); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal), s_bad_formal, formal, expr); + ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx), + s_duplicate_formal, formal, expr); + formals_idx = next_idx; + } + ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || SCM_SYMBOLP (formals_idx), + s_bad_formal, formals_idx, expr); + + return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (cdr_expr), + scm_m_body (SCM_IM_LAMBDA, SCM_CDR (cdr_expr), s_lambda)); } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index ca4482122..f4deb831d 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,15 @@ +2003-10-12 Dirk Herrmann + + * tests/syntax.test (define exception:bad-formal, define + exception:duplicate-formal): New. + + (exception:duplicate-formals): Removed. + + (exception:bad-formals): Adapted to the new way of error + reporting. + + Adapted tests for 'lambda' to the new way of error reporting. + 2003-10-11 Dirk Herrmann * tests/syntax.test (exception:missing/extra-expr-syntax): Fixed diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 58fbc7feb..9bde520a7 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -40,9 +40,11 @@ (define exception:bad-body (cons 'misc-error "^bad body")) (define exception:bad-formals - (cons 'misc-error "^bad formals")) -(define exception:duplicate-formals - (cons 'misc-error "^duplicate formals")) + (cons 'syntax-error "Bad formals")) +(define exception:bad-formal + (cons 'syntax-error "Bad formal")) +(define exception:duplicate-formal + (cons 'syntax-error "Duplicate formal")) (define exception:missing-clauses (cons 'syntax-error "Missing clauses")) @@ -122,17 +124,17 @@ (with-test-prefix "bad formals" (pass-if-exception "(lambda)" - exception:bad-formals + exception:missing-expr (eval '(lambda) (interaction-environment))) (pass-if-exception "(lambda . \"foo\")" - exception:bad-formals + exception:bad-expression (eval '(lambda . "foo") (interaction-environment))) (pass-if-exception "(lambda \"foo\")" - exception:bad-formals + exception:missing-expr (eval '(lambda "foo") (interaction-environment))) @@ -142,22 +144,22 @@ (interaction-environment))) (pass-if-exception "(lambda (x 1) 2)" - exception:bad-formals + exception:bad-formal (eval '(lambda (x 1) 2) (interaction-environment))) (pass-if-exception "(lambda (1 x) 2)" - exception:bad-formals + exception:bad-formal (eval '(lambda (1 x) 2) (interaction-environment))) (pass-if-exception "(lambda (x \"a\") 2)" - exception:bad-formals + exception:bad-formal (eval '(lambda (x "a") 2) (interaction-environment))) (pass-if-exception "(lambda (\"a\" x) 2)" - exception:bad-formals + exception:bad-formal (eval '(lambda ("a" x) 2) (interaction-environment)))) @@ -165,20 +167,20 @@ ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x) 1)" - exception:duplicate-formals + exception:duplicate-formal (eval '(lambda (x x) 1) (interaction-environment))) ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x x) 1)" - exception:duplicate-formals + exception:duplicate-formal (eval '(lambda (x x x) 1) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(lambda ())" - exception:bad-body + exception:missing-expr (eval '(lambda ()) (interaction-environment))))) From 9f1af5d96ed382eb8eacec0016858b28654509c3 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 16 Oct 2003 11:53:58 +0000 Subject: [PATCH 054/239] Work on debugger frontend code. --- emacs/gds.el | 173 +++++++++++++----- ice-9/ChangeLog | 10 ++ ice-9/debugger.scm | 8 +- ice-9/debugger/ui-client.scm | 338 ----------------------------------- 4 files changed, 146 insertions(+), 383 deletions(-) diff --git a/emacs/gds.el b/emacs/gds.el index c9d53575f..0c8e33792 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -297,20 +297,6 @@ )))))) -(defun gds-display-results (client results) - (let ((buf (get-buffer-create "*Guile Results*"))) - (save-excursion - (set-buffer buf) - (erase-buffer) - (while results - (insert (car results)) - (mapcar (function (lambda (value) - (insert " => " value "\n"))) - (cadr results)) - (insert "\n") - (setq results (cddr results)))) - (pop-to-buffer buf))) - ;; Store latest status, stack or module list for the specified client. (defmacro gds-set (alist client val) `(let ((existing (assq ,client ,alist))) @@ -512,17 +498,6 @@ ;; Force redisplay. (sit-for 0)) -(defun old-stuff () - (if (gds-buffer-visible-in-selected-frame-p) - ;; Buffer already visible enough. - nil - ;; Delete any views of the buffer in other frames - we don't want - ;; views all over the place. - (delete-windows-on gds-client-buffer) - ;; Run idle timer to display the buffer as soon as user isn't in - ;; the middle of something else. - )) - (defun gds-insert-stack (stack) (let ((frames (car stack)) (index (cadr stack)) @@ -780,7 +755,7 @@ not of primary interest when debugging application code." ;; Where there are multiple Guile applications known to GDS, GDS by ;; default sends code to the one that holds the debugging focus, ;; i.e. `gds-displayed-client'. Where no application has the focus, -;; or the command is invoked `C-u', GDS asks the user which +;; or the command is invoked with `C-u', GDS asks the user which ;; application is intended. (defun gds-read-client () @@ -793,14 +768,16 @@ not of primary interest when debugging application code." "Application for eval: ")) (name (completing-read prompt - (mapcar (function cdr) gds-names) + (mapcar (function list) + (mapcar (function cdr) gds-names)) nil t nil nil def))) (let (client (names gds-names)) (while (and names (not client)) - (if (string-equal (cadar names) name) + (if (string-equal (cdar names) name) (setq client (caar names))) - (setq names (cdr names)))))) + (setq names (cdr names))) + client))) (defun gds-choose-client (client) (or ;; If client is an integer, it is the port number of the @@ -813,18 +790,25 @@ not of primary interest when debugging application code." ;; If ask not forced, and there is a client with the focus, ;; default to that one. gds-displayed-client + ;; If there are no clients at this point, and we are allowed to + ;; autostart a captive Guile, do so. + (and (null gds-names) + gds-autostart-captive + (progn + (gds-start-captive t) + (while (null gds-names) + (accept-process-output (get-buffer-process gds-captive) + 0 100000)) + (caar gds-names))) + ;; If there is only one known client, use that one. + (if (and (car gds-names) + (null (cdr gds-names))) + (caar gds-names)) ;; Last resort - ask the user. (gds-read-client) ;; Signal an error. (error "No application chosen."))) -(defcustom gds-default-module-name '(guile-user) - "Name of the default module for GDS code evaluation, as list of symbols. -This module is used when there is no `define-module' form in the -buffer preceding the code to be evaluated." - :type 'sexp - :group 'gds) - (defun gds-module-name (start end) "Determine and return the name of the module that governs the specified region. The module name is returned as a list of symbols." @@ -887,6 +871,66 @@ region's code." (interactive "P") (gds-eval-region (save-excursion (backward-sexp) (point)) (point) client)) + +;;;; Help. + +;; Help is implemented as a special case of evaluation, where we +;; arrange for the evaluation result to be a known symbol that is +;; unlikely to crop up otherwise. When the evaluation result is this +;; symbol, we only display the output from the evaluation. + +(defvar gds-help-symbol '%-gds-help-% + "Symbol used by GDS to identify an evaluation response as help.") + +(defun gds-help-symbol (sym &optional client) + "Get help for SYM (a Scheme symbol)." + (interactive "SHelp for symbol: \nP") + (gds-eval-expression (format "(begin (help %S) '%S)" sym gds-help-symbol) + client)) + +(defun gds-help-symbol-here (&optional client) + (interactive "P") + (gds-help-symbol (thing-at-point 'symbol) client)) + +(defun gds-apropos (regex &optional client) + "List Guile symbols matching REGEX." + (interactive "sApropos Guile regex: \nP") + (gds-eval-expression (format "(begin (apropos %S) '%S)" regex gds-help-symbol) + client)) + + +;;;; Display of evaluation and help results. + +(defun gds-display-results (client results) + (let ((helpp (and (= (length results) 2) + (= (length (cadr results)) 1) + (string-equal (caadr results) + (prin1-to-string gds-help-symbol))))) + (let ((buf (get-buffer-create (if helpp + "*Guile Help*" + "*Guile Results*")))) + (save-excursion + (set-buffer buf) + (erase-buffer) + (while results + (insert (car results)) + (if helpp + nil + (mapcar (function (lambda (value) + (insert " => " value "\n"))) + (cadr results)) + (insert "\n")) + (setq results (cddr results))) + (goto-char (point-min)) + (if (and helpp (looking-at "Evaluating in ")) + (delete-region (point) (progn (forward-line 1) (point))))) + (pop-to-buffer buf) + (run-hooks 'temp-buffer-show-hook) + (other-window 1)))) + + +;;;; Loading (evaluating) a whole Scheme file. + (defcustom gds-source-modes '(scheme-mode) "*Used to determine if a buffer contains Scheme source code. If it's loaded into a buffer that is in one of these major modes, it's @@ -973,6 +1017,9 @@ Used for determining the default for the next `gds-load-file'.") (if gds-advanced-menu nil (setq gds-advanced-menu (make-sparse-keymap "Advanced")) + (define-key gds-advanced-menu [run-captive] + '(menu-item "Run Captive Guile" gds-start-captive + :enable (not (comint-check-proc gds-captive)))) (define-key gds-advanced-menu [restart-gds] '(menu-item "Restart IDE" gds-start :enable gds-process)) (define-key gds-advanced-menu [kill-gds] @@ -989,18 +1036,21 @@ Used for determining the default for the next `gds-load-file'.") (cons "Advanced" gds-advanced-menu)) (define-key gds-menu [separator-1] '("--")) - (define-key gds-menu [help] - `(menu-item "Help" ,gds-help-menu :enable gds-names)) - (define-key gds-menu [eval] - `(menu-item "Evaluate" ,gds-eval-menu :enable gds-names)) (define-key gds-menu [debug] `(menu-item "Debug" ,gds-debug-menu :enable (and gds-displayed-client (gds-client-waiting)))) + (define-key gds-menu [eval] + `(menu-item "Evaluate" ,gds-eval-menu :enable (or gds-names + gds-autostart-captive))) + (define-key gds-menu [help] + `(menu-item "Help" ,gds-help-menu :enable (or gds-names + gds-autostart-captive))) (setq menu-bar-final-items (cons 'guile menu-bar-final-items)) (define-key global-map [menu-bar guile] (cons "Guile" gds-menu))) + ;;;; Autostarting the GDS server. (defcustom gds-autostart-server t @@ -1012,6 +1062,49 @@ Used for determining the default for the next `gds-load-file'.") (not gds-process)) (gds-start)) + +;;;; `Captive' Guile - a Guile process that is started when needed to +;;;; provide help, completion, evaluations etc. + +(defcustom gds-autostart-captive t + "Whether to automatically start a `captive' Guile process when needed." + :type 'boolean + :group 'gds) + +(defvar gds-captive nil + "Buffer of captive Guile.") + +(defun gds-start-captive (&optional restart) + (interactive) + (if (and restart + (comint-check-proc gds-captive)) + (gds-kill-captive)) + (if (comint-check-proc gds-captive) + nil + (let ((process-connection-type nil)) + (setq gds-captive (make-comint "captive-guile" + "guile" + nil + "-q"))) + (let ((proc (get-buffer-process gds-captive))) + (comint-send-string proc "(set! %load-path (cons \"/home/neil/Guile/cvs/guile-core\" %load-path))\n") + (comint-send-string proc "(debug-enable 'backtrace)\n") + (comint-send-string proc "(use-modules (ice-9 debugger ui-client))\n") + (comint-send-string proc "(ui-connect \"Captive Guile\" #f)\n")))) + +(defun gds-kill-captive () + (if gds-captive + (let ((proc (get-buffer-process gds-captive))) + (process-kill-without-query proc) + (condition-case nil + (progn + (kill-process gds-process) + (accept-process-output gds-process 0 200)) + (error))))) + + +;;;; The end! + (provide 'gds) ;;; gds.el ends here. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 6dc941cca..8282630f6 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,13 @@ +2003-10-16 Neil Jerram + + * debugger/ui-client.scm (ui-connect): Add arg to say whether to + debug immediately on connection. + (ui-eval): Handle exceptions during read and evaluation. + + * debugger.scm (debug-on-error, default-default-lazy-handler): + Remove an unnecessary level of indirection in calling lazy + handler. + 2003-10-12 Marius Vollmer * ftw.scm (directory-files): Close dir-stream when done. Thanks diff --git a/ice-9/debugger.scm b/ice-9/debugger.scm index f02af1de7..891e0bc82 100644 --- a/ice-9/debugger.scm +++ b/ice-9/debugger.scm @@ -158,18 +158,16 @@ Indicates that the debugger should display an introductory message. ;;; {Debug on Error} -(define default-default-lazy-handler default-lazy-handler) - (define (debug-on-error syms) "Enable or disable debug on error." - (set! default-lazy-handler + (set! lazy-handler-dispatch (if syms (lambda (key . args) (or (memq key syms) (debug-stack (make-stack #t lazy-handler-dispatch) #:with-introduction #:continuable)) - (apply default-default-lazy-handler key args)) - default-default-lazy-handler))) + (apply default-lazy-handler key args)) + default-lazy-handler))) ;;; (ice-9 debugger) ends here. diff --git a/ice-9/debugger/ui-client.scm b/ice-9/debugger/ui-client.scm index f7fc7b0e2..e69de29bb 100644 --- a/ice-9/debugger/ui-client.scm +++ b/ice-9/debugger/ui-client.scm @@ -1,338 +0,0 @@ -;;;; Guile Debugger UI client - -;;; Copyright (C) 2003 Free Software Foundation, Inc. -;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -(define-module (ice-9 debugger ui-client) - #:use-module (ice-9 debugger) - #:use-module (ice-9 debugger behaviour) - #:use-module (ice-9 debugger breakpoints) - #:use-module (ice-9 debugger breakpoints procedural) - #:use-module (ice-9 debugger state) - #:use-module (ice-9 debugger utils) - #:use-module (ice-9 optargs) - #:use-module (ice-9 session) - #:use-module (ice-9 string-fun) - #:use-module (ice-9 threads) - #:export (ui-port-number - ui-connected? - ui-connect - ui-command-loop) - #:no-backtrace) - -;; The TCP port number that the UI server listens for application -;; connections on. -(define ui-port-number 8333) - -;; Once connected, the TCP socket port to the UI server. -(define ui-port #f) - -(define* (ui-connect name #:optional host) - "Connect to the debug UI server as @var{name}, a string that should -be sufficient to describe the calling application to the debug UI -user. The optional @var{host} arg specifies the hostname or dotted -decimal IP address where the UI server is running; default is -127.0.0.1." - (if (ui-connected?) - (error "Already connected to UI server!")) - ;; Connect to debug server. - (set! ui-port - (let ((s (socket PF_INET SOCK_STREAM 0)) - (SOL_TCP 6) - (TCP_NODELAY 1)) - (setsockopt s SOL_TCP TCP_NODELAY 1) - (connect s AF_INET (inet-aton (or host "127.0.0.1")) ui-port-number) - s)) - ;; Set debugger-output-port so that stuff written to it is - ;; accumulated for sending to the debug server. - (set! (debugger-output-port) - (make-soft-port (vector accumulate-output - accumulate-output - #f #f #f #f) - "w")) - ;; Start the asynchronous UI thread. - (start-async-ui-thread) - ;; Write initial context to debug server. - (write-form (list 'name name)) - (write-form (cons 'modules (map module-name (loaded-modules)))) - (debug-stack (make-stack #t ui-connect) #:continuable) -; (ui-command-loop #f) - ) - -(define ui-disable-async-thread noop) -(define ui-continue-async-thread noop) - -(define (start-async-ui-thread) - (let ((mutex (make-mutex)) - (condition (make-condition-variable)) - (admin (pipe))) - ;; Start the asynchronous UI thread. - (begin-thread - (lock-mutex mutex) - ;;(write (cons admin ui-port)) - ;;(newline) - (let loop ((avail '())) - ;;(write avail) - ;;(newline) - (if (null? avail) - (begin - (write-status 'ready-for-input) - (loop (car (select (list ui-port (car admin)) '() '())))) - (let ((port (car avail))) - (if (eq? port ui-port) - (handle-instruction #f (read ui-port)) - (begin - ;; Notification from debugger that it wants to take - ;; over. Read the notification char. - (read-char (car admin)) - ;; Wait on condition variable - this allows the - ;; debugger thread to grab the mutex. - (wait-condition-variable condition mutex))) - ;; Loop. - (loop (cdr avail)))))) - ;; Redefine procs used by debugger thread to take control. - (set! ui-disable-async-thread - (lambda () - (write-char #\x (cdr admin)) - (force-output (cdr admin)) - ;;(display "ui-disable-async-thread: locking mutex...\n" - ;; (current-error-port)) - (lock-mutex mutex))) - (set! ui-continue-async-thread - (lambda () - (unlock-mutex mutex) - (signal-condition-variable condition))))) - -(define accumulated-output '()) - -(define (accumulate-output obj) - (set! accumulated-output - (cons (if (string? obj) obj (make-string 1 obj)) - accumulated-output))) - -(define (get-accumulated-output) - (let ((s (apply string-append (reverse! accumulated-output)))) - (set! accumulated-output '()) - s)) - -(define (ui-connected?) - "Return @code{#t} if a UI server connected has been made; else @code{#f}." - (not (not ui-port))) - -(define (ui-command-loop state) - "Interact with the UI frontend." - (or (ui-connected?) - (error "Not connected to UI server.")) - (ui-disable-async-thread) - (catch 'exit-debugger - (lambda () - (let loop ((state state)) - ;; Write accumulated debugger output. - (write-form (list 'output - (sans-surrounding-whitespace - (get-accumulated-output)))) - ;; Write current state to the frontend. - (if state (write-stack state)) - ;; Tell the frontend that we're waiting for input. - (write-status 'waiting-for-input) - ;; Read next instruction, act on it, and loop with - ;; updated state. - (loop (handle-instruction state (read ui-port))))) - (lambda args *unspecified*)) - (ui-continue-async-thread)) - -(define (write-stack state) - ;; Write Emacs-readable representation of current state to UI - ;; frontend. - (let ((frames (stack->emacs-readable (state-stack state))) - (index (index->emacs-readable (state-index state))) - (flags (flags->emacs-readable (state-flags state)))) - (if (memq 'backwards (debug-options)) - (write-form (list 'stack - frames - index - flags)) - ;; Calculate (length frames) here because `reverse!' will make - ;; the original `frames' invalid. - (let ((nframes (length frames))) - (write-form (list 'stack - (reverse! frames) - (- nframes index 1) - flags)))))) - -(define (write-form form) - ;; Write any form FORM to UI frontend. - (write form ui-port) - (newline ui-port) - (force-output ui-port)) - -(define (stack->emacs-readable stack) - ;; Return Emacs-readable representation of STACK. - (map (lambda (index) - (frame->emacs-readable (stack-ref stack index))) - (iota (stack-length stack)))) - -(define (frame->emacs-readable frame) - ;; Return Emacs-readable representation of FRAME. - (if (frame-procedure? frame) - (list 'application - (with-output-to-string - (lambda () - (display (if (frame-real? frame) " " "T ")) - (write-frame-short/application frame))) - (source->emacs-readable (frame-source frame))) - (list 'evaluation - (with-output-to-string - (lambda () - (display (if (frame-real? frame) " " "T ")) - (write-frame-short/expression frame))) - (source->emacs-readable (frame-source frame))))) - -(define (source->emacs-readable source) - ;; Return Emacs-readable representation of the filename, line and - ;; column source properties of SOURCE. - (if (and source - (string? (source-property source 'filename))) - (list (source-property source 'filename) - (source-property source 'line) - (source-property source 'column)) - 'nil)) - -(define (index->emacs-readable index) - ;; Return Emacs-readable representation of INDEX (the current stack - ;; index). - index) - -(define (flags->emacs-readable flags) - ;; Return Emacs-readable representation of FLAGS passed to - ;; debug-stack. - (map keyword->symbol flags)) - -(define the-ice-9-debugger-commands-module - (resolve-module '(ice-9 debugger commands))) - -(define (handle-instruction state ins) - ;; Read the newline that always follows an instruction. - (read-char ui-port) - ;; Handle instruction from the UI frontend, and return updated state. - (case (car ins) - ((query-module) - (let ((name (cadr ins))) - (write-form `(module ,name - ,(or (loaded-module-source name) "(no source file)") - ,@(sort (module-map (lambda (key value) - (symbol->string key)) - (resolve-module name)) - stringstring (car reverse-name))) - (dir-hint-module-name (reverse (cdr reverse-name))) - (dir-hint (apply string-append - (map (lambda (elt) - (string-append (symbol->string elt) "/")) - dir-hint-module-name)))) - (%search-load-path (in-vicinity dir-hint name)))) - -(define (loaded-modules) - ;; Return list of all loaded modules sorted by name. - (sort (apropos-fold-all (lambda (module acc) (cons module acc)) '()) - (lambda (m1 m2) - (symliststring (car l1)) (symbol->string (car l2)))))) - -;;; (ice-9 debugger ui-client) ends here. From 3e73b6f9df275867038eba52dd564ada8ef97353 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 18 Oct 2003 00:49:08 +0000 Subject: [PATCH 055/239] (SRFI-1 Searching): In break, note conflict with binding established by `while'. --- doc/ref/srfi-modules.texi | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index ee27bbffb..0e0eb0917 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -672,6 +672,11 @@ tail. @code{break} inverts the sense of the predicate. @code{span!} and @code{break!} are allowed, but not required to modify the structure of the input list @var{lst} in order to produce the result. + +Note that the name @code{break} conflicts with the @code{break} +binding established by @code{while} (@pxref{while do}). Applications +wanting to use @code{break} from within a @code{while} loop will need +to make a new define under a different name. @end deffn @deffn {Scheme Procedure} any pred lst1 lst2 @dots{} From 158fab2b80a1a9ed39a30c45a9f3338f79aa65b6 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 18 Oct 2003 01:43:55 +0000 Subject: [PATCH 056/239] * posix.texi (Time): Correction to strftime glibc cross reference node, now "Formatting Calendar Time". --- doc/ref/posix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 1eb29f47d..41215f438 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1123,7 +1123,7 @@ or @code{gmtime}. @var{template} is a string which can include formatting specifications introduced by a @samp{%} character. The formatting of month and day names is dependent on the current locale. The value returned is the formatted string. -@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}. +@xref{Formatting Calendar Time, , , libc, The GNU C Library Reference Manual}. @lisp (strftime "%c" (localtime (current-time))) From 7395c9cbd036b8ff2d951657af8e06ab15b54748 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 18 Oct 2003 01:49:18 +0000 Subject: [PATCH 057/239] (Calling Scheme procedures from C, scm transition summary): Refer to scm_list_n, not the old name scm_listify. (scm transition summary): For gh_apply, recommend scm_apply_0, which is now documented. --- doc/ref/gh.texi | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/doc/ref/gh.texi b/doc/ref/gh.texi index 621df1896..09cf11110 100644 --- a/doc/ref/gh.texi +++ b/doc/ref/gh.texi @@ -609,7 +609,7 @@ the given name (which is a C string). Returns the new object. @deftypefunx SCM gh_list (SCM l0, SCM l1, ... , SCM_UNDEFINED) These correspond to the Scheme @code{(cons a b)} and @code{(list l0 l1 ...)} procedures. Note that @code{gh_list()} is a C macro that invokes -@code{scm_listify()}. +@code{scm_list_n()}. @end deftypefun @deftypefun SCM gh_car (SCM @var{obj}) @@ -1118,7 +1118,7 @@ Use the @code{SCM_CAR} and @code{SCM_CDR} macros instead. Use @code{scm_set_car_x} and @code{scm_set_cdr_x} instead. @item @code{gh_list} -Use @code{scm_listify} instead. +Use @code{scm_list_n} instead. @item @code{gh_length} Replace @code{gh_length (@var{lst})} by @@ -1133,7 +1133,7 @@ Use @code{scm_append} instead. @item @code{gh_append2}, @code{gh_append3}, @code{gh_append4} Replace @code{gh_append@var{N} (@var{l1}, @dots{}, @var{lN})} by @example -scm_append (scm_listify (@var{l1}, @dots{}, @var{lN}, SCM_UNDEFINED)) +scm_append (scm_list_n (@var{l1}, @dots{}, @var{lN}, SCM_UNDEFINED)) @end example @item @code{gh_reverse} @@ -1161,7 +1161,6 @@ Use @code{scm_vector_ref} and @code{scm_vector_set_x} instead. Use the @code{SCM_VECTOR_LENGTH} macro instead. @item @code{gh_apply} -Use @code{scm_apply} instead, but note that @code{scm_apply} takes an -additional third argument that you should set to @code{SCM_EOL}. +Use @code{scm_apply_0} instead. @end table From e05b02b6b46100da0699a979bbd3b83d95596b7b Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 18 Oct 2003 01:51:24 +0000 Subject: [PATCH 058/239] (Defining new Scheme procedures in C): Don't use @strong{Note:}, latest makeinfo will complain it looks like a cross reference. --- doc/ref/gh.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/gh.texi b/doc/ref/gh.texi index 09cf11110..8c166373d 100644 --- a/doc/ref/gh.texi +++ b/doc/ref/gh.texi @@ -317,7 +317,7 @@ the sample programs @code{learn0} and @code{learn1}. procedures in C. The ugly mess of arguments is required because of how C handles procedures with variable numbers of arguments. -@strong{Note:} what about documentation strings? +@strong{NB:} what about documentation strings? @cartouche There are several important considerations to be made when writing the C From 2ec8656041167d96d3fda3302210df619d8826aa Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 18 Oct 2003 01:51:48 +0000 Subject: [PATCH 059/239] *** empty log message *** --- doc/ref/ChangeLog | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 021830819..a566f58ef 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,20 @@ +2003-10-18 Kevin Ryde + + * gh.texi (Calling Scheme procedures from C, scm transition summary): + Refer to scm_list_n, not the old name scm_listify. + (scm transition summary): For gh_apply, recommend scm_apply_0, which + is now documented. + + * gh.texi (Defining new Scheme procedures in C): Don't use + @strong{Note:}, latest makeinfo will complain it looks like a cross + reference. + + * posix.texi (Time): Correction to strftime glibc cross reference + node, now "Formatting Calendar Time". + + * srfi-modules.texi (SRFI-1 Searching): In break, note conflict with + binding established by `while'. + 2003-10-09 Kevin Ryde * scheme-compound.texi (Hash Table Reference): Decribe rehashing, note From d6754c2398030aea59dc7b1e1a4ceb99157fd829 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 18 Oct 2003 12:07:39 +0000 Subject: [PATCH 060/239] * libguile/eval.c (scm_m_let, scm_m_letstar, scm_m_letrec, scm_m_expand_body, check_bindings): Extracted syntax checking of bindings to new static function check_bindings. (scm_m_let, memoize_named_let): Extracted handling of named let to new static function memoize_named_let. (transform_bindings, scm_m_let, scm_m_letstar, scm_m_letrec): Use ASSERT_SYNTAX to signal syntax errors. Be more specific about the kind of error that was detected. Avoid use of SCM_CDRLOC. Avoid unnecessary consing when creating the memoized code. * test-suite/lib.scm (exception:bad-variable): New. * test-suite/tests/syntax.test (exception:bad-binding, exception:duplicate-binding): New. (exception:duplicate-bindings): Removed. Adapted tests for 'let', 'let*' and 'letrec' to the new way of error reporting. --- libguile/ChangeLog | 14 ++ libguile/eval.c | 256 +++++++++++++++++++++-------------- test-suite/ChangeLog | 12 ++ test-suite/lib.scm | 3 + test-suite/tests/syntax.test | 76 +++++------ 5 files changed, 218 insertions(+), 143 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f12cb87f8..84475aeed 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,17 @@ +2003-10-18 Dirk Herrmann + + * eval.c (scm_m_let, scm_m_letstar, scm_m_letrec, + scm_m_expand_body, check_bindings): Extracted syntax checking of + bindings to new static function check_bindings. + + (scm_m_let, memoize_named_let): Extracted handling of named let to + new static function memoize_named_let. + + (transform_bindings, scm_m_let, scm_m_letstar, scm_m_letrec): Use + ASSERT_SYNTAX to signal syntax errors. Be more specific about the + kind of error that was detected. Avoid use of SCM_CDRLOC. Avoid + unnecessary consing when creating the memoized code. + 2003-10-12 Dirk Herrmann * eval.c (s_bad_formals, s_bad_formal, s_duplicate_formal): New diff --git a/libguile/eval.c b/libguile/eval.c index d9299645e..91cd36d81 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1153,101 +1153,137 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED) } -/* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists - * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is - * reversed here, the list of inits gets reversed during evaluation. */ +/* Check if the format of the bindings is (( ) ...). */ static void -transform_bindings (SCM bindings, SCM *rvarloc, SCM *initloc, const char *what) +check_bindings (const SCM bindings, const SCM expr) { - SCM rvars = SCM_EOL; - *rvarloc = SCM_EOL; - *initloc = SCM_EOL; + SCM binding_idx; - SCM_ASSYNT (scm_ilength (bindings) >= 1, s_bindings, what); + ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0, + s_bad_bindings, bindings, expr); - do + binding_idx = bindings; + for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx)) { - SCM binding = SCM_CAR (bindings); - SCM_ASSYNT (scm_ilength (binding) == 2, s_bindings, what); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), s_variable, what); - if (!SCM_FALSEP (scm_c_memq (SCM_CAR (binding), rvars))) - scm_misc_error (what, s_duplicate_bindings, SCM_EOL); - rvars = scm_cons (SCM_CAR (binding), rvars); - *initloc = scm_list_1 (SCM_CADR (binding)); - initloc = SCM_CDRLOC (*initloc); - bindings = SCM_CDR (bindings); - } - while (!SCM_NULLP (bindings)); + SCM name; /* const */ - *rvarloc = rvars; + const SCM binding = SCM_CAR (binding_idx); + ASSERT_SYNTAX_2 (scm_ilength (binding) == 2, + s_bad_binding, binding, expr); + + name = SCM_CAR (binding); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr); + } +} + + +/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are + * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the + * variables are returned in a list with their order reversed, and the init + * forms are returned in a list in the same order as they are given in the + * bindings. If a duplicate variable name is detected, an error is + * signalled. */ +static void +transform_bindings ( + const SCM bindings, const SCM expr, + SCM *const rvarptr, SCM *const initptr ) +{ + SCM rvariables = SCM_EOL; + SCM rinits = SCM_EOL; + SCM binding_idx = bindings; + for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx)) + { + const SCM binding = SCM_CAR (binding_idx); + const SCM cdr_binding = SCM_CDR (binding); + const SCM name = SCM_CAR (binding); + ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name, rvariables)), + s_duplicate_binding, name, expr); + rvariables = scm_cons (name, rvariables); + rinits = scm_cons (SCM_CAR (cdr_binding), rinits); + } + *rvarptr = rvariables; + *initptr = scm_reverse_x (rinits, SCM_UNDEFINED); } SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let); SCM_GLOBAL_SYMBOL(scm_sym_let, s_let); -SCM -scm_m_let (SCM xorig, SCM env) +/* This function is a helper function for memoize_let. It transforms + * (let name ((var init) ...) body ...) into + * ((letrec ((name (lambda (var ...) body ...))) name) init ...) + * and memoizes the expression. It is assumed that the caller has checked + * that name is a symbol and that there are bindings and a body. */ +static SCM +memoize_named_let (const SCM expr, const SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig); - SCM temp; + SCM rvariables; + SCM variables; + SCM inits; - SCM_ASSYNT (SCM_CONSP (x), s_bindings, s_let); - temp = SCM_CAR (x); - if (SCM_NULLP (temp) - || (scm_ilength (temp) == 1 && SCM_CONSP (SCM_CAR (temp)))) + const SCM cdr_expr = SCM_CDR (expr); + const SCM name = SCM_CAR (cdr_expr); + const SCM cddr_expr = SCM_CDR (cdr_expr); + const SCM bindings = SCM_CAR (cddr_expr); + check_bindings (bindings, expr); + + transform_bindings (bindings, expr, &rvariables, &inits); + variables = scm_reverse_x (rvariables, SCM_UNDEFINED); + + { + const SCM let_body = SCM_CDR (cddr_expr); + const SCM lambda_body = scm_m_body (SCM_IM_LET, let_body, "let"); + const SCM lambda_tail = scm_cons (variables, lambda_body); + const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail); + + const SCM rvar = scm_list_1 (name); + const SCM init = scm_list_1 (lambda_form); + const SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name), "let"); + const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body)); + const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail); + return scm_cons_source (expr, letrec_form, inits); + } +} + +/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers + * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */ +SCM +scm_m_let (SCM expr, SCM env) +{ + SCM bindings; + + const SCM cdr_expr = SCM_CDR (expr); + const long length = scm_ilength (cdr_expr); + ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (length >= 2, s_missing_expression, expr); + + bindings = SCM_CAR (cdr_expr); + if (SCM_SYMBOLP (bindings)) { - /* null or single binding, let* is faster */ - SCM bindings = temp; - SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (x), s_let); - return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), bindings, body), env); + ASSERT_SYNTAX (length >= 3, s_missing_expression, expr); + return memoize_named_let (expr, env); } - else if (SCM_CONSP (temp)) + + check_bindings (bindings, expr); + if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings))) { - /* plain let */ - SCM bindings = temp; - SCM rvars, inits, body; - transform_bindings (bindings, &rvars, &inits, "let"); - body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let"); - return scm_cons2 (SCM_IM_LET, rvars, scm_cons (inits, body)); + /* Special case: no bindings or single binding => let* is faster. */ + const SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr), s_let); + return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env); } else { - /* named let: Transform (let name ((var init) ...) body ...) into - * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */ - - SCM name = temp; - SCM vars = SCM_EOL; - SCM *varloc = &vars; - SCM inits = SCM_EOL; - SCM *initloc = &inits; - SCM bindings; - - SCM_ASSYNT (SCM_SYMBOLP (name), s_bindings, s_let); - x = SCM_CDR (x); - SCM_ASSYNT (SCM_CONSP (x), s_bindings, s_let); - bindings = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (bindings) >= 0, s_bindings, s_let); - while (!SCM_NULLP (bindings)) - { /* vars and inits both in order */ - SCM binding = SCM_CAR (bindings); - SCM_ASSYNT (scm_ilength (binding) == 2, s_bindings, s_let); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), s_variable, s_let); - *varloc = scm_list_1 (SCM_CAR (binding)); - varloc = SCM_CDRLOC (*varloc); - *initloc = scm_list_1 (SCM_CADR (binding)); - initloc = SCM_CDRLOC (*initloc); - bindings = SCM_CDR (bindings); - } + /* plain let */ + SCM rvariables; + SCM inits; + transform_bindings (bindings, expr, &rvariables, &inits); { - SCM lambda_body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let"); - SCM lambda_form = scm_cons2 (scm_sym_lambda, vars, lambda_body); - SCM rvar = scm_list_1 (name); - SCM init = scm_list_1 (lambda_form); - SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name), "let"); - SCM letrec = scm_cons2 (SCM_IM_LETREC, rvar, scm_cons (init, body)); - return scm_cons (letrec, inits); + const SCM new_body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr), "let"); + const SCM new_tail = scm_cons2 (rvariables, inits, new_body); + SCM_SETCAR (expr, SCM_IM_LET); + SCM_SETCDR (expr, new_tail); + return expr; } } } @@ -1256,32 +1292,33 @@ scm_m_let (SCM xorig, SCM env) SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar); SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar); -/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers - * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */ +/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers + * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */ SCM -scm_m_letstar (SCM xorig, SCM env SCM_UNUSED) +scm_m_letstar (SCM expr, SCM env SCM_UNUSED) { - SCM bindings; - SCM x = SCM_CDR (xorig); - SCM vars = SCM_EOL; - SCM *varloc = &vars; + SCM binding_idx; + SCM new_bindings = SCM_EOL; + SCM new_body; - SCM_ASSYNT (SCM_CONSP (x), s_bindings, s_letstar); + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); - bindings = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (bindings) >= 0, s_bindings, s_letstar); - while (!SCM_NULLP (bindings)) + binding_idx = SCM_CAR (cdr_expr); + check_bindings (binding_idx, expr); + + for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx)) { - SCM binding = SCM_CAR (bindings); - SCM_ASSYNT (scm_ilength (binding) == 2, s_bindings, s_letstar); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), s_variable, s_letstar); - *varloc = scm_list_2 (SCM_CAR (binding), SCM_CADR (binding)); - varloc = SCM_CDRLOC (SCM_CDR (*varloc)); - bindings = SCM_CDR (bindings); + const SCM binding = SCM_CAR (binding_idx); + const SCM name = SCM_CAR (binding); + const SCM init = SCM_CADR (binding); + new_bindings = scm_cons2 (init, name, new_bindings); } + new_bindings = scm_reverse_x (new_bindings, SCM_UNDEFINED); - return scm_cons2 (SCM_IM_LETSTAR, vars, - scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar)); + new_body = scm_m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr), s_letstar); + return scm_cons2 (SCM_IM_LETSTAR, new_bindings, new_body); } @@ -1289,23 +1326,31 @@ SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec); SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec); SCM -scm_m_letrec (SCM xorig, SCM env) +scm_m_letrec (SCM expr, SCM env) { - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (SCM_CONSP (x), s_bindings, s_letrec); - - if (SCM_NULLP (SCM_CAR (x))) + SCM bindings; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); + + bindings = SCM_CAR (cdr_expr); + if (SCM_NULLP (bindings)) { - /* null binding, let* faster */ - SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), s_letrec); - return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, body), env); + /* no bindings, let* is executed faster */ + SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr), s_letrec); + return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env); } else { - SCM rvars, inits, body; - transform_bindings (SCM_CAR (x), &rvars, &inits, "letrec"); - body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), "letrec"); - return scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); + SCM rvariables; + SCM inits; + SCM new_body; + + check_bindings (bindings, expr); + transform_bindings (bindings, expr, &rvariables, &inits); + new_body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr), "letrec"); + return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body)); } } @@ -1721,7 +1766,8 @@ scm_m_expand_body (SCM xorig, SCM env) if (!SCM_NULLP (defs)) { SCM rvars, inits, body, letrec; - transform_bindings (defs, &rvars, &inits, what); + check_bindings (defs, xorig); + transform_bindings (defs, xorig, &rvars, &inits); body = scm_m_body (SCM_IM_DEFINE, x, what); letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); SCM_SETCAR (xorig, letrec); diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index f4deb831d..1c51bb6eb 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,15 @@ +2003-10-18 Dirk Herrmann + + * lib.scm (exception:bad-variable): New. + + * tests/syntax.test (exception:bad-binding, + exception:duplicate-binding): New. + + (exception:duplicate-bindings): Removed. + + Adapted tests for 'let', 'let*' and 'letrec' to the new way of + error reporting. + 2003-10-12 Dirk Herrmann * tests/syntax.test (define exception:bad-formal, define diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 7248b3e96..46da7e1cc 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -22,6 +22,7 @@ :export ( ;; Exceptions which are commonly being tested for. + exception:bad-variable exception:missing-expression exception:out-of-range exception:unbound-var exception:wrong-num-args exception:wrong-type-arg @@ -233,6 +234,8 @@ ;;;; ;;; Define some exceptions which are commonly being tested for. +(define exception:bad-variable + (cons 'syntax-error "Bad variable")) (define exception:missing-expression (cons 'misc-error "^missing or extra expression")) (define exception:out-of-range diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 9bde520a7..e8be3382e 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -34,9 +34,11 @@ (cons 'syntax-error "Extra expression")) (define exception:bad-bindings - (cons 'misc-error "^bad bindings")) -(define exception:duplicate-bindings - (cons 'misc-error "^duplicate bindings")) + (cons 'syntax-error "Bad bindings")) +(define exception:bad-binding + (cons 'syntax-error "Bad binding")) +(define exception:duplicate-binding + (cons 'syntax-error "Duplicate binding")) (define exception:bad-body (cons 'misc-error "^bad body")) (define exception:bad-formals @@ -195,63 +197,61 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let)" - exception:bad-bindings + exception:missing-expr (eval '(let) (interaction-environment))) (pass-if-exception "(let 1)" - exception:bad-bindings + exception:missing-expr (eval '(let 1) (interaction-environment))) (pass-if-exception "(let (x))" - exception:bad-bindings + exception:missing-expr (eval '(let (x)) (interaction-environment))) - ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? - ;; (Even although the body is bad as well...) (pass-if-exception "(let ((x)))" - exception:bad-body + exception:missing-expr (eval '(let ((x))) (interaction-environment))) (pass-if-exception "(let (x) 1)" - exception:bad-bindings + exception:bad-binding (eval '(let (x) 1) (interaction-environment))) (pass-if-exception "(let ((x)) 3)" - exception:bad-bindings + exception:bad-binding (eval '(let ((x)) 3) (interaction-environment))) (pass-if-exception "(let ((x 1) y) x)" - exception:bad-bindings + exception:bad-binding (eval '(let ((x 1) y) x) (interaction-environment))) (pass-if-exception "(let ((1 2)) 3)" - exception:bad-var + exception:bad-variable (eval '(let ((1 2)) 3) (interaction-environment)))) (with-test-prefix "duplicate bindings" (pass-if-exception "(let ((x 1) (x 2)) x)" - exception:duplicate-bindings + exception:duplicate-binding (eval '(let ((x 1) (x 2)) x) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let ())" - exception:bad-body + exception:missing-expr (eval '(let ()) (interaction-environment))) (pass-if-exception "(let ((x 1)))" - exception:bad-body + exception:missing-expr (eval '(let ((x 1))) (interaction-environment))))) @@ -266,19 +266,19 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let x (y))" - exception:bad-bindings + exception:missing-expr (eval '(let x (y)) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let x ())" - exception:bad-body + exception:missing-expr (eval '(let x ()) (interaction-environment))) (pass-if-exception "(let x ((y 1)))" - exception:bad-body + exception:missing-expr (eval '(let x ((y 1))) (interaction-environment))))) @@ -297,32 +297,32 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let*)" - exception:bad-bindings + exception:missing-expr (eval '(let*) (interaction-environment))) (pass-if-exception "(let* 1)" - exception:bad-bindings + exception:missing-expr (eval '(let* 1) (interaction-environment))) (pass-if-exception "(let* (x))" - exception:bad-bindings + exception:missing-expr (eval '(let* (x)) (interaction-environment))) (pass-if-exception "(let* (x) 1)" - exception:bad-bindings + exception:bad-binding (eval '(let* (x) 1) (interaction-environment))) (pass-if-exception "(let* ((x)) 3)" - exception:bad-bindings + exception:bad-binding (eval '(let* ((x)) 3) (interaction-environment))) (pass-if-exception "(let* ((x 1) y) x)" - exception:bad-bindings + exception:bad-binding (eval '(let* ((x 1) y) x) (interaction-environment))) @@ -337,19 +337,19 @@ (interaction-environment))) (pass-if-exception "(let* ((1 2)) 3)" - exception:bad-var + exception:bad-variable (eval '(let* ((1 2)) 3) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let* ())" - exception:bad-body + exception:missing-expr (eval '(let* ()) (interaction-environment))) (pass-if-exception "(let* ((x 1)))" - exception:bad-body + exception:missing-expr (eval '(let* ((x 1))) (interaction-environment))))) @@ -365,32 +365,32 @@ (with-test-prefix "bad bindings" (pass-if-exception "(letrec)" - exception:bad-bindings + exception:missing-expr (eval '(letrec) (interaction-environment))) (pass-if-exception "(letrec 1)" - exception:bad-bindings + exception:missing-expr (eval '(letrec 1) (interaction-environment))) (pass-if-exception "(letrec (x))" - exception:bad-bindings + exception:missing-expr (eval '(letrec (x)) (interaction-environment))) (pass-if-exception "(letrec (x) 1)" - exception:bad-bindings + exception:bad-binding (eval '(letrec (x) 1) (interaction-environment))) (pass-if-exception "(letrec ((x)) 3)" - exception:bad-bindings + exception:bad-binding (eval '(letrec ((x)) 3) (interaction-environment))) (pass-if-exception "(letrec ((x 1) y) x)" - exception:bad-bindings + exception:bad-binding (eval '(letrec ((x 1) y) x) (interaction-environment))) @@ -405,26 +405,26 @@ (interaction-environment))) (pass-if-exception "(letrec ((1 2)) 3)" - exception:bad-var + exception:bad-variable (eval '(letrec ((1 2)) 3) (interaction-environment)))) (with-test-prefix "duplicate bindings" (pass-if-exception "(letrec ((x 1) (x 2)) x)" - exception:duplicate-bindings + exception:duplicate-binding (eval '(letrec ((x 1) (x 2)) x) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(letrec ())" - exception:bad-body + exception:missing-expr (eval '(letrec ()) (interaction-environment))) (pass-if-exception "(letrec ((x 1)))" - exception:bad-body + exception:missing-expr (eval '(letrec ((x 1))) (interaction-environment))))) From 216286857be77676b068f36ed96ea686de03a89e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 18 Oct 2003 14:49:55 +0000 Subject: [PATCH 061/239] * libguile/eval.c: Sorted include files alphabetically. (scm_m_begin): Added comment. (scm_m_or): Use ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing when creating the memoized code. (iqq, scm_m_quasiquote, scm_m_quote): Use ASSERT_SYNTAX to signal syntax errors. Be more specific about the kind of error that was detected. (scm_m_quote, unmemocopy): As an optimization, vector constants are now inserted unquoted into the memoized code. During unmemoization the quotes are added again to provide syntactically correct code. * test-suite/tests/syntax.test (exception:missing/extra-expr, exception:missing/extra-expr-misc): Renamed exception:missing/extra-expr to exception:missing/extra-expr-misc. (exception:missing/extra-expr-syntax, exception:missing/extra-expr): Renamed exception:missing/extra-expr-syntax to exception:missing/extra-expr. --- libguile/ChangeLog | 18 +++++ libguile/eval.c | 123 ++++++++++++++++++++++------------- test-suite/ChangeLog | 11 ++++ test-suite/tests/syntax.test | 16 ++--- 4 files changed, 116 insertions(+), 52 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 84475aeed..d557757d7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,21 @@ +2003-10-18 Dirk Herrmann + + * eval.c: Sorted include files alphabetically. + + (scm_m_begin): Added comment. + + (scm_m_or): Use ASSERT_SYNTAX to signal syntax errors. Avoid + unnecessary consing when creating the memoized code. + + (iqq, scm_m_quasiquote, scm_m_quote): Use ASSERT_SYNTAX to signal + syntax errors. Be more specific about the kind of error that was + detected. + + (scm_m_quote, unmemocopy): As an optimization, vector constants + are now inserted unquoted into the memoized code. During + unmemoization the quotes are added again to provide syntactically + correct code. + 2003-10-18 Dirk Herrmann * eval.c (scm_m_let, scm_m_letstar, scm_m_letrec, diff --git a/libguile/eval.c b/libguile/eval.c index 91cd36d81..ac5d006b6 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -54,36 +54,36 @@ char *alloca (); #endif #include "libguile/_scm.h" +#include "libguile/alist.h" +#include "libguile/async.h" +#include "libguile/continuations.h" #include "libguile/debug.h" #include "libguile/dynwind.h" -#include "libguile/alist.h" #include "libguile/eq.h" -#include "libguile/continuations.h" +#include "libguile/feature.h" +#include "libguile/fluids.h" #include "libguile/futures.h" -#include "libguile/strings.h" -#include "libguile/throw.h" -#include "libguile/smob.h" +#include "libguile/goops.h" +#include "libguile/hash.h" +#include "libguile/hashtab.h" +#include "libguile/lang.h" #include "libguile/list.h" #include "libguile/macros.h" +#include "libguile/modules.h" +#include "libguile/objects.h" +#include "libguile/ports.h" #include "libguile/procprop.h" -#include "libguile/hashtab.h" -#include "libguile/hash.h" +#include "libguile/root.h" +#include "libguile/smob.h" #include "libguile/srcprop.h" #include "libguile/stackchk.h" -#include "libguile/objects.h" -#include "libguile/async.h" -#include "libguile/feature.h" -#include "libguile/modules.h" -#include "libguile/ports.h" -#include "libguile/root.h" -#include "libguile/vectors.h" -#include "libguile/fluids.h" -#include "libguile/goops.h" -#include "libguile/values.h" - +#include "libguile/strings.h" +#include "libguile/throw.h" #include "libguile/validate.h" +#include "libguile/values.h" +#include "libguile/vectors.h" + #include "libguile/eval.h" -#include "libguile/lang.h" @@ -755,7 +755,9 @@ SCM scm_m_begin (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); - + /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS. + * That means, there should be a distinction between uses of begin where an + * empty clause is OK and where it is not. */ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); SCM_SETCAR (expr, SCM_IM_BEGIN); @@ -1359,14 +1361,23 @@ SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or); SCM_GLOBAL_SYMBOL (scm_sym_or, s_or); SCM -scm_m_or (SCM xorig, SCM env SCM_UNUSED) +scm_m_or (SCM expr, SCM env SCM_UNUSED) { - long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 0, s_test, s_or); - if (len >= 1) - return scm_cons (SCM_IM_OR, SCM_CDR (xorig)); + const SCM cdr_expr = SCM_CDR (expr); + const long length = scm_ilength (cdr_expr); + + ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); + + if (length == 0) + { + /* Special case: (or) is replaced by #f. */ + return SCM_BOOL_F; + } else - return SCM_BOOL_F; + { + SCM_SETCAR (expr, SCM_IM_OR); + return expr; + } } @@ -1382,17 +1393,17 @@ iqq (SCM form, SCM env, unsigned long int depth) { if (SCM_CONSP (form)) { - SCM tmp = SCM_CAR (form); + const SCM tmp = SCM_CAR (form); if (SCM_EQ_P (tmp, scm_sym_quasiquote)) { - SCM args = SCM_CDR (form); - SCM_ASSYNT (scm_ilength (args) == 1, s_expression, s_quasiquote); + const SCM args = SCM_CDR (form); + ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form); return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1)); } else if (SCM_EQ_P (tmp, scm_sym_unquote)) { - SCM args = SCM_CDR (form); - SCM_ASSYNT (scm_ilength (args) == 1, s_expression, s_quasiquote); + const SCM args = SCM_CDR (form); + ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form); if (depth - 1 == 0) return scm_eval_car (args, env); else @@ -1401,13 +1412,14 @@ iqq (SCM form, SCM env, unsigned long int depth) else if (SCM_CONSP (tmp) && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing)) { - SCM args = SCM_CDR (tmp); - SCM_ASSYNT (scm_ilength (args) == 1, s_expression, s_quasiquote); + const SCM args = SCM_CDR (tmp); + ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form); if (depth - 1 == 0) { - SCM list = scm_eval_car (args, env); - SCM rest = SCM_CDR (form); - SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote); + const SCM list = scm_eval_car (args, env); + const SCM rest = SCM_CDR (form); + ASSERT_SYNTAX_2 (scm_ilength (list) >= 0, + s_splicing, list, form); return scm_append (scm_list_2 (list, iqq (rest, env, depth))); } else @@ -1433,11 +1445,12 @@ iqq (SCM form, SCM env, unsigned long int depth) } SCM -scm_m_quasiquote (SCM xorig, SCM env) +scm_m_quasiquote (SCM expr, SCM env) { - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 1, s_expression, s_quasiquote); - return iqq (SCM_CAR (x), env, 1); + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); + return iqq (SCM_CAR (cdr_expr), env, 1); } @@ -1445,10 +1458,26 @@ SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote); SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote); SCM -scm_m_quote (SCM xorig, SCM env SCM_UNUSED) +scm_m_quote (SCM expr, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, s_expression, s_quote); - return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig)); + SCM quotee; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); + quotee = SCM_CAR (cdr_expr); + if (SCM_IMP (quotee) && !SCM_NULLP (quotee)) + return quotee; + else if (SCM_VECTORP (quotee)) + return quotee; +#if 0 + /* The following optimization would be possible if all variable references + * were resolved during memoization: */ + else if (SCM_SYMBOLP (quotee)) + return quotee; +#endif + SCM_SETCAR (expr, SCM_IM_QUOTE); + return expr; } @@ -1868,8 +1897,14 @@ unmemocopy (SCM x, SCM env) { SCM ls, z; SCM p; - if (!SCM_CONSP (x)) + + if (SCM_VECTORP (x)) + { + return scm_list_2 (scm_sym_quote, x); + } + else if (!SCM_CONSP (x)) return x; + p = scm_whash_lookup (scm_source_whash, x); switch (SCM_ITAG7 (SCM_CAR (x))) { diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 1c51bb6eb..77cb1e1a1 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,14 @@ +2003-10-18 Dirk Herrmann + + * tests/syntax.test (exception:missing/extra-expr, + exception:missing/extra-expr-misc): Renamed + exception:missing/extra-expr to exception:missing/extra-expr-misc. + + (exception:missing/extra-expr-syntax, + exception:missing/extra-expr): Renamed + exception:missing/extra-expr-syntax to + exception:missing/extra-expr. + 2003-10-18 Dirk Herrmann * lib.scm (exception:bad-variable): New. diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index e8be3382e..38e85c9fb 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -24,9 +24,9 @@ (define exception:bad-expression (cons 'syntax-error "Bad expression")) -(define exception:missing/extra-expr +(define exception:missing/extra-expr-misc (cons 'misc-error "^missing or extra expression")) -(define exception:missing/extra-expr-syntax +(define exception:missing/extra-expr (cons 'syntax-error "missing or extra expression")) (define exception:missing-expr (cons 'syntax-error "Missing expression")) @@ -89,7 +89,7 @@ ;; Fixed on 2001-3-3 (pass-if-exception "empty parentheses \"()\"" - exception:missing/extra-expr + exception:missing/extra-expr-misc (eval '() (interaction-environment))))) @@ -433,12 +433,12 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(if)" - exception:missing/extra-expr-syntax + exception:missing/extra-expr (eval '(if) (interaction-environment))) (pass-if-exception "(if 1 2 3 4)" - exception:missing/extra-expr-syntax + exception:missing/extra-expr (eval '(if 1 2 3 4) (interaction-environment))))) @@ -611,17 +611,17 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(set!)" - exception:missing/extra-expr + exception:missing/extra-expr-misc (eval '(set!) (interaction-environment))) (pass-if-exception "(set! 1)" - exception:missing/extra-expr + exception:missing/extra-expr-misc (eval '(set! 1) (interaction-environment))) (pass-if-exception "(set! 1 2 3)" - exception:missing/extra-expr + exception:missing/extra-expr-misc (eval '(set! 1 2 3) (interaction-environment)))) From 82b3e2c612f1d3ec45ce596d064512848e6b23e3 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 18 Oct 2003 17:24:09 +0000 Subject: [PATCH 062/239] * libguile/eval.c (scm_m_set_x, scm_m_apply, scm_m_atbind): Use ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing when creating the memoized code. (scm_m_atbind): Reversed the order, in which the init expressions are stored and executed. The order of execution is now equal to the order in which the initializers of the let-forms are executed. Use check_bindings and transform_bindings. (SCM_CEVAL): Eliminated SCM_NIMP in favor of more appropriate !SCM_NULLP. Added some comments. * test-suite/tests/dynamic-scope.test (exception:missing-expr): Introduced temporarily until all memoizers use the new way of error reporting. --- libguile/ChangeLog | 14 +++ libguile/eval.c | 128 ++++++++++++++++------------ test-suite/ChangeLog | 6 ++ test-suite/tests/dynamic-scope.test | 10 ++- 4 files changed, 98 insertions(+), 60 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d557757d7..07d41ee2e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,17 @@ +2003-10-18 Dirk Herrmann + + * eval.c (scm_m_set_x, scm_m_apply, scm_m_atbind): Use + ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing + when creating the memoized code. + + (scm_m_atbind): Reversed the order, in which the init expressions + are stored and executed. The order of execution is now equal to + the order in which the initializers of the let-forms are executed. + Use check_bindings and transform_bindings. + + (SCM_CEVAL): Eliminated SCM_NIMP in favor of more appropriate + !SCM_NULLP. Added some comments. + 2003-10-18 Dirk Herrmann * eval.c: Sorted include files alphabetically. diff --git a/libguile/eval.c b/libguile/eval.c index ac5d006b6..b700e9e8b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1487,12 +1487,18 @@ static const char s_set_x[] = "set!"; SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x); SCM -scm_m_set_x (SCM xorig, SCM env SCM_UNUSED) +scm_m_set_x (SCM expr, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 2, s_expression, s_set_x); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), s_variable, s_set_x); - return scm_cons (SCM_IM_SET_X, x); + SCM variable; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); + variable = SCM_CAR (cdr_expr); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + + SCM_SETCAR (expr, SCM_IM_SET_X); + return expr; } @@ -1504,64 +1510,69 @@ SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply); SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); SCM -scm_m_apply (SCM xorig, SCM env SCM_UNUSED) +scm_m_apply (SCM expr, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, s_expression, s_atapply); - return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig)); + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr); + + SCM_SETCAR (expr, SCM_IM_APPLY); + return expr; } -/* (@bind ((var exp) ...) body ...) - - This will assign the values of the `exp's to the global variables - named by `var's (symbols, not evaluated), creating them if they - don't exist, executes body, and then restores the previous values of - the `var's. Additionally, whenever control leaves body, the values - of the `var's are saved and restored when control returns. It is an - error when a symbol appears more than once among the `var's. - All `exp's are evaluated before any `var' is set. - - Think of this as `let' for dynamic scope. - - It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...). - - XXX - also implement `@bind*'. -*/ - SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind); +/* FIXME: The following explanation should go into the documentation: */ +/* (@bind ((var init) ...) body ...) will assign the values of the `init's to + * the global variables named by `var's (symbols, not evaluated), creating + * them if they don't exist, executes body, and then restores the previous + * values of the `var's. Additionally, whenever control leaves body, the + * values of the `var's are saved and restored when control returns. It is an + * error when a symbol appears more than once among the `var's. All `init's + * are evaluated before any `var' is set. + * + * Think of this as `let' for dynamic scope. + */ + +/* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into + * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...). + * + * FIXME - also implement `@bind*'. + */ SCM -scm_m_atbind (SCM xorig, SCM env) +scm_m_atbind (SCM expr, SCM env) { - SCM x = SCM_CDR (xorig); - SCM top_level = scm_env_top_level (env); - SCM vars = SCM_EOL, var; - SCM exps = SCM_EOL; + SCM bindings; + SCM rvariables; + SCM inits; + SCM variable_idx; - SCM_ASSYNT (scm_ilength (x) > 1, s_expression, s_atbind); + const SCM top_level = scm_env_top_level (env); - x = SCM_CAR (x); - while (SCM_NIMP (x)) + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); + bindings = SCM_CAR (cdr_expr); + check_bindings (bindings, expr); + transform_bindings (bindings, expr, &rvariables, &inits); + + for (variable_idx = rvariables; + !SCM_NULLP (variable_idx); + variable_idx = SCM_CDR (variable_idx)) { - SCM rest; - SCM sym_exp = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (sym_exp) == 2, s_bindings, s_atbind); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), s_bindings, s_atbind); - x = SCM_CDR (x); - for (rest = x; SCM_NIMP (rest); rest = SCM_CDR (rest)) - if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAAR (rest))) - scm_misc_error (s_atbind, s_duplicate_bindings, SCM_EOL); - /* The first call to scm_sym2var will look beyond the current - module, while the second call wont. */ - var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_F); - if (SCM_FALSEP (var)) - var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T); - vars = scm_cons (var, vars); - exps = scm_cons (SCM_CADR (sym_exp), exps); + /* The first call to scm_sym2var will look beyond the current module, + * while the second call wont. */ + const SCM variable = SCM_CAR (variable_idx); + SCM new_variable = scm_sym2var (variable, top_level, SCM_BOOL_F); + if (SCM_FALSEP (new_variable)) + new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T); + SCM_SETCAR (variable_idx, new_variable); } - return scm_cons (SCM_IM_BIND, - scm_cons (scm_cons (scm_reverse_x (vars, SCM_EOL), exps), - SCM_CDDR (xorig))); + + SCM_SETCAR (expr, SCM_IM_BIND); + SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits)); + return expr; } @@ -3169,10 +3180,8 @@ dispatch: x = SCM_CDR (x); vars = SCM_CAAR (x); exps = SCM_CDAR (x); - vals = SCM_EOL; - - while (SCM_NIMP (exps)) + while (!SCM_NULLP (exps)) { vals = scm_cons (EVALCAR (exps, env), vals); exps = SCM_CDR (exps); @@ -3206,9 +3215,15 @@ dispatch: proc = EVALCAR (x, env); /* proc is the consumer. */ arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL); if (SCM_VALUESP (arg1)) - arg1 = scm_struct_ref (arg1, SCM_INUM0); + { + /* The list of arguments is not copied. Rather, it is assumed + * that this has been done by the 'values' procedure. */ + arg1 = scm_struct_ref (arg1, SCM_INUM0); + } else - arg1 = scm_list_1 (arg1); + { + arg1 = scm_list_1 (arg1); + } PREP_APPLY (proc, arg1); goto apply_proc; } @@ -3221,6 +3236,7 @@ dispatch: default: proc = x; goto evapply; + case scm_tc7_vector: case scm_tc7_wvect: #if SCM_HAVE_ARRAYS diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 77cb1e1a1..e2b2843f1 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2003-10-18 Dirk Herrmann + + * tests/dynamic-scope.test (exception:missing-expr): Introduced + temporarily until all memoizers use the new way of error + reporting. + 2003-10-18 Dirk Herrmann * tests/syntax.test (exception:missing/extra-expr, diff --git a/test-suite/tests/dynamic-scope.test b/test-suite/tests/dynamic-scope.test index 89f43ae6f..a8c56a9f0 100644 --- a/test-suite/tests/dynamic-scope.test +++ b/test-suite/tests/dynamic-scope.test @@ -22,10 +22,12 @@ :use-module (test-suite lib)) -(define exception:duplicate-binding - (cons 'misc-error "^duplicate bindings")) +(define exception:missing-expr + (cons 'syntax-error "Missing expression")) (define exception:bad-binding - (cons 'misc-error "^bad bindings")) + (cons 'syntax-error "Bad binding")) +(define exception:duplicate-binding + (cons 'syntax-error "Duplicate binding")) (define global-a 0) (define (fetch-global-a) global-a) @@ -47,7 +49,7 @@ (interaction-environment))) (pass-if-exception "@bind missing expression" - exception:missing-expression + exception:missing-expr (eval '(@bind ((global-a 1))) (interaction-environment))) From da48db629c4f554518af65bf7b47a316e8c9f85f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 18 Oct 2003 18:26:43 +0000 Subject: [PATCH 063/239] * libguile/eval.c (scm_m_cont, scm_m_at_call_with_values, scm_m_generalized_set_x): Use ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing when creating the memoized code. (scm_m_generalized_set_x): Let scm_m_set_x handle the R5RS standard case. Make sure line and file information are copied to every created expression. * test-suite/tests/syntax.test (exception:bad-var): Removed. Adapted tests for 'set!' to the new way of error reporting. --- libguile/ChangeLog | 17 +++++++++-- libguile/eval.c | 58 +++++++++++++++++++++++++----------- test-suite/ChangeLog | 6 ++++ test-suite/tests/syntax.test | 19 +++++------- 4 files changed, 68 insertions(+), 32 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 07d41ee2e..0e1723db4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2003-10-18 Dirk Herrmann + + * eval.c (scm_m_cont, scm_m_at_call_with_values, + scm_m_generalized_set_x): Use ASSERT_SYNTAX to signal syntax + errors. Avoid unnecessary consing when creating the memoized + code. + + (scm_m_generalized_set_x): Let scm_m_set_x handle the R5RS + standard case. Make sure line and file information are copied to + every created expression. + 2003-10-18 Dirk Herrmann * eval.c (scm_m_set_x, scm_m_apply, scm_m_atbind): Use @@ -55,7 +66,7 @@ specific about the kind of error that was detected. Prepare for easier integration of changes for separated memoization. -2003-10-11 Dirk Herrmann +2003-10-12 Dirk Herrmann * eval.c (s_duplicate_binding): New static identifier. @@ -77,7 +88,7 @@ (SCM_CEVAL): Simplified handling of SCM_IM_IF forms. -2003-10-11 Dirk Herrmann +2003-10-12 Dirk Herrmann * eval.c (s_bad_bindings, s_bad_binding, s_bad_exit_clause): New static identifiers. @@ -88,7 +99,7 @@ code, this way also making sure that file name, line number information etc. remain available. -2003-10-11 Dirk Herrmann +2003-10-12 Dirk Herrmann * eval.c (memoize_as_thunk_prototype): New static function. diff --git a/libguile/eval.c b/libguile/eval.c index b700e9e8b..1cfd88efe 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1579,13 +1579,15 @@ scm_m_atbind (SCM expr, SCM env) SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont); SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc); - SCM -scm_m_cont (SCM xorig, SCM env SCM_UNUSED) +scm_m_cont (SCM expr, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, - s_expression, s_atcall_cc); - return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); + + SCM_SETCAR (expr, SCM_IM_CONT); + return expr; } @@ -1593,11 +1595,14 @@ SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_ SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values); SCM -scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED) +scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, - s_expression, s_at_call_with_values); - return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig)); + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); + + SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES); + return expr; } @@ -1622,17 +1627,34 @@ SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x); SCM_SYMBOL (scm_sym_setter, "setter"); SCM -scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED) +scm_m_generalized_set_x (SCM expr, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (2 == scm_ilength (x), s_expression, s_set_x); - if (SCM_SYMBOLP (SCM_CAR (x))) - return scm_cons (SCM_IM_SET_X, x); - else if (SCM_CONSP (SCM_CAR (x))) - return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)), - scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x)))); + SCM target; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); + + target = SCM_CAR (cdr_expr); + if (!SCM_CONSP (target)) + { + /* R5RS usage */ + return scm_m_set_x (expr, env); + } else - scm_misc_error (s_set_x, s_variable, SCM_EOL); + { + /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */ + + const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target)); + const SCM setter_proc = scm_cons_source (expr, scm_sym_setter, setter_proc_tail); + + const SCM cddr_expr = SCM_CDR (cdr_expr); + const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target), cddr_expr)); + + SCM_SETCAR (expr, setter_proc); + SCM_SETCDR (expr, setter_args); + return expr; + } } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e2b2843f1..a42891980 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2003-10-18 Dirk Herrmann + + * tests/syntax.test (exception:bad-var): Removed. + + Adapted tests for 'set!' to the new way of error reporting. + 2003-10-18 Dirk Herrmann * tests/dynamic-scope.test (exception:missing-expr): Introduced diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 38e85c9fb..82ff4d980 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -59,9 +59,6 @@ (define exception:bad-cond-clause (cons 'syntax-error "Bad cond clause")) -(define exception:bad-var - (cons 'misc-error "^bad variable")) - (with-test-prefix "expressions" @@ -611,44 +608,44 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(set!)" - exception:missing/extra-expr-misc + exception:missing/extra-expr (eval '(set!) (interaction-environment))) (pass-if-exception "(set! 1)" - exception:missing/extra-expr-misc + exception:missing/extra-expr (eval '(set! 1) (interaction-environment))) (pass-if-exception "(set! 1 2 3)" - exception:missing/extra-expr-misc + exception:missing/extra-expr (eval '(set! 1 2 3) (interaction-environment)))) (with-test-prefix "bad variable" (pass-if-exception "(set! \"\" #t)" - exception:bad-var + exception:bad-variable (eval '(set! "" #t) (interaction-environment))) (pass-if-exception "(set! 1 #t)" - exception:bad-var + exception:bad-variable (eval '(set! 1 #t) (interaction-environment))) (pass-if-exception "(set! #t #f)" - exception:bad-var + exception:bad-variable (eval '(set! #t #f) (interaction-environment))) (pass-if-exception "(set! #f #t)" - exception:bad-var + exception:bad-variable (eval '(set! #f #t) (interaction-environment))) (pass-if-exception "(set! #\space #f)" - exception:bad-var + exception:bad-variable (eval '(set! #\space #f) (interaction-environment))))) From 9a848baf552eaaaca7e6055b90dbd7d70cf5fb6c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 18 Oct 2003 19:03:24 +0000 Subject: [PATCH 064/239] * eval.c (s_bad_slot_number): New static identifier. (scm_m_atslot_ref, scm_m_atslot_set_x): Use ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing when creating the memoized code. --- libguile/ChangeLog | 8 ++++++++ libguile/eval.c | 44 ++++++++++++++++++++++++++------------------ 2 files changed, 34 insertions(+), 18 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 0e1723db4..c11c8fa3d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2003-10-18 Dirk Herrmann + + * eval.c (s_bad_slot_number): New static identifier. + + (scm_m_atslot_ref, scm_m_atslot_set_x): Use ASSERT_SYNTAX to + signal syntax errors. Avoid unnecessary consing when creating the + memoized code. + 2003-10-18 Dirk Herrmann * eval.c (scm_m_cont, scm_m_at_call_with_values, diff --git a/libguile/eval.c b/libguile/eval.c index 1cfd88efe..99ecf1017 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -187,6 +187,10 @@ static const char s_bad_formal[] = "Bad formal"; * more than once, a 'Duplicate formal' error is signalled. */ static const char s_duplicate_formal[] = "Duplicate formal"; +/* If something else than an exact integer is detected as the argument for + * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */ +static const char s_bad_slot_number[] = "Bad slot number"; + /* Signal a syntax error. We distinguish between the form that caused the * error and the enclosing expression. The error message will print out as @@ -1658,40 +1662,44 @@ scm_m_generalized_set_x (SCM expr, SCM env SCM_UNUSED) } -static const char* s_atslot_ref = "@slot-ref"; - /* @slot-ref is bound privately in the (oop goops) module from goops.c. As * soon as the module system allows us to more freely create bindings in * arbitrary modules during the startup phase, the code from goops.c should be * moved here. */ SCM -scm_m_atslot_ref (SCM xorig, SCM env SCM_UNUSED) -#define FUNC_NAME s_atslot_ref +scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 2, s_expression, FUNC_NAME); - SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x)); - return scm_cons (SCM_IM_SLOT_REF, x); + SCM slot_nr; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); + slot_nr = SCM_CADR (cdr_expr); + ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr); + + SCM_SETCAR (expr, SCM_IM_SLOT_REF); + return expr; } -#undef FUNC_NAME -static const char* s_atslot_set_x = "@slot-set!"; - /* @slot-set! is bound privately in the (oop goops) module from goops.c. As * soon as the module system allows us to more freely create bindings in * arbitrary modules during the startup phase, the code from goops.c should be * moved here. */ SCM -scm_m_atslot_set_x (SCM xorig, SCM env SCM_UNUSED) -#define FUNC_NAME s_atslot_set_x +scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 3, s_expression, FUNC_NAME); - SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x)); - return scm_cons (SCM_IM_SLOT_SET_X, x); + SCM slot_nr; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_expression, expr); + slot_nr = SCM_CADR (cdr_expr); + ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr); + + SCM_SETCAR (expr, SCM_IM_SLOT_SET_X); + return expr; } -#undef FUNC_NAME #if SCM_ENABLE_ELISP From 32f19569bc405eebfa01f7570a42eb7f41384f74 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 19 Oct 2003 00:27:00 +0000 Subject: [PATCH 065/239] (scm_ash): Revise docstring as per recent update to manual. --- libguile/numbers.c | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index b0b5d36f3..c21022577 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1367,20 +1367,24 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, SCM_DEFINE (scm_ash, "ash", 2, 0, 0, (SCM n, SCM cnt), - "The function ash performs an arithmetic shift left by @var{cnt}\n" - "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n" - "means, that the function does not guarantee to keep the bit\n" - "structure of @var{n}, but rather guarantees that the result\n" - "will always be rounded towards minus infinity. Therefore, the\n" - "results of ash and a corresponding bitwise shift will differ if\n" - "@var{n} is negative.\n" + "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n" + "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n" "\n" - "Formally, the function returns an integer equivalent to\n" - "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n" + "This is effectively a multiplication by 2^@var{cnt}}, and when\n" + "@var{cnt} is negative it's a division, rounded towards negative\n" + "infinity. (Note that this is not the same rounding as\n" + "@code{quotient} does.)\n" + "\n" + "With @var{n} viewed as an infinite precision twos complement,\n" + "@code{ash} means a left shift introducing zero bits, or a right\n" + "shift dropping bits.\n" "\n" "@lisp\n" "(number->string (ash #b1 3) 2) @result{} \"1000\"\n" "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n" + "\n" + ";; -23 is bits ...11101001, -6 is bits ...111010\n" + "(ash -23 -2) @result{} -6\n" "@end lisp") #define FUNC_NAME s_scm_ash { From 089c9a59093db3f4db3da2e86ddb1fd4dd4e14a1 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 19 Oct 2003 00:32:25 +0000 Subject: [PATCH 066/239] (scm_i_big2dbl): Rewrite, carefully rounding to "closest" in accordance with R5RS, which just mpz_get_d doesn't really give. --- libguile/numbers.c | 64 ++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 62 insertions(+), 2 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index c21022577..d36194f9e 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -167,10 +167,70 @@ scm_i_dbl2big (double d) return z; } -SCM_C_INLINE_KEYWORD double +/* scm_i_big2dbl() rounds to the closest representable double, in accordance + with R5RS exact->inexact. + + The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits + (ie. it truncates towards zero), then adjust to get the closest double by + examining the next lower bit and adding 1 if necessary. + + Note that bignums exactly half way between representable doubles are + rounded to the next higher absolute value (ie. away from zero). This + seems like an adequate interpretation of R5RS "numerically closest", and + it's easier and faster than a full "nearest-even" style. + + The bit test is done on the absolute value of the mpz_t, which means we + must use mpz_getlimbn. mpz_tstbit is not right, it treats negatives as + twos complement. + + Prior to GMP 4.2, the rounding done by mpz_get_d was unspecified. It + happened to follow the hardware rounding mode, but on the absolute value + of its operand. This is not what we want, so we put the high + DBL_MANT_DIG bits into a temporary. This extra init/clear is a slowdown, + but doesn't matter too much since it's only for older GMP. */ + +double scm_i_big2dbl (SCM b) { - double result = mpz_get_d (SCM_I_BIG_MPZ (b)); + double result; + size_t bits; + + bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2); + +#if __GNU_MP_VERSION < 4 \ + || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2) + { + /* GMP prior to 4.2, force truncate towards zero */ + mpz_t tmp; + if (bits > DBL_MANT_DIG) + { + size_t shift = bits - DBL_MANT_DIG; + mpz_init2 (tmp, DBL_MANT_DIG); + mpz_tdiv_q_2exp (tmp, SCM_I_BIG_MPZ (b), shift); + result = ldexp (mpz_get_d (tmp), shift); + mpz_clear (tmp); + } + else + { + result = mpz_get_d (SCM_I_BIG_MPZ (b)); + } + } +#else + /* GMP 4.2 and up */ + result = mpz_get_d (SCM_I_BIG_MPZ (b)); +#endif + + if (bits > DBL_MANT_DIG) + { + unsigned long pos = bits - DBL_MANT_DIG - 1; + /* test bit number "pos" in absolute value */ + if (mpz_getlimbn (SCM_I_BIG_MPZ (b), pos / GMP_NUMB_BITS) + & ((mp_limb_t) 1 << (pos % GMP_NUMB_BITS))) + { + result += ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b)), pos + 1); + } + } + scm_remember_upto_here_1 (b); return result; } From a1fb3b1c1101a236ca65032f18b3df66549d3694 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 19 Oct 2003 00:34:39 +0000 Subject: [PATCH 067/239] Use define-module to hide helper defines. (dbl-mant-dig, ash-flo): New helpers. (exact->inexact): New tests. --- test-suite/tests/numbers.test | 114 +++++++++++++++++++++++++++++++++- 1 file changed, 113 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 5fe98bf06..b2920a2f9 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -15,7 +15,9 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -(use-modules (ice-9 documentation)) +(define-module (test-suite test-numbers) + #:use-module (test-suite lib) + #:use-module (ice-9 documentation)) ;;; ;;; miscellaneous @@ -33,6 +35,36 @@ (define fixnum-min most-negative-fixnum) (define fixnum-max most-positive-fixnum) +;; Divine the number of bits in the mantissa of a flonum. +;; We look for when 2.0^i+1.0 gets rounded, ie. the difference between that +;; value and 2.0^k is not 1.0. +;; Of course this assumes flonums have a fixed precision mantissa, but +;; that's the case now and probably into the forseeable future. +;; On an IEEE system, which means pretty much everywhere, the value here is +;; the usual 53. +;; +(define dbl-mant-dig + (let more ((i 1) + (d 2.0)) + (if (> i 1024) + (error "Oops, cannot determine number of bits in mantissa of inexact")) + (let* ((sum (+ 1.0 d)) + (diff (- sum d))) + (if (= diff 1.0) + (more (1+ i) (* 2.0 d)) + i)))) + +;; like ash, but working on a flonum +(define (ash-flo x n) + (while (> n 0) + (set! x (* 2.0 x)) + (set! n (1- n))) + (while (< n 0) + (set! x (* 0.5 x)) + (set! n (1+ n))) + x) + + ;;; ;;; exact? ;;; @@ -1965,6 +1997,86 @@ ;;; exact->inexact ;;; +(with-test-prefix "exact->inexact" + + ;; Test "(exact->inexact n)", expect "want". + ;; "i" is a index, for diagnostic purposes. + (define (try-i i n want) + (with-test-prefix (list i n want) + (with-test-prefix "pos" + (let ((got (exact->inexact n))) + (pass-if "inexact?" (inexact? got)) + (pass-if (list "=" got) (= want got)))) + (set! n (- n)) + (set! want (- want)) + (with-test-prefix "neg" + (let ((got (exact->inexact n))) + (pass-if "inexact?" (inexact? got)) + (pass-if (list "=" got) (= want got)))))) + + (with-test-prefix "2^i, no round" + (do ((i 0 (1+ i)) + (n 1 (* 2 n)) + (want 1.0 (* 2.0 want))) + ((> i 100)) + (try-i i n want))) + + (with-test-prefix "2^i+1, no round" + (do ((i 1 (1+ i)) + (n 3 (1- (* 2 n))) + (want 3.0 (- (* 2.0 want) 1.0))) + ((>= i dbl-mant-dig)) + (try-i i n want))) + + (with-test-prefix "(2^i+1)*2^100, no round" + (do ((i 1 (1+ i)) + (n 3 (1- (* 2 n))) + (want 3.0 (- (* 2.0 want) 1.0))) + ((>= i dbl-mant-dig)) + (try-i i (ash n 100) (ash-flo want 100)))) + + ;; bit pattern: 1111....11100.00 + ;; <-mantdig-><-i-> + ;; + (with-test-prefix "mantdig ones then zeros, no rounding" + (do ((i 0 (1+ i)) + (n (- (ash 1 dbl-mant-dig) 1) (* 2 n)) + (want (- (ash-flo 1.0 dbl-mant-dig) 1.0) (* 2.0 want))) + ((> i 100)) + (try-i i n want))) + + ;; bit pattern: 1111....111011..1 + ;; <-mantdig-> <-i-> + ;; This sort of value was incorrectly rounded upwards in Guile 1.6.4 when + ;; i >= 11 (that's when the total is 65 or more bits). + ;; + (with-test-prefix "mantdig ones then 011..11, round down" + (do ((i 0 (1+ i)) + (n (- (ash 1 (+ 1 dbl-mant-dig)) 2) (+ 1 (* 2 n))) + (want (- (ash-flo 1.0 (+ 1 dbl-mant-dig)) 2.0) (* 2.0 want))) + ((> i 100)) + (try-i i n want))) + + ;; bit pattern: 1111....111100..001 + ;; <-mantdig-> <--i-> + ;; + (with-test-prefix "mantdig ones then 100..001, round up" + (do ((i 0 (1+ i)) + (n (- (ash 1 (+ 2 dbl-mant-dig)) 1) (1- (* 2 n))) + (want (ash-flo 1.0 (+ 2 dbl-mant-dig)) (* 2.0 want))) + ((> i 100)) + (try-i i n want))) + + ;; bit pattern: 1000....000100..001 + ;; <-mantdig-> <--i-> + ;; + (with-test-prefix "2^mantdig then 100..001, round up" + (do ((i 0 (1+ i)) + (n (- (ash 1 (+ 2 dbl-mant-dig)) 1) (1- (* 2 n))) + (want (+ (ash-flo 1.0 (+ 2 dbl-mant-dig)) 4.0) (* 2.0 want))) + ((> i 100)) + (try-i i n want)))) + ;;; ;;; floor ;;; From 3bf6ee15c06301fe86b198e35468420b401d5949 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 19 Oct 2003 00:36:26 +0000 Subject: [PATCH 068/239] *** empty log message *** --- test-suite/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index a42891980..b86ae9572 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2003-10-19 Kevin Ryde + + * tests/numbers.test: Use define-module to hide helper defines. + (dbl-mant-dig, ash-flo): New helpers. + (exact->inexact): New tests. + 2003-10-18 Dirk Herrmann * tests/syntax.test (exception:bad-var): Removed. From 0ee39677b96c827ffb6596f2f8e71cfee7c4d2d1 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 19 Oct 2003 00:49:36 +0000 Subject: [PATCH 069/239] *** empty log message *** --- libguile/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c11c8fa3d..fb7f3990b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2003-10-19 Kevin Ryde + + * numbers.c (scm_ash): Revise docstring as per recent update to manual. + + * numbers.c (scm_i_big2dbl): Rewrite, carefully rounding to "closest" + in accordance with R5RS, which just mpz_get_d doesn't really give. + 2003-10-18 Dirk Herrmann * eval.c (s_bad_slot_number): New static identifier. From 70c1c1086456296090d276c499b451282b60befb Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 22 Oct 2003 20:16:41 +0000 Subject: [PATCH 070/239] * eval.c (s_defun): New static identifier. (scm_m_nil_cond, scm_m_atfop, scm_m_undefine): Add comments. Use ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing when creating the memoized code. --- libguile/ChangeLog | 8 +++ libguile/eval.c | 131 ++++++++++++++++++++++++++------------------- 2 files changed, 84 insertions(+), 55 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fb7f3990b..45329b5e8 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2003-10-22 Dirk Herrmann + + * eval.c (s_defun): New static identifier. + + (scm_m_nil_cond, scm_m_atfop, scm_m_undefine): Add comments. Use + ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing + when creating the memoized code. + 2003-10-19 Kevin Ryde * numbers.c (scm_ash): Revise docstring as per recent update to manual. diff --git a/libguile/eval.c b/libguile/eval.c index 99ecf1017..3771db23e 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1704,60 +1704,81 @@ scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED) #if SCM_ENABLE_ELISP +static const char s_defun[] = "Symbol's function definition is void"; + SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond); +/* nil-cond expressions have the form + * (nil-cond COND VAL COND VAL ... ELSEVAL) */ SCM -scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED) +scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED) { - long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 1 && (len & 1) == 1, s_expression, "nil-cond"); - return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig)); + const long length = scm_ilength (SCM_CDR (expr)); + ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (length >= 1 && (length % 2) == 1, s_expression, expr); + + SCM_SETCAR (expr, SCM_IM_NIL_COND); + return expr; } SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop); +/* The @fop-macro handles procedure and macro applications for elisp. The + * input expression must have the form + * (@fop (transformer-macro ...)) + * where must be a symbol. The expression is transformed into the + * memoized form of either + * (apply (transformer-macro ...)) + * if the value of var (across all aliasing) is not a macro, or + * ( ...) + * if var is a macro. */ SCM -scm_m_atfop (SCM xorig, SCM env SCM_UNUSED) +scm_m_atfop (SCM expr, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig), var; - SCM_ASSYNT (scm_ilength (x) >= 1, s_expression, "@fop"); - var = scm_symbol_fref (SCM_CAR (x)); - /* Passing the symbol name as the `subr' arg here isn't really - right, but without it it can be very difficult to work out from - the error message which function definition was missing. In any - case, we shouldn't really use SCM_ASSYNT here at all, but instead - something equivalent to (signal void-function (list SYM)) in - Elisp. */ - SCM_ASSYNT (SCM_VARIABLEP (var), - "Symbol's function definition is void", - SCM_SYMBOL_CHARS (SCM_CAR (x))); - /* Support `defalias'. */ - while (SCM_SYMBOLP (SCM_VARIABLE_REF (var))) + SCM location; + SCM symbol; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_missing_expression, expr); + + symbol = SCM_CAR (cdr_expr); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol), s_bad_variable, symbol, expr); + + location = scm_symbol_fref (symbol); + ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr); + + /* The elisp function `defalias' allows to define aliases for symbols. To + * look up such definitions, the chain of symbol definitions has to be + * followed up to the terminal symbol. */ + while (SCM_SYMBOLP (SCM_VARIABLE_REF (location))) { - var = scm_symbol_fref (SCM_VARIABLE_REF (var)); - SCM_ASSYNT (SCM_VARIABLEP (var), - "Symbol's function definition is void", - SCM_SYMBOL_CHARS (SCM_CAR (x))); + const SCM alias = SCM_VARIABLE_REF (location); + location = scm_symbol_fref (alias); + ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr); } - /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the - former allows for automatically picking up redefinitions of the - corresponding symbol. */ - SCM_SETCAR (x, var); - /* If the variable contains a procedure, leave the - `transformer-macro' in place so that the procedure's arguments - get properly transformed, and change the initial @fop to - SCM_IM_APPLY. */ - if (!SCM_MACROP (SCM_VARIABLE_REF (var))) + + /* Memoize the value location belonging to the terminal symbol. */ + SCM_SETCAR (cdr_expr, location); + + if (!SCM_MACROP (SCM_VARIABLE_REF (location))) { - SCM_SETCAR (xorig, SCM_IM_APPLY); - return xorig; + /* Since the location does not contain a macro, the form is a procedure + * application. Replace `@fop' by `@apply' and transform the expression + * including the `transformer-macro'. */ + SCM_SETCAR (expr, SCM_IM_APPLY); + return expr; + } + else + { + /* Since the location contains a macro, the arguments should not be + * transformed, so the `transformer-macro' is cut out. The resulting + * expression starts with the memoized variable, that is at the cdr of + * the input expression. */ + SCM_SETCDR (cdr_expr, SCM_CDADR (cdr_expr)); + return cdr_expr; } - /* Otherwise (the variable contains a macro), the arguments should - not be transformed, so cut the `transformer-macro' out and return - the resulting expression starting with the variable. */ - SCM_SETCDR (x, SCM_CDADR (x)); - return x; } #endif /* SCM_ENABLE_ELISP */ @@ -1771,24 +1792,24 @@ scm_m_atfop (SCM xorig, SCM env SCM_UNUSED) SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine); SCM -scm_m_undefine (SCM x, SCM env) +scm_m_undefine (SCM expr, SCM env) { - SCM arg1 = x; - x = SCM_CDR (x); - SCM_ASSYNT (SCM_TOP_LEVEL (env), "bad placement ", s_undefine); - SCM_ASSYNT (SCM_CONSP (x) && SCM_NULLP (SCM_CDR (x)), - s_expression, s_undefine); - x = SCM_CAR (x); - SCM_ASSYNT (SCM_SYMBOLP (x), s_variable, s_undefine); - arg1 = scm_sym2var (x, scm_env_top_level (env), SCM_BOOL_F); - SCM_ASSYNT (!SCM_FALSEP (arg1) && !SCM_UNBNDP (SCM_VARIABLE_REF (arg1)), - "variable already unbound ", s_undefine); - SCM_VARIABLE_SET (arg1, SCM_UNDEFINED); -#ifdef SICP - return x; -#else + SCM variable; + SCM location; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (SCM_TOP_LEVEL (env), "Bad undefine placement in", expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); + + variable = SCM_CAR (cdr_expr); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + location = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_F); + ASSERT_SYNTAX_2 (!SCM_FALSEP (location) + && !SCM_UNBNDP (SCM_VARIABLE_REF (location)), + "variable already unbound ", variable, expr); + SCM_VARIABLE_SET (location, SCM_UNDEFINED); return SCM_UNSPECIFIED; -#endif } #endif From 60a4984209e2a1f7bfaf478af8c668f65cda3843 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 25 Oct 2003 07:00:50 +0000 Subject: [PATCH 071/239] * eval.c (unmemocar, sym_three_question_marks, scm_unmemocar): Grouped together with unmemocopy, without modifications. (build_binding_list, unmemocopy): Renamed names of list arguments and variables to reflect the actual order of the list elements. --- libguile/ChangeLog | 8 ++++ libguile/eval.c | 106 +++++++++++++++++++++++---------------------- 2 files changed, 62 insertions(+), 52 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 45329b5e8..d22bdad03 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2003-10-25 Dirk Herrmann + + * eval.c (unmemocar, sym_three_question_marks, scm_unmemocar): + Grouped together with unmemocopy, without modifications. + + (build_binding_list, unmemocopy): Renamed names of list arguments + and variables to reflect the actual order of the list elements. + 2003-10-22 Dirk Herrmann * eval.c (s_defun): New static identifier. diff --git a/libguile/eval.c b/libguile/eval.c index 3771db23e..38e33826b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -633,40 +633,6 @@ literal_p (const SCM symbol, const SCM env) return 0; } -#define unmemocar scm_unmemocar - -SCM_SYMBOL (sym_three_question_marks, "???"); - -SCM -scm_unmemocar (SCM form, SCM env) -{ - if (!SCM_CONSP (form)) - return form; - else - { - SCM c = SCM_CAR (form); - if (SCM_VARIABLEP (c)) - { - SCM sym = scm_module_reverse_lookup (scm_env_module (env), c); - if (SCM_FALSEP (sym)) - sym = sym_three_question_marks; - SCM_SETCAR (form, sym); - } - else if (SCM_ILOCP (c)) - { - unsigned long int ir; - - for (ir = SCM_IFRAME (c); ir != 0; --ir) - env = SCM_CDR (env); - env = SCM_CAAR (env); - for (ir = SCM_IDIST (c); ir != 0; --ir) - env = SCM_CDR (env); - SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env)); - } - return form; - } -} - SCM scm_eval_car (SCM pair, SCM env) @@ -1925,6 +1891,7 @@ static SCM f_apply; /* An endless list consisting of # objects: */ static SCM undefineds; + /* scm_unmemocopy takes a memoized expression together with its * environment and rewrites it to its original form. Thus, it is the * inversion of the rewrite rules above. The procedure is not @@ -1941,19 +1908,54 @@ static SCM undefineds; */ static SCM -build_binding_list (SCM names, SCM inits) +build_binding_list (SCM rnames, SCM rinits) { SCM bindings = SCM_EOL; - while (!SCM_NULLP (names)) + while (!SCM_NULLP (rnames)) { - SCM binding = scm_list_2 (SCM_CAR (names), SCM_CAR (inits)); + SCM binding = scm_list_2 (SCM_CAR (rnames), SCM_CAR (rinits)); bindings = scm_cons (binding, bindings); - names = SCM_CDR (names); - inits = SCM_CDR (inits); + rnames = SCM_CDR (rnames); + rinits = SCM_CDR (rinits); } return bindings; } + +SCM_SYMBOL (sym_three_question_marks, "???"); + +#define unmemocar scm_unmemocar + +SCM +scm_unmemocar (SCM form, SCM env) +{ + if (!SCM_CONSP (form)) + return form; + else + { + SCM c = SCM_CAR (form); + if (SCM_VARIABLEP (c)) + { + SCM sym = scm_module_reverse_lookup (scm_env_module (env), c); + if (SCM_FALSEP (sym)) + sym = sym_three_question_marks; + SCM_SETCAR (form, sym); + } + else if (SCM_ILOCP (c)) + { + unsigned long int ir; + + for (ir = SCM_IFRAME (c); ir != 0; --ir) + env = SCM_CDR (env); + env = SCM_CAAR (env); + for (ir = SCM_IDIST (c); ir != 0; --ir) + env = SCM_CDR (env); + SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env)); + } + return form; + } +} + static SCM unmemocopy (SCM x, SCM env) { @@ -2032,33 +2034,33 @@ unmemocopy (SCM x, SCM env) /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...), * where nx is the name of a local variable, ix is an initializer for * the local variable and by are the body clauses. */ - SCM names, inits, bindings; + SCM rnames, rinits, bindings; x = SCM_CDR (x); - names = SCM_CAR (x); + rnames = SCM_CAR (x); x = SCM_CDR (x); - inits = scm_reverse (unmemocopy (SCM_CAR (x), env)); - env = SCM_EXTEND_ENV (names, SCM_EOL, env); + rinits = scm_reverse (unmemocopy (SCM_CAR (x), env)); + env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); - bindings = build_binding_list (names, inits); + bindings = build_binding_list (rnames, rinits); z = scm_cons (bindings, SCM_UNSPECIFIED); ls = scm_cons (scm_sym_let, z); break; } case SCM_BIT7 (SCM_IM_LETREC): { - /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...), - * where nx is the name of a local variable, ix is an initializer for + /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...), + * where vx is the name of a local variable, ix is an initializer for * the local variable and by are the body clauses. */ - SCM names, inits, bindings; + SCM rnames, rinits, bindings; x = SCM_CDR (x); - names = SCM_CAR (x); - env = SCM_EXTEND_ENV (names, SCM_EOL, env); + rnames = SCM_CAR (x); + env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); x = SCM_CDR (x); - inits = scm_reverse (unmemocopy (SCM_CAR (x), env)); + rinits = scm_reverse (unmemocopy (SCM_CAR (x), env)); - bindings = build_binding_list (names, inits); + bindings = build_binding_list (rnames, rinits); z = scm_cons (bindings, SCM_UNSPECIFIED); ls = scm_cons (scm_sym_letrec, z); break; @@ -5166,7 +5168,7 @@ scm_init_eval () scm_permanent_object (f_apply); #include "libguile/eval.x" - + scm_add_feature ("delay"); } From 89bff2fc106ccde319e48488ff26c824dd8529f4 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 1 Nov 2003 07:26:44 +0000 Subject: [PATCH 072/239] * libguile/eval.c (s_expression): Added comment. (s_empty_combination, error_unbound_variable): New static identifiers. (SCM_VALIDATE_NON_EMPTY_COMBINATION, SCM_EVALIM2, scm_lookupcar1): Use ASSERT_SYNTAX, syntax_error or error_unbound_variable to signal syntax errors. (SCM_CEVAL): Separated handling of evaluator bytecodes and other scheme objects. * test-suite/tests/syntax.test (exception:missing/extra-expr-misc): Removed. (exception:illegal-empty-combination): New. (exception:missing/extra-expr): Unified capitalization. Adapted test for '()' to the new way of error reporting. --- libguile/ChangeLog | 14 ++++++++++ libguile/eval.c | 51 +++++++++++++++++++++++++----------- test-suite/ChangeLog | 10 +++++++ test-suite/tests/syntax.test | 8 +++--- 4 files changed, 63 insertions(+), 20 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d22bdad03..d1b8df801 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,17 @@ +2003-11-01 Dirk Herrmann + + * eval.c (s_expression): Added comment. + + (s_empty_combination, error_unbound_variable): New static + identifiers. + + (SCM_VALIDATE_NON_EMPTY_COMBINATION, SCM_EVALIM2, scm_lookupcar1): + Use ASSERT_SYNTAX, syntax_error or error_unbound_variable to + signal syntax errors. + + (SCM_CEVAL): Separated handling of evaluator bytecodes and other + scheme objects. + 2003-10-25 Dirk Herrmann * eval.c (unmemocar, sym_three_question_marks, scm_unmemocar): diff --git a/libguile/eval.c b/libguile/eval.c index 38e33826b..a51455b3f 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -101,6 +101,11 @@ char *alloca (); * expression is expected, a 'Bad expression' error is signalled. */ static const char s_bad_expression[] = "Bad expression"; +/* If a form is detected that holds a different number of expressions than are + * required in that context, a 'Missing or extra expression' error is + * signalled. */ +static const char s_expression[] = "Missing or extra expression in"; + /* If a form is detected that holds less expressions than are required in that * context, a 'Missing expression' error is signalled. */ static const char s_missing_expression[] = "Missing expression in"; @@ -109,6 +114,13 @@ static const char s_missing_expression[] = "Missing expression in"; * context, an 'Extra expression' error is signalled. */ static const char s_extra_expression[] = "Extra expression in"; +/* The empty combination '()' is not allowed as an expression in scheme. If + * it is detected in a place where an expression is expected, an 'Illegal + * empty combination' error is signalled. Note: If you encounter this error + * message, it is very likely that you intended to denote the empty list. To + * do so, you need to quote the empty list like (quote ()) or '(). */ +static const char s_empty_combination[] = "Illegal empty combination"; + /* Case or cond expressions must have at least one clause. If a case or cond * expression without any clauses is detected, a 'Missing clauses' error is * signalled. */ @@ -327,10 +339,7 @@ SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", 1, 0, 0, #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ - do { \ - if (SCM_EQ_P ((x), SCM_EOL)) \ - scm_misc_error (NULL, s_expression, SCM_EOL); \ - } while (0) + ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x) @@ -367,7 +376,7 @@ SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", 1, 0, 0, #define SCM_EVALIM2(x) \ ((SCM_EQ_P ((x), SCM_EOL) \ - ? scm_misc_error (NULL, s_expression, SCM_EOL), 0 \ + ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \ : 0), \ (x)) @@ -394,7 +403,6 @@ SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", 1, 0, 0, SCM_REC_MUTEX (source_mutex); -static const char s_expression[] = "missing or extra expression"; static const char s_test[] = "bad test"; static const char s_body[] = "bad body"; static const char s_bindings[] = "bad bindings"; @@ -431,6 +439,18 @@ scm_ilookup (SCM iloc, SCM env) } +SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); + +static void error_unbound_variable (SCM symbol) SCM_NORETURN; +static void +error_unbound_variable (SCM symbol) +{ + scm_error (scm_unbound_variable_key, NULL, + "Unbound variable: ~S", + scm_list_1 (symbol), SCM_BOOL_F); +} + + /* The Lookup Car Race - by Eva Luator @@ -504,8 +524,6 @@ scm_ilookup (SCM iloc, SCM env) for NULL. I think I've found the only places where this applies. */ -SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); - static SCM * scm_lookupcar1 (SCM vloc, SCM genv, int check) { @@ -568,9 +586,7 @@ scm_lookupcar1 (SCM vloc, SCM genv, int check) if (check) { if (SCM_NULLP (env)) - scm_error (scm_unbound_variable_key, NULL, - "Unbound variable: ~S", - scm_list_1 (var), SCM_BOOL_F); + error_unbound_variable (var); else scm_misc_error (NULL, "Damaged environment: ~S", scm_list_1 (var)); @@ -1840,6 +1856,7 @@ scm_m_expand_body (SCM xorig, SCM env) return xorig; } + SCM scm_macroexp (SCM x, SCM env) { @@ -2602,11 +2619,6 @@ dispatch: SCM_TICK; switch (SCM_TYP7 (x)) { - case scm_tc7_symbol: - /* Only happens when called at top level. */ - x = scm_cons (x, SCM_UNDEFINED); - RETURN (*scm_lookupcar (x, env, 1)); - case SCM_BIT7 (SCM_IM_AND): x = SCM_CDR (x); while (!SCM_NULLP (SCM_CDR (x))) @@ -3286,10 +3298,12 @@ dispatch: goto evapply; } + default: proc = x; goto evapply; + case scm_tc7_vector: case scm_tc7_wvect: #if SCM_HAVE_ARRAYS @@ -3315,6 +3329,11 @@ dispatch: case scm_tcs_struct: RETURN (x); + case scm_tc7_symbol: + /* Only happens when called at top level. */ + x = scm_cons (x, SCM_UNDEFINED); + RETURN (*scm_lookupcar (x, env, 1)); + case scm_tc7_variable: RETURN (SCM_VARIABLE_REF(x)); diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index b86ae9572..0367d4da9 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,13 @@ +2003-11-01 Dirk Herrmann + + * tests/syntax.test (exception:missing/extra-expr-misc): Removed. + + (exception:illegal-empty-combination): New. + + (exception:missing/extra-expr): Unified capitalization. + + Adapted test for '()' to the new way of error reporting. + 2003-10-19 Kevin Ryde * tests/numbers.test: Use define-module to hide helper defines. diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 82ff4d980..9691f2bfc 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -24,14 +24,14 @@ (define exception:bad-expression (cons 'syntax-error "Bad expression")) -(define exception:missing/extra-expr-misc - (cons 'misc-error "^missing or extra expression")) (define exception:missing/extra-expr - (cons 'syntax-error "missing or extra expression")) + (cons 'syntax-error "Missing or extra expression")) (define exception:missing-expr (cons 'syntax-error "Missing expression")) (define exception:extra-expr (cons 'syntax-error "Extra expression")) +(define exception:illegal-empty-combination + (cons 'syntax-error "Illegal empty combination")) (define exception:bad-bindings (cons 'syntax-error "Bad bindings")) @@ -86,7 +86,7 @@ ;; Fixed on 2001-3-3 (pass-if-exception "empty parentheses \"()\"" - exception:missing/extra-expr-misc + exception:illegal-empty-combination (eval '() (interaction-environment))))) From 34adf7eaf2f1799ea909f002493cd05aa8c54692 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 1 Nov 2003 10:21:15 +0000 Subject: [PATCH 073/239] * eval.c (scm_m_body, scm_m_lambda): Documentation strings are not handled in scm_m_body any more, but rather in scm_m_lambda. (scm_m_body, memoize_named_let, scm_m_let, scm_m_letstar, scm_m_letrec, scm_m_expand_body): Check for validity is done by calling functions of scm_m_body. (scm_m_lambda): Avoid unnecessary consing when creating the memoized code. --- libguile/ChangeLog | 12 +++++++ libguile/eval.c | 83 ++++++++++++++++++++++++---------------------- 2 files changed, 56 insertions(+), 39 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d1b8df801..24c645fbd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2003-11-01 Dirk Herrmann + + * eval.c (scm_m_body, scm_m_lambda): Documentation strings are not + handled in scm_m_body any more, but rather in scm_m_lambda. + + (scm_m_body, memoize_named_let, scm_m_let, scm_m_letstar, + scm_m_letrec, scm_m_expand_body): Check for validity is done by + calling functions of scm_m_body. + + (scm_m_lambda): Avoid unnecessary consing when creating the + memoized code. + 2003-11-01 Dirk Herrmann * eval.c (s_expression): Added comment. diff --git a/libguile/eval.c b/libguile/eval.c index a51455b3f..489f4c90f 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -672,38 +672,25 @@ SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame"); SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); -/* Check that the body denoted by XORIG is valid and rewrite it into - its internal form. The internal form of a body is just the body - itself, but prefixed with an ISYM that denotes to what kind of - outer construct this body belongs. A lambda body starts with - SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET, - etc. The one exception is a body that belongs to a letrec that has - been formed by rewriting internal defines: it starts with - SCM_IM_DEFINE. */ - -/* XXX - Besides controlling the rewriting of internal defines, the - additional ISYM could be used for improved error messages. - This is not done yet. */ - +/* Rewrite the body (which is given as the list of expressions forming the + * body) into its internal form. The internal form of a body ( ...) is + * just the body itself, but prefixed with an ISYM that denotes to what kind + * of outer construct this body belongs: ( ...). A lambda body + * starts with SCM_IM_LAMBDA, for example, a body of a let starts with + * SCM_IM_LET, etc. The one exception is a body that belongs to a letrec that + * has been formed by rewriting internal defines: It starts with SCM_IM_DEFINE + * (instead of SCM_IM_LETREC). + * + * It is assumed that the calling expression has already made sure that the + * body is a proper list. */ static SCM -scm_m_body (SCM op, SCM xorig, const char *what) +scm_m_body (SCM op, SCM exprs) { - SCM_ASSYNT (scm_ilength (xorig) >= 1, s_body, what); - /* Don't add another ISYM if one is present already. */ - if (SCM_ISYMP (SCM_CAR (xorig))) - return xorig; - - /* Retain possible doc string. */ - if (!SCM_CONSP (SCM_CAR (xorig))) - { - if (!SCM_NULLP (SCM_CDR (xorig))) - return scm_cons (SCM_CAR (xorig), - scm_m_body (op, SCM_CDR (xorig), what)); - return xorig; - } - - return scm_cons (op, xorig); + if (SCM_ISYMP (SCM_CAR (exprs))) + return exprs; + else + return scm_cons (op, exprs); } @@ -1101,6 +1088,10 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED) { SCM formals; SCM formals_idx; + SCM cddr_expr; + int documentation; + SCM body; + SCM new_body; const SCM cdr_expr = SCM_CDR (expr); const long length = scm_ilength (cdr_expr); @@ -1136,8 +1127,22 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED) ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || SCM_SYMBOLP (formals_idx), s_bad_formal, formals_idx, expr); - return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (cdr_expr), - scm_m_body (SCM_IM_LAMBDA, SCM_CDR (cdr_expr), s_lambda)); + /* Memoize the body. Keep a potential documentation string. */ + /* Dirk:FIXME:: We should probably extract the documentation string to + * some external database. Otherwise it will slow down execution, since + * the documentation string will have to be skipped with every execution + * of the closure. */ + cddr_expr = SCM_CDR (cdr_expr); + documentation = (length >= 3 && SCM_STRINGP (SCM_CAR (cddr_expr))); + body = documentation ? SCM_CDR (cddr_expr) : cddr_expr; + new_body = scm_m_body (SCM_IM_LAMBDA, body); + + SCM_SETCAR (expr, SCM_IM_LAMBDA); + if (documentation) + SCM_SETCDR (cddr_expr, new_body); + else + SCM_SETCDR (cdr_expr, new_body); + return expr; } @@ -1220,13 +1225,13 @@ memoize_named_let (const SCM expr, const SCM env SCM_UNUSED) { const SCM let_body = SCM_CDR (cddr_expr); - const SCM lambda_body = scm_m_body (SCM_IM_LET, let_body, "let"); + const SCM lambda_body = scm_m_body (SCM_IM_LET, let_body); const SCM lambda_tail = scm_cons (variables, lambda_body); const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail); const SCM rvar = scm_list_1 (name); const SCM init = scm_list_1 (lambda_form); - const SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name), "let"); + const SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name)); const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body)); const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail); return scm_cons_source (expr, letrec_form, inits); @@ -1256,7 +1261,7 @@ scm_m_let (SCM expr, SCM env) if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings))) { /* Special case: no bindings or single binding => let* is faster. */ - const SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr), s_let); + const SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env); } else @@ -1267,7 +1272,7 @@ scm_m_let (SCM expr, SCM env) transform_bindings (bindings, expr, &rvariables, &inits); { - const SCM new_body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr), "let"); + const SCM new_body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); const SCM new_tail = scm_cons2 (rvariables, inits, new_body); SCM_SETCAR (expr, SCM_IM_LET); SCM_SETCDR (expr, new_tail); @@ -1305,7 +1310,7 @@ scm_m_letstar (SCM expr, SCM env SCM_UNUSED) } new_bindings = scm_reverse_x (new_bindings, SCM_UNDEFINED); - new_body = scm_m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr), s_letstar); + new_body = scm_m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr)); return scm_cons2 (SCM_IM_LETSTAR, new_bindings, new_body); } @@ -1326,7 +1331,7 @@ scm_m_letrec (SCM expr, SCM env) if (SCM_NULLP (bindings)) { /* no bindings, let* is executed faster */ - SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr), s_letrec); + SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env); } else @@ -1337,7 +1342,7 @@ scm_m_letrec (SCM expr, SCM env) check_bindings (bindings, expr); transform_bindings (bindings, expr, &rvariables, &inits); - new_body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr), "letrec"); + new_body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body)); } } @@ -1841,7 +1846,7 @@ scm_m_expand_body (SCM xorig, SCM env) SCM rvars, inits, body, letrec; check_bindings (defs, xorig); transform_bindings (defs, xorig, &rvars, &inits); - body = scm_m_body (SCM_IM_DEFINE, x, what); + body = scm_m_body (SCM_IM_DEFINE, x); letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); SCM_SETCAR (xorig, letrec); SCM_SETCDR (xorig, SCM_EOL); From 2510c810619043253061794c665080dbad9353d5 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 2 Nov 2003 10:48:10 +0000 Subject: [PATCH 074/239] * eval.c (scm_trampoline_0, scm_trampoline_1, scm_trampoline_2): Make sure that error checking in debug mode is not worse than in standard mode. --- libguile/ChangeLog | 6 +++ libguile/eval.c | 125 ++++++++++++++++++++++++++++++++------------- 2 files changed, 95 insertions(+), 36 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 24c645fbd..b870edd9c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2003-11-02 Dirk Herrmann + + * eval.c (scm_trampoline_0, scm_trampoline_1, scm_trampoline_2): + Make sure that error checking in debug mode is not worse than in + standard mode. + 2003-11-01 Dirk Herrmann * eval.c (scm_m_body, scm_m_lambda): Documentation strings are not diff --git a/libguile/eval.c b/libguile/eval.c index 489f4c90f..31d03baf9 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -4486,45 +4486,62 @@ scm_i_call_closure_0 (SCM proc) scm_t_trampoline_0 scm_trampoline_0 (SCM proc) { + scm_t_trampoline_0 trampoline; + if (SCM_IMP (proc)) return NULL; - if (SCM_DEBUGGINGP) - return scm_call_0; + switch (SCM_TYP7 (proc)) { case scm_tc7_subr_0: - return call_subr0_0; + trampoline = call_subr0_0; + break; case scm_tc7_subr_1o: - return call_subr1o_0; + trampoline = call_subr1o_0; + break; case scm_tc7_lsubr: - return call_lsubr_0; + trampoline = call_lsubr_0; + break; case scm_tcs_closures: { SCM formals = SCM_CLOSURE_FORMALS (proc); if (SCM_NULLP (formals) || !SCM_CONSP (formals)) - return scm_i_call_closure_0; + trampoline = scm_i_call_closure_0; else return NULL; + break; } case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - return scm_call_generic_0; + trampoline = scm_call_generic_0; else if (SCM_I_OPERATORP (proc)) - return scm_call_0; - return NULL; + trampoline = scm_call_0; + else + return NULL; + break; case scm_tc7_smob: if (SCM_SMOB_APPLICABLE_P (proc)) - return SCM_SMOB_DESCRIPTOR (proc).apply_0; + trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_0; else return NULL; + break; case scm_tc7_asubr: case scm_tc7_rpsubr: case scm_tc7_cclo: case scm_tc7_pws: - return scm_call_0; + trampoline = scm_call_0; + break; default: - return NULL; /* not applicable on one arg */ + return NULL; /* not applicable on zero arguments */ } + /* We only reach this point if a valid trampoline was determined. */ + + /* If debugging is enabled, we want to see all calls to proc on the stack. + * Thus, we replace the trampoline shortcut with scm_call_0. */ + if (SCM_DEBUGGINGP) + return scm_call_0; + else + return trampoline; } static SCM @@ -4589,51 +4606,70 @@ call_closure_1 (SCM proc, SCM arg1) scm_t_trampoline_1 scm_trampoline_1 (SCM proc) { + scm_t_trampoline_1 trampoline; + if (SCM_IMP (proc)) return NULL; - if (SCM_DEBUGGINGP) - return scm_call_1; + switch (SCM_TYP7 (proc)) { case scm_tc7_subr_1: case scm_tc7_subr_1o: - return call_subr1_1; + trampoline = call_subr1_1; + break; case scm_tc7_subr_2o: - return call_subr2o_1; + trampoline = call_subr2o_1; + break; case scm_tc7_lsubr: - return call_lsubr_1; + trampoline = call_lsubr_1; + break; case scm_tc7_dsubr: - return call_dsubr_1; + trampoline = call_dsubr_1; + break; case scm_tc7_cxr: - return call_cxr_1; + trampoline = call_cxr_1; + break; case scm_tcs_closures: { SCM formals = SCM_CLOSURE_FORMALS (proc); if (!SCM_NULLP (formals) && (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals)))) - return call_closure_1; + trampoline = call_closure_1; else return NULL; + break; } case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - return scm_call_generic_1; + trampoline = scm_call_generic_1; else if (SCM_I_OPERATORP (proc)) - return scm_call_1; - return NULL; + trampoline = scm_call_1; + else + return NULL; + break; case scm_tc7_smob: if (SCM_SMOB_APPLICABLE_P (proc)) - return SCM_SMOB_DESCRIPTOR (proc).apply_1; + trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_1; else return NULL; + break; case scm_tc7_asubr: case scm_tc7_rpsubr: case scm_tc7_cclo: case scm_tc7_pws: - return scm_call_1; + trampoline = scm_call_1; + break; default: return NULL; /* not applicable on one arg */ } + /* We only reach this point if a valid trampoline was determined. */ + + /* If debugging is enabled, we want to see all calls to proc on the stack. + * Thus, we replace the trampoline shortcut with scm_call_1. */ + if (SCM_DEBUGGINGP) + return scm_call_1; + else + return trampoline; } static SCM @@ -4667,21 +4703,25 @@ call_closure_2 (SCM proc, SCM arg1, SCM arg2) scm_t_trampoline_2 scm_trampoline_2 (SCM proc) { + scm_t_trampoline_2 trampoline; + if (SCM_IMP (proc)) return NULL; - if (SCM_DEBUGGINGP) - return scm_call_2; + switch (SCM_TYP7 (proc)) { case scm_tc7_subr_2: case scm_tc7_subr_2o: case scm_tc7_rpsubr: case scm_tc7_asubr: - return call_subr2_2; + trampoline = call_subr2_2; + break; case scm_tc7_lsubr_2: - return call_lsubr2_2; + trampoline = call_lsubr2_2; + break; case scm_tc7_lsubr: - return call_lsubr_2; + trampoline = call_lsubr_2; + break; case scm_tcs_closures: { SCM formals = SCM_CLOSURE_FORMALS (proc); @@ -4690,27 +4730,40 @@ scm_trampoline_2 (SCM proc) || (!SCM_NULLP (SCM_CDR (formals)) && (!SCM_CONSP (SCM_CDR (formals)) || !SCM_CONSP (SCM_CDDR (formals)))))) - return call_closure_2; + trampoline = call_closure_2; else return NULL; + break; } case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - return scm_call_generic_2; + trampoline = scm_call_generic_2; else if (SCM_I_OPERATORP (proc)) - return scm_call_2; - return NULL; + trampoline = scm_call_2; + else + return NULL; + break; case scm_tc7_smob: if (SCM_SMOB_APPLICABLE_P (proc)) - return SCM_SMOB_DESCRIPTOR (proc).apply_2; + trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_2; else return NULL; + break; case scm_tc7_cclo: case scm_tc7_pws: - return scm_call_2; + trampoline = scm_call_2; + break; default: return NULL; /* not applicable on two args */ } + /* We only reach this point if a valid trampoline was determined. */ + + /* If debugging is enabled, we want to see all calls to proc on the stack. + * Thus, we replace the trampoline shortcut with scm_call_2. */ + if (SCM_DEBUGGINGP) + return scm_call_2; + else + return trampoline; } /* Typechecking for multi-argument MAP and FOR-EACH. From 0f572ba764bd30027d73fc857f0650b1e27cf967 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 2 Nov 2003 11:39:35 +0000 Subject: [PATCH 075/239] * eval.c (canonicalize_define): New static helper function. (memoize_define, canonicalize_define): Extract handling of function currying to canonicalize_define. --- libguile/ChangeLog | 7 +++++++ libguile/eval.c | 38 +++++++++++++++++++++++++++++--------- 2 files changed, 36 insertions(+), 9 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b870edd9c..cab50b9c2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2003-11-02 Dirk Herrmann + + * eval.c (canonicalize_define): New static helper function. + + (memoize_define, canonicalize_define): Extract handling of + function currying to canonicalize_define. + 2003-11-02 Dirk Herrmann * eval.c (scm_trampoline_0, scm_trampoline_1, scm_trampoline_2): diff --git a/libguile/eval.c b/libguile/eval.c index 31d03baf9..e86b8e9d0 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -87,6 +87,10 @@ char *alloca (); +static SCM canonicalize_define (SCM expr); + + + /* {Syntax Errors} * * This section defines the message strings for the syntax errors that can be @@ -857,8 +861,8 @@ scm_m_cond (SCM expr, SCM env) } -SCM_SYNTAX(s_define, "define", scm_i_makbimacro, scm_m_define); -SCM_GLOBAL_SYMBOL(scm_sym_define, s_define); +SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define); +SCM_GLOBAL_SYMBOL (scm_sym_define, s_define); /* Guile provides an extension to R5RS' define syntax to represent function * currying in a compact way. With this extension, it is allowed to write @@ -879,14 +883,13 @@ SCM_GLOBAL_SYMBOL(scm_sym_define, s_define); */ /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS * module that does not implement this extension. */ -SCM -scm_m_define (SCM expr, SCM env) +static SCM +canonicalize_define (const SCM expr) { SCM body; SCM variable; const SCM cdr_expr = SCM_CDR (expr); - ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); body = SCM_CDR (cdr_expr); @@ -910,9 +913,28 @@ scm_m_define (SCM expr, SCM env) ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr); + SCM_SETCAR (cdr_expr, variable); + SCM_SETCDR (cdr_expr, body); + return expr; +} + +SCM +scm_m_define (SCM expr, SCM env) +{ + SCM canonical_definition; + SCM cdr_canonical_definition; + SCM body; + + ASSERT_SYNTAX (scm_ilength (expr) >= 0, s_bad_expression, expr); + + canonical_definition = canonicalize_define (expr); + cdr_canonical_definition = SCM_CDR (canonical_definition); + body = SCM_CDR (cdr_canonical_definition); + if (SCM_TOP_LEVEL (env)) { SCM var; + const SCM variable = SCM_CAR (cdr_canonical_definition); const SCM value = scm_eval_car (body, env); if (SCM_REC_PROCNAMES_P) { @@ -930,10 +952,8 @@ scm_m_define (SCM expr, SCM env) } else { - SCM_SETCAR (expr, SCM_IM_DEFINE); - SCM_SETCAR (cdr_expr, variable); - SCM_SETCDR (cdr_expr, body); - return expr; + SCM_SETCAR (canonical_definition, SCM_IM_DEFINE); + return canonical_definition; } } From 6da1534c0bfb9641cc4ac1b03e35f9e133678e44 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 3 Nov 2003 00:52:32 +0000 Subject: [PATCH 076/239] * misc-modules.texi (File Tree Walk): New chapter. --- doc/ref/misc-modules.texi | 177 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 177 insertions(+) diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index 6f262701e..76b40e62c 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -421,6 +421,183 @@ Test whether obj is a compiled regular expression. @end deffn +@node File Tree Walk +@chapter File Tree Walk +@cindex file tree walk + +The functions in this section traverse a tree of files and +directories, in a fashion similar to the C @code{ftw} and @code{nftw} +routines (@pxref{Working with Directory Trees,,, libc, GNU C Library +Reference Manual}). + +@example +(use-modules (ice-9 ftw)) +@end example +@sp 1 + +@defun ftw startname proc ['hash-size n] +Walk the filesystem tree descending from @var{startname}, calling +@var{proc} for each file and directory. + +Hard links and symbolic links are followed. A file or directory is +reported to @var{proc} only once, and skipped if seen again in another +place. One consequence of this is that @code{ftw} is safe against +circularly linked directory structures. + +Each @var{proc} call is @code{(@var{proc} filename statinfo flag)} and +it should return @code{#t} to continue, or any other value to stop. + +@var{filename} is the item visited, being @var{startname} plus a +further path and the name of the item. @var{statinfo} is the return +from @code{stat} (@pxref{File System}) on @var{filename}. @var{flag} +is one of the following symbols, + +@table @code +@item regular +@var{filename} is a file, this includes special files like devices, +named pipes, etc. + +@item directory +@var{filename} is a directory. + +@item invalid-stat +An error occurred when calling @code{stat}, so nothing is known. +@var{statinfo} is @code{#f} in this case. + +@item directory-not-readable +@var{filename} is a directory, but one which cannot be read and hence +won't be recursed into. + +@item symlink +@var{filename} is a dangling symbolic link. Symbolic links are +normally followed and their target reported, the link itself is +reported if the target does not exist. +@end table + +The return value from @code{ftw} is @code{#t} if it ran to completion, +or otherwise the non-@code{#t} value from @var{proc} which caused the +stop. + +Optional argument symbol @code{hash-size} and an integer can be given +to set the size of the hash table used to track items already visited. +(@pxref{Hash Table Reference}) + +@c Actually, it's probably safe to escape from ftw, just need to +@c check it. +@c +In the current implementation, returning non-@code{#t} from @var{proc} +is the only valid way to terminate @code{ftw}. @var{proc} must not +use @code{throw} or similar to escape. +@end defun + + +@defun nftw startname proc ['chdir] ['depth] ['hash-size n] ['mount] ['physical] +Walk the filesystem tree starting at @var{startname}, calling +@var{proc} for each file and directory. @code{nftw} has extra +features over the basic @code{ftw} described above. + +Hard links and symbolic links are followed, but a file or directory is +reported to @var{proc} only once, and skipped if seen again in another +place. One consequence of this is that @code{nftw} is safe against +circular linked directory structures. + +Each @var{proc} call is @code{(@var{proc} filename statinfo flag +basename level)} and it should return @code{#t} to continue, or any +other value to stop. + +@var{filename} is the item visited, being @var{startname} plus a +further path and the name of the item. @var{statinfo} is the return +from @code{stat} on @var{filename} (@pxref{File System}). +@var{basename} it the item name without any path. @var{level} is an +integer giving the directory nesting level, starting from 0 for the +contents of @var{startname} (or that item itself if it's a file). +@var{flag} is one of the following symbols, + +@table @code +@item regular +@var{filename} is a file, this includes special files like devices, +named pipes, etc. + +@item directory +@var{filename} is a directory. + +@item directory-processed +@var{filename} is a directory, and its contents have all been visited. +This flag is given instead of @code{directory} when the @code{depth} +option below is used. + +@item invalid-stat +An error occurred when applying @code{stat} to @var{filename}, so +nothing is known about it. @var{statinfo} is @code{#f} in this case. + +@item directory-not-readable +@var{filename} is a directory, but one which cannot be read and hence +won't be recursed into. + +@item symlink +@var{filename} is a dangling symbolic link. Symbolic links are +normally followed and their target reported, the link itself is +reported if the target does not exist. + +Under the @code{physical} option described below, @code{symlink} is +instead given for symbolic links whose target does exist. + +@item stale-symlink +Under the @code{physical} option described below, this indicates +@var{filename} is a dangling symbolic link, meaning its target does +not exist. Without the @code{physical} option plain @code{symlink} +indicates this. +@end table + +The following optional arguments can be given to modify the way +@code{nftw} works. Each is passed as a symbol (and @code{hash-size} +takes a following integer value). + +@table @asis +@item @code{chdir} +Change to the directory containing the item before calling @var{proc}. +When @code{nftw} returns the original current directory is restored. + +Under this option, generally the @var{basename} parameter should be +used to access the item in each @var{proc} call. The @var{filename} +parameter still has a path as normal and this will only be valid if +the @var{startname} directory was absolute. + +@item @code{depth} +Visit files ``depth first'', meaning @var{proc} is called for the +contents of each directory before it's called for the directory +itself. Normally a directory is reported first, then its contents. + +Under this option, the @var{flag} to @var{proc} for a directory is +@code{directory-processed} instead of @code{directory}. + +@item @code{hash-size @var{n}} +Set the size of the hash table used to track items already visited. +(@pxref{Hash Table Reference}) + +@item @code{mount} +Don't cross a mount point, meaning only visit items on the same +filesystem as @var{startname}. (Ie.@: the same @code{stat:dev}.) + +@item @code{physical} +Don't follow symbolic links, instead report them to @var{proc} as +@code{symlink}, and report dangling links as @code{stale-symlink}. +@end table + +The return value from @code{nftw} is @code{#t} if it ran to +completion, or otherwise the non-@code{#t} value from @var{proc} which +caused the stop. + +@c For reference, one reason not to esacpe is that the current +@c directory is not saved and restored with dynamic-wind. Maybe +@c changing that would be enough to allow escaping. +@c +In the current implementation, returning non-@code{#t} from @var{proc} +is the only valid way to terminate @code{ftw}. @var{proc} must not +use @code{throw} or similar to escape. +@end defun + + @c Local Variables: @c TeX-master: "guile.texi" @c End: From e1bc8c34d32f4350c9db66922d0c366cb6fdb807 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 3 Nov 2003 00:53:08 +0000 Subject: [PATCH 077/239] * misc-modules.texi (File Tree Walk): New chapter. * guile.texi: Add it. --- doc/ref/guile.texi | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index ce25a7f6c..96060e614 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -129,7 +129,7 @@ notice identical to this one except for the removal of this paragraph @comment The title is printed in a large font. @title Guile Reference Manual @subtitle Edition @value{MANUAL-EDITION}, for use with Guile @value{VERSION} -@subtitle $Id: guile.texi,v 1.24 2003-08-29 23:02:36 kryde Exp $ +@subtitle $Id: guile.texi,v 1.25 2003-11-03 00:53:08 kryde Exp $ @c AUTHORS @@ -270,6 +270,7 @@ Part V: Guile Modules * Pretty Printing:: Nicely formatting Scheme objects for output. * Formatted Output:: The @code{format} procedure. * Rx Regexps:: The Rx regular expression library. +* File Tree Walk:: Traversing the file system. * Expect:: Controlling interactive programs with Guile. * The Scheme shell (scsh):: Using scsh interfaces in Guile. From a5fda890f5b9eb07240355924ccaf78ba842bcaf Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 3 Nov 2003 00:55:47 +0000 Subject: [PATCH 078/239] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index a566f58ef..4490c8645 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2003-11-03 Kevin Ryde + + * misc-modules.texi (File Tree Walk): New chapter. + * guile.texi: Add it. + 2003-10-18 Kevin Ryde * gh.texi (Calling Scheme procedures from C, scm transition summary): From ced8edb0f9545e7e37ec62cf7ab6c0c1c66fe1db Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 8 Nov 2003 08:11:14 +0000 Subject: [PATCH 079/239] * libguile/eval.c (s_missing_body_expression): New static identifier. (s_body): Removed. (scm_m_expand_body): Fixed core dump when passing a body with defines, but without expressions (see additions to syntax.test). Use ASSERT_SYNTAX to signal syntax errors. * test-suite/tests/syntax.test (exception:missing-body-expr): New. Renamed section 'define' to 'top-level define' and added a new section 'internal define' with some tests. --- libguile/ChangeLog | 10 +++++++ libguile/eval.c | 13 ++++++--- test-suite/ChangeLog | 7 +++++ test-suite/tests/syntax.test | 51 +++++++++++++++++++++++++++++++++--- 4 files changed, 75 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cab50b9c2..64c294fde 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2003-11-08 Dirk Herrmann + + * eval.c (s_missing_body_expression): New static identifier. + + (s_body): Removed. + + (scm_m_expand_body): Fixed core dump when passing a body with + defines, but without expressions (see additions to syntax.test). + Use ASSERT_SYNTAX to signal syntax errors. + 2003-11-02 Dirk Herrmann * eval.c (canonicalize_define): New static helper function. diff --git a/libguile/eval.c b/libguile/eval.c index e86b8e9d0..266066ef7 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -114,6 +114,12 @@ static const char s_expression[] = "Missing or extra expression in"; * context, a 'Missing expression' error is signalled. */ static const char s_missing_expression[] = "Missing expression in"; +/* A body may hold an arbitrary number of internal defines, followed by a + * non-empty sequence of expressions. If a body with an empty sequence of + * expressions is detected, a 'Missing body expression' error is signalled. + */ +static const char s_missing_body_expression[] = "Missing body expression in"; + /* If a form is detected that holds more expressions than are allowed in that * context, an 'Extra expression' error is signalled. */ static const char s_extra_expression[] = "Extra expression in"; @@ -408,7 +414,6 @@ SCM_REC_MUTEX (source_mutex); static const char s_test[] = "bad test"; -static const char s_body[] = "bad body"; static const char s_bindings[] = "bad bindings"; static const char s_duplicate_bindings[] = "duplicate bindings"; static const char s_variable[] = "bad variable"; @@ -1826,7 +1831,6 @@ SCM scm_m_expand_body (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig), defs = SCM_EOL; - char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2; while (SCM_NIMP (x)) { @@ -1861,6 +1865,10 @@ scm_m_expand_body (SCM xorig, SCM env) } } + /* FIXME: xorig is already partially memoized and does not hold information + * about the file location. */ + ASSERT_SYNTAX (SCM_CONSP (x), s_missing_body_expression, xorig); + if (!SCM_NULLP (defs)) { SCM rvars, inits, body, letrec; @@ -1873,7 +1881,6 @@ scm_m_expand_body (SCM xorig, SCM env) } else { - SCM_ASSYNT (SCM_CONSP (x), s_body, what); SCM_SETCAR (xorig, SCM_CAR (x)); SCM_SETCDR (xorig, SCM_CDR (x)); } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 0367d4da9..bc8597f7e 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,10 @@ +2003-11-08 Dirk Herrmann + + * tests/syntax.test (exception:missing-body-expr): New. + + Renamed section 'define' to 'top-level define' and added a new + section 'internal define' with some tests. + 2003-11-01 Dirk Herrmann * tests/syntax.test (exception:missing/extra-expr-misc): Removed. diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 9691f2bfc..3a0b8c982 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -28,6 +28,8 @@ (cons 'syntax-error "Missing or extra expression")) (define exception:missing-expr (cons 'syntax-error "Missing expression")) +(define exception:missing-body-expr + (cons 'syntax-error "Missing body expression")) (define exception:extra-expr (cons 'syntax-error "Extra expression")) (define exception:illegal-empty-combination @@ -588,13 +590,15 @@ (eval '(case 1 (else #f) ((1) #t)) (interaction-environment))))) -(with-test-prefix "define" +(with-test-prefix "top-level define" (with-test-prefix "currying" (pass-if "(define ((foo)) #f)" - (define ((foo)) #t) - ((foo)))) + (eval '(begin + (define ((foo)) #t) + ((foo))) + (interaction-environment)))) (with-test-prefix "missing or extra expressions" @@ -603,6 +607,47 @@ (eval '(define) (interaction-environment))))) +(with-test-prefix "internal define" + + (pass-if "internal defines become letrec" + (eval '(let ((a identity) (b identity) (c identity)) + (define (a x) (if (= x 0) 'a (b (- x 1)))) + (define (b x) (if (= x 0) 'b (c (- x 1)))) + (define (c x) (if (= x 0) 'c (a (- x 1)))) + (and (eq? 'a (a 0) (a 3)) + (eq? 'b (a 1) (a 4)) + (eq? 'c (a 2) (a 5)))) + (interaction-environment))) + + (expect-fail "internal defines with begin" + (false-if-exception + (eval '(let ((a identity) (b identity) (c identity)) + (define (a x) (if (= x 0) 'a (b (- x 1)))) + (begin + (define (b x) (if (= x 0) 'b (c (- x 1))))) + (define (c x) (if (= x 0) 'c (a (- x 1)))) + (and (eq? 'a (a 0) (a 3)) + (eq? 'b (a 1) (a 4)) + (eq? 'c (a 2) (a 5)))) + (interaction-environment)))) + + (expect-fail "internal defines with empty begin" + (false-if-exception + (eval '(let ((a identity) (b identity) (c identity)) + (define (a x) (if (= x 0) 'a (b (- x 1)))) + (begin) + (define (b x) (if (= x 0) 'b (c (- x 1)))) + (define (c x) (if (= x 0) 'c (a (- x 1)))) + (and (eq? 'a (a 0) (a 3)) + (eq? 'b (a 1) (a 4)) + (eq? 'c (a 2) (a 5)))) + (interaction-environment)))) + + (pass-if-exception "missing body expression" + exception:missing-body-expr + (eval '(let () (define x #t)) + (interaction-environment)))) + (with-test-prefix "set!" (with-test-prefix "missing or extra expressions" From f4de8d110eaac0682741efe5dcbcc74c03354f1a Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 8 Nov 2003 20:27:41 +0000 Subject: [PATCH 080/239] (Random): In random, use @code for *random-state*. Reported by Stephen Compall. --- doc/ref/scheme-data.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/scheme-data.texi b/doc/ref/scheme-data.texi index 7fa4ac6bd..f45170773 100755 --- a/doc/ref/scheme-data.texi +++ b/doc/ref/scheme-data.texi @@ -1245,7 +1245,7 @@ distribution. The optional argument @var{state} must be of the type produced by @code{seed->random-state}. It defaults to the value of the -variable @var{*random-state*}. This object is used to maintain +variable @code{*random-state*}. This object is used to maintain the state of the pseudo-random-number generator and is altered as a side effect of the random operation. @end deffn From a07b5c18cb297137ee87567d552139acbd2c2f4b Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 8 Nov 2003 20:29:24 +0000 Subject: [PATCH 081/239] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 4490c8645..25e96472f 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2003-11-09 Kevin Ryde + + * scheme-data.texi (Random): In random, use @code for *random-state*. + Reported by Stephen Compall. + 2003-11-03 Kevin Ryde * misc-modules.texi (File Tree Walk): New chapter. From 385dbc8b9cb1231d2ba612d2a7f6241ff5bb0ec2 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 8 Nov 2003 22:07:50 +0000 Subject: [PATCH 082/239] (Pretty Printing): Add new keyword options, break example to avoid long line. --- doc/ref/misc-modules.texi | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index 76b40e62c..aac4c3a58 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -21,7 +21,8 @@ how @code{pretty-print} will format the output, see the following: @lisp (pretty-print '(define (foo) (lambda (x) -(cond ((zero? x) #t) ((negative? x) -x) (else (if (= x 1) 2 (* x x x))))))) +(cond ((zero? x) #t) ((negative? x) -x) (else +(if (= x 1) 2 (* x x x))))))) @print{} (define (foo) (lambda (x) @@ -30,10 +31,26 @@ how @code{pretty-print} will format the output, see the following: (else (if (= x 1) 2 (* x x x)))))) @end lisp -@deffn {Scheme Procedure} pretty-print obj [port] +@deffn {Scheme Procedure} pretty-print obj [port] [keyword-options] Print the textual representation of the Scheme object @var{obj} to @var{port}. @var{port} defaults to the current output port, if not given. + +The further @var{keyword-options} are keywords and parameters as +follows, + +@table @asis +@item @nicode{#:display?} @var{flag} +If @var{flag} is true then print using @code{display}. The default is +@code{#f} which means use @code{write} style. (@pxref{Writing}) + +@item @nicode{#:per-line-prefix} @var{string} +Print the given @var{string} as a prefix on each line. The default is +no prefix. + +@item @nicode{#:width} @var{columns} +Print within the given @var{columns}. The default is 79. +@end table @end deffn Beware: Since @code{pretty-print} uses it's own write procedure, it's From 60e25dc4cd89b7881b41d32beaa73689a2e5012d Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 8 Nov 2003 22:15:07 +0000 Subject: [PATCH 083/239] * srfi-modules.texi (SRFI-1 Filtering and Partitioning): Move filter and filter! ... * scheme-compound.texi (List Modification): ... to here, now that they're implemented in the core. --- doc/ref/scheme-compound.texi | 10 ++++++++++ doc/ref/srfi-modules.texi | 11 ++--------- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/doc/ref/scheme-compound.texi b/doc/ref/scheme-compound.texi index 6064c8c52..b2fb11e42 100644 --- a/doc/ref/scheme-compound.texi +++ b/doc/ref/scheme-compound.texi @@ -461,6 +461,16 @@ Like @code{delete!}, but only deletes the first occurrence of @code{equal?}. See also @code{delq1!} and @code{delv1!}. @end deffn +@deffn {Scheme Procedure} filter pred lst +@deffnx {Scheme Procedure} filter! pred lst +Return a list containing all elements from @var{lst} which satisfy the +predicate @var{pred}. The elements in the result list have the same +order as in @var{lst}. The order in which @var{pred} is applied to +the list elements is not specified. + +@code{filter!} is allowed, but not required to modify the structure of +@end deffn + @node List Searching @subsection List Searching diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 0e0eb0917..82209ffe7 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -594,15 +594,8 @@ specific condition. Partitioning a list means to make two groups of list elements, one which contains the elements satisfying a condition, and the other for the elements which don't. -@deffn {Scheme Procedure} filter pred lst -@deffnx {Scheme Procedure} filter! pred lst -Return a list containing all elements from @var{lst} which satisfy the -predicate @var{pred}. The elements in the result list have the same -order as in @var{lst}. The order in which @var{pred} is applied to -the list elements is not specified. - -@code{filter!} is allowed, but not required to modify the structure of -@end deffn +The @code{filter} and @code{filter!} functions are implemented in the +Guile core, @xref{List Modification}. @deffn {Scheme Procedure} partition pred lst @deffnx {Scheme Procedure} partition! pred lst From 9e375910176a1f4a9dd3488c8772deff622feb9a Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 8 Nov 2003 22:18:01 +0000 Subject: [PATCH 084/239] (scm_dynamic_unlink): Need scm_list_1 on error message argument. Reported by Mike Gran. --- libguile/dynl.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/dynl.c b/libguile/dynl.c index 443102ad2..827728bef 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -179,7 +179,7 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, /*fixme* GC-problem */ SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj); if (DYNL_HANDLE (dobj) == NULL) { - SCM_MISC_ERROR ("Already unlinked: ~S", dobj); + SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj)); } else { sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME); SET_DYNL_HANDLE (dobj, NULL); From 4d3526d09680ad599f7689a296a4d3448f2c3567 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 8 Nov 2003 22:18:33 +0000 Subject: [PATCH 085/239] Add a copyright year. --- libguile/dynl.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/dynl.c b/libguile/dynl.c index 827728bef..f027c20f8 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -1,6 +1,7 @@ /* dynl.c - dynamic linking * - * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002 Free Software Foundation, Inc. + * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002, + * 2003 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public From c2337a6178282861418d9b277b2a6084a8120f66 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 8 Nov 2003 22:19:24 +0000 Subject: [PATCH 086/239] *** empty log message *** --- doc/ref/ChangeLog | 8 ++++++++ libguile/ChangeLog | 5 +++++ 2 files changed, 13 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 25e96472f..828b06e4c 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,8 +1,16 @@ 2003-11-09 Kevin Ryde + * misc-modules.texi (Pretty Printing): Add new keyword options, break + example to avoid long line. + * scheme-data.texi (Random): In random, use @code for *random-state*. Reported by Stephen Compall. + * srfi-modules.texi (SRFI-1 Filtering and Partitioning): Move filter + and filter! ... + * scheme-compound.texi (List Modification): ... to here, now that + they're implemented in the core. + 2003-11-03 Kevin Ryde * misc-modules.texi (File Tree Walk): New chapter. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 64c294fde..8273f36e6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-11-09 Kevin Ryde + + * dynl.c (scm_dynamic_unlink): Need scm_list_1 on error message + argument. Reported by Mike Gran. + 2003-11-08 Dirk Herrmann * eval.c (s_missing_body_expression): New static identifier. From 328dc9a3ef372c0e1a439afabebd44d0ab1edaa9 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 9 Nov 2003 08:10:58 +0000 Subject: [PATCH 087/239] * eval.c, eval.h (scm_m_expand_body, m_expand_body): Deprecated public use of scm_m_expand_body in eval.h. In eval.c, renamed scm_m_expand_body to m_expand_body and made it static. Added deprecated wrapper scm_m_expand_body. (scm_eval_body, SCM_CEVAL, SCM_APPLY): Use m_expand_body instead of scm_m_expand_body. --- NEWS | 11 +++++++++-- libguile/ChangeLog | 10 ++++++++++ libguile/eval.c | 24 +++++++++++++++++++----- libguile/eval.h | 4 +++- 4 files changed, 41 insertions(+), 8 deletions(-) diff --git a/NEWS b/NEWS index 14e74b595..b8a6849dd 100644 --- a/NEWS +++ b/NEWS @@ -117,7 +117,7 @@ while the scripting code runs single-threadedly. We now use a modified version of libltdl that allows us to make improvements to it without having to rely on libtool releases. -* Changes to the standalone interpreter +* Changes to the stand-alone interpreter ** New command line option `--no-debug'. @@ -894,6 +894,12 @@ SCM_EVALIM, SCM_XEVAL, SCM_XEVALCAR These macros were used in the implementation of the evaluator. It's unlikely that they have been used by user code. +** Deprecated helper functions for evaluation and application: +scm_m_expand_body + +These functions were used in the implementation of the evaluator. It's +unlikely that they have been used by user code. + ** Deprecated macros for iloc handling: SCM_ILOC00, SCM_IDINC, SCM_IDSTMSK These macros were used in the implementation of the evaluator. It's unlikely @@ -908,7 +914,7 @@ SCM_IM_1_IFY, SCM_GC_SET_ALLOCATED, scm_debug_newcell, scm_debug_newcell2, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS, -*top-level-lookup-closure*, scm_top_level_lookup_closure_var, +scm_top_level_lookup_closure_var, *top-level-lookup-closure*, scm_system_transformer, scm_eval_3, scm_eval2, root_module_lookup_closure, SCM_SLOPPY_STRINGP, SCM_RWSTRINGP, scm_read_only_string_p, scm_make_shared_substring, scm_tc7_substring, @@ -931,6 +937,7 @@ scm_istring2number, scm_vtable_index_vcell, scm_si_vcell, SCM_ECONSP, SCM_NECONSP, SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL, SCM_GLOC_VAL_LOC, scm_make_gloc, scm_gloc_p, scm_tc16_variable + Changes since Guile 1.4: * Changes to the distribution diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8273f36e6..cabb9a423 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2003-11-09 Dirk Herrmann + + * eval.c, eval.h (scm_m_expand_body, m_expand_body): Deprecated + public use of scm_m_expand_body in eval.h. In eval.c, renamed + scm_m_expand_body to m_expand_body and made it static. Added + deprecated wrapper scm_m_expand_body. + + (scm_eval_body, SCM_CEVAL, SCM_APPLY): Use m_expand_body instead + of scm_m_expand_body. + 2003-11-09 Kevin Ryde * dynl.c (scm_dynamic_unlink): Need scm_list_1 on error message diff --git a/libguile/eval.c b/libguile/eval.c index 266066ef7..901fa93c8 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -58,6 +58,7 @@ char *alloca (); #include "libguile/async.h" #include "libguile/continuations.h" #include "libguile/debug.h" +#include "libguile/deprecation.h" #include "libguile/dynwind.h" #include "libguile/eq.h" #include "libguile/feature.h" @@ -1827,8 +1828,8 @@ scm_m_undefine (SCM expr, SCM env) #endif -SCM -scm_m_expand_body (SCM xorig, SCM env) +static SCM +m_expand_body (const SCM xorig, const SCM env) { SCM x = SCM_CDR (xorig), defs = SCM_EOL; @@ -1888,6 +1889,19 @@ scm_m_expand_body (SCM xorig, SCM env) return xorig; } +#if (SCM_ENABLE_DEPRECATED == 1) + +/* Deprecated in guile 1.7.0 on 2003-11-09. */ +SCM +scm_m_expand_body (SCM exprs, SCM env) +{ + scm_c_issue_deprecation_warning + ("`scm_m_expand_body' is deprecated."); + return m_expand_body (exprs, env); +} + +#endif + SCM scm_macroexp (SCM x, SCM env) @@ -2301,7 +2315,7 @@ scm_eval_body (SCM code, SCM env) scm_rec_mutex_lock (&source_mutex); /* check for race condition */ if (SCM_ISYMP (SCM_CAR (code))) - code = scm_m_expand_body (code, env); + code = m_expand_body (code, env); scm_rec_mutex_unlock (&source_mutex); goto again; } @@ -2699,7 +2713,7 @@ dispatch: scm_rec_mutex_lock (&source_mutex); /* check for race condition */ if (SCM_ISYMP (SCM_CAR (x))) - x = scm_m_expand_body (x, env); + x = m_expand_body (x, env); scm_rec_mutex_unlock (&source_mutex); goto nontoplevel_begin; } @@ -4350,7 +4364,7 @@ tail: scm_rec_mutex_lock (&source_mutex); /* check for race condition */ if (SCM_ISYMP (SCM_CAR (proc))) - proc = scm_m_expand_body (proc, args); + proc = m_expand_body (proc, args); scm_rec_mutex_unlock (&source_mutex); goto again; } diff --git a/libguile/eval.h b/libguile/eval.h index c6f7a9bc3..3f6acb529 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -186,7 +186,6 @@ SCM_API scm_t_trampoline_2 scm_trampoline_2 (SCM proc); SCM_API SCM scm_nconc2last (SCM lst); SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_dapply (SCM proc, SCM arg1, SCM args); -SCM_API SCM scm_m_expand_body (SCM xorig, SCM env); SCM_API SCM scm_macroexp (SCM x, SCM env); SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args); @@ -210,6 +209,9 @@ SCM_API void scm_init_eval (void); SCM_API SCM scm_m_undefine (SCM x, SCM env); +/* Deprecated in guile 1.7.0 on 2003-11-09. */ +SCM_API SCM scm_m_expand_body (SCM xorig, SCM env); + #endif From 430b840193ce8048dd27c2a6bef25415ae98cffd Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 9 Nov 2003 08:47:19 +0000 Subject: [PATCH 088/239] * eval.c (scm_m_body, m_body, scm_m_lambda, memoize_named_let, scm_m_let, scm_m_letrec, m_expand_body): Renamed static function scm_m_body to m_body. --- libguile/ChangeLog | 6 ++++++ libguile/eval.c | 20 ++++++++++---------- 2 files changed, 16 insertions(+), 10 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cabb9a423..d395477ab 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2003-11-09 Dirk Herrmann + + * eval.c (scm_m_body, m_body, scm_m_lambda, memoize_named_let, + scm_m_let, scm_m_letrec, m_expand_body): Renamed static function + scm_m_body to m_body. + 2003-11-09 Dirk Herrmann * eval.c, eval.h (scm_m_expand_body, m_expand_body): Deprecated diff --git a/libguile/eval.c b/libguile/eval.c index 901fa93c8..793a28ce2 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -694,7 +694,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); * It is assumed that the calling expression has already made sure that the * body is a proper list. */ static SCM -scm_m_body (SCM op, SCM exprs) +m_body (SCM op, SCM exprs) { /* Don't add another ISYM if one is present already. */ if (SCM_ISYMP (SCM_CAR (exprs))) @@ -1161,7 +1161,7 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED) cddr_expr = SCM_CDR (cdr_expr); documentation = (length >= 3 && SCM_STRINGP (SCM_CAR (cddr_expr))); body = documentation ? SCM_CDR (cddr_expr) : cddr_expr; - new_body = scm_m_body (SCM_IM_LAMBDA, body); + new_body = m_body (SCM_IM_LAMBDA, body); SCM_SETCAR (expr, SCM_IM_LAMBDA); if (documentation) @@ -1251,13 +1251,13 @@ memoize_named_let (const SCM expr, const SCM env SCM_UNUSED) { const SCM let_body = SCM_CDR (cddr_expr); - const SCM lambda_body = scm_m_body (SCM_IM_LET, let_body); + const SCM lambda_body = m_body (SCM_IM_LET, let_body); const SCM lambda_tail = scm_cons (variables, lambda_body); const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail); const SCM rvar = scm_list_1 (name); const SCM init = scm_list_1 (lambda_form); - const SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name)); + const SCM body = m_body (SCM_IM_LET, scm_list_1 (name)); const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body)); const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail); return scm_cons_source (expr, letrec_form, inits); @@ -1287,7 +1287,7 @@ scm_m_let (SCM expr, SCM env) if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings))) { /* Special case: no bindings or single binding => let* is faster. */ - const SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); + const SCM body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env); } else @@ -1298,7 +1298,7 @@ scm_m_let (SCM expr, SCM env) transform_bindings (bindings, expr, &rvariables, &inits); { - const SCM new_body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); + const SCM new_body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); const SCM new_tail = scm_cons2 (rvariables, inits, new_body); SCM_SETCAR (expr, SCM_IM_LET); SCM_SETCDR (expr, new_tail); @@ -1336,7 +1336,7 @@ scm_m_letstar (SCM expr, SCM env SCM_UNUSED) } new_bindings = scm_reverse_x (new_bindings, SCM_UNDEFINED); - new_body = scm_m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr)); + new_body = m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr)); return scm_cons2 (SCM_IM_LETSTAR, new_bindings, new_body); } @@ -1357,7 +1357,7 @@ scm_m_letrec (SCM expr, SCM env) if (SCM_NULLP (bindings)) { /* no bindings, let* is executed faster */ - SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); + SCM body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env); } else @@ -1368,7 +1368,7 @@ scm_m_letrec (SCM expr, SCM env) check_bindings (bindings, expr); transform_bindings (bindings, expr, &rvariables, &inits); - new_body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); + new_body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body)); } } @@ -1875,7 +1875,7 @@ m_expand_body (const SCM xorig, const SCM env) SCM rvars, inits, body, letrec; check_bindings (defs, xorig); transform_bindings (defs, xorig, &rvars, &inits); - body = scm_m_body (SCM_IM_DEFINE, x); + body = m_body (SCM_IM_DEFINE, x); letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); SCM_SETCAR (xorig, letrec); SCM_SETCDR (xorig, SCM_EOL); From 560434b36940df287672ef1db6bafe46008a8b7e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 9 Nov 2003 19:07:41 +0000 Subject: [PATCH 089/239] * tests/optargs.test: Wrap tests in module (test-suite test-). Rewrite test to be R5RS conforming. * tests/syntax.test: Added test to check correct handling of internal defines. --- test-suite/ChangeLog | 9 +++++++++ test-suite/tests/optargs.test | 15 +++++++++------ test-suite/tests/syntax.test | 10 ++++++++++ 3 files changed, 28 insertions(+), 6 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index bc8597f7e..036069e55 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,12 @@ +2003-11-09 Dirk Herrmann + + * tests/optargs.test: Wrap tests in module (test-suite + test-). Rewrite test to be R5RS + conforming. + + * tests/syntax.test: Added test to check correct handling of + internal defines. + 2003-11-08 Dirk Herrmann * tests/syntax.test (exception:missing-body-expr): New. diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test index 4f356b020..ba2fe8596 100644 --- a/test-suite/tests/optargs.test +++ b/test-suite/tests/optargs.test @@ -18,12 +18,15 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA -(use-modules (test-suite lib) - (ice-9 optargs)) +(define-module (test-suite test-optargs) + :use-module (test-suite lib) + :use-module (ice-9 optargs)) (with-test-prefix "optional argument processing" - (define* (test-1 #:optional (x 0)) - (define d 1) ; local define - #t) (pass-if "local defines work with optional arguments" - (false-if-exception (test-1)))) + (eval '(begin + (define* (test-1 #:optional (x 0)) + (define d 1) ; local define + #t) + (false-if-exception (test-1))) + (interaction-environment)))) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 3a0b8c982..37a8fbe4b 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -643,6 +643,16 @@ (eq? 'c (a 2) (a 5)))) (interaction-environment)))) + (expect-fail "internal defines with macro application" + (false-if-exception + (eval '(begin + (defmacro a forms + (cons 'define forms)) + (let ((c identity) (x #t)) + (define (a x y) (and x y)) + (a (c x) (c x)))) + (interaction-environment)))) + (pass-if-exception "missing body expression" exception:missing-body-expr (eval '(let () (define x #t)) From 651f2c7854771245b2cf522db47f18db22c4b4f1 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 11 Nov 2003 23:09:23 +0000 Subject: [PATCH 090/239] Avoid duplicate binding warnings from (lang elisp) modules. --- lang/elisp/ChangeLog | 6 ++++++ lang/elisp/internals/format.scm | 4 ++-- lang/elisp/internals/load.scm | 4 ++-- lang/elisp/internals/signal.scm | 2 +- 4 files changed, 11 insertions(+), 5 deletions(-) diff --git a/lang/elisp/ChangeLog b/lang/elisp/ChangeLog index 1f976e58e..57a99e8a4 100644 --- a/lang/elisp/ChangeLog +++ b/lang/elisp/ChangeLog @@ -1,3 +1,9 @@ +2003-11-01 Neil Jerram + + * internals/format.scm (format), internals/signal.scm (error), + internals/load.scm (load): Export using #:replace to avoid + duplicate binding warnings. + 2003-01-05 Marius Vollmer * primitives/Makefile.am (elisp_sources): Added char-table.scm. diff --git a/lang/elisp/internals/format.scm b/lang/elisp/internals/format.scm index 6862dab27..7ea562a2e 100644 --- a/lang/elisp/internals/format.scm +++ b/lang/elisp/internals/format.scm @@ -4,8 +4,8 @@ #:use-module ((ice-9 format) #:select ((format . scheme:format))) #:use-module (lang elisp internals fset) #:use-module (lang elisp internals signal) - #:export (format - message)) + #:replace (format) + #:export (message)) (define (format control-string . args) diff --git a/lang/elisp/internals/load.scm b/lang/elisp/internals/load.scm index 88d14b802..e55c8b50f 100644 --- a/lang/elisp/internals/load.scm +++ b/lang/elisp/internals/load.scm @@ -3,8 +3,8 @@ #:use-module (lang elisp internals signal) #:use-module (lang elisp internals format) #:use-module (lang elisp internals evaluation) - #:export (load-path - load)) + #:replace (load) + #:export (load-path)) (define load-path '("/usr/share/emacs/20.7/lisp/" "/usr/share/emacs/20.7/lisp/emacs-lisp/")) diff --git a/lang/elisp/internals/signal.scm b/lang/elisp/internals/signal.scm index 09e2c05a6..7055a9b92 100644 --- a/lang/elisp/internals/signal.scm +++ b/lang/elisp/internals/signal.scm @@ -1,7 +1,7 @@ (define-module (lang elisp internals signal) #:use-module (lang elisp internals format) + #:replace (error) #:export (signal - error wta)) (define (signal error-symbol data) From 9529c681ed22fab3cb50b072338b1c2685b56ea7 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 11 Nov 2003 23:12:48 +0000 Subject: [PATCH 091/239] Big comment added. --- ice-9/debugger/utils.scm | 42 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/ice-9/debugger/utils.scm b/ice-9/debugger/utils.scm index ce1fb83ae..a25290f56 100644 --- a/ice-9/debugger/utils.scm +++ b/ice-9/debugger/utils.scm @@ -10,6 +10,48 @@ write-state-long write-state-short)) +;;; Procedures in this module print information about a stack frame. +;;; The available information is as follows. +;;; +;;; * Source code location. +;;; +;;; For an evaluation frame, this is the location recorded at the time +;;; that the expression being evaluated was read, if the 'positions +;;; read option was enabled at that time. +;;; +;;; For an application frame, I'm not yet sure. Some applications +;;; seem to have associated source expressions. +;;; +;;; * Whether frame is still evaluating its arguments. +;;; +;;; Only applies to an application frame. For example, an expression +;;; like `(+ (* 2 3) 4)' goes through the following stages of +;;; evaluation. +;;; +;;; (+ (* 2 3) 4) -- evaluation +;;; [+ ... -- application; the car of the evaluation +;;; has been evaluated and found to be a +;;; procedure; before this procedure can +;;; be applied, its arguments must be evaluated +;;; [+ 6 ... -- same application after evaluating the +;;; first argument +;;; [+ 6 4] -- same application after evaluating all +;;; arguments +;;; 10 -- result +;;; +;;; * Whether frame is real or tail-recursive. +;;; +;;; If a frame is tail-recursive, its containing frame as shown by the +;;; debugger backtrace doesn't really exist as far as the Guile +;;; evaluator is concerned. The effect of this is that when a +;;; tail-recursive frame returns, it looks as though its containing +;;; frame returns at the same time. (And if the containing frame is +;;; also tail-recursive, _its_ containing frame returns at that time +;;; also, and so on ...) +;;; +;;; A `real' frame is one that is not tail-recursive. + + (define (write-state-short state) (let* ((frame (stack-ref (state-stack state) (state-index state))) (source (frame-source frame)) From 61bb5df48cb1974669ea4ea31818d13b5b4b8b02 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 11 Nov 2003 23:17:06 +0000 Subject: [PATCH 092/239] Pass trap type to debug-stack flags. --- ice-9/debugger/behaviour.scm | 53 ++++++++++++++++++++---------------- 1 file changed, 29 insertions(+), 24 deletions(-) diff --git a/ice-9/debugger/behaviour.scm b/ice-9/debugger/behaviour.scm index ddd14c466..b72a769dd 100644 --- a/ice-9/debugger/behaviour.scm +++ b/ice-9/debugger/behaviour.scm @@ -40,6 +40,7 @@ ;;; This module defines useful kinds of behaviour for breakpoints. +(define *trap* #f) (define *cont* #f) (define *frame* #f) (define *depth* #f) @@ -53,6 +54,7 @@ (add-hook! before-enter-frame-hook (lambda (cont tail? expr) (trc 'before-enter-frame-hook cont tail? expr) + (set! *trap* #:evaluation) (set! *cont* cont) (set! *frame* (last-stack-frame cont)) (set! *depth* (stack-length (make-stack cont))) @@ -64,6 +66,7 @@ (add-hook! before-apply-frame-hook (lambda (cont tail?) (trc 'before-apply-frame-hook cont tail?) + (set! *trap* #:application) (set! *cont* cont) (set! *frame* (last-stack-frame cont)) (set! *depth* (stack-length (make-stack cont))) @@ -75,6 +78,7 @@ (add-hook! before-exit-frame-hook (lambda (cont retval) (trc 'before-exit-frame-hook cont retval) + (set! *trap* #:return) (set! *cont* cont) (set! *frame* (last-stack-frame cont)) (set! *depth* (stack-length (make-stack cont))) @@ -87,12 +91,15 @@ (define (debug-if-flag-set) (if *debug-flag* - (begin + (let ((ds-flags (cons #:continuable + (if (eq? *trap* #:return) + (list *trap* *retval*) + (list *trap*))))) (for-each (lambda (msg) (display msg (debugger-output-port))) (reverse! *debug-entry-messages*)) (set! *debug-entry-messages* '()) - (debug-stack (make-stack *cont*) #:continuable)))) + (apply debug-stack (make-stack *cont*) ds-flags)))) (add-hook! after-enter-frame-hook debug-if-flag-set) @@ -177,22 +184,33 @@ (thunk)))))) (add-apply-frame-hook! apply))) -;;; at-step [COUNT [THUNK]] +;;; at-step [COUNT [THUNK [FILENAME]]] ;;; -;;; Install a thunk to run when we get to the COUNT'th next -;;; application or frame entry. COUNT defaults to 1; THUNK defaults -;;; to debug-here. +;;; Install THUNK to run on the COUNT'th next application, frame entry +;;; or frame exit. COUNT defaults to 1; THUNK defaults to debug-here. +;;; If FILENAME is specified and not #f, only frames that begin in the +;;; named file are counted. -(define* (at-step #:optional count thunk) +(define* (at-step #:optional count thunk filename) (or count (set! count 1)) (or thunk (set! thunk debug-here)) - (letrec ((step (lambda () + (letrec ((proc (lambda () + ;; Behaviour whenever we enter or exit a frame. (set! count (- count 1)) - (if (<= count 0) + (if (= count 0) (begin (remove-enter-frame-hook! step) (remove-apply-frame-hook! step) - (thunk)))))) + (thunk))))) + (step (lambda () + ;; Behaviour on frame entry: both execute the above + ;; and install it as an exit hook. + (if (or (not filename) + (equal? (current-file-name) filename)) + (begin + (proc) + (at-exit proc)))))) + (at-exit proc) (add-enter-frame-hook! step) (add-apply-frame-hook! step))) @@ -210,20 +228,7 @@ (and position (car position)))) (define* (at-next #:optional count thunk) - (or count (set! count 1)) - (or thunk (set! thunk debug-here)) - (let ((filename (current-file-name))) - (if filename - (letrec ((next (lambda () - (if (equal? (current-file-name) filename) - (begin - (set! count (- count 1)) - (if (<= count 0) - (begin - (remove-enter-frame-hook! next) - (thunk)))))))) - (add-enter-frame-hook! next)) - (at-entry count thunk)))) + (at-step count thunk (current-file-name))) ;;; debug-here ;;; From 3273abd221003767b5e38a9ebc37dc49b4e292e5 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 11 Nov 2003 23:21:39 +0000 Subject: [PATCH 093/239] Removed ui-client.scm and ui-server.scm (not in emacs/gds-*.scm). --- ice-9/ChangeLog | 14 ++++++++++++++ ice-9/debugger/Makefile.am | 2 +- ice-9/debugger/ui-client.scm | 0 ice-9/debugger/ui-server.scm | 0 4 files changed, 15 insertions(+), 1 deletion(-) delete mode 100644 ice-9/debugger/ui-client.scm delete mode 100644 ice-9/debugger/ui-server.scm diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 8282630f6..43dc16b7f 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,17 @@ +2003-11-11 Neil Jerram + + * debugger/behaviour.scm (*trap*): New variable, stores trap type. + (before-enter-frame-hook, before-apply-frame-hook, + before-exit-frame-hook): Set here. + (debug-if-flag-set): Passed into flags on debug-stack call. + (at-step, at-next): Changed to debug at frame exit points as well. + + * debugger/utils.scm: Big comment added. + +2003-10-30 Neil Jerram + + * debugger/ui-client.scm: Moved to ../emacs/gds-client.scm. + 2003-10-16 Neil Jerram * debugger/ui-client.scm (ui-connect): Add arg to say whether to diff --git a/ice-9/debugger/Makefile.am b/ice-9/debugger/Makefile.am index 21019ee45..0697378b4 100644 --- a/ice-9/debugger/Makefile.am +++ b/ice-9/debugger/Makefile.am @@ -25,7 +25,7 @@ SUBDIRS = breakpoints # These should be installed and distributed. ice9_debugger_sources = behaviour.scm breakpoints.scm command-loop.scm \ - commands.scm state.scm trap-hooks.scm trc.scm utils.scm ui-client.scm + commands.scm state.scm trap-hooks.scm trc.scm utils.scm subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/ice-9/debugger subpkgdata_DATA = $(ice9_debugger_sources) diff --git a/ice-9/debugger/ui-client.scm b/ice-9/debugger/ui-client.scm deleted file mode 100644 index e69de29bb..000000000 diff --git a/ice-9/debugger/ui-server.scm b/ice-9/debugger/ui-server.scm deleted file mode 100644 index e69de29bb..000000000 From 30d90280a466a5a49ab2b90ea58cba32eff51fdf Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 11 Nov 2003 23:27:22 +0000 Subject: [PATCH 094/239] ui- to gds- change; debug-on-error fix. --- ice-9/ChangeLog | 5 +++++ ice-9/debugger.scm | 16 +++++++++------- 2 files changed, 14 insertions(+), 7 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 43dc16b7f..0fa2a44a4 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,5 +1,10 @@ 2003-11-11 Neil Jerram + * debugger.scm: Change ui-* calls to gds-*. + (debug-on-error): Debug if throw key is in specified syms, not if + it isn't! Also throw 'abort after debugging, so as to skip the + REPL's backtrace. + * debugger/behaviour.scm (*trap*): New variable, stores trap type. (before-enter-frame-hook, before-apply-frame-hook, before-exit-frame-hook): Set here. diff --git a/ice-9/debugger.scm b/ice-9/debugger.scm index 891e0bc82..3e4250ef0 100644 --- a/ice-9/debugger.scm +++ b/ice-9/debugger.scm @@ -19,9 +19,9 @@ (define-module (ice-9 debugger) #:use-module (ice-9 debugger command-loop) #:use-module (ice-9 debugger state) - #:use-module (ice-9 debugger ui-client) #:use-module (ice-9 debugger utils) #:use-module (ice-9 format) + #:use-module (emacs gds-client) #:export (debug-stack debug debug-last-error @@ -121,8 +121,8 @@ Indicates that the debugger should display an introductory message. (display "There is 1 frame on the stack.\n\n") (format #t "There are ~A frames on the stack.\n\n" ssize)))) (write-state-short state) - (if (ui-connected?) - (ui-command-loop state) + (if (gds-connected?) + (gds-command-loop state) (debugger-command-loop state))))))))) (define (debug) @@ -163,10 +163,12 @@ Indicates that the debugger should display an introductory message. (set! lazy-handler-dispatch (if syms (lambda (key . args) - (or (memq key syms) - (debug-stack (make-stack #t lazy-handler-dispatch) - #:with-introduction - #:continuable)) + (if (memq key syms) + (begin + (debug-stack (make-stack #t lazy-handler-dispatch) + #:with-introduction + #:continuable) + (throw 'abort key))) (apply default-lazy-handler key args)) default-lazy-handler))) From 32ac6ed12f7c7d3f9d5eb251c1b19c27f239b580 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 11 Nov 2003 23:30:06 +0000 Subject: [PATCH 095/239] Moved all gds files here; plus ongoing work on them. --- emacs/ChangeLog | 7 + emacs/Makefile.am | 31 +++ emacs/README.GDS | 0 emacs/gds-client.scm | 464 +++++++++++++++++++++++++++++++++++++++++++ emacs/gds-server.scm | 98 +++++++++ 5 files changed, 600 insertions(+) create mode 100644 emacs/Makefile.am create mode 100644 emacs/README.GDS create mode 100644 emacs/gds-client.scm create mode 100644 emacs/gds-server.scm diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 4d7b0bf53..eb6820a32 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,10 @@ +2003-11-11 Neil Jerram + + * Makefile.am, README.GDS: New. + + * gds-client.scm, gds-server.scm: New (moved here from + ice-9/debugger/ui-{client,server}.scm). + 2003-08-20 Neil Jerram * guileint: New subdirectory. diff --git a/emacs/Makefile.am b/emacs/Makefile.am new file mode 100644 index 000000000..e281ff03c --- /dev/null +++ b/emacs/Makefile.am @@ -0,0 +1,31 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2003 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as +## published by the Free Software Foundation; either version 2, or +## (at your option) any later version. +## +## GUILE is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public +## License along with GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +AUTOMAKE_OPTIONS = gnu + +subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/emacs +subpkgdata_DATA = gds-client.scm gds-server.scm + +lisp_LISP = gds.el +ELCFILES = + +ETAGS_ARGS = $(subpkgdata_DATA) $(lisp_LISP) +EXTRA_DIST = $(subpkgdata_DATA) $(lisp_LISP) diff --git a/emacs/README.GDS b/emacs/README.GDS new file mode 100644 index 000000000..e69de29bb diff --git a/emacs/gds-client.scm b/emacs/gds-client.scm new file mode 100644 index 000000000..a560a2cd1 --- /dev/null +++ b/emacs/gds-client.scm @@ -0,0 +1,464 @@ +;;;; Guile Debugger UI client + +;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 2.1 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (emacs gds-client) + #:use-module (ice-9 debugger) + #:use-module (ice-9 debugger behaviour) + #:use-module (ice-9 debugger breakpoints) + #:use-module (ice-9 debugger breakpoints procedural) + #:use-module (ice-9 debugger state) + #:use-module (ice-9 debugger utils) + #:use-module (ice-9 optargs) + #:use-module (ice-9 regex) + #:use-module (ice-9 session) + #:use-module (ice-9 string-fun) + #:use-module (ice-9 threads) + #:export (gds-port-number + gds-connected? + gds-connect + gds-command-loop + gds-server-died-hook) + #:no-backtrace) + +;; The TCP port number that the UI server listens for application +;; connections on. +(define gds-port-number 8333) + +;; Once connected, the TCP socket port to the UI server. +(define gds-port #f) + +(define* (gds-connect name debug #:optional host) + "Connect to the debug UI server as @var{name}, a string that should +be sufficient to describe the calling application to the debug UI +user. The optional @var{host} arg specifies the hostname or dotted +decimal IP address where the UI server is running; default is +127.0.0.1." + (if (gds-connected?) + (error "Already connected to UI server!")) + ;; Connect to debug server. + (set! gds-port + (let ((s (socket PF_INET SOCK_STREAM 0)) + (SOL_TCP 6) + (TCP_NODELAY 1)) + (setsockopt s SOL_TCP TCP_NODELAY 1) + (connect s AF_INET (inet-aton (or host "127.0.0.1")) gds-port-number) + s)) + ;; Set debugger-output-port so that stuff written to it is + ;; accumulated for sending to the debug server. + (set! (debugger-output-port) + (make-soft-port (vector accumulate-output + accumulate-output + #f #f #f #f) + "w")) + ;; Write initial context to debug server. + (write-form (list 'name name (getpid))) + (write-form (cons 'modules (map module-name (loaded-modules)))) + ;; Start the asynchronous UI thread. + (start-async-gds-thread) + ;; If `debug' is true, debug immediately. + (if debug + (debug-stack (make-stack #t gds-connect) #:continuable)) +; (gds-command-loop #f) + ) + +(define gds-disable-async-thread noop) +(define gds-continue-async-thread noop) +(define async-gds-thread #f) + +(define (start-async-gds-thread) + (let ((mutex (make-mutex)) + (condition (make-condition-variable)) + (admin (pipe))) + ;; Start the asynchronous UI thread. + (begin-thread + (set! async-gds-thread (current-thread)) + (lock-mutex mutex) + ;;(write (cons admin gds-port)) + ;;(newline) + (catch 'server-died + (lambda () + (let loop ((avail '())) + ;;(write avail) + ;;(newline) + (cond ((not gds-port)) ; exit loop + ((null? avail) + (write-status 'ready-for-input) + (loop (car (select (list gds-port (car admin)) + '() '())))) + (else + (let ((port (car avail))) + (if (eq? port gds-port) + (handle-instruction #f (read gds-port)) + (begin + ;; Notification from debugger that it + ;; wants to take over. Read the + ;; notification char. + (read-char (car admin)) + ;; Wait on condition variable - this allows the + ;; debugger thread to grab the mutex. + (wait-condition-variable condition mutex))) + ;; Loop. + (loop (cdr avail))))))) + (lambda args #f)) + (set! gds-disable-async-thread noop) + (set! gds-continue-async-thread noop) + (set! async-gds-thread #f) + (unlock-mutex mutex)) + ;; Redefine procs used by debugger thread to take control. + (set! gds-disable-async-thread + (lambda () + (write-char #\x (cdr admin)) + (force-output (cdr admin)) + ;;(display "gds-disable-async-thread: locking mutex...\n" + ;; (current-error-port)) + (lock-mutex mutex))) + (set! gds-continue-async-thread + (lambda () + (unlock-mutex mutex) + (signal-condition-variable condition))))) + +(define accumulated-output '()) + +(define (accumulate-output obj) + (set! accumulated-output + (cons (if (string? obj) obj (make-string 1 obj)) + accumulated-output))) + +(define (get-accumulated-output) + (let ((s (apply string-append (reverse! accumulated-output)))) + (set! accumulated-output '()) + s)) + +(define (gds-connected?) + "Return @code{#t} if a UI server connected has been made; else @code{#f}." + (not (not gds-port))) + +(define (gds-command-loop state) + "Interact with the UI frontend." + (or (gds-connected?) + (error "Not connected to UI server.")) + (gds-disable-async-thread) + (catch #t ; Only expect here 'exit-debugger or 'server-died. + (lambda () + (let loop ((state state)) + ;; Write accumulated debugger output. + (write-form (list 'output + (sans-surrounding-whitespace + (get-accumulated-output)))) + ;; Write current state to the frontend. + (if state (write-stack state)) + ;; Tell the frontend that we're waiting for input. + (write-status 'waiting-for-input) + ;; Read next instruction, act on it, and loop with + ;; updated state. + (loop (handle-instruction state (read gds-port))))) + (lambda args *unspecified*)) + (gds-continue-async-thread)) + +(define (write-stack state) + ;; Write Emacs-readable representation of current state to UI + ;; frontend. + (let ((frames (stack->emacs-readable (state-stack state))) + (index (index->emacs-readable (state-index state))) + (flags (flags->emacs-readable (state-flags state)))) + (if (memq 'backwards (debug-options)) + (write-form (list 'stack + frames + index + flags)) + ;; Calculate (length frames) here because `reverse!' will make + ;; the original `frames' invalid. + (let ((nframes (length frames))) + (write-form (list 'stack + (reverse! frames) + (- nframes index 1) + flags)))))) + +(define (write-form form) + ;; Write any form FORM to UI frontend. + (write form gds-port) + (newline gds-port) + (force-output gds-port)) + +(define (stack->emacs-readable stack) + ;; Return Emacs-readable representation of STACK. + (map (lambda (index) + (frame->emacs-readable (stack-ref stack index))) + (iota (stack-length stack)))) + +(define (frame->emacs-readable frame) + ;; Return Emacs-readable representation of FRAME. + (if (frame-procedure? frame) + (list 'application + (with-output-to-string + (lambda () + (display (if (frame-real? frame) " " "t ")) + (write-frame-short/application frame))) + (source->emacs-readable (or (frame-source frame) + (let ((proc (frame-procedure frame))) + (and proc + (procedure-source proc)))))) + (list 'evaluation + (with-output-to-string + (lambda () + (display (if (frame-real? frame) " " "t ")) + (write-frame-short/expression frame))) + (source->emacs-readable (frame-source frame))))) + +(define (source->emacs-readable source) + ;; Return Emacs-readable representation of the filename, line and + ;; column source properties of SOURCE. + (if (and source + (string? (source-property source 'filename))) + (list (source-property source 'filename) + (source-property source 'line) + (source-property source 'column)) + 'nil)) + +(define (index->emacs-readable index) + ;; Return Emacs-readable representation of INDEX (the current stack + ;; index). + index) + +(define (flags->emacs-readable flags) + ;; Return Emacs-readable representation of FLAGS passed to + ;; debug-stack. + (map (lambda (flag) + (if (keyword? flag) + (keyword->symbol flag) + (format #f "~S" flag))) + flags)) + +(define the-ice-9-debugger-commands-module + (resolve-module '(ice-9 debugger commands))) + +(define internal-error-stack #f) + +(define (handle-instruction state ins) + (if (eof-object? ins) + (server-died) + (catch #t + (lambda () + (lazy-catch #t + (lambda () + (handle-instruction-1 state ins)) + (lambda (key . args) + (set! internal-error-stack (make-stack #t)) + (apply throw key args)))) + (lambda (key . args) + (case key + ((exit-debugger) + (apply throw key args)) + (else + (write-form + `(eval-results "GDS Internal Error\n" + ,(list (with-output-to-string + (lambda () + (write key) + (display ": ") + (write args) + (newline) + (display-backtrace internal-error-stack + (current-output-port))))))))) + state)))) + +(define (server-died) + (get-accumulated-output) + (close-port gds-port) + (set! gds-port #f) + (run-hook gds-server-died-hook) + (throw 'server-died)) + +(define gds-server-died-hook (make-hook)) + +(define (handle-instruction-1 state ins) + ;; Read the newline that always follows an instruction. + (read-char gds-port) + ;; Handle instruction from the UI frontend, and return updated state. + (case (car ins) + ((query-modules) + (write-form (cons 'modules (map module-name (loaded-modules)))) + state) + ((query-module) + (let ((name (cadr ins))) + (write-form `(module ,name + ,(or (loaded-module-source name) "(no source file)") + ,@(sort (module-map (lambda (key value) + (symbol->string key)) + (resolve-module name)) + stringstring (car matches))) + (matches (cdr matches))) + ;;(write match (current-error-port)) + ;;(newline (current-error-port)) + ;;(write matches (current-error-port)) + ;;(newline (current-error-port)) + (if (null? matches) + match + (if (string-prefix=? match + (symbol->string (car matches))) + (loop match (cdr matches)) + (loop (substring match 0 + (- (string-length match) 1)) + matches)))))) + (if (string=? match (cadr ins)) + (write-form `(completion-result + ,(map symbol->string matches))) + (write-form `(completion-result + ,match))))))) + state) + ((async-break) + (let ((thread (car (delq async-gds-thread (all-threads))))) + (write (cons 'target-thread thread)) + (newline) + (write (cons 'async-thread async-gds-thread)) + (newline) + (system-async-mark (lambda () + (debug-stack (make-stack #t 3) #:continuable)) + thread)) + state) + (else state))) + +(define (gds-eval x m) + ;; Consumer to accept possibly multiple values and present them for + ;; Emacs as a list of strings. + (define (value-consumer . values) + (if (unspecified? (car values)) + '() + (map (lambda (value) + (with-output-to-string (lambda () (write value)))) + values))) + (let ((value #f)) + (let* ((do-eval (if m + (lambda () + (display "Evaluating in module ") + (write (module-name m)) + (newline) + (set! value + (call-with-values (lambda () + (eval x m)) + value-consumer))) + (lambda () + (display "Evaluating in current module ") + (write (module-name (current-module))) + (newline) + (set! value + (call-with-values (lambda () + (primitive-eval x)) + value-consumer))))) + (output + (with-output-to-string + (lambda () + (catch #t + do-eval + (lambda (key . args) + (case key + ((misc-error signal unbound-variable + numerical-overflow) + (apply display-error #f + (current-output-port) args) + (set! value '("error-in-evaluation"))) + (else + (display "EXCEPTION: ") + (display key) + (display " ") + (write args) + (newline) + (set! value + '("unhandled-exception-in-evaluation")))))))))) + (list output value)))) + +(define (write-status status) + (write-form (list 'current-module + (format #f "~S" (module-name (current-module))))) + (write-form (list 'status status))) + +(define (loaded-module-source module-name) + ;; Return the file name that (ice-9 boot-9) probably loaded the + ;; named module from. (The `probably' is because `%load-path' might + ;; have changed since the module was loaded.) + (let* ((reverse-name (reverse module-name)) + (name (symbol->string (car reverse-name))) + (dir-hint-module-name (reverse (cdr reverse-name))) + (dir-hint (apply string-append + (map (lambda (elt) + (string-append (symbol->string elt) "/")) + dir-hint-module-name)))) + (%search-load-path (in-vicinity dir-hint name)))) + +(define (loaded-modules) + ;; Return list of all loaded modules sorted by name. + (sort (apropos-fold-all (lambda (module acc) (cons module acc)) '()) + (lambda (m1 m2) + (symliststring (car l1)) (symbol->string (car l2)))))) + +;;; (emacs gds-client) ends here. diff --git a/emacs/gds-server.scm b/emacs/gds-server.scm new file mode 100644 index 000000000..c472ee359 --- /dev/null +++ b/emacs/gds-server.scm @@ -0,0 +1,98 @@ +;;;; Guile Debugger UI server + +;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 2.1 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (emacs gds-server) + #:use-module (emacs gds-client) + #:export (run-server)) + +;; UI is normally via a pipe to Emacs, so make sure to flush output +;; every time we write. +(define (write-to-ui form) + (write form) + (newline) + (force-output)) + +(define (trc . args) + (write-to-ui (cons '* args))) + +(define (with-error->eof proc port) + (catch #t + (lambda () (proc port)) + (lambda args the-eof-object))) + +(define (run-server . ignored-args) + + (let ((server (socket PF_INET SOCK_STREAM 0))) + + ;; Initialize server socket. + (setsockopt server SOL_SOCKET SO_REUSEADDR 1) + (bind server AF_INET INADDR_ANY gds-port-number) + (listen server 5) + + (let loop ((clients '()) (readable-sockets '())) + + (define (do-read port) + (cond ((eq? port (current-input-port)) + (do-read-from-ui)) + ((eq? port server) + (accept-new-client)) + (else + (do-read-from-client port)))) + + (define (do-read-from-ui) + (trc "reading from ui") + (let* ((form (with-error->eof read (current-input-port))) + (client (assq-ref (map (lambda (port) + (cons (fileno port) port)) + clients) + (car form)))) + (with-error->eof read-char (current-input-port)) + (if client + (begin + (write (cdr form) client) + (newline client)) + (trc "client not found"))) + clients) + + (define (accept-new-client) + (cons (car (accept server)) clients)) + + (define (do-read-from-client port) + (trc "reading from client") + (let ((next-char (with-error->eof peek-char port))) + ;;(trc 'next-char next-char) + (cond ((eof-object? next-char) + (write-to-ui (list (fileno port) 'closed)) + (close port) + (delq port clients)) + ((char=? next-char #\() + (write-to-ui (cons (fileno port) (with-error->eof read port))) + clients) + (else + (with-error->eof read-char port) + clients)))) + + ;;(trc 'clients clients) + ;;(trc 'readable-sockets readable-sockets) + + (if (null? readable-sockets) + (loop clients (car (select (cons (current-input-port) + (cons server clients)) + '() + '()))) + (loop (do-read (car readable-sockets)) (cdr readable-sockets)))))) From d995da7f2a2c21d9be3c949bc27432348b620412 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 11 Nov 2003 23:34:01 +0000 Subject: [PATCH 096/239] Changes to build and install files in emacs subdir. --- ChangeLog | 7 +++++++ Makefile.am | 3 ++- configure.in | 3 +++ 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index a90002438..d62c4ee58 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2003-10-30 Neil Jerram + + * configure.in (AC_CONFIG_FILES): Add `emacs/Makefile'. + (AM_PATH_LISPDIR): Added. + + * Makefile.am (SUBDIRS): Add `emacs'. + 2003-07-27 Marius Vollmer * configure.in: Look for sched_yield in -lrt; this is needed for diff --git a/Makefile.am b/Makefile.am index 70730cb0b..5af661132 100644 --- a/Makefile.am +++ b/Makefile.am @@ -22,7 +22,8 @@ AUTOMAKE_OPTIONS = 1.5 SUBDIRS = oop libguile-ltdl libguile ice-9 guile-config guile-readline \ - scripts srfi doc examples test-suite benchmark-suite lang am + scripts srfi doc examples test-suite benchmark-suite lang am \ + emacs bin_SCRIPTS = guile-tools diff --git a/configure.in b/configure.in index 72d834b0a..275ed7beb 100644 --- a/configure.in +++ b/configure.in @@ -62,6 +62,8 @@ AC_LIB_LTDL AC_CHECK_PROG(have_makeinfo, makeinfo, yes, no) AM_CONDITIONAL(HAVE_MAKEINFO, test "$have_makeinfo" = yes) +AM_PATH_LISPDIR + #-------------------------------------------------------------------- # # User options (after above tests that may set default CFLAGS etc.) @@ -1086,6 +1088,7 @@ AC_CONFIG_FILES([ doc/r5rs/Makefile doc/ref/Makefile doc/tutorial/Makefile + emacs/Makefile examples/Makefile examples/box-dynamic-module/Makefile examples/box-dynamic/Makefile From e707c78b4bd16cdcc8dd3baf14cc25036443e994 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 11 Nov 2003 23:40:38 +0000 Subject: [PATCH 097/239] Lots of ongoing development. --- emacs/ChangeLog | 2 + emacs/gds.el | 832 ++++++++++++++++++++++++++---------------------- 2 files changed, 453 insertions(+), 381 deletions(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index eb6820a32..35e0ddffa 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,5 +1,7 @@ 2003-11-11 Neil Jerram + * gds.el: New. (Or rather, first mention in this ChangeLog.) + * Makefile.am, README.GDS: New. * gds-client.scm, gds-server.scm: New (moved here from diff --git a/emacs/gds.el b/emacs/gds.el index 0c8e33792..5cefd8a06 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -40,7 +40,7 @@ :group 'scheme) -;;;; Communication with the (ice-9 debugger ui-server) subprocess. +;;;; Communication with the (emacs gds-server) subprocess. ;; The subprocess object. (defvar gds-process nil) @@ -63,10 +63,8 @@ "guile" "-q" "--debug" - "-e" - "run" - "-s" - "/home/neil/Guile/cvs/guile-core/ice-9/debugger/ui-server.scm")))) + "-c" + "(begin (use-modules (emacs gds-server)) (run-server))")))) (setq gds-read-cursor (point-min)) (set-process-filter gds-process (function gds-filter)) (set-process-sentinel gds-process (function gds-sentinel)) @@ -76,16 +74,10 @@ (defun gds-shutdown () "Shut down the GDS subprocess." (interactive) - ;; Do cleanup for all clients. - (while gds-names - (gds-client-cleanup (caar gds-names))) - ;; Reset any remaining variables. - (setq gds-displayed-client nil + ;; Reset variables. + (setq gds-buffers nil + gds-focus-client nil gds-waiting nil) - ;; If the timer is running, cancel it. - (if gds-timer - (cancel-timer gds-timer)) - (setq gds-timer nil) ;; Kill the subprocess. (process-kill-without-query gds-process) (condition-case nil @@ -126,269 +118,148 @@ ;;;; Multiple application scheduling. -;; At any moment one Guile application has the focus of the frontend -;; code. `gds-displayed-client' holds the port number of that client. -;; If there are no Guile applications wanting the focus - that is, -;; ready for instructions - `gds-displayed-client' is nil. -(defvar gds-displayed-client nil) - -;; The list of other Guile applications waiting for focus, referenced -;; by their port numbers. +;; Here is how we schedule the display of multiple clients that are +;; competing for user attention. +;; +;; - `gds-waiting' holds a list of clients that want attention but +;; haven't yet got it. A client is added to this list for two +;; reasons. (1) When it is blocked waiting for user input. (2) When +;; it first connects to GDS, even if not blocked. +;; +;; - `gds-focus-client' holds the client, if any, that currently has +;; the user's attention. A client can be given the focus if +;; `gds-focus-client' is nil at the time that the client wants +;; attention, or if another client relinquishes it. A client can +;; relinquish the focus in two ways. (1) If the client application +;; says that it is no longer blocked, and a small time passes without +;; it becoming blocked again. (2) If the user explicitly `quits' that +;; client. +(defvar gds-focus-client nil) (defvar gds-waiting nil) -;; An idle timer that we use to avoid confusing any user work when -;; popping up debug buffers. `gds-timer' is non-nil whenever the -;; timer is running and nil whenever it is not running. -(defvar gds-timer nil) +;; Sometimes we want to display a client buffer immediately even if it +;; isn't already in the selected window. To do we this, we bind the +;; following variable to non-nil. +(defvar gds-immediate-display nil) -;; Debug the specified client. If it already has the focus, do so -;; immediately, but using the idle timer to ensure that it doesn't -;; confuse any work the user may be doing. Non-structural work is -;; delegated to `gds-display-state'. -(defun gds-debug (&optional client) - (dmessage "gds-debug") - ;; If `client' is specified, add it to the end of `gds-waiting', - ;; unless that client is already the current client or it is already - ;; in the waiting list. - (if (and client - (not (eq client gds-displayed-client)) - (not (memq client gds-waiting))) - (setq gds-waiting (append gds-waiting (list client)))) - ;; Now update `client' to be the next client in the list. - (setq client (or gds-displayed-client (car gds-waiting))) - ;; If conditions are right, start the idle timer. - (if (and client - (or (null gds-displayed-client) - (eq gds-displayed-client client))) - (gds-display-state (or gds-displayed-client - (prog1 (car gds-waiting) - (setq gds-waiting - (cdr gds-waiting))))))) +(defun gds-request-focus (client) + (cond ((eq client gds-focus-client) + ;; CLIENT already has the focus. Display its buffer. + (gds-display-buffers)) + (gds-focus-client + ;; Another client has the focus. Add CLIENT to `gds-waiting'. + (or (memq client gds-waiting) + (setq gds-waiting (append gds-waiting (list client))))) + (t + ;; Give focus to CLIENT and display its buffer. + (setq gds-focus-client client) + (gds-display-buffers)))) -;; Give up focus because debugging is done for now. Display detail in -;; case of no waiting clients is delegated to `gds-clear-display'. -(defun gds-focus-done () - (gds-clear-display) - (gds-debug)) - -;; Although debugging of this client isn't done, yield focus to the -;; next waiting client. -(defun gds-focus-yield () +;; Explicitly give up focus. +(defun gds-quit () (interactive) - (if (and (null gds-waiting) - (y-or-n-p "No other clients waiting - bury *Guile* buffer? ")) - (bury-buffer) - (or (memq gds-displayed-client gds-waiting) - (setq gds-waiting (append gds-waiting (list gds-displayed-client)))) - (gds-focus-done))) + (if (or (car gds-waiting) + (not (gds-client-blocked)) + (y-or-n-p + "Client is blocked and no others are waiting. Still quit? ")) + (let ((gds-immediate-display + (eq (window-buffer (selected-window)) (current-buffer)))) + (bury-buffer (current-buffer)) + ;; Pass on the focus. + (setq gds-focus-client (car gds-waiting) + gds-waiting (cdr gds-waiting)) + ;; If this client is blocked, add it back into the waiting list. + (if (gds-client-blocked) + (gds-request-focus gds-client)) + ;; If there is a new focus client, request display for it. + (if gds-focus-client + (gds-request-focus gds-focus-client))))) -;;;; Per-client state information. - -;; Alist mapping client port numbers to application names. The names -;; in this list have been uniquified by `gds-uniquify'. -(defvar gds-names nil) - -;; Return unique form of NAME. -(defun gds-uniquify (name) - (let ((count 1) - (maybe-unique name)) - (while (member maybe-unique (mapcar (function cdr) gds-names)) - (setq count (1+ count) - maybe-unique (concat name "<" (number-to-string count) ">"))) - maybe-unique)) - -;; Alist mapping client port numbers to last known status. -;; -;; Status is one of the following symbols. -;; -;; `running' - application is running. -;; -;; `waiting-for-input' - application is blocked waiting for -;; instruction from the frontend. -;; -;; `ready-for-input' - application is not blocked but can also -;; accept asynchronous instructions from the frontend. -;; -(defvar gds-statuses nil) - -;; Alist mapping client port numbers to last printed outputs. -(defvar gds-outputs nil) - -;; Alist mapping client port numbers to last known stacks. -(defvar gds-stacks nil) - -;; Alist mapping client port numbers to module information. This -;; looks like: -;; -;; ((4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...) ...) -;; -;; So, for example: -;; -;; (assq client gds-modules) -;; => -;; (4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...) -;; -;; The t or nil after the module name indicates whether the module is -;; displayed in expanded form (that is, showing the bindings in that -;; module). -;; -;; The syms are actually all strings, because some Guile symbols are -;; not readable by Emacs. -(defvar gds-modules nil) - - -;;;; Handling debugging instructions. - -;; General dispatch function called by the subprocess filter. -(defun gds-handle-input (form) - (dmessage "Form: %S" form) - (let ((client (car form))) - (cond ((eq client '*)) - (t - (let ((proc (cadr form))) - - (cond ((eq proc 'name) - ;; (name ...) - Application's name. - (setq gds-names - (cons (cons client (gds-uniquify (caddr form))) - gds-names))) - - ((eq proc 'stack) - ;; (stack ...) - Stack at an error or breakpoint. - (gds-set gds-stacks client (cddr form))) - - ((eq proc 'modules) - ;; (modules ...) - Application's loaded modules. - (gds-set gds-modules client - (mapcar (function list) (cddr form)))) - - ((eq proc 'output) - ;; (output ...) - Last printed output. - (gds-set gds-outputs client (caddr form))) - - ((eq proc 'status) - ;; (status ...) - Application status indication. - (let ((status (caddr form))) - (gds-set gds-statuses client status) - (cond ((eq status 'waiting-for-input) - (gds-debug client)) - ((or (eq status 'running) - (eq status 'ready-for-input)) - (if (eq client gds-displayed-client) - (gds-display-state client))) - (t - (error "Unexpected status: %S" status))))) - - ((eq proc 'module) - ;; (module MODULE ...) - The specified module's bindings. - (let* ((modules (assq client gds-modules)) - (minfo (assoc (caddr form) modules))) - (if minfo - (setcdr (cdr minfo) (cdddr form))))) - - ((eq proc 'closed) - ;; (closed) - Client has gone away. - (gds-client-cleanup client)) - - ((eq proc 'eval-results) - ;; (eval-results ...) - Results of evaluation. - (gds-display-results client (cddr form))) - - )))))) - -;; Store latest status, stack or module list for the specified client. -(defmacro gds-set (alist client val) - `(let ((existing (assq ,client ,alist))) - (if existing - (setcdr existing ,val) - (setq ,alist - (cons (cons client ,val) ,alist))))) - -;; Cleanup processing when CLIENT goes away. -(defun gds-client-cleanup (client) - (if (eq client gds-displayed-client) - (gds-focus-done)) - (setq gds-names - (delq (assq client gds-names) gds-names)) - (setq gds-stacks - (delq (assq client gds-stacks) gds-stacks)) - (setq gds-modules - (delq (assq client gds-modules) gds-modules))) - - -;;;; Displaying debugging information. - -(defvar gds-client-buffer nil) +;;;; Per-client buffer state. (define-derived-mode gds-mode - fundamental-mode - "Guile" - "Major mode for Guile information buffers.") + scheme-mode + "Guile Interaction" + "Major mode for interacting with a Guile client application.") -(defun gds-set-client-buffer (&optional client) - (if (and gds-client-buffer - (buffer-live-p gds-client-buffer)) - (set-buffer gds-client-buffer) - (setq gds-client-buffer (get-buffer-create "*Guile*")) - (set-buffer gds-client-buffer) - (gds-mode)) - ;; Rename to something we don't want first. Otherwise, if the - ;; buffer is already correctly named, we get a confusing change - ;; from, say, `*Guile: REPL*' to `*Guile: REPL*<2>'. - (rename-buffer "*Guile Fake Buffer Name*" t) - (rename-buffer (if client - (concat "*Guile: " - (cdr (assq client gds-names)) - "*") - "*Guile*") - t) ; Rename uniquely if needed, - ; although it shouldn't be. - (force-mode-line-update t)) +(defvar gds-client nil + "GDS client's port number.") +(make-variable-buffer-local 'gds-client) -(defun gds-clear-display () - ;; Clear the client buffer. - (gds-set-client-buffer) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert "Stack:\nNo clients ready for debugging.\n") - (goto-char (point-min))) - (setq gds-displayed-stack 'no-clients) - (setq gds-displayed-modules nil) - (setq gds-displayed-client nil) - (bury-buffer)) +(defvar gds-current-module "()" + "GDS client's current module.") +(make-variable-buffer-local 'gds-current-module) -;; Determine whether the client display buffer is visible in the -;; currently selected frame (i.e. where the user is editing). -(defun gds-buffer-visible-in-selected-frame-p () - (let ((visible-p nil)) - (walk-windows (lambda (w) - (if (eq (window-buffer w) gds-client-buffer) - (setq visible-p t)))) - visible-p)) +(defvar gds-stack nil + "GDS client's stack when last stopped.") +(make-variable-buffer-local 'gds-stack) -;; Cached display variables for `gds-display-state'. -(defvar gds-displayed-stack nil) +(defvar gds-modules nil + "GDS client's module information. +Alist mapping module names to their symbols and related information. +This looks like: + + (((guile) t sym1 sym2 ...) + ((guile-user)) + ((ice-9 debug) nil sym3 sym4) + ...) + +The `t' or `nil' after the module name indicates whether the module is +displayed in expanded form (that is, showing the bindings in that +module). The syms are actually all strings because some Guile symbols +are not readable by Emacs.") +(make-variable-buffer-local 'gds-modules) + +(defvar gds-output nil + "GDS client's recent output (printed).") +(make-variable-buffer-local 'gds-output) + +(defvar gds-status nil + "GDS client's latest status, one of the following symbols. + +`running' - application is running. + +`waiting-for-input' - application is blocked waiting for instruction +from the frontend. + +`ready-for-input' - application is not blocked but can also accept +asynchronous instructions from the frontend.") +(make-variable-buffer-local 'gds-status) + +(defvar gds-pid nil + "GDS client's process ID.") +(make-variable-buffer-local 'gds-pid) + +(defvar gds-debug-exceptions nil + "Whether to debug exceptions.") +(make-variable-buffer-local 'gds-debug-exceptions) + +(defvar gds-exception-keys "signal misc-error" + "The exception keys for which to debug a GDS client.") +(make-variable-buffer-local 'gds-exception-keys) + +;; Cached display variables for `gds-update-buffers'. (defvar gds-displayed-modules nil) +(make-variable-buffer-local 'gds-displayed-modules) ;; Types of display areas in the *Guile* buffer. -(defvar gds-display-types '("Status" "Stack" "Modules")) +(defvar gds-display-types '("\\`" + "^Modules:" + "^Transcript:")) (defvar gds-display-type-regexp - (concat "^\\(" + (concat "\\(" (substring (apply (function concat) (mapcar (lambda (type) (concat "\\|" type)) gds-display-types)) 2) - "\\):")) + "\\)")) -(defun gds-maybe-delete-region (type) +(defun gds-maybe-delete-region (regexp) (let ((beg (save-excursion (goto-char (point-min)) - (and (re-search-forward (concat "^" - (regexp-quote type) - ":") - nil t) + (and (re-search-forward regexp nil t) (match-beginning 0))))) (if beg (delete-region beg @@ -400,60 +271,81 @@ (match-beginning 0)) (point-max))))))) -(defun gds-maybe-skip-region (type) - (if (looking-at (regexp-quote type)) +(defun gds-maybe-skip-region (regexp) + (if (looking-at regexp) (if (re-search-forward gds-display-type-regexp nil t 2) (beginning-of-line) (goto-char (point-max))))) -(defun gds-display-state (client) - (dmessage "gds-display-state") +(defun gds-update-buffers (client) + (dmessage "gds-update-buffers") ;; Avoid continually popping up the last associated source buffer ;; unless it really is still current. (setq gds-selected-frame-source-buffer nil) - (gds-set-client-buffer client) - (let ((stack (cdr (assq client gds-stacks))) - (modules (cdr (assq client gds-modules))) - (inhibit-read-only t) - (p (if (eq client gds-displayed-client) + (set-buffer (cdr (assq client gds-buffers))) + (force-mode-line-update t) + (let ((inhibit-read-only t) + (p (if (eq client gds-focus-client) (point) (point-min))) stack-changed) ;; Start at top of buffer. (goto-char (point-min)) ;; Display status; too simple to be worth caching. - (gds-maybe-delete-region "Status") - (widget-insert "Status: " - (cdr (assq (cdr (assq client gds-statuses)) + (gds-maybe-delete-region (concat "\\`" (regexp-quote (buffer-name)))) + (widget-insert (buffer-name) + ", " + (cdr (assq gds-status '((running . "running (cannot accept input)") (waiting-for-input . "waiting for input") - (ready-for-input . "running")))) - "\n\n") - (let ((output (cdr (assq client gds-outputs)))) - (if (> (length output) 0) - (widget-insert output "\n\n"))) + (ready-for-input . "running") + (closed . "closed")))) + ", in " + gds-current-module + "\n") + (widget-create 'push-button + :notify (function gds-sigint) + "SIGINT") + (widget-insert " ") + (widget-create 'push-button + :notify (function gds-async-break) + "Break") + (widget-insert "\n") + (widget-create 'checkbox + :notify (function gds-toggle-debug-exceptions) + gds-debug-exceptions) + (widget-insert " Debug exception keys: ") + (widget-create 'editable-field + :notify (function gds-set-exception-keys) + gds-exception-keys) + (widget-insert "\n") +; (widget-insert "\n\n") +; (if (> (length gds-output) 0) +; (widget-insert gds-output "\n\n")) ;; Display stack. (dmessage "insert stack") - (if (equal stack gds-displayed-stack) - (gds-maybe-skip-region "Stack") - ;; Note that stack has changed. - (if stack (setq stack-changed t)) - ;; Delete existing stack. - (gds-maybe-delete-region "Stack") - ;; Insert new stack. - (if stack (gds-insert-stack stack)) - ;; Record displayed stack. - (setq gds-displayed-stack stack)) + (let ((stack gds-stack) + (buf (get-buffer-create (concat (buffer-name) " - stack")))) + (with-current-buffer buf + (if (equal stack gds-stack) + ;; No change needed. + nil + (erase-buffer) + (gds-mode) + ;; Insert new stack. + (if stack (gds-insert-stack stack)) + ;; Record displayed stack. + (setq gds-stack stack)))) ;; Display module list. (dmessage "insert modules") - (if (equal modules gds-displayed-modules) - (gds-maybe-skip-region "Modules") + (if (equal gds-modules gds-displayed-modules) + (gds-maybe-skip-region "^Modules:") ;; Delete existing module list. - (gds-maybe-delete-region "Modules") + (gds-maybe-delete-region "^Modules:") ;; Insert new list. - (if modules (gds-insert-modules modules)) + (if gds-modules (gds-insert-modules gds-modules)) ;; Record displayed list. - (setq gds-displayed-modules (copy-tree modules))) + (setq gds-displayed-modules (copy-tree gds-modules))) ;; Finish off. (dmessage "widget-setup") (widget-setup) @@ -462,48 +354,71 @@ ;; buffer is visible. (progn (goto-char (point-min)) - (re-search-forward "^Stack:") - (forward-line (+ 1 (cadr stack)))) + (forward-line (+ 1 (cadr gds-stack)))) ;; Restore point from before buffer was redrawn. - (goto-char p))) - (setq gds-displayed-client client) - (dmessage "consider display") - (if (eq (window-buffer (selected-window)) gds-client-buffer) - ;; *Guile* buffer already selected. - (gds-display-buffers) - (dmessage "Running GDS timer") - (setq gds-timer - (run-with-idle-timer 0.5 - nil - (lambda () - (setq gds-timer nil) - (gds-display-buffers)))))) + (goto-char p)))) + +(defun gds-sigint (w &rest ignore) + (interactive) + (signal-process gds-pid 2)) + +(defun gds-async-break (w &rest ignore) + (interactive) + (gds-send (format "(%S async-break)\n" gds-focus-client))) + +(defun gds-toggle-debug-exceptions (w &rest ignore) + (interactive) + (setq gds-debug-exceptions (widget-value w)) + (gds-eval-expression (concat "(use-modules (ice-9 debugger))" + "(debug-on-error '(" + gds-exception-keys + "))"))) + +(defun gds-set-exception-keys (w &rest ignore) + (interactive) + (setq gds-exception-keys (widget-value w))) (defun gds-display-buffers () - ;; If there's already a window showing the *Guile* buffer, use - ;; it. - (let ((window (get-buffer-window gds-client-buffer t))) - (if window - (progn - (make-frame-visible (window-frame window)) - (raise-frame (window-frame window)) - (select-frame (window-frame window)) - (select-window window)) - (switch-to-buffer gds-client-buffer))) - ;; If there is an associated source buffer, display it as well. - (if gds-selected-frame-source-buffer - (let ((window (display-buffer gds-selected-frame-source-buffer))) - (set-window-point window - (overlay-start gds-selected-frame-source-overlay)))) - ;; Force redisplay. - (sit-for 0)) + (if gds-focus-client + (let ((gds-focus-buffer (cdr (assq gds-focus-client gds-buffers)))) + ;; If there's already a window showing the buffer, use it. + (let ((window (get-buffer-window gds-focus-buffer t))) + (if window + (progn + (make-frame-visible (window-frame window)) + (select-frame (window-frame window)) + (select-window window)) + ;(select-window (display-buffer gds-focus-buffer)) + (display-buffer gds-focus-buffer))) + ;; If there is an associated source buffer, display it as well. + (if gds-selected-frame-source-buffer + (let ((window (display-buffer gds-selected-frame-source-buffer))) + (set-window-point window + (overlay-start + gds-selected-frame-source-overlay)))) + ;; If there is a stack to display, display it. + (if gds-stack + (let ((buf (get-buffer (concat (buffer-name) " - stack")))) + (if (get-buffer-window buf) + nil + (split-window) + (set-window-buffer (selected-window) buf))))))) (defun gds-insert-stack (stack) (let ((frames (car stack)) (index (cadr stack)) (flags (caddr stack)) frame items) - (widget-insert "Stack: " (prin1-to-string flags) "\n") + (cond ((memq 'application flags) + (widget-insert "Calling procedure:\n")) + ((memq 'evaluation flags) + (widget-insert "Evaluating expression:\n")) + ((memq 'return flags) + (widget-insert "Return value: " + (cadr (memq 'return flags)) + "\n")) + (t + (widget-insert "Stack: " (prin1-to-string flags) "\n"))) (let ((i -1)) (gds-show-selected-frame (caddr (nth index frames))) (while frames @@ -527,7 +442,7 @@ (let* ((s (widget-value widget)) (ind (memq 'index (text-properties-at 0 s)))) (gds-send (format "(%S debugger-command frame %d)\n" - gds-displayed-client + gds-focus-client (cadr ind))))) ;; Overlay used to highlight the source expression corresponding to @@ -612,24 +527,129 @@ not of primary interest when debugging application code." (while syms (widget-insert " > " (car syms) "\n") (setq syms (cdr syms)))))))) - (setq modules (cdr modules)))) + (setq modules (cdr modules))) + (insert "\n")) (defun gds-module-notify (w &rest ignore) (let* ((module (widget-get w :module)) (client (car module)) (name (cdr module)) - (modules (assq client gds-modules)) - (minfo (assoc name modules))) + (minfo (assoc name gds-modules))) (if (cdr minfo) ;; Just toggle expansion state. (progn (setcar (cdr minfo) (not (cadr minfo))) - (gds-display-state client)) + (gds-update-buffers client)) ;; Set flag to indicate module expanded. (setcdr minfo (list t)) ;; Get symlist from Guile. (gds-send (format "(%S query-module %S)\n" client name))))) +(defun gds-query-modules () + (interactive) + (gds-send (format "(%S query-modules)\n" gds-focus-client))) + + +;;;; Handling debugging instructions. + +;; Alist mapping each client port number to corresponding buffer. +(defvar gds-buffers nil) + +;; Return client buffer for specified client and protocol input. +(defun gds-client-buffer (client proc args) + (if (eq proc 'name) + ;; Introduction from client - create a new buffer. + (with-current-buffer (generate-new-buffer (car args)) + (gds-mode) + (insert "Transcript:\n") + (setq gds-buffers + (cons (cons client (current-buffer)) + gds-buffers)) + (current-buffer)) + ;; Otherwise there should be an existing buffer that we can + ;; return. + (let ((existing (assq client gds-buffers))) + (if (buffer-live-p (cdr existing)) + (cdr existing) + (setq gds-buffers (delq existing gds-buffers)) + (gds-client-buffer client 'name '("(GDS buffer killed)")))))) + +;; General dispatch function called by the subprocess filter. +(defun gds-handle-input (form) + (dmessage "Form: %S" form) + (let ((client (car form))) + (or (eq client '*) + (let* ((proc (cadr form)) + (args (cddr form)) + (buf (gds-client-buffer client proc args))) + (if buf (gds-handle-client-input buf client proc args)))))) + +(defun gds-handle-client-input (buf client proc args) + (with-current-buffer buf + (save-excursion + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (insert (format "<%S %S %S>" client proc args) "\n"))) + (dmessage "Buffer: %S" (current-buffer)) + (cond (;; (name ...) - Client name. + (eq proc 'name) + (setq gds-pid (cadr args)) + (gds-request-focus client)) + + (;; (current-module ...) - Current module. + (eq proc 'current-module) + (setq gds-current-module (car args)) + (dmessage "Current module: %S" gds-current-module)) + + (;; (stack ...) - Stack at an error or breakpoint. + (eq proc 'stack) + (setq gds-stack args)) + + (;; (modules ...) - Application's loaded modules. + (eq proc 'modules) + (while args + (or (assoc (car args) gds-modules) + (setq gds-modules (cons (list (car args)) gds-modules))) + (setq args (cdr args)))) + + (;; (output ...) - Last printed output. + (eq proc 'output) + (setq gds-output (car args))) + + (;; (status ...) - Application status indication. + (eq proc 'status) + (setq gds-status (car args)) + (or (eq gds-status 'waiting-for-input) + (setq gds-stack nil)) + (gds-update-buffers client) + (if (eq gds-status 'waiting-for-input) + (gds-request-focus client) + (setq gds-stack nil))) + + (;; (module MODULE ...) - The specified module's bindings. + (eq proc 'module) + (let ((minfo (assoc (car args) gds-modules))) + (if minfo + (setcdr (cdr minfo) (cdr args))))) + + (;; (closed) - Client has gone away. + (eq proc 'closed) + (setq gds-status 'closed) + (gds-update-buffers client) + (setq gds-buffers + (delq (assq client gds-buffers) gds-buffers)) + (if (eq client gds-focus-client) + (gds-quit))) + + (;; (eval-results ...) - Results of evaluation. + (eq proc 'eval-results) + (gds-display-results client args)) + + ((eq proc 'completion-result) + (setq gds-completion-results (or (car args) t))) + + ))) + ;;;; Guile Debugging keymap. @@ -637,55 +657,52 @@ not of primary interest when debugging application code." (define-key gds-mode-map "g" (function gds-go)) (define-key gds-mode-map "b" (function gds-set-breakpoint)) (define-key gds-mode-map "q" (function gds-quit)) -(define-key gds-mode-map "y" (function gds-yield)) (define-key gds-mode-map " " (function gds-next)) (define-key gds-mode-map "e" (function gds-evaluate)) (define-key gds-mode-map "i" (function gds-step-in)) (define-key gds-mode-map "o" (function gds-step-out)) (define-key gds-mode-map "t" (function gds-trace-finish)) +(define-key gds-mode-map "I" (function gds-frame-info)) +(define-key gds-mode-map "A" (function gds-frame-args)) +(define-key gds-mode-map "M" (function gds-query-modules)) -(defun gds-client-waiting () - (eq (cdr (assq gds-displayed-client gds-statuses)) 'waiting-for-input)) +(defun gds-client-blocked () + (eq gds-status 'waiting-for-input)) (defun gds-go () (interactive) - (gds-send (format "(%S debugger-command continue)\n" gds-displayed-client))) - -(defun gds-quit () - (interactive) - (if (gds-client-waiting) - (if (y-or-n-p "Client is waiting for instruction - tell it to continue? ") - (gds-go))) - (gds-yield)) - -(defun gds-yield () - (interactive) - (if (gds-client-waiting) - (gds-focus-yield) - (gds-focus-done))) + (gds-send (format "(%S debugger-command continue)\n" gds-focus-client))) (defun gds-next () (interactive) - (gds-send (format "(%S debugger-command next 1)\n" gds-displayed-client))) + (gds-send (format "(%S debugger-command next 1)\n" gds-focus-client))) (defun gds-evaluate (expr) (interactive "sEvaluate (in this stack frame): ") (gds-send (format "(%S debugger-command evaluate %s)\n" - gds-displayed-client + gds-focus-client (prin1-to-string expr)))) (defun gds-step-in () (interactive) - (gds-send (format "(%S debugger-command step 1)\n" gds-displayed-client))) + (gds-send (format "(%S debugger-command step 1)\n" gds-focus-client))) (defun gds-step-out () (interactive) - (gds-send (format "(%S debugger-command finish)\n" gds-displayed-client))) + (gds-send (format "(%S debugger-command finish)\n" gds-focus-client))) (defun gds-trace-finish () (interactive) (gds-send (format "(%S debugger-command trace-finish)\n" - gds-displayed-client))) + gds-focus-client))) + +(defun gds-frame-info () + (interactive) + (gds-send (format "(%S debugger-command info-frame)\n" gds-focus-client))) + +(defun gds-frame-args () + (interactive) + (gds-send (format "(%S debugger-command info-args)\n" gds-focus-client))) (defun gds-set-breakpoint () (interactive) @@ -704,16 +721,14 @@ not of primary interest when debugging application code." nil) (defun gds-in-stack () - (and (eq (current-buffer) gds-client-buffer) - (save-excursion - (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t) - (looking-at "Stack"))))) + (save-excursion + (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t) + (looking-at "Stack")))) (defun gds-in-modules () - (and (eq (current-buffer) gds-client-buffer) - (save-excursion - (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t) - (looking-at "Modules"))))) + (save-excursion + (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t) + (looking-at "Modules")))) (defun gds-set-module-breakpoint () (let ((sym (save-excursion @@ -740,7 +755,7 @@ not of primary interest when debugging application code." nil "debug-here"))) (gds-send (format "(%S set-breakpoint %s %s %s)\n" - gds-displayed-client + gds-focus-client module sym behaviour))))) @@ -754,13 +769,13 @@ not of primary interest when debugging application code." ;; ;; Where there are multiple Guile applications known to GDS, GDS by ;; default sends code to the one that holds the debugging focus, -;; i.e. `gds-displayed-client'. Where no application has the focus, +;; i.e. `gds-focus-client'. Where no application has the focus, ;; or the command is invoked with `C-u', GDS asks the user which ;; application is intended. (defun gds-read-client () - (let* ((def (if gds-displayed-client - (cdr (assq gds-displayed-client gds-names)))) + (let* ((def (if gds-focus-client + (cdr (assq gds-focus-client gds-names)))) (prompt (if def (concat "Application for eval (default " def @@ -789,21 +804,21 @@ not of primary interest when debugging application code." (if client (gds-read-client)) ;; If ask not forced, and there is a client with the focus, ;; default to that one. - gds-displayed-client + gds-focus-client ;; If there are no clients at this point, and we are allowed to ;; autostart a captive Guile, do so. - (and (null gds-names) + (and (null gds-buffers) gds-autostart-captive (progn (gds-start-captive t) - (while (null gds-names) + (while (null gds-buffers) (accept-process-output (get-buffer-process gds-captive) 0 100000)) - (caar gds-names))) + (caar gds-buffers))) ;; If there is only one known client, use that one. - (if (and (car gds-names) - (null (cdr gds-names))) - (caar gds-names)) + (if (and (car gds-buffers) + (null (cdr gds-buffers))) + (caar gds-buffers)) ;; Last resort - ask the user. (gds-read-client) ;; Signal an error. @@ -884,20 +899,73 @@ region's code." (defun gds-help-symbol (sym &optional client) "Get help for SYM (a Scheme symbol)." - (interactive "SHelp for symbol: \nP") - (gds-eval-expression (format "(begin (help %S) '%S)" sym gds-help-symbol) + (interactive + (let ((sym (thing-at-point 'symbol)) + (enable-recursive-minibuffers t) + val) + (setq val (read-from-minibuffer + (if sym + (format "Describe Guile symbol (default %s): " sym) + "Describe Guile symbol: "))) + (list (if (zerop (length val)) sym val) + current-prefix-arg))) + (gds-eval-expression (format "(begin (help %s) '%S)" sym gds-help-symbol) client)) -(defun gds-help-symbol-here (&optional client) - (interactive "P") - (gds-help-symbol (thing-at-point 'symbol) client)) - (defun gds-apropos (regex &optional client) "List Guile symbols matching REGEX." - (interactive "sApropos Guile regex: \nP") + (interactive + (let ((sym (thing-at-point 'symbol)) + (enable-recursive-minibuffers t) + val) + (setq val (read-from-minibuffer + (if sym + (format "Guile apropos (regexp, default \"%s\"): " sym) + "Guile apropos (regexp): "))) + (list (if (zerop (length val)) sym val) + current-prefix-arg))) (gds-eval-expression (format "(begin (apropos %S) '%S)" regex gds-help-symbol) client)) +(defvar gds-completion-results nil) + +(defun gds-complete-symbol (&optional client) + "Complete the Guile symbol before point. Returns `t' if anything +interesting happened, `nil' if not." + (interactive "P") + (let* ((chars (- (point) (save-excursion + (while (let ((syntax (char-syntax (char-before (point))))) + (or (eq syntax ?w) (eq syntax ?_))) + (forward-char -1)) + (point))))) + (if (zerop chars) + nil + (setq client (gds-choose-client client)) + (setq gds-completion-results nil) + (gds-send (format "(%S complete %s)\n" client + (prin1-to-string + (buffer-substring-no-properties (- (point) chars) + (point))))) + (while (null gds-completion-results) + (accept-process-output gds-process 0 200)) + (cond ((eq gds-completion-results t) + nil) + ((stringp gds-completion-results) + (if (<= (length gds-completion-results) chars) + nil + (insert (substring gds-completion-results chars)) + (message "Sole completion") + t)) + ((= (length gds-completion-results) 1) + (if (<= (length (car gds-completion-results)) chars) + nil + (insert (substring (car gds-completion-results) chars)) + t)) + (t + (with-output-to-temp-buffer "*Completions*" + (display-completion-list gds-completion-results)) + t))))) + ;;;; Display of evaluation and help results. @@ -912,6 +980,7 @@ region's code." (save-excursion (set-buffer buf) (erase-buffer) + (scheme-mode) (while results (insert (car results)) (if helpp @@ -959,9 +1028,12 @@ Used for determining the default for the next `gds-load-file'.") ;; Install the process communication commands in the scheme-mode keymap. (define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention (define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention -(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-defun) +(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression) (define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region) (define-key scheme-mode-map "\C-c\C-l" 'gds-load-file) +(define-key scheme-mode-map "\C-hg" 'gds-help-symbol) +(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos) +(define-key scheme-mode-map "\e\t" 'gds-complete-symbol) ;;;; Menu bar entries. @@ -1007,8 +1079,6 @@ Used for determining the default for the next `gds-load-file'.") (setq gds-help-menu (make-sparse-keymap "Help")) (define-key gds-help-menu [apropos] '(menu-item "Apropos..." gds-apropos)) - (define-key gds-help-menu [sym-here] - '(menu-item "Symbol At Point" gds-help-symbol-here)) (define-key gds-help-menu [sym] '(menu-item "Symbol..." gds-help-symbol))) @@ -1037,17 +1107,17 @@ Used for determining the default for the next `gds-load-file'.") (define-key gds-menu [separator-1] '("--")) (define-key gds-menu [debug] - `(menu-item "Debug" ,gds-debug-menu :enable (and gds-displayed-client - (gds-client-waiting)))) + `(menu-item "Debug" ,gds-debug-menu :enable (and gds-focus-client + (gds-client-blocked)))) (define-key gds-menu [eval] - `(menu-item "Evaluate" ,gds-eval-menu :enable (or gds-names + `(menu-item "Evaluate" ,gds-eval-menu :enable (or gds-buffers gds-autostart-captive))) (define-key gds-menu [help] - `(menu-item "Help" ,gds-help-menu :enable (or gds-names + `(menu-item "Help" ,gds-help-menu :enable (or gds-buffers gds-autostart-captive))) (setq menu-bar-final-items (cons 'guile menu-bar-final-items)) - (define-key global-map [menu-bar guile] + (define-key scheme-mode-map [menu-bar guile] (cons "Guile" gds-menu))) @@ -1089,8 +1159,8 @@ Used for determining the default for the next `gds-load-file'.") (let ((proc (get-buffer-process gds-captive))) (comint-send-string proc "(set! %load-path (cons \"/home/neil/Guile/cvs/guile-core\" %load-path))\n") (comint-send-string proc "(debug-enable 'backtrace)\n") - (comint-send-string proc "(use-modules (ice-9 debugger ui-client))\n") - (comint-send-string proc "(ui-connect \"Captive Guile\" #f)\n")))) + (comint-send-string proc "(use-modules (emacs gds-client))\n") + (comint-send-string proc "(gds-connect \"Captive Guile\" #f)\n")))) (defun gds-kill-captive () (if gds-captive @@ -1098,7 +1168,7 @@ Used for determining the default for the next `gds-load-file'.") (process-kill-without-query proc) (condition-case nil (progn - (kill-process gds-process) + (kill-process proc) (accept-process-output gds-process 0 200)) (error))))) From eeac938c7cdeab9cce745dbe77f19dfc1be8560f Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 11 Nov 2003 23:47:56 +0000 Subject: [PATCH 098/239] Addition to .cvsignore. --- .cvsignore | 1 + ChangeLog | 4 ++++ 2 files changed, 5 insertions(+) diff --git a/.cvsignore b/.cvsignore index 1f73cf277..14d3b2fa4 100644 --- a/.cvsignore +++ b/.cvsignore @@ -20,6 +20,7 @@ configure conftest conftest.c depcomp +elisp-comp guile-*.tar.gz guile-tools install-sh diff --git a/ChangeLog b/ChangeLog index d62c4ee58..45e0b0bc5 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2003-11-11 Neil Jerram + + * .cvsignore: Add elisp-comp. + 2003-10-30 Neil Jerram * configure.in (AC_CONFIG_FILES): Add `emacs/Makefile'. From fbff94c9c3db522504ee7eddda7b949f1c915b66 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 13 Nov 2003 18:19:02 +0000 Subject: [PATCH 099/239] (scm_get_stack_base): Provide a definition that return NULL when the machine type is unknown. Previously, gc_os_dep.c would refuse to compile. --- libguile/gc_os_dep.c | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c index 04e180059..c6e61cbe9 100644 --- a/libguile/gc_os_dep.c +++ b/libguile/gc_os_dep.c @@ -3,7 +3,7 @@ * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. * Copyright (c) 1999 by Hewlett-Packard Company. All rights reserved. - * Copyright (c) 2000, 2001, 2002 Free Software Foundation + * Copyright (c) 2000, 2001, 2002, 2003 Free Software Foundation * * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. @@ -394,8 +394,14 @@ typedef int GC_bool; /* SYSV on an M68K actually means A/UX. */ /* The distinction in these cases is usually the stack starting address */ # ifndef mach_type_known - --> unknown machine type -# endif + +void * +scm_get_stack_base () +{ + return NULL; +} + +# else /* Mapping is: M68K ==> Motorola 680X0 */ /* (SUNOS4,HP,NEXT, and SYSV (A/UX), */ /* MACOS and AMIGA variants) */ @@ -1923,4 +1929,5 @@ void *scm_get_stack_base() # endif /* ! OS2 */ # endif /* ! MSWIN32 */ +#endif /* mach_type_known */ #endif /* ! HAVE_LIBC_STACK_END */ From 3890131acdb4628b566fa708c3c97a861ca13691 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 13 Nov 2003 18:23:06 +0000 Subject: [PATCH 100/239] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d395477ab..74ba13f43 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2003-11-13 Marius Vollmer + + * gc_os_dep.c (scm_get_stack_base): Provide a definition that + return NULL when the machine type is unknown. Previously, + gc_os_dep.c would refuse to compile. + 2003-11-09 Dirk Herrmann * eval.c (scm_m_body, m_body, scm_m_lambda, memoize_named_let, From 94e38a653a85ae66979875878e3d04501f98b8c1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 13 Nov 2003 19:40:29 +0000 Subject: [PATCH 101/239] (SCM_SMOB, SCM_GLOBAL_SMOB, SCM_SMOB_MARK, SCM_GLOBAL_SMOB_MARK, SCM_SMOB_FREE, SCM_GLOBAL_SMOB_FREE, SCM_SMOB_PRINT, SCM_GLOBAL_SMOB_PRINT, SCM_SMOB_EQUALP, SCM_GLOBAL_SMOB_EQUALP, SCM_SMOB_APPLY, SCM_GLOBAL_SMOB_APPLY): New macros from Paul Jarc. Thanks! --- libguile/snarf.h | 49 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/libguile/snarf.h b/libguile/snarf.h index 06797142e..b9cbb056c 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -221,6 +221,55 @@ SCM_SNARF_INIT(scm_i_plugin_rec_mutex_init (&c_name, &scm_i_plugin_rec_mutex)) SCM_SNARF_HERE(scm_t_rec_mutex c_name) \ SCM_SNARF_INIT(scm_i_plugin_rec_mutex_init (&c_name, &scm_i_plugin_rec_mutex)) +#define SCM_SMOB(tag, scheme_name, size) \ +SCM_SNARF_HERE(static scm_t_bits tag) \ +SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));) + +#define SCM_GLOBAL_SMOB(tag, scheme_name, size) \ +SCM_SNARF_HERE(scm_t_bits tag) \ +SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));) + +#define SCM_SMOB_MARK(tag, c_name, arg) \ +SCM_SNARF_HERE(static SCM c_name(SCM arg)) \ +SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));) + +#define SCM_GLOBAL_SMOB_MARK(tag, c_name, arg) \ +SCM_SNARF_HERE(SCM c_name(SCM arg)) \ +SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));) + +#define SCM_SMOB_FREE(tag, c_name, arg) \ +SCM_SNARF_HERE(static size_t c_name(SCM arg)) \ +SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));) + +#define SCM_GLOBAL_SMOB_FREE(tag, c_name, arg) \ +SCM_SNARF_HERE(size_t c_name(SCM arg)) \ +SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));) + +#define SCM_SMOB_PRINT(tag, c_name, obj, port, pstate) \ +SCM_SNARF_HERE(static int c_name(SCM obj, SCM port, scm_print_state* pstate)) \ +SCM_SNARF_INIT(scm_set_smob_print((tag), (c_name));) + +#define SCM_GLOBAL_SMOB_PRINT(tag, c_name, obj, port, pstate) \ +SCM_SNARF_HERE(int c_name(SCM obj, SCM port, scm_print_state* pstate)) \ +SCM_SNARF_INIT(scm_set_smob_print((tag), (c_name));) + +#define SCM_SMOB_EQUALP(tag, c_name, obj1, obj2) \ +SCM_SNARF_HERE(static SCM c_name(SCM obj1, SCM obj2)) \ +SCM_SNARF_INIT(scm_set_smob_equalp((tag), (c_name));) + +#define SCM_GLOBAL_SMOB_EQUALP(tag, c_name, obj1, obj2) \ +SCM_SNARF_HERE(SCM c_name(SCM obj1, SCM obj2)) \ +SCM_SNARF_INIT(scm_set_smob_equalp((tag), (c_name));) + +#define SCM_SMOB_APPLY(tag, c_name, req, opt, rest, arglist) \ +SCM_SNARF_HERE(static SCM c_name arglist) \ +SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));) + +#define SCM_GLOBAL_SMOB_APPLY(tag, c_name, req, opt, rest, arglist) \ +SCM_SNARF_HERE(SCM c_name arglist) \ +SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));) + + #ifdef SCM_MAGIC_SNARF_DOCS #undef SCM_ASSERT #define SCM_ASSERT(_cond, _arg, _pos, _subr) ^^ argpos _arg _pos __LINE__ ^^ From 5df36eac8499297bcead81d9a6e92e17ff34001f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 13 Nov 2003 19:41:12 +0000 Subject: [PATCH 102/239] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 74ba13f43..d25655c6b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,11 @@ 2003-11-13 Marius Vollmer + * snarf.h (SCM_SMOB, SCM_GLOBAL_SMOB, SCM_SMOB_MARK, + SCM_GLOBAL_SMOB_MARK, SCM_SMOB_FREE, SCM_GLOBAL_SMOB_FREE, + SCM_SMOB_PRINT, SCM_GLOBAL_SMOB_PRINT, SCM_SMOB_EQUALP, + SCM_GLOBAL_SMOB_EQUALP, SCM_SMOB_APPLY, SCM_GLOBAL_SMOB_APPLY): + New macros from Paul Jarc. Thanks! + * gc_os_dep.c (scm_get_stack_base): Provide a definition that return NULL when the machine type is unknown. Previously, gc_os_dep.c would refuse to compile. From 96e053825271cc1fdaa46378e68b7c2daa62ceff Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 13 Nov 2003 20:46:48 +0000 Subject: [PATCH 103/239] (Manual Layout): Wrap POSIX, API, and SLIB in @acronym. Change from paragraph format (somewhat clumsy-looking on paper, at least) to @table format, with headers @strong. Made example modules complete sentences. From Stephen Compall, thanks! --- doc/ref/preface.texi | 63 ++++++++++++++++++++++++-------------------- 1 file changed, 34 insertions(+), 29 deletions(-) diff --git a/doc/ref/preface.texi b/doc/ref/preface.texi index 737f86065..0313f7337 100644 --- a/doc/ref/preface.texi +++ b/doc/ref/preface.texi @@ -34,23 +34,25 @@ the file @file{COPYING.LIB}. The manual is divided into five parts. -@strong{Part I: Introduction to Guile} provides an overview of what -Guile is and how you can use it. A whirlwind tour shows how Guile can -be used interactively and as a script interpreter, how to link Guile -into your own applications, and how to write modules of interpreted and -compiled code for use with Guile. Everything introduced here is -documented again and in full by the later parts of the manual. This -part also explains how to obtain and install new versions of Guile, and -how to report bugs effectively. +@table @strong +@item Part I: Introduction to Guile +Provides an overview of what Guile is and how you can use it. A +whirlwind tour shows how Guile can be used interactively and as a +script interpreter, how to link Guile into your own applications, and +how to write modules of interpreted and compiled code for use with +Guile. Everything introduced here is documented again and in full by +the later parts of the manual. This part also explains how to obtain +and install new versions of Guile, and how to report bugs effectively. -@strong{Part II: Writing and Running Guile Scheme} and @strong{Part III: -Programming with Guile} document all aspects of practical programming -using Guile. This covers both the Scheme level --- where we provide an -introduction to the key ideas of the Scheme language --- and use of -Guile's @code{scm} interface to write new primitives and objects in C, -and to incorporate Guile into a C application. It also covers the use -of Guile as a POSIX-compliant script interpreter and how to use the -Guile debugger. +@item Part II: Writing and Running Guile Scheme +@itemx Part III: Programming with Guile +Document all aspects of practical programming using Guile. This +covers both the Scheme level --- where we provide an introduction to +the key ideas of the Scheme language --- and use of Guile's @code{scm} +interface to write new primitives and objects in C, and to incorporate +Guile into a C application. It also covers the use of Guile as a +@acronym{POSIX}-compliant script interpreter and how to use the Guile +debugger. @c @strong{Part V: Extending Applications Using Guile} explains the options @c available for using Guile as a application extension language. At the @@ -65,11 +67,12 @@ Guile debugger. @c This part of the manual covers the complete range of application @c extension options. -@strong{Part IV: Guile API Reference} documents Guile's core API. Most -of the variables and procedures in Guile's core programming interface -are available in both Scheme and C and are related systematically such -that the C interface can be inferred from the Scheme interface and vice -versa. Therefore, this part of the manual documents the Guile API in +@item Part IV: Guile API Reference +Documents Guile's core @acronym{API}. Most of the variables and +procedures in Guile's core programming interface are available in both +Scheme and C and are related systematically such that the C interface +can be inferred from the Scheme interface and vice versa. Therefore, +this part of the manual documents the Guile @acronym{API} in functionality-based groups with the Scheme and C interfaces presented side by side. Where the Scheme and C interfaces for a particular functional area do differ --- which is sometimes inevitable, given the @@ -86,20 +89,22 @@ together. @c all documented from scratch, and organized by functionality rather than @c by the defining standards. -@strong{Part V: Guile Modules} describes some important modules, -distributed as part of the Guile distribution, that extend the -functionality provided by the Guile Scheme core. Two important examples -are: +@item Part V: Guile Modules +Describes some important modules, distributed as part of the Guile +distribution, that extend the functionality provided by the Guile +Scheme core. Two important examples are: @itemize @bullet @item -the POSIX module, which provides Scheme-level procedures for system and -network programming that conform to the POSIX standard +The @acronym{POSIX} module, which provides Scheme-level procedures for +system and network programming that conform to the @acronym{POSIX} +standard. @item -the SLIB module, which makes Aubrey Jaffer's portable Scheme library -available for use in Guile. +The @acronym{SLIB} module, which makes Aubrey Jaffer's portable Scheme +library available for use in Guile. @end itemize +@end table @iftex From 89f69c5252ba31b4dcc6bb9cdae73ede67306a7e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 14 Nov 2003 20:51:22 +0000 Subject: [PATCH 104/239] (--with-guile-for-build): Remove this option, it's not normal style for --with. (GUILE_FOR_BUILD): Use AC_ARG_VAR. --- configure.in | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/configure.in b/configure.in index 275ed7beb..bb05268c2 100644 --- a/configure.in +++ b/configure.in @@ -970,15 +970,13 @@ if test "$cross_compiling" = "yes"; then else GUILE_FOR_BUILD='$(preinstguile)' fi -AC_ARG_WITH(guile-for-build, - [ --with-guile-for-build=guile native guile executable, to be used during build]) -test -n "$with_guile_for_build" && GUILE_FOR_BUILD="$with_guile_for_build" ## AC_MSG_CHECKING("if we are cross compiling") ## AC_MSG_RESULT($cross_compiling) if test "$cross_compiling" = "yes"; then AC_MSG_RESULT($GUILE_FOR_BUILD) fi +AC_ARG_VAR(GUILE_FOR_BUILD,[guile for build system]) AC_SUBST(GUILE_FOR_BUILD) ## If we're using GCC, ask for aggressive warnings. From 6deea00ef3a369c9116e2c8ea54e14b272f0f005 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 14 Nov 2003 20:53:22 +0000 Subject: [PATCH 105/239] (Random): Add *random-state* variable, put note at the top of the node about it being the default, rather than just in the description of random. --- doc/ref/scheme-data.texi | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/doc/ref/scheme-data.texi b/doc/ref/scheme-data.texi index f45170773..a05a07e62 100755 --- a/doc/ref/scheme-data.texi +++ b/doc/ref/scheme-data.texi @@ -1229,6 +1229,11 @@ through @var{end} (exclusive) bits of @var{n}. The @node Random @subsection Random Number Generation +Pseudo-random numbers are generated from a random state object, which +can be created with @code{seed->random-state}. The @var{state} +parameter to the various functions below is optional, it defaults to +the state object in the @code{*random-state*} variable. + @deffn {Scheme Procedure} copy-random-state [state] @deffnx {C Function} scm_copy_random_state (state) Return a copy of the random state @var{state}. @@ -1242,12 +1247,6 @@ Accepts a positive integer or real n and returns a number of the same type between zero (inclusive) and @var{n} (exclusive). The values returned have a uniform distribution. - -The optional argument @var{state} must be of the type produced -by @code{seed->random-state}. It defaults to the value of the -variable @code{*random-state*}. This object is used to maintain -the state of the pseudo-random-number generator and is altered -as a side effect of the random operation. @end deffn @deffn {Scheme Procedure} random:exp [state] @@ -1302,6 +1301,11 @@ Return a uniformly distributed inexact real random number in Return a new random state using @var{seed}. @end deffn +@defvar *random-state* +The global random state used by the above functions when the +@var{state} parameter is not given. +@end defvar + @node Characters @section Characters From 8868e47232a318bf09930d322a298bdda99ba2ca Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 14 Nov 2003 20:53:57 +0000 Subject: [PATCH 106/239] *** empty log message *** --- ChangeLog | 6 ++++++ doc/ref/ChangeLog | 6 ++++++ 2 files changed, 12 insertions(+) diff --git a/ChangeLog b/ChangeLog index 45e0b0bc5..f788710fc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2003-11-15 Kevin Ryde + + * configure.in (--with-guile-for-build): Remove this option, it's not + normal style for --with. + (GUILE_FOR_BUILD): Use AC_ARG_VAR. + 2003-11-11 Neil Jerram * .cvsignore: Add elisp-comp. diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 828b06e4c..104a5a4a5 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,9 @@ +2003-11-15 Kevin Ryde + + * scheme-data.texi (Random): Add *random-state* variable, put note at + the top of the node about it being the default, rather than just in + the description of random. + 2003-11-09 Kevin Ryde * misc-modules.texi (Pretty Printing): Add new keyword options, break From 1028fcb2cfd266885b0faebcbbd580dea7341c2c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 14 Nov 2003 21:27:11 +0000 Subject: [PATCH 107/239] (Cross building Guile): Describe GUILE_FOR_BUILD rather than --with-guile-for-build. --- README | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/README b/README index b6c337a92..30b72bc23 100644 --- a/README +++ b/README @@ -222,11 +222,8 @@ with the CC_FOR_BUILD variable in the usual way, for instance ./configure --host=m68k-unknown-linux-gnu CC_FOR_BUILD=/my/local/gcc -A further special option for cross building is available: - ---with-guile-for-build --- native Guile executable, to be used during build - defaults to: `guile', assuming you just - installed this guile natively. +Guile for the build system can be specified similarly with the +GUILE_FOR_BUILD variable, it defaults to just "guile". Using Guile Without Installing It ========================================= From 08134d1d761acb7449ff2a903f571088e77faf2d Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 14 Nov 2003 21:27:36 +0000 Subject: [PATCH 108/239] *** empty log message *** --- ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog b/ChangeLog index f788710fc..0d22b8dc3 100644 --- a/ChangeLog +++ b/ChangeLog @@ -3,6 +3,8 @@ * configure.in (--with-guile-for-build): Remove this option, it's not normal style for --with. (GUILE_FOR_BUILD): Use AC_ARG_VAR. + * README (Cross building Guile): Describe GUILE_FOR_BUILD rather than + --with-guile-for-build. 2003-11-11 Neil Jerram From 2a71634743a75e12e66e4eb018e540bdfe739051 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 14 Nov 2003 21:34:21 +0000 Subject: [PATCH 109/239] Use (test-suite lib), for the benefit of standalone execution. --- test-suite/tests/bit-operations.test | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test-suite/tests/bit-operations.test b/test-suite/tests/bit-operations.test index 141da0340..95e24fc9c 100644 --- a/test-suite/tests/bit-operations.test +++ b/test-suite/tests/bit-operations.test @@ -1,5 +1,5 @@ ;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2003 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -15,7 +15,8 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -(use-modules (ice-9 documentation)) +(use-modules (test-suite lib) + (ice-9 documentation)) ;;; From c4a56a692d2b04752759cbe90dbe8ab922d8ac10 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 14 Nov 2003 21:36:18 +0000 Subject: [PATCH 110/239] *** empty log message *** --- test-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 036069e55..0d6e7a6ad 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2003-11-15 Kevin Ryde + + * tests/bit-operations.test: Use (test-suite lib), for the benefit of + standalone execution. + 2003-11-09 Dirk Herrmann * tests/optargs.test: Wrap tests in module (test-suite From c3d948015a1cc7fc633d3a28d62507d5be169e0a Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 15 Nov 2003 11:51:17 +0000 Subject: [PATCH 111/239] * tests/syntax.test: Fixed test that checks for the correct handling of macros in the context of internal defines. --- test-suite/ChangeLog | 5 +++++ test-suite/tests/syntax.test | 14 +++++++++----- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 0d6e7a6ad..d254c1b62 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2003-11-15 Dirk Herrmann + + * tests/syntax.test: Fixed test that checks for the correct + handling of macros in the context of internal defines. + 2003-11-15 Kevin Ryde * tests/bit-operations.test: Use (test-suite lib), for the benefit of diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 37a8fbe4b..d6ce13deb 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -643,14 +643,18 @@ (eq? 'c (a 2) (a 5)))) (interaction-environment)))) - (expect-fail "internal defines with macro application" + (pass-if "internal defines with macro application" (false-if-exception (eval '(begin - (defmacro a forms + (defmacro my-define forms (cons 'define forms)) - (let ((c identity) (x #t)) - (define (a x y) (and x y)) - (a (c x) (c x)))) + (let ((a identity) (b identity) (c identity)) + (define (a x) (if (= x 0) 'a (b (- x 1)))) + (my-define (b x) (if (= x 0) 'b (c (- x 1)))) + (define (c x) (if (= x 0) 'c (a (- x 1)))) + (and (eq? 'a (a 0) (a 3)) + (eq? 'b (a 1) (a 4)) + (eq? 'c (a 2) (a 5))))) (interaction-environment)))) (pass-if-exception "missing body expression" From c86c440b17cc85d57015b63802d7e10c60c5deaa Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 15 Nov 2003 12:27:54 +0000 Subject: [PATCH 112/239] * libguile/eval.c (s_mixed_body_forms): New static identifier. (canonicalize_define, scm_m_define): The check for a bad expression is performed in canonicalize_define now. (try_macro_lookup, expand_user_macros, is_system_macro_p): New static helper functions for m_expand_body. (m_expand_body): Use ASSERT_SYNTAX to signal syntax errors. Only expand user defined macros. Fixed handling of the definition/ expression boundary. Fixed handling of definitions grouped with 'begin. Use canonicalize_define to expand definitions. * test-suite/tests/syntax.test: Tests that check for the correct handling of internal defines with begin work now. --- libguile/ChangeLog | 15 ++ libguile/eval.c | 261 +++++++++++++++++++++++++++-------- test-suite/ChangeLog | 5 + test-suite/tests/syntax.test | 4 +- 4 files changed, 224 insertions(+), 61 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d25655c6b..afc488cb5 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2003-11-15 Dirk Herrmann + + * eval.c (s_mixed_body_forms): New static identifier. + + (canonicalize_define, scm_m_define): The check for a bad + expression is performed in canonicalize_define now. + + (try_macro_lookup, expand_user_macros, is_system_macro_p): New + static helper functions for m_expand_body. + + (m_expand_body): Use ASSERT_SYNTAX to signal syntax errors. Only + expand user defined macros. Fixed handling of the definition/ + expression boundary. Fixed handling of definitions grouped with + 'begin. Use canonicalize_define to expand definitions. + 2003-11-13 Marius Vollmer * snarf.h (SCM_SMOB, SCM_GLOBAL_SMOB, SCM_SMOB_MARK, diff --git a/libguile/eval.c b/libguile/eval.c index 793a28ce2..6b8e336b6 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -115,12 +115,6 @@ static const char s_expression[] = "Missing or extra expression in"; * context, a 'Missing expression' error is signalled. */ static const char s_missing_expression[] = "Missing expression in"; -/* A body may hold an arbitrary number of internal defines, followed by a - * non-empty sequence of expressions. If a body with an empty sequence of - * expressions is detected, a 'Missing body expression' error is signalled. - */ -static const char s_missing_body_expression[] = "Missing body expression in"; - /* If a form is detected that holds more expressions than are allowed in that * context, an 'Extra expression' error is signalled. */ static const char s_extra_expression[] = "Extra expression in"; @@ -132,6 +126,21 @@ static const char s_extra_expression[] = "Extra expression in"; * do so, you need to quote the empty list like (quote ()) or '(). */ static const char s_empty_combination[] = "Illegal empty combination"; +/* A body may hold an arbitrary number of internal defines, followed by a + * non-empty sequence of expressions. If a body with an empty sequence of + * expressions is detected, a 'Missing body expression' error is signalled. + */ +static const char s_missing_body_expression[] = "Missing body expression in"; + +/* A body may hold an arbitrary number of internal defines, followed by a + * non-empty sequence of expressions. Each the definitions and the + * expressions may be grouped arbitraryly with begin, but it is not allowed to + * mix definitions and expressions. If a define form in a body mixes + * definitions and expressions, a 'Mixed definitions and expressions' error is + * signalled. + */ +static const char s_mixed_body_forms[] = "Mixed definitions and expressions in"; + /* Case or cond expressions must have at least one clause. If a case or cond * expression without any clauses is detected, a 'Missing clauses' error is * signalled. */ @@ -896,6 +905,7 @@ canonicalize_define (const SCM expr) SCM variable; const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); body = SCM_CDR (cdr_expr); @@ -931,8 +941,6 @@ scm_m_define (SCM expr, SCM env) SCM cdr_canonical_definition; SCM body; - ASSERT_SYNTAX (scm_ilength (expr) >= 0, s_bad_expression, expr); - canonical_definition = canonicalize_define (expr); cdr_canonical_definition = SCM_CDR (canonical_definition); body = SCM_CDR (cdr_canonical_definition); @@ -1828,65 +1836,200 @@ scm_m_undefine (SCM expr, SCM env) #endif +/* The function m_expand_body memoizes a proper list of expressions forming a + * body. This function takes care of dealing with internal defines and + * transforming them into an equivalent letrec expression. */ + +/* This is a helper function for m_expand_body. It helps to figure out whether + * an expression denotes a syntactic keyword. */ static SCM -m_expand_body (const SCM xorig, const SCM env) +try_macro_lookup (const SCM expr, const SCM env) { - SCM x = SCM_CDR (xorig), defs = SCM_EOL; - - while (SCM_NIMP (x)) + if (SCM_SYMBOLP (expr)) { - SCM form = SCM_CAR (x); - if (!SCM_CONSP (form)) - break; - if (!SCM_SYMBOLP (SCM_CAR (form))) - break; - - form = scm_macroexp (scm_cons_source (form, - SCM_CAR (form), - SCM_CDR (form)), - env); - - if (SCM_EQ_P (SCM_IM_DEFINE, SCM_CAR (form))) - { - defs = scm_cons (SCM_CDR (form), defs); - x = SCM_CDR (x); - } - else if (!SCM_IMP (defs)) - { - break; - } - else if (SCM_EQ_P (SCM_IM_BEGIN, SCM_CAR (form))) - { - x = scm_append (scm_list_2 (SCM_CDR (form), SCM_CDR (x))); - } - else - { - x = scm_cons (form, SCM_CDR (x)); - break; - } - } - - /* FIXME: xorig is already partially memoized and does not hold information - * about the file location. */ - ASSERT_SYNTAX (SCM_CONSP (x), s_missing_body_expression, xorig); - - if (!SCM_NULLP (defs)) - { - SCM rvars, inits, body, letrec; - check_bindings (defs, xorig); - transform_bindings (defs, xorig, &rvars, &inits); - body = m_body (SCM_IM_DEFINE, x); - letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); - SCM_SETCAR (xorig, letrec); - SCM_SETCDR (xorig, SCM_EOL); + const SCM tmp_pair = scm_list_1 (expr); + const SCM value = *scm_lookupcar1 (tmp_pair, env, 0); + return value; } else { - SCM_SETCAR (xorig, SCM_CAR (x)); - SCM_SETCDR (xorig, SCM_CDR (x)); + return SCM_UNDEFINED; + } +} + +/* This is a helper function for m_expand_body. It expands user macros, + * because for the correct translation of a body we need to know whether they + * expand to a definition. */ +static SCM +expand_user_macros (SCM expr, const SCM env) +{ + while (SCM_CONSP (expr)) + { + const SCM car_expr = SCM_CAR (expr); + const SCM new_car = expand_user_macros (car_expr, env); + const SCM value = try_macro_lookup (new_car, env); + + if (SCM_MACROP (value) && SCM_MACRO_TYPE (value) == 2) + { + /* User macros transform code into code. */ + expr = scm_call_2 (SCM_MACRO_CODE (value), expr, env); + /* We need to reiterate on the transformed code. */ + } + else + { + /* No user macro: return. */ + SCM_SETCAR (expr, new_car); + return expr; + } } - return xorig; + return expr; +} + +/* This is a helper function for m_expand_body. It determines if a given form + * represents an application of a given built-in macro. The built-in macro to + * check for is identified by its syntactic keyword. The form is an + * application of the given macro if looking up the car of the form in the + * given environment actually returns the built-in macro. */ +static int +is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env) +{ + if (SCM_CONSP (form)) + { + const SCM car_form = SCM_CAR (form); + const SCM value = try_macro_lookup (car_form, env); + if (SCM_BUILTIN_MACRO_P (value)) + { + const SCM macro_name = scm_macro_name (value); + return SCM_EQ_P (macro_name, syntactic_keyword); + } + } + + return 0; +} + +static SCM +m_expand_body (const SCM forms, const SCM env) +{ + /* The first body form can be skipped since it is known to be the ISYM that + * was prepended to the body by m_body. */ + SCM cdr_forms = SCM_CDR (forms); + SCM form_idx = cdr_forms; + SCM definitions = SCM_EOL; + SCM sequence = SCM_EOL; + + /* According to R5RS, the list of body forms consists of two parts: a number + * (maybe zero) of definitions, followed by a non-empty sequence of + * expressions. Each the definitions and the expressions may be grouped + * arbitrarily with begin, but it is not allowed to mix definitions and + * expressions. The task of the following loop therefore is to split the + * list of body forms into the list of definitions and the sequence of + * expressions. */ + while (!SCM_NULLP (form_idx)) + { + const SCM form = SCM_CAR (form_idx); + const SCM new_form = expand_user_macros (form, env); + if (is_system_macro_p (scm_sym_define, new_form, env)) + { + definitions = scm_cons (new_form, definitions); + form_idx = SCM_CDR (form_idx); + } + else if (is_system_macro_p (scm_sym_begin, new_form, env)) + { + /* We have encountered a group of forms. This has to be either a + * (possibly empty) group of (possibly further grouped) definitions, + * or a non-empty group of (possibly further grouped) + * expressions. */ + const SCM grouped_forms = SCM_CDR (new_form); + unsigned int found_definition = 0; + unsigned int found_expression = 0; + SCM grouped_form_idx = grouped_forms; + while (!found_expression && !SCM_NULLP (grouped_form_idx)) + { + const SCM inner_form = SCM_CAR (grouped_form_idx); + const SCM new_inner_form = expand_user_macros (inner_form, env); + if (is_system_macro_p (scm_sym_define, new_inner_form, env)) + { + found_definition = 1; + definitions = scm_cons (new_inner_form, definitions); + grouped_form_idx = SCM_CDR (grouped_form_idx); + } + else if (is_system_macro_p (scm_sym_begin, new_inner_form, env)) + { + const SCM inner_group = SCM_CDR (new_inner_form); + grouped_form_idx + = scm_append (scm_list_2 (inner_group, + SCM_CDR (grouped_form_idx))); + } + else + { + /* The group marks the start of the expressions of the body. + * We have to make sure that within the same group we have + * not encountered a definition before. */ + ASSERT_SYNTAX (!found_definition, s_mixed_body_forms, form); + found_expression = 1; + grouped_form_idx = SCM_EOL; + } + } + + /* We have finished processing the group. If we have not yet + * encountered an expression we continue processing the forms of the + * body to collect further definition forms. Otherwise, the group + * marks the start of the sequence of expressions of the body. */ + if (!found_expression) + { + form_idx = SCM_CDR (form_idx); + } + else + { + sequence = form_idx; + form_idx = SCM_EOL; + } + } + else + { + /* We have detected a form which is no definition. This marks the + * start of the sequence of expressions of the body. */ + sequence = form_idx; + form_idx = SCM_EOL; + } + } + + /* FIXME: forms does not hold information about the file location. */ + ASSERT_SYNTAX (SCM_CONSP (sequence), s_missing_body_expression, cdr_forms); + + if (!SCM_NULLP (definitions)) + { + SCM definition_idx; + SCM letrec_tail; + SCM letrec_expression; + SCM new_letrec_expression; + SCM new_body; + + SCM bindings = SCM_EOL; + for (definition_idx = definitions; + !SCM_NULLP (definition_idx); + definition_idx = SCM_CDR (definition_idx)) + { + const SCM definition = SCM_CAR (definition_idx); + const SCM canonical_definition = canonicalize_define (definition); + const SCM binding = SCM_CDR (canonical_definition); + bindings = scm_cons (binding, bindings); + }; + + letrec_tail = scm_cons (bindings, sequence); + /* FIXME: forms does not hold information about the file location. */ + letrec_expression = scm_cons_source (forms, scm_sym_letrec, letrec_tail); + new_letrec_expression = scm_m_letrec (letrec_expression, env); + new_body = scm_list_1 (new_letrec_expression); + return new_body; + } + else + { + SCM_SETCAR (forms, SCM_CAR (sequence)); + SCM_SETCDR (forms, SCM_CDR (sequence)); + return forms; + } } #if (SCM_ENABLE_DEPRECATED == 1) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d254c1b62..63238d5f7 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2003-11-15 Dirk Herrmann + + * tests/syntax.test: Tests that check for the correct handling of + internal defines with begin work now. + 2003-11-15 Dirk Herrmann * tests/syntax.test: Fixed test that checks for the correct diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index d6ce13deb..e7a6458fb 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -619,7 +619,7 @@ (eq? 'c (a 2) (a 5)))) (interaction-environment))) - (expect-fail "internal defines with begin" + (pass-if "internal defines with begin" (false-if-exception (eval '(let ((a identity) (b identity) (c identity)) (define (a x) (if (= x 0) 'a (b (- x 1)))) @@ -631,7 +631,7 @@ (eq? 'c (a 2) (a 5)))) (interaction-environment)))) - (expect-fail "internal defines with empty begin" + (pass-if "internal defines with empty begin" (false-if-exception (eval '(let ((a identity) (b identity) (c identity)) (define (a x) (if (= x 0) 'a (b (- x 1)))) From 910b512506d24b4a7c7f55e0b1d4940b5b7d15bc Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 15 Nov 2003 12:43:00 +0000 Subject: [PATCH 113/239] * eval.c (try_macro_lookup, expand_user_macros, is_system_macro_p, m_expand_body, scm_m_expand_body): Grouped together with m_body. No further modifications. --- libguile/ChangeLog | 6 + libguile/eval.c | 420 ++++++++++++++++++++++----------------------- 2 files changed, 216 insertions(+), 210 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index afc488cb5..d93158e65 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2003-11-15 Dirk Herrmann + + * eval.c (try_macro_lookup, expand_user_macros, is_system_macro_p, + m_expand_body, scm_m_expand_body): Grouped together with m_body. + No further modifications. + 2003-11-15 Dirk Herrmann * eval.c (s_mixed_body_forms): New static identifier. diff --git a/libguile/eval.c b/libguile/eval.c index 6b8e336b6..281addeda 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -713,6 +713,216 @@ m_body (SCM op, SCM exprs) } +/* The function m_expand_body memoizes a proper list of expressions forming a + * body. This function takes care of dealing with internal defines and + * transforming them into an equivalent letrec expression. */ + +/* This is a helper function for m_expand_body. It helps to figure out whether + * an expression denotes a syntactic keyword. */ +static SCM +try_macro_lookup (const SCM expr, const SCM env) +{ + if (SCM_SYMBOLP (expr)) + { + const SCM tmp_pair = scm_list_1 (expr); + const SCM value = *scm_lookupcar1 (tmp_pair, env, 0); + return value; + } + else + { + return SCM_UNDEFINED; + } +} + +/* This is a helper function for m_expand_body. It expands user macros, + * because for the correct translation of a body we need to know whether they + * expand to a definition. */ +static SCM +expand_user_macros (SCM expr, const SCM env) +{ + while (SCM_CONSP (expr)) + { + const SCM car_expr = SCM_CAR (expr); + const SCM new_car = expand_user_macros (car_expr, env); + const SCM value = try_macro_lookup (new_car, env); + + if (SCM_MACROP (value) && SCM_MACRO_TYPE (value) == 2) + { + /* User macros transform code into code. */ + expr = scm_call_2 (SCM_MACRO_CODE (value), expr, env); + /* We need to reiterate on the transformed code. */ + } + else + { + /* No user macro: return. */ + SCM_SETCAR (expr, new_car); + return expr; + } + } + + return expr; +} + +/* This is a helper function for m_expand_body. It determines if a given form + * represents an application of a given built-in macro. The built-in macro to + * check for is identified by its syntactic keyword. The form is an + * application of the given macro if looking up the car of the form in the + * given environment actually returns the built-in macro. */ +static int +is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env) +{ + if (SCM_CONSP (form)) + { + const SCM car_form = SCM_CAR (form); + const SCM value = try_macro_lookup (car_form, env); + if (SCM_BUILTIN_MACRO_P (value)) + { + const SCM macro_name = scm_macro_name (value); + return SCM_EQ_P (macro_name, syntactic_keyword); + } + } + + return 0; +} + +static SCM +m_expand_body (const SCM forms, const SCM env) +{ + /* The first body form can be skipped since it is known to be the ISYM that + * was prepended to the body by m_body. */ + SCM cdr_forms = SCM_CDR (forms); + SCM form_idx = cdr_forms; + SCM definitions = SCM_EOL; + SCM sequence = SCM_EOL; + + /* According to R5RS, the list of body forms consists of two parts: a number + * (maybe zero) of definitions, followed by a non-empty sequence of + * expressions. Each the definitions and the expressions may be grouped + * arbitrarily with begin, but it is not allowed to mix definitions and + * expressions. The task of the following loop therefore is to split the + * list of body forms into the list of definitions and the sequence of + * expressions. */ + while (!SCM_NULLP (form_idx)) + { + const SCM form = SCM_CAR (form_idx); + const SCM new_form = expand_user_macros (form, env); + if (is_system_macro_p (scm_sym_define, new_form, env)) + { + definitions = scm_cons (new_form, definitions); + form_idx = SCM_CDR (form_idx); + } + else if (is_system_macro_p (scm_sym_begin, new_form, env)) + { + /* We have encountered a group of forms. This has to be either a + * (possibly empty) group of (possibly further grouped) definitions, + * or a non-empty group of (possibly further grouped) + * expressions. */ + const SCM grouped_forms = SCM_CDR (new_form); + unsigned int found_definition = 0; + unsigned int found_expression = 0; + SCM grouped_form_idx = grouped_forms; + while (!found_expression && !SCM_NULLP (grouped_form_idx)) + { + const SCM inner_form = SCM_CAR (grouped_form_idx); + const SCM new_inner_form = expand_user_macros (inner_form, env); + if (is_system_macro_p (scm_sym_define, new_inner_form, env)) + { + found_definition = 1; + definitions = scm_cons (new_inner_form, definitions); + grouped_form_idx = SCM_CDR (grouped_form_idx); + } + else if (is_system_macro_p (scm_sym_begin, new_inner_form, env)) + { + const SCM inner_group = SCM_CDR (new_inner_form); + grouped_form_idx + = scm_append (scm_list_2 (inner_group, + SCM_CDR (grouped_form_idx))); + } + else + { + /* The group marks the start of the expressions of the body. + * We have to make sure that within the same group we have + * not encountered a definition before. */ + ASSERT_SYNTAX (!found_definition, s_mixed_body_forms, form); + found_expression = 1; + grouped_form_idx = SCM_EOL; + } + } + + /* We have finished processing the group. If we have not yet + * encountered an expression we continue processing the forms of the + * body to collect further definition forms. Otherwise, the group + * marks the start of the sequence of expressions of the body. */ + if (!found_expression) + { + form_idx = SCM_CDR (form_idx); + } + else + { + sequence = form_idx; + form_idx = SCM_EOL; + } + } + else + { + /* We have detected a form which is no definition. This marks the + * start of the sequence of expressions of the body. */ + sequence = form_idx; + form_idx = SCM_EOL; + } + } + + /* FIXME: forms does not hold information about the file location. */ + ASSERT_SYNTAX (SCM_CONSP (sequence), s_missing_body_expression, cdr_forms); + + if (!SCM_NULLP (definitions)) + { + SCM definition_idx; + SCM letrec_tail; + SCM letrec_expression; + SCM new_letrec_expression; + SCM new_body; + + SCM bindings = SCM_EOL; + for (definition_idx = definitions; + !SCM_NULLP (definition_idx); + definition_idx = SCM_CDR (definition_idx)) + { + const SCM definition = SCM_CAR (definition_idx); + const SCM canonical_definition = canonicalize_define (definition); + const SCM binding = SCM_CDR (canonical_definition); + bindings = scm_cons (binding, bindings); + }; + + letrec_tail = scm_cons (bindings, sequence); + /* FIXME: forms does not hold information about the file location. */ + letrec_expression = scm_cons_source (forms, scm_sym_letrec, letrec_tail); + new_letrec_expression = scm_m_letrec (letrec_expression, env); + new_body = scm_list_1 (new_letrec_expression); + return new_body; + } + else + { + SCM_SETCAR (forms, SCM_CAR (sequence)); + SCM_SETCDR (forms, SCM_CDR (sequence)); + return forms; + } +} + +#if (SCM_ENABLE_DEPRECATED == 1) + +/* Deprecated in guile 1.7.0 on 2003-11-09. */ +SCM +scm_m_expand_body (SCM exprs, SCM env) +{ + scm_c_issue_deprecation_warning + ("`scm_m_expand_body' is deprecated."); + return m_expand_body (exprs, env); +} + +#endif + + /* Start of the memoizers for the standard R5RS builtin macros. */ @@ -1836,216 +2046,6 @@ scm_m_undefine (SCM expr, SCM env) #endif -/* The function m_expand_body memoizes a proper list of expressions forming a - * body. This function takes care of dealing with internal defines and - * transforming them into an equivalent letrec expression. */ - -/* This is a helper function for m_expand_body. It helps to figure out whether - * an expression denotes a syntactic keyword. */ -static SCM -try_macro_lookup (const SCM expr, const SCM env) -{ - if (SCM_SYMBOLP (expr)) - { - const SCM tmp_pair = scm_list_1 (expr); - const SCM value = *scm_lookupcar1 (tmp_pair, env, 0); - return value; - } - else - { - return SCM_UNDEFINED; - } -} - -/* This is a helper function for m_expand_body. It expands user macros, - * because for the correct translation of a body we need to know whether they - * expand to a definition. */ -static SCM -expand_user_macros (SCM expr, const SCM env) -{ - while (SCM_CONSP (expr)) - { - const SCM car_expr = SCM_CAR (expr); - const SCM new_car = expand_user_macros (car_expr, env); - const SCM value = try_macro_lookup (new_car, env); - - if (SCM_MACROP (value) && SCM_MACRO_TYPE (value) == 2) - { - /* User macros transform code into code. */ - expr = scm_call_2 (SCM_MACRO_CODE (value), expr, env); - /* We need to reiterate on the transformed code. */ - } - else - { - /* No user macro: return. */ - SCM_SETCAR (expr, new_car); - return expr; - } - } - - return expr; -} - -/* This is a helper function for m_expand_body. It determines if a given form - * represents an application of a given built-in macro. The built-in macro to - * check for is identified by its syntactic keyword. The form is an - * application of the given macro if looking up the car of the form in the - * given environment actually returns the built-in macro. */ -static int -is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env) -{ - if (SCM_CONSP (form)) - { - const SCM car_form = SCM_CAR (form); - const SCM value = try_macro_lookup (car_form, env); - if (SCM_BUILTIN_MACRO_P (value)) - { - const SCM macro_name = scm_macro_name (value); - return SCM_EQ_P (macro_name, syntactic_keyword); - } - } - - return 0; -} - -static SCM -m_expand_body (const SCM forms, const SCM env) -{ - /* The first body form can be skipped since it is known to be the ISYM that - * was prepended to the body by m_body. */ - SCM cdr_forms = SCM_CDR (forms); - SCM form_idx = cdr_forms; - SCM definitions = SCM_EOL; - SCM sequence = SCM_EOL; - - /* According to R5RS, the list of body forms consists of two parts: a number - * (maybe zero) of definitions, followed by a non-empty sequence of - * expressions. Each the definitions and the expressions may be grouped - * arbitrarily with begin, but it is not allowed to mix definitions and - * expressions. The task of the following loop therefore is to split the - * list of body forms into the list of definitions and the sequence of - * expressions. */ - while (!SCM_NULLP (form_idx)) - { - const SCM form = SCM_CAR (form_idx); - const SCM new_form = expand_user_macros (form, env); - if (is_system_macro_p (scm_sym_define, new_form, env)) - { - definitions = scm_cons (new_form, definitions); - form_idx = SCM_CDR (form_idx); - } - else if (is_system_macro_p (scm_sym_begin, new_form, env)) - { - /* We have encountered a group of forms. This has to be either a - * (possibly empty) group of (possibly further grouped) definitions, - * or a non-empty group of (possibly further grouped) - * expressions. */ - const SCM grouped_forms = SCM_CDR (new_form); - unsigned int found_definition = 0; - unsigned int found_expression = 0; - SCM grouped_form_idx = grouped_forms; - while (!found_expression && !SCM_NULLP (grouped_form_idx)) - { - const SCM inner_form = SCM_CAR (grouped_form_idx); - const SCM new_inner_form = expand_user_macros (inner_form, env); - if (is_system_macro_p (scm_sym_define, new_inner_form, env)) - { - found_definition = 1; - definitions = scm_cons (new_inner_form, definitions); - grouped_form_idx = SCM_CDR (grouped_form_idx); - } - else if (is_system_macro_p (scm_sym_begin, new_inner_form, env)) - { - const SCM inner_group = SCM_CDR (new_inner_form); - grouped_form_idx - = scm_append (scm_list_2 (inner_group, - SCM_CDR (grouped_form_idx))); - } - else - { - /* The group marks the start of the expressions of the body. - * We have to make sure that within the same group we have - * not encountered a definition before. */ - ASSERT_SYNTAX (!found_definition, s_mixed_body_forms, form); - found_expression = 1; - grouped_form_idx = SCM_EOL; - } - } - - /* We have finished processing the group. If we have not yet - * encountered an expression we continue processing the forms of the - * body to collect further definition forms. Otherwise, the group - * marks the start of the sequence of expressions of the body. */ - if (!found_expression) - { - form_idx = SCM_CDR (form_idx); - } - else - { - sequence = form_idx; - form_idx = SCM_EOL; - } - } - else - { - /* We have detected a form which is no definition. This marks the - * start of the sequence of expressions of the body. */ - sequence = form_idx; - form_idx = SCM_EOL; - } - } - - /* FIXME: forms does not hold information about the file location. */ - ASSERT_SYNTAX (SCM_CONSP (sequence), s_missing_body_expression, cdr_forms); - - if (!SCM_NULLP (definitions)) - { - SCM definition_idx; - SCM letrec_tail; - SCM letrec_expression; - SCM new_letrec_expression; - SCM new_body; - - SCM bindings = SCM_EOL; - for (definition_idx = definitions; - !SCM_NULLP (definition_idx); - definition_idx = SCM_CDR (definition_idx)) - { - const SCM definition = SCM_CAR (definition_idx); - const SCM canonical_definition = canonicalize_define (definition); - const SCM binding = SCM_CDR (canonical_definition); - bindings = scm_cons (binding, bindings); - }; - - letrec_tail = scm_cons (bindings, sequence); - /* FIXME: forms does not hold information about the file location. */ - letrec_expression = scm_cons_source (forms, scm_sym_letrec, letrec_tail); - new_letrec_expression = scm_m_letrec (letrec_expression, env); - new_body = scm_list_1 (new_letrec_expression); - return new_body; - } - else - { - SCM_SETCAR (forms, SCM_CAR (sequence)); - SCM_SETCDR (forms, SCM_CDR (sequence)); - return forms; - } -} - -#if (SCM_ENABLE_DEPRECATED == 1) - -/* Deprecated in guile 1.7.0 on 2003-11-09. */ -SCM -scm_m_expand_body (SCM exprs, SCM env) -{ - scm_c_issue_deprecation_warning - ("`scm_m_expand_body' is deprecated."); - return m_expand_body (exprs, env); -} - -#endif - - SCM scm_macroexp (SCM x, SCM env) { From 6f81708ae081e9226bf71719ce70e529527f12b6 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 16 Nov 2003 10:47:45 +0000 Subject: [PATCH 114/239] * eval.c (s_splicing): Commented and reformulated. (lookup_global_symbol, lookup_symbol): New static functions. (s_test, s_bindings, s_duplicate_bindings, s_variable): Removed. (try_macro_lookup, literal_p): Use lookup_symbol instead of creating a temporary pair for scm_lookupcar. (scm_unmemocar, unmemocar): Renamed scm_unmemocar to unmemocar, created deprecated wrapper function scm_unmemocar. (SCM_VALIDATE_NON_EMPTY_COMBINATION, scm_sym_else, scm_sym_unquote, scm_sym_uq_splicing, scm_sym_enter_frame, scm_sym_apply_frame, scm_sym_exit_frame, scm_sym_trace, f_apply, undefineds, sym_three_question_marks): Moved around without modifications. * eval.c, eval.h (scm_macroexp, scm_unmemocar): Deprecated. --- NEWS | 4 +- libguile/ChangeLog | 22 ++++++ libguile/eval.c | 193 ++++++++++++++++++++++++++++++++------------- libguile/eval.h | 6 +- 4 files changed, 169 insertions(+), 56 deletions(-) diff --git a/NEWS b/NEWS index b8a6849dd..461d6cc49 100644 --- a/NEWS +++ b/NEWS @@ -895,11 +895,13 @@ These macros were used in the implementation of the evaluator. It's unlikely that they have been used by user code. ** Deprecated helper functions for evaluation and application: -scm_m_expand_body +scm_m_expand_body, scm_macroexp These functions were used in the implementation of the evaluator. It's unlikely that they have been used by user code. +** Deprecated functions for unmemoization: scm_unmemocar + ** Deprecated macros for iloc handling: SCM_ILOC00, SCM_IDINC, SCM_IDSTMSK These macros were used in the implementation of the evaluator. It's unlikely diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d93158e65..f4131b36b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2003-11-16 Dirk Herrmann + + * eval.c (s_splicing): Commented and reformulated. + + (lookup_global_symbol, lookup_symbol): New static functions. + + (s_test, s_bindings, s_duplicate_bindings, s_variable): Removed. + + (try_macro_lookup, literal_p): Use lookup_symbol instead of + creating a temporary pair for scm_lookupcar. + + (scm_unmemocar, unmemocar): Renamed scm_unmemocar to unmemocar, + created deprecated wrapper function scm_unmemocar. + + (SCM_VALIDATE_NON_EMPTY_COMBINATION, scm_sym_else, + scm_sym_unquote, scm_sym_uq_splicing, scm_sym_enter_frame, + scm_sym_apply_frame, scm_sym_exit_frame, scm_sym_trace, f_apply, + undefineds, sym_three_question_marks): Moved around without + modifications. + + * eval.c, eval.h (scm_macroexp, scm_unmemocar): Deprecated. + 2003-11-15 Dirk Herrmann * eval.c (try_macro_lookup, expand_user_macros, is_system_macro_p, diff --git a/libguile/eval.c b/libguile/eval.c index 281addeda..671831d73 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -219,6 +219,11 @@ static const char s_bad_formal[] = "Bad formal"; * more than once, a 'Duplicate formal' error is signalled. */ static const char s_duplicate_formal[] = "Duplicate formal"; +/* If the evaluation of an unquote-splicing expression gives something else + * than a proper list, a 'Non-list result for unquote-splicing' error is + * signalled. */ +static const char s_splicing[] = "Non-list result for unquote-splicing"; + /* If something else than an exact integer is detected as the argument for * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */ static const char s_bad_slot_number[] = "Bad slot number"; @@ -358,8 +363,90 @@ SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", 1, 0, 0, -#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ - ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x) +/* The function lookup_symbol is used during memoization: Lookup the symbol + * in the environment. If there is no binding for the symbol, SCM_UNDEFINED + * is returned. If the symbol is a syntactic keyword, the macro object to + * which the symbol is bound is returned. If the symbol is a global variable, + * the variable object to which the symbol is bound is returned. Finally, if + * the symbol is a local variable the corresponding iloc object is returned. + */ + +/* A helper function for lookup_symbol: Try to find the symbol in the top + * level environment frame. The function returns SCM_UNDEFINED if the symbol + * is unbound, it returns a macro object if the symbol is a syntactic keyword + * and it returns a variable object if the symbol is a global variable. */ +static SCM +lookup_global_symbol (const SCM symbol, const SCM top_level) +{ + const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F); + if (SCM_FALSEP (variable)) + { + return SCM_UNDEFINED; + } + else + { + const SCM value = SCM_VARIABLE_REF (variable); + if (SCM_MACROP (value)) + return value; + else + return variable; + } +} + +static SCM +lookup_symbol (const SCM symbol, const SCM env) +{ + SCM frame_idx; + unsigned int frame_nr; + + for (frame_idx = env, frame_nr = 0; + !SCM_NULLP (frame_idx); + frame_idx = SCM_CDR (frame_idx), ++frame_nr) + { + const SCM frame = SCM_CAR (frame_idx); + if (SCM_CONSP (frame)) + { + /* frame holds a local environment frame */ + SCM symbol_idx; + unsigned int symbol_nr; + + for (symbol_idx = SCM_CAR (frame), symbol_nr = 0; + SCM_CONSP (symbol_idx); + symbol_idx = SCM_CDR (symbol_idx), ++symbol_nr) + { + if (SCM_EQ_P (SCM_CAR (symbol_idx), symbol)) + /* found the symbol, therefore return the iloc */ + return SCM_MAKE_ILOC (frame_nr, symbol_nr, 0); + } + if (SCM_EQ_P (symbol_idx, symbol)) + /* found the symbol as the last element of the current frame */ + return SCM_MAKE_ILOC (frame_nr, symbol_nr, 1); + } + else + { + /* no more local environment frames */ + return lookup_global_symbol (symbol, frame); + } + } + + return lookup_global_symbol (symbol, SCM_BOOL_F); +} + + +/* Return true if the symbol is - from the point of view of a macro + * transformer - a literal in the sense specified in chapter "pattern + * language" of R5RS. In the code below, however, we don't match the + * definition of R5RS exactly: It returns true if the identifier has no + * binding or if it is a syntactic keyword. */ +static int +literal_p (const SCM symbol, const SCM env) +{ + const SCM value = lookup_symbol (symbol, env); + if (SCM_UNBNDP (value) || SCM_MACROP (value)) + return 1; + else + return 0; +} @@ -423,13 +510,6 @@ SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", 1, 0, 0, SCM_REC_MUTEX (source_mutex); -static const char s_test[] = "bad test"; -static const char s_bindings[] = "bad bindings"; -static const char s_duplicate_bindings[] = "duplicate bindings"; -static const char s_variable[] = "bad variable"; -static const char s_splicing[] = "bad (non-list) result for unquote-splicing"; - - /* Lookup a given local variable in an environment. The local variable is * given as an iloc, that is a triple , where frame * indicates the relative number of the environment frame (counting upwards @@ -652,22 +732,6 @@ scm_lookupcar (SCM vloc, SCM genv, int check) return loc; } -/* Return true if the symbol is - from the point of view of a macro - * transformer - a literal in the sense specified in chapter "pattern - * language" of R5RS. In the code below, however, we don't match the - * definition of R5RS exactly: It returns true if the identifier has no - * binding or if it is a syntactic keyword. */ -static int -literal_p (const SCM symbol, const SCM env) -{ - const SCM x = scm_cons (symbol, SCM_UNDEFINED); - const SCM value = *scm_lookupcar (x, env, 0); - if (SCM_UNBNDP (value) || SCM_MACROP (value)) - return 1; - else - return 0; -} - SCM scm_eval_car (SCM pair, SCM env) @@ -676,20 +740,6 @@ scm_eval_car (SCM pair, SCM env) } -/* - * The following rewrite expressions and - * some memoized forms have different syntax - */ - -SCM_GLOBAL_SYMBOL (scm_sym_else, "else"); -SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote"); -SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing"); - -SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame"); -SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame"); -SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame"); -SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); - /* Rewrite the body (which is given as the list of expressions forming the * body) into its internal form. The internal form of a body ( ...) is @@ -724,8 +774,7 @@ try_macro_lookup (const SCM expr, const SCM env) { if (SCM_SYMBOLP (expr)) { - const SCM tmp_pair = scm_list_1 (expr); - const SCM value = *scm_lookupcar1 (tmp_pair, env, 0); + const SCM value = lookup_symbol (expr, env); return value; } else @@ -969,6 +1018,7 @@ scm_m_begin (SCM expr, SCM env SCM_UNUSED) SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case); SCM_GLOBAL_SYMBOL (scm_sym_case, s_case); +SCM_GLOBAL_SYMBOL (scm_sym_else, "else"); SCM scm_m_case (SCM expr, SCM env) @@ -1618,6 +1668,8 @@ scm_m_or (SCM expr, SCM env SCM_UNUSED) SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote); +SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote"); +SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing"); /* Internal function to handle a quasiquotation: 'form' is the parameter in * the call (quasiquotation form), 'env' is the environment where unquoted @@ -2046,6 +2098,8 @@ scm_m_undefine (SCM expr, SCM env) #endif +#if (SCM_ENABLE_DEPRECATED == 1) + SCM scm_macroexp (SCM x, SCM env) { @@ -2090,12 +2144,17 @@ scm_macroexp (SCM x, SCM env) goto macro_tail; } +#endif + +/*****************************************************************************/ +/*****************************************************************************/ +/* The definitions for unmemoization start here. */ +/*****************************************************************************/ +/*****************************************************************************/ + #define SCM_BIT7(x) (127 & SCM_UNPACK (x)) -/* A function object to implement "apply" for non-closure functions. */ -static SCM f_apply; -/* An endless list consisting of # objects: */ -static SCM undefineds; +SCM_SYMBOL (sym_three_question_marks, "???"); /* scm_unmemocopy takes a memoized expression together with its @@ -2128,12 +2187,8 @@ build_binding_list (SCM rnames, SCM rinits) } -SCM_SYMBOL (sym_three_question_marks, "???"); - -#define unmemocar scm_unmemocar - -SCM -scm_unmemocar (SCM form, SCM env) +static SCM +unmemocar (SCM form, SCM env) { if (!SCM_CONSP (form)) return form; @@ -2162,6 +2217,18 @@ scm_unmemocar (SCM form, SCM env) } } + +#if (SCM_ENABLE_DEPRECATED == 1) + +SCM +scm_unmemocar (SCM form, SCM env) +{ + return unmemocar (form, env); +} + +#endif + + static SCM unmemocopy (SCM x, SCM env) { @@ -2396,7 +2463,6 @@ loop: return ls; } - SCM scm_unmemocopy (SCM x, SCM env) { @@ -2409,7 +2475,24 @@ scm_unmemocopy (SCM x, SCM env) } -int +/*****************************************************************************/ +/*****************************************************************************/ +/* The definitions for execution start here. */ +/*****************************************************************************/ +/*****************************************************************************/ + +SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame"); +SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame"); +SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame"); +SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); + +/* A function object to implement "apply" for non-closure functions. */ +static SCM f_apply; +/* An endless list consisting of # objects: */ +static SCM undefineds; + + +int scm_badargsp (SCM formals, SCM args) { while (!SCM_NULLP (formals)) @@ -2667,6 +2750,10 @@ deval_args (SCM l, SCM env, SCM proc, SCM *lloc) } while (0) +#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ + ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x) + + /* This is the evaluator. Like any real monster, it has three heads: * * scm_ceval is the non-debugging evaluator, scm_deval is the debugging diff --git a/libguile/eval.h b/libguile/eval.h index 3f6acb529..94e07c01d 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -131,7 +131,6 @@ SCM_API SCM scm_sym_args; SCM_API SCM * scm_ilookup (SCM iloc, SCM env); SCM_API SCM * scm_lookupcar (SCM vloc, SCM genv, int check); -SCM_API SCM scm_unmemocar (SCM form, SCM env); SCM_API SCM scm_unmemocopy (SCM form, SCM env); SCM_API SCM scm_eval_car (SCM pair, SCM env); SCM_API SCM scm_eval_body (SCM code, SCM env); @@ -186,7 +185,6 @@ SCM_API scm_t_trampoline_2 scm_trampoline_2 (SCM proc); SCM_API SCM scm_nconc2last (SCM lst); SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_dapply (SCM proc, SCM arg1, SCM args); -SCM_API SCM scm_macroexp (SCM x, SCM env); SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_closure (SCM code, SCM env); @@ -212,6 +210,10 @@ SCM_API SCM scm_m_undefine (SCM x, SCM env); /* Deprecated in guile 1.7.0 on 2003-11-09. */ SCM_API SCM scm_m_expand_body (SCM xorig, SCM env); +/* Deprecated in guile 1.7.0 on 2003-11-16. */ +SCM_API SCM scm_unmemocar (SCM form, SCM env); +SCM_API SCM scm_macroexp (SCM x, SCM env); + #endif From 461bffb131fef926638069b4525190f971ce8c5e Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 16 Nov 2003 13:32:02 +0000 Subject: [PATCH 115/239] * eval.c (scm_m_letstar): Create memoized code in place to minimize consing. --- libguile/ChangeLog | 5 +++++ libguile/eval.c | 28 ++++++++++++++++++++++------ 2 files changed, 27 insertions(+), 6 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f4131b36b..98e43df90 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-11-16 Dirk Herrmann + + * eval.c (scm_m_letstar): Create memoized code in place to + minimize consing. + 2003-11-16 Dirk Herrmann * eval.c (s_splicing): Commented and reformulated. diff --git a/libguile/eval.c b/libguile/eval.c index 671831d73..50a5663eb 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1585,7 +1585,6 @@ SCM scm_m_letstar (SCM expr, SCM env SCM_UNUSED) { SCM binding_idx; - SCM new_bindings = SCM_EOL; SCM new_body; const SCM cdr_expr = SCM_CDR (expr); @@ -1595,17 +1594,34 @@ scm_m_letstar (SCM expr, SCM env SCM_UNUSED) binding_idx = SCM_CAR (cdr_expr); check_bindings (binding_idx, expr); - for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx)) + /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The + * transformation is done in place. At the beginning of one iteration of + * the loop the variable binding_idx holds the form + * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ), + * where P1, P2 and P3 indicate the pairs, that are relevant for the + * transformation. P1 and P2 are modified in the loop, P3 remains + * untouched. After the execution of the loop, P1 will hold + * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) ) + * and binding_idx will hold P3. */ + while (!SCM_NULLP (binding_idx)) { + const SCM cdr_binding_idx = SCM_CDR (binding_idx); /* remember P3 */ const SCM binding = SCM_CAR (binding_idx); const SCM name = SCM_CAR (binding); - const SCM init = SCM_CADR (binding); - new_bindings = scm_cons2 (init, name, new_bindings); + const SCM cdr_binding = SCM_CDR (binding); + + SCM_SETCDR (cdr_binding, cdr_binding_idx); /* update P2 */ + SCM_SETCAR (binding_idx, name); /* update P1 */ + SCM_SETCDR (binding_idx, cdr_binding); /* update P1 */ + + binding_idx = cdr_binding_idx; /* continue with P3 */ } - new_bindings = scm_reverse_x (new_bindings, SCM_UNDEFINED); new_body = m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr)); - return scm_cons2 (SCM_IM_LETSTAR, new_bindings, new_body); + SCM_SETCAR (expr, SCM_IM_LETSTAR); + /* the bindings have been changed in place */ + SCM_SETCDR (cdr_expr, new_body); + return expr; } From 37f5dfe5339d137c7ab7ed9762eaf3b66277273d Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 16 Nov 2003 13:54:26 +0000 Subject: [PATCH 116/239] * boot-9.scm: Started comment about module system workings. --- ice-9/ChangeLog | 4 ++ ice-9/boot-9.scm | 102 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 106 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 0fa2a44a4..ed7666e40 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2003-11-16 Dirk Herrmann + + * boot-9.scm: Started comment about module system workings. + 2003-11-11 Neil Jerram * debugger.scm: Change ui-* calls to gds-*. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index b06c34484..512b47655 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -887,6 +887,108 @@ ;;; ;;; These are the low level data structures for modules. ;;; +;;; Every module object is of the type 'module-type', which is a record +;;; consisting of the following members: +;;; +;;; - eval-closure: the function that defines for its module the strategy that +;;; shall be followed when looking up symbols in the module. +;;; +;;; An eval-closure is a function taking two arguments: the symbol to be +;;; looked up and a boolean value telling whether a binding for the symbol +;;; should be created if it does not exist yet. If the symbol lookup +;;; succeeded (either because an existing binding was found or because a new +;;; binding was created), a variable object representing the binding is +;;; returned. Otherwise, the value #f is returned. Note that the eval +;;; closure does not take the module to be searched as an argument: During +;;; construction of the eval-closure, the eval-closure has to store the +;;; module it belongs to in its environment. This means, that any +;;; eval-closure can belong to only one module. +;;; +;;; The eval-closure of a module can be defined arbitrarily. However, three +;;; special cases of eval-closures are to be distinguished: During startup +;;; the module system is not yet activated. In this phase, no modules are +;;; defined and all bindings are automatically stored by the system in the +;;; pre-modules-obarray. Since no eval-closures exist at this time, the +;;; functions which require an eval-closure as their argument need to be +;;; passed the value #f. +;;; +;;; The other two special cases of eval-closures are the +;;; standard-eval-closure and the standard-interface-eval-closure. Both +;;; behave equally for the case that no new binding is to be created. The +;;; difference between the two comes in, when the boolean argument to the +;;; eval-closure indicates that a new binding shall be created if it is not +;;; found. +;;; +;;; Given that no new binding shall be created, both standard eval-closures +;;; define the following standard strategy of searching bindings in the +;;; module: First, the module's obarray is searched for the symbol. Second, +;;; if no binding for the symbol was found in the module's obarray, the +;;; module's binder procedure is exececuted. If this procedure did not +;;; return a binding for the symbol, the modules referenced in the module's +;;; uses list are recursively searched for a binding of the symbol. If the +;;; binding can not be found in these modules also, the symbol lookup has +;;; failed. +;;; +;;; If a new binding shall be created, the standard-interface-eval-closure +;;; immediately returns indicating failure. That is, it does not even try +;;; to look up the symbol. In contrast, the standard-eval-closure would +;;; first search the obarray, and if no binding was found there, would +;;; create a new binding in the obarray, therefore not calling the binder +;;; procedure or searching the modules in the uses list. +;;; +;;; The explanation of the following members obarray, binder and uses +;;; assumes that the symbol lookup follows the strategy that is defined in +;;; the standard-eval-closure and the standard-interface-eval-closure. +;;; +;;; - obarray: a hash table that maps symbols to variable objects. In this +;;; hash table, the definitions are found that are local to the module (that +;;; is, not imported from other modules). When looking up bindings in the +;;; module, this hash table is searched first. +;;; +;;; - binder: either #f or a function taking a module and a symbol argument. +;;; If it is a function it is called after the obarray has been +;;; unsuccessfully searched for a binding. It then can provide bindings +;;; that would otherwise not be found locally in the module. +;;; +;;; - uses: a list of modules from which non-local bindings can be inherited. +;;; These modules are the third place queried for bindings after the obarray +;;; has been unsuccessfully searched and the binder function did not deliver +;;; a result either. +;;; +;;; - transformer: either #f or a function taking a scheme expression as +;;; delivered by read. If it is a function, it will be called to perform +;;; syntax transformations (e. g. makro expansion) on the given scheme +;;; expression. The output of the transformer function will then be passed +;;; to Guile's internal memoizer. This means that the output must be valid +;;; scheme code. The only exception is, that the output may make use of the +;;; syntax extensions provided to identify the modules that a binding +;;; belongs to. +;;; +;;; - name: the name of the module. This is used for all kinds of printing +;;; outputs. In certain places the module name also serves as a way of +;;; identification. When adding a module to the uses list of another +;;; module, it is made sure that the new uses list will not contain two +;;; modules of the same name. +;;; +;;; - kind: classification of the kind of module. The value is (currently?) +;;; only used for printing. It has no influence on how a module is treated. +;;; Currently the following values are used when setting the module kind: +;;; 'module, 'directory, 'interface, 'custom-interface. If no explicit kind +;;; is set, it defaults to 'module. +;;; +;;; - duplicates-handlers +;;; +;;; - duplicates-interface +;;; +;;; - observers +;;; +;;; - weak-observers +;;; +;;; - observer-id +;;; +;;; In addition, the module may (must?) contain a binding for +;;; %module-public-interface... More explanations here... +;;; ;;; !!! warning: The interface to lazy binder procedures is going ;;; to be changed in an incompatible way to permit all the basic ;;; module ops to be virtualized. From 59e8c5a3e9ea1d83f235ec714660e7a6b8dcf70c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 16 Nov 2003 20:55:04 +0000 Subject: [PATCH 117/239] *** empty log message *** --- doc/ref/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 104a5a4a5..428726101 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -4,6 +4,13 @@ the top of the node about it being the default, rather than just in the description of random. +2003-11-13 Marius Vollmer + + * preface.texi (Manual Layout): Wrap POSIX, API, and SLIB in + @acronym. Change from paragraph format (somewhat clumsy-looking + on paper, at least) to @table format, with headers @strong. Made + example modules complete sentences. From Stephen Compall, thanks! + 2003-11-09 Kevin Ryde * misc-modules.texi (Pretty Printing): Add new keyword options, break From c62a38765d0b8d508d89eda037fa00787889d42b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 16 Nov 2003 21:01:57 +0000 Subject: [PATCH 118/239] (scm_lreadr): detect EOF after backslash, and interpret \xNN hexadecimal sequences. From Paul Jarc, thanks! --- libguile/read.c | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/libguile/read.c b/libguile/read.c index 583c1466f..2d391d973 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -489,7 +489,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) while ('"' != (c = scm_getc (port))) { if (c == EOF) - scm_input_error (FUNC_NAME, port, "end of file in string constant", SCM_EOL); + str_eof: scm_input_error (FUNC_NAME, port, "end of file in string constant", SCM_EOL); while (j + 2 >= SCM_STRING_LENGTH (*tok_buf)) scm_grow_tok_buf (tok_buf); @@ -497,6 +497,8 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) if (c == '\\') switch (c = scm_getc (port)) { + case EOF: + goto str_eof; case '\n': continue; case '0': @@ -520,6 +522,30 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) case 'v': c = '\v'; break; + case 'x': + { + int a, b, a_09 = 0, b_09 = 0, a_AF = 0, b_AF = 0, a_af = 0, + b_af = 0; + a = scm_getc (port); + if (a == EOF) goto str_eof; + b = scm_getc (port); + if (b == EOF) goto str_eof; + if ('0' <= a && a <= '9') a_09 = 1; + else if ('A' <= a && a <= 'F') a_AF = 1; + else if ('a' <= a && a <= 'f') a_af = 1; + if ('0' <= b && b <= '9') b_09 = 1; + else if ('A' <= b && b <= 'F') b_AF = 1; + else if ('a' <= b && b <= 'f') b_af = 1; + if ((a_09 || a_AF || a_af) && (b_09 || b_AF || b_af)) + c = (a_09? a - '0': a_AF? a - 'A' + 10: a - 'a' + 10) * 16 + + (b_09? b - '0': b_AF? b - 'A' + 10: b - 'a' + 10); + else + { + scm_ungetc (b, port); + scm_ungetc (a, port); + } + break; + } } SCM_STRING_CHARS (*tok_buf)[j] = c; ++j; From 8b31d75b34c98ead99d76cd6752d167430c60065 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 17 Nov 2003 00:22:18 +0000 Subject: [PATCH 119/239] (scm_compile_shell_switches): Use scm_c_read_string for the "-e" option instead of scm_str2symbol. This allows things like (@ ...) to be specified for the entry point. --- libguile/script.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/script.c b/libguile/script.c index 3e6624594..74a910db0 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002 Free Software Foundation, Inc. +/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either @@ -495,7 +495,7 @@ scm_compile_shell_switches (int argc, char **argv) else if (! strcmp (argv[i], "-e")) /* entry point */ { if (++i < argc) - entry_point = scm_str2symbol (argv[i]); + entry_point = scm_c_read_string (argv[i]); else scm_shell_usage (1, "missing argument to `-e' switch"); } From 7893dbbf456efdbecd42746458d462bbffeccac7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 17 Nov 2003 00:24:48 +0000 Subject: [PATCH 120/239] (scm_m_generalized_set_x): Macroexpand the target when it is a list. This allows (@ ...) to work with set!. --- libguile/eval.c | 42 +++++++++++++++++++++++++++++++----------- 1 file changed, 31 insertions(+), 11 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 50a5663eb..c8a534501 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1798,7 +1798,8 @@ scm_m_set_x (SCM expr, SCM env SCM_UNUSED) ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); variable = SCM_CAR (cdr_expr); - ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable) || SCM_VARIABLEP (variable), + s_bad_variable, variable, expr); SCM_SETCAR (expr, SCM_IM_SET_X); return expr; @@ -1930,9 +1931,9 @@ SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x); SCM_SYMBOL (scm_sym_setter, "setter"); SCM -scm_m_generalized_set_x (SCM expr, SCM env SCM_UNUSED) +scm_m_generalized_set_x (SCM expr, SCM env) { - SCM target; + SCM target, exp_target; const SCM cdr_expr = SCM_CDR (expr); ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); @@ -1947,16 +1948,35 @@ scm_m_generalized_set_x (SCM expr, SCM env SCM_UNUSED) else { /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */ + /* Macroexpanding the target might return things of the form + (begin ). In that case, must be a symbol or a + variable and we memoize to (set! ...). + */ + exp_target = scm_macroexp (target, env); + if (SCM_EQ_P (SCM_CAR (exp_target), SCM_IM_BEGIN) + && !SCM_NULLP (SCM_CDR (exp_target)) + && SCM_NULLP (SCM_CDDR (exp_target))) + { + exp_target= SCM_CADR (exp_target); + SCM_ASSYNT (SCM_SYMBOLP (exp_target) || SCM_VARIABLEP (exp_target), + s_bad_variable, s_set_x); + return scm_cons (SCM_IM_SET_X, scm_cons (exp_target, + SCM_CDR (cdr_expr))); + } + else + { + const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target)); + const SCM setter_proc = scm_cons_source (expr, scm_sym_setter, + setter_proc_tail); - const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target)); - const SCM setter_proc = scm_cons_source (expr, scm_sym_setter, setter_proc_tail); + const SCM cddr_expr = SCM_CDR (cdr_expr); + const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target), + cddr_expr)); - const SCM cddr_expr = SCM_CDR (cdr_expr); - const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target), cddr_expr)); - - SCM_SETCAR (expr, setter_proc); - SCM_SETCDR (expr, setter_args); - return expr; + SCM_SETCAR (expr, setter_proc); + SCM_SETCDR (expr, setter_args); + return expr; + } } } From b58e7420391f8ff674a8bae3474743ff0ff5ffc9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 17 Nov 2003 00:26:14 +0000 Subject: [PATCH 121/239] *** empty log message *** --- libguile/ChangeLog | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 98e43df90..98d07f52f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2003-11-17 Marius Vollmer + + * eval.c (scm_m_generalized_set_x): Macroexpand the target when it + is a list. This allows (@ ...) to work with set!. + + * script.c (scm_compile_shell_switches): Use scm_c_read_string for + the "-e" option instead of scm_str2symbol. This allows things + like (@ ...) to be specified for the entry point. + 2003-11-16 Dirk Herrmann * eval.c (scm_m_letstar): Create memoized code in place to @@ -48,6 +57,9 @@ 2003-11-13 Marius Vollmer + * read.c (scm_lreadr): detect EOF after backslash, and interpret + \xNN hexadecimal sequences. From Paul Jarc, thanks! + * snarf.h (SCM_SMOB, SCM_GLOBAL_SMOB, SCM_SMOB_MARK, SCM_GLOBAL_SMOB_MARK, SCM_SMOB_FREE, SCM_GLOBAL_SMOB_FREE, SCM_SMOB_PRINT, SCM_GLOBAL_SMOB_PRINT, SCM_SMOB_EQUALP, From 473687d1307aaed9d63f4cad1335e7ee6a010ff3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 17 Nov 2003 00:28:03 +0000 Subject: [PATCH 122/239] (@, @@): New macros. --- ice-9/boot-9.scm | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 512b47655..3989f69e9 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2893,6 +2893,31 @@ (define load load-module) +;; The following macro allows one to write, for example, +;; +;; (@ (ice-9 pretty-print) pretty-print) +;; +;; to refer directly to the pretty-print variable in module (ice-9 +;; pretty-print). It works by looking up the variable and inserting +;; it directly into the code. This is understood by the evaluator. +;; Indeed, all references to global variables are memoized into such +;; variable objects. + +(define-macro (@ mod-name var-name) + (let ((var (module-variable (resolve-interface mod-name) var-name))) + (if (not var) + (error "no such public variable" (list '@ mod-name var-name))) + var)) + +;; The '@@' macro is like '@' but it can also access bindings that +;; have not been explicitely exported. + +(define-macro (@@ mod-name var-name) + (let ((var (module-variable (resolve-module mod-name) var-name))) + (if (not var) + (error "no such variable" (list '@@ mod-name var-name))) + var)) + ;;; {Parameters} ;;; From da769b1937801843e5f5d6de4924fac2e615ba10 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 17 Nov 2003 00:36:00 +0000 Subject: [PATCH 123/239] * scheme-modules.texi: Document '@' and '@@'. * scripts.texi: Mention that "-e (@ ...)" also works. --- doc/ref/scheme-modules.texi | 37 +++++++++++++++++++++++++++++++++++++ doc/ref/scripts.texi | 5 +++++ 2 files changed, 42 insertions(+) diff --git a/doc/ref/scheme-modules.texi b/doc/ref/scheme-modules.texi index d15d8c23f..012238d74 100644 --- a/doc/ref/scheme-modules.texi +++ b/doc/ref/scheme-modules.texi @@ -254,6 +254,32 @@ close-pipe unixy:close-pipe This example also shows how to use the convenience procedure @code{symbol-prefix-proc}. +You can also directly refer to bindings in a module by using the +@code{@@} syntax. For example, instead of using the +@code{use-modules} statement from above and writing +@code{unixy:pipe-open} to refer to the @code{pipe-open} from the +@code{(ice-9 popen)}, you could also write @code{(@@ (ice-9 popen) +open-pipe)}. Thus an alternative to the complete @code{use-modules} +statement would be + +@smalllisp +(define unixy:pipe-open (@@ (ice-9 popen) open-pipe)) +(define unixy:close-pipe (@@ (ice-9 popen) close-pipe)) +@end smalllisp + +There is also @code{@@@@}, which can be used like @code{@@}, but does +not check whether the variable that is being accessed is actually +exported. Thus, @code{@@@@} can be thought of as the impolite version +of @code{@@} and should only be used as a last resort or for +debugging, for example. + +Note that just as with a @code{use-modules} statement, any module that +has not yet been loaded yet will be loaded when referenced by a +@code{@@} or @code{@@@@} form. + +You can also use the @code{@@} and @code{@@@@} syntaxes as the target +of a @code{set!} when the binding refers to a variable. + @c begin (scm-doc-string "boot-9.scm" "symbol-prefix-proc") @deffn {Scheme Procedure} symbol-prefix-proc prefix-sym Return a procedure that prefixes its arg (a symbol) with @@ -302,6 +328,17 @@ transformer as the system transformer for the currently defined module, as well as installing it as the current system transformer. @end deffn +@deffn syntax @@ module-name binding-name +Refer to the binding named @var{binding-name} in module +@var{module-name}. The binding must have been exported by the module. +@end deffn + +@deffn syntax @@@@ module-name binding-name +Refer to the binding named @var{binding-name} in module +@var{module-name}. The binding must not have been exported by the +module. This syntax is only intended for debugging purposes or as a +last resort. +@end deffn @node Creating Guile Modules @subsection Creating Guile Modules diff --git a/doc/ref/scripts.texi b/doc/ref/scripts.texi index 10549dc12..e0c5f2345 100644 --- a/doc/ref/scripts.texi +++ b/doc/ref/scripts.texi @@ -60,6 +60,11 @@ always invokes the @var{function} as the @emph{last} action it performs. This is weird, but because of the way script invocation works under POSIX, the @code{-s} option must always come last in the list. +The @var{function} is most often a simple symbol that names a function +that is defined in the script. It can also be of the form @code{(@@ +@var{module-name} @var{symbol}} and in that case, the symbol is +looked up in the module named @var{module-name}. + @xref{Scripting Examples}. @item -ds From aff7e166e8a11a5a014e3de757a6b8060d0dba09 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 17 Nov 2003 00:38:25 +0000 Subject: [PATCH 124/239] *** empty log message *** --- NEWS | 33 +++++++++++++++++++++++++++++++++ doc/ref/ChangeLog | 6 ++++++ ice-9/ChangeLog | 4 ++++ 3 files changed, 43 insertions(+) diff --git a/NEWS b/NEWS index 461d6cc49..2cff4f86f 100644 --- a/NEWS +++ b/NEWS @@ -129,8 +129,41 @@ evaluator turned off, even for interactive sessions. Previously, the normal evaluator would have been used. Using the debugging evaluator gives better error messages. +** The '-e' option now 'read's its argument. + +This is to allow the new '(@ MODULE-NAME VARIABLE-NAME)' construct to +be used with '-e'. For example, you can now write a script like + + #! /bin/sh + exec guile -e '(@ (demo) main)' -s "$0" "$@" + !# + + (define-module (demo) + :export (main)) + + (define (main args) + (format #t "Demo: ~a~%" args)) + + * Changes to Scheme functions and syntax +** New syntax '@' and '@@': + +You can now directly refer to variables exported from a module by +writing + + (@ MODULE-NAME VARIABLE-NAME) + +For example (@ (ice-9 pretty-print) pretty-print) will directly access +the pretty-print variable exported from the (ice-9 pretty-print) +module. You don't need to 'use' that module first. You can also use +'@' with 'set!'. + +The related syntax (@@ MODULE-NAME VARIABLE-NAME) works just like '@', +but it can also access variables that have not been exported. It is +intended only for kluges and temporary fixes and for debugging, not +for ordinary code. + ** 'while' now provides 'break' and 'continue' break and continue were previously bound in a while loop, but not diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 428726101..e0a758c65 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,9 @@ +2003-11-17 Marius Vollmer + + * scheme-modules.texi: Document '@' and '@@'. + + * scripts.texi: Mention that "-e (@ ...)" also works. + 2003-11-15 Kevin Ryde * scheme-data.texi (Random): Add *random-state* variable, put note at diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ed7666e40..2cad1c17c 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2003-11-17 Marius Vollmer + + * boot-9.scm (@, @@): New macros. + 2003-11-16 Dirk Herrmann * boot-9.scm: Started comment about module system workings. From 6d1a2e9f4b676011b029505c602f523bd1aeb64e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 17 Nov 2003 16:52:05 +0000 Subject: [PATCH 125/239] (scm_m_generalized_set_x): Macroexpand the target when it is a list. This allows (@ ...) to work with set!. (scm_m_generalized_set_x): Use ASSERT_SYNTAX_2 instead of SCM_ASSYNT. --- libguile/eval.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index c8a534501..d6135b407 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1958,8 +1958,9 @@ scm_m_generalized_set_x (SCM expr, SCM env) && SCM_NULLP (SCM_CDDR (exp_target))) { exp_target= SCM_CADR (exp_target); - SCM_ASSYNT (SCM_SYMBOLP (exp_target) || SCM_VARIABLEP (exp_target), - s_bad_variable, s_set_x); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target) + || SCM_VARIABLEP (exp_target), + s_bad_variable, exp_target, expr); return scm_cons (SCM_IM_SET_X, scm_cons (exp_target, SCM_CDR (cdr_expr))); } From 64daa01285894544c9aec13b3fd7617be7286caf Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 17 Nov 2003 16:55:03 +0000 Subject: [PATCH 126/239] Expect a "Bad variable" error for (set! #f 1). --- test-suite/tests/srfi-17.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test index f39489db7..6f0cd81f3 100644 --- a/test-suite/tests/srfi-17.test +++ b/test-suite/tests/srfi-17.test @@ -1,6 +1,6 @@ ;;;; srfi-17.test --- test suite for Guile's SRFI-17 functions. -*- scheme -*- ;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2003 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -31,5 +31,5 @@ (set! (symbol->string 'x) 1)) (pass-if-exception "(set! '#f 1)" - exception:wrong-type-arg + exception:bad-variable (eval '(set! '#f 1) (interaction-environment))))) From b4d59261843d0c8809dee3791738b3559e8bf8aa Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 17 Nov 2003 16:56:48 +0000 Subject: [PATCH 127/239] (scm_string_hash): New hashing algorithm that takes the complete string into account. --- libguile/hash.c | 25 ++++++++----------------- 1 file changed, 8 insertions(+), 17 deletions(-) diff --git a/libguile/hash.c b/libguile/hash.c index 8801a7a28..37ff07797 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -37,22 +37,13 @@ extern double floor(); unsigned long scm_string_hash (const unsigned char *str, size_t len) { - if (len > 5) - { - size_t i = 5; - unsigned long h = 264; - while (i--) - h = (h << 8) + (unsigned) str[h % len]; - return h; - } - else - { - size_t i = len; - unsigned long h = 0; - while (i) - h = (h << 8) + (unsigned) str[--i]; - return h; - } + /* from suggestion at: */ + /* http://srfi.schemers.org/srfi-13/mail-archive/msg00112.html */ + + unsigned long h = 0; + while (len-- > 0) + h = *str++ + h*37; + return h; } From 9a1d7d7c8b1889f86b8ceb9ad3a08e35e3876981 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 17 Nov 2003 16:57:27 +0000 Subject: [PATCH 128/239] *** empty log message *** --- libguile/ChangeLog | 5 +++++ test-suite/ChangeLog | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 98d07f52f..23e4af609 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,7 +1,12 @@ 2003-11-17 Marius Vollmer + * hash.c (scm_string_hash): New hashing algorithm that takes the + complete string into account. + * eval.c (scm_m_generalized_set_x): Macroexpand the target when it is a list. This allows (@ ...) to work with set!. + (scm_m_generalized_set_x): Use ASSERT_SYNTAX_2 instead of + SCM_ASSYNT. * script.c (scm_compile_shell_switches): Use scm_c_read_string for the "-e" option instead of scm_str2symbol. This allows things diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 63238d5f7..b5de860d2 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2003-11-17 Marius Vollmer + + * tests/srfi-17.test: Expect a "Bad variable" error for (set! #f + 1). + 2003-11-15 Dirk Herrmann * tests/syntax.test: Tests that check for the correct handling of From 5a76d4dc0552c35c796c5d1a5278c27117904ace Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 17 Nov 2003 18:59:08 +0000 Subject: [PATCH 129/239] *** empty log message *** --- NEWS | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 2cff4f86f..e802eecd3 100644 --- a/NEWS +++ b/NEWS @@ -660,12 +660,12 @@ Guile always defines scm_t_int32 scm_t_uint32 -Guile always defines +Guile always defines these to 0 or 1 SCM_HAVE_T_INT64 SCM_HAVE_T_UINT64 -and when either of these are defined to 1, optionally defines +and when either of these are defined to 1, also defines scm_t_int64 scm_t_uint64 From fb2de91a2ce27b41a05b4030e503d73c64ed3723 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 17 Nov 2003 19:14:44 +0000 Subject: [PATCH 130/239] rewrite ALLOCA related code as multiple lines so it doesn't break with current autoconf substitutions. --- configure.in | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/configure.in b/configure.in index bb05268c2..00724b88c 100644 --- a/configure.in +++ b/configure.in @@ -773,7 +773,10 @@ AC_CHECK_FUNCS(asinh acosh atanh copysign finite isinf isnan sincos trunc) # explicitly to LIBOBJS to make sure that it is translated to # `alloca.lo' for libtool later on. This can and should be done more cleanly. AC_FUNC_ALLOCA -if test "$ALLOCA" = "alloca.o"; then AC_LIBOBJ([alloca]); fi +if test "$ALLOCA" = "alloca.o" +then + AC_LIBOBJ([alloca]) +fi AC_CHECK_MEMBERS([struct stat.st_rdev]) AC_CHECK_MEMBERS([struct stat.st_blksize]) From 936f702bfd43609860415e1b68424bc0e8207598 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 17 Nov 2003 19:15:30 +0000 Subject: [PATCH 131/239] new file. --- emacs/.cvsignore | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 emacs/.cvsignore diff --git a/emacs/.cvsignore b/emacs/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/emacs/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in From ec3972f75363af7c527a94a86df4a83b5144e771 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 17 Nov 2003 19:19:26 +0000 Subject: [PATCH 132/239] *** empty log message *** --- emacs/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 35e0ddffa..5172cc312 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,7 @@ +2003-11-17 Rob Browning + + * .cvsignore: new file. + 2003-11-11 Neil Jerram * gds.el: New. (Or rather, first mention in this ChangeLog.) From 1fe5648d3107c74750ba3563878b63aa9b9f74a9 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Tue, 18 Nov 2003 06:10:11 +0000 Subject: [PATCH 133/239] move long_long and ulong_long definitions to gen-scmconfig.c so that we don't need to add SCM_SIZEOF___INT64 and SCM_SIZEOF_UNSIGNED___INT64 to the public namespace. --- libguile/deprecated.h | 8 -------- 1 file changed, 8 deletions(-) diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 1b76ae2ed..dd9c68bd9 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -80,14 +80,6 @@ SCM_API const char scm_s_formals[]; #define scm_substring_move_left_x scm_substring_move_x #define scm_substring_move_right_x scm_substring_move_x -#if SCM_SIZEOF_LONG_LONG != 0 -typedef long long long_long; -typedef unsigned long long ulong_long; -#elif SCM_SIZEOF___INT64 != 0 -typedef __int64 long_long; -typedef unsigned __int64 ulong_long; -#endif - #define scm_sizet size_t SCM_API SCM scm_wta (SCM arg, const char *pos, const char *s_subr); From 9ca20a9c88b8490f7a991d1983bbea25f9c5076f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Tue, 18 Nov 2003 06:10:39 +0000 Subject: [PATCH 134/239] * gen-scmconfig.c (main): remove public definition of SCM_SIZEOF___INT64 and SCM_SIZEOF_UNSIGNED___INT64 and add direct typedef of long_long and ulong_long inside deprecated block when appropriate. --- libguile/gen-scmconfig.c | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 4384b36eb..481b4ee6a 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -276,8 +276,21 @@ main (int argc, char *argv[]) " be more likely to be what you want */\n"); pf ("#define SCM_SIZEOF_LONG_LONG %d\n", SIZEOF_LONG_LONG); pf ("#define SCM_SIZEOF_UNSIGNED_LONG_LONG %d\n", SIZEOF_UNSIGNED_LONG_LONG); - pf ("#define SCM_SIZEOF___INT64 %d\n", SIZEOF___INT64); - pf ("#define SCM_SIZEOF_UNSIGNED___INT64 %d\n", SIZEOF_UNSIGNED___INT64); + + pf("\n"); + pf("/* handling for the deprecated long_long and ulong_long types */\n"); + pf("/* If anything suitable is available, it'll be defined here. */\n"); + pf("#if (SCM_ENABLE_DEPRECATED == 1)\n"); + if (SIZEOF_LONG_LONG != 0) + pf ("typedef long long long_long;\n"); + else if (SIZEOF___INT64 != 0) + pf ("typedef __int64 long_long;\n"); + + if (SIZEOF_UNSIGNED_LONG_LONG != 0) + pf ("typedef unsigned long long ulong_long;\n"); + else if (SIZEOF_UNSIGNED___INT64 != 0) + pf ("typedef unsigned __int64 ulong_long;\n"); + pf("#endif /* SCM_ENABLE_DEPRECATED == 1 */\n"); pf ("\n"); pf ("/* These are always defined. */\n"); From 28fda54472ab197d36f198f41d474908c45be226 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Tue, 18 Nov 2003 06:14:29 +0000 Subject: [PATCH 135/239] *** empty log message *** --- ChangeLog | 5 +++++ libguile/ChangeLog | 11 +++++++++++ 2 files changed, 16 insertions(+) diff --git a/ChangeLog b/ChangeLog index 0d22b8dc3..1f4a948f1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2003-11-17 Rob Browning + + * configure.in: rewrite ALLOCA related code as multiple lines so + it doesn't break with current autoconf substitutions. + 2003-11-15 Kevin Ryde * configure.in (--with-guile-for-build): Remove this option, it's not diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 23e4af609..d69f16495 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2003-11-18 Rob Browning + + * gen-scmconfig.c (main): remove public definition of + SCM_SIZEOF___INT64 and SCM_SIZEOF_UNSIGNED___INT64 and add + direct typedef of long_long and ulong_long inside deprecated block + when appropriate. + + * deprecated.h: move long_long and ulong_long definitions to + gen-scmconfig.c so that we don't need to add SCM_SIZEOF___INT64 + and SCM_SIZEOF_UNSIGNED___INT64 to the public namespace. + 2003-11-17 Marius Vollmer * hash.c (scm_string_hash): New hashing algorithm that takes the From 9dd9857f77451a706052cae009d2fe7150373c5a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 18 Nov 2003 19:57:30 +0000 Subject: [PATCH 136/239] * tests/numbers.test ("string->number"): Expect exact rationals for things like "1/2" and "#e1.2". ("inexact->exact"): Expect overflow error for infs and nans. * tests/fractions.test: New file from Bill Schottstaedt. Thanks! * tests/bit-operations.test (fixnum-bit): Round the result so that fixnum-bit really is an integer. --- test-suite/tests/bit-operations.test | 2 +- test-suite/tests/fractions.test | 390 +++++++++++++++++++++++++++ test-suite/tests/numbers.test | 20 +- 3 files changed, 402 insertions(+), 10 deletions(-) create mode 100644 test-suite/tests/fractions.test diff --git a/test-suite/tests/bit-operations.test b/test-suite/tests/bit-operations.test index 95e24fc9c..4678d1be8 100644 --- a/test-suite/tests/bit-operations.test +++ b/test-suite/tests/bit-operations.test @@ -34,7 +34,7 @@ (not (not (object-documentation object)))) (define fixnum-bit - (inexact->exact (+ (/ (log (+ most-positive-fixnum 1)) (log 2)) 1))) + (inexact->exact (round (+ (/ (log (+ most-positive-fixnum 1)) (log 2)) 1)))) (define fixnum-min most-negative-fixnum) (define fixnum-max most-positive-fixnum) diff --git a/test-suite/tests/fractions.test b/test-suite/tests/fractions.test new file mode 100644 index 000000000..2e7e05e8c --- /dev/null +++ b/test-suite/tests/fractions.test @@ -0,0 +1,390 @@ +(define-module (test-suite test-fractions) + #:use-module (test-suite lib) + #:use-module (ice-9 documentation) + #:use-module (oop goops)) + +(defmacro test= (a b) + `(pass-if ,(format #f "(= ~A ~A)" a b) (= ,a ,b))) + +(defmacro testeqv (a b) + `(pass-if ,(format #f "(eqv? ~A ~A)" a b) (eqv? ,a ,b))) + +(defmacro testeq (a b) + `(pass-if ,(format #f "(eq? ~A ~A)" a b) (eq? ,a ,b))) + +(defmacro teststr= (a b) + `(pass-if ,(format #f "(string=? ~A ~A)" a b) (string=? ,a ,b))) + +(with-test-prefix "fractions" + + (test= 3/4 .75) + (test= 3000000000000/4000000000000 .75) + (test= .75 3/4) + (test= .75 3000000000000/4000000000000) + (testeqv 3/4 6/8) + (testeqv 3/4 3000000000000/4000000000000) + (testeqv 3 3/1) + (test= 1/3 (/ 1.0 3.0)) + (testeqv (+ 1/4 1/2) 3/4) + (testeqv (* 1/4 2/3) 1/6) + (testeqv (/ 1/4 2/3) 3/8) + (testeqv (+ 1/4 2/3) 11/12) + (testeqv (- 1/4 2/3) -5/12) + (test= -3/4 -.75) + (testeqv -3/4 -6/8) + (testeqv -3/4 (/ 1/2 -2/3)) + (testeqv (* 3/4 2) 3/2) + (testeqv (* 2 3/4) 3/2) + (testeqv (* 3/4 0.5) .375) + (testeqv (* 0.5 3/4) .375) + (testeqv (* 1/2 2-4i) 1-2i) + (testeqv (* 2-4i 1/2) 1-2i) + (testeqv (* 1/2 2+3i) 1+1.5i) + (testeqv (/ 2+4i 1/2) 4+8i) + (test= 1/2 0.5+0i) + (testeqv (- 1/2 0.5+i) -i) + (testeqv (- 0.5+i 1/2) +i) + (testeqv (+ 1/2 0.5+i) 1+i) + (testeqv (+ 0.5+i 1/2) 1+i) + (testeq (> 1 2/3) #t) + (testeq (> 2/3 1) #f) + (testeq (> 1.5 2/3) #t) + (testeq (> 2/3 1.5) #f) + (testeq (> 3/4 2/3) #t) + (testeq (> 2/3 3/4) #f) + (testeqv (max 1 2/3) 1) + (testeqv (max 2/3 1) 1) + (testeqv (max 1 4/3) 4/3) + (testeqv (max 4/3 1) 4/3) + (testeqv (max 1.5 4/3) 1.5) + (testeqv (max 4/3 1.5) 1.5) + (testeqv (max 4/3 2/3) 4/3) + (testeqv (max 2/3 4/3) 4/3) + (testeqv (min 1 2/3) 2/3) + (testeqv (min 2/3 1) 2/3) + (testeqv (min 1 4/3) 1) + (testeqv (min 4/3 1) 1) + (testeqv (min 1.5 1/2) 0.5) + (testeqv (min 1/2 1.5) 0.5) + (testeqv (min 4/3 2/3) 2/3) + (testeqv (min 2/3 4/3) 2/3) + (testeq (> 3/4 12345678912345678) #f) + (testeq (> 12345678912345678 3/4) #t) + (testeq (< 3/4 12345678912345678) #t) + (testeq (< 12345678912345678 3/4) #f) + (testeqv (max 12345678912345678 3/4) 12345678912345678) + (testeqv (max 3/4 12345678912345678) 12345678912345678) + (testeqv (min 12345678912345678 3/4) 3/4) + (testeqv (min 3/4 12345678912345678) 3/4) + (testeqv (max 3/4 10197734562406803221/17452826108659293487) 3/4) + (testeqv (max 1/2 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487) + (testeqv (min 3/4 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487) + (testeqv (min 1/2 10197734562406803221/17452826108659293487) 1/2) + (testeqv (max 10197734562406803221/17452826108659293487 10197734562406803221/17) 10197734562406803221/17) + (testeqv (max 10197734562406803221/174 10197734562406803221/17452826108659293487) 10197734562406803221/174) + (testeqv (max 10/17452826108659293487 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487) + (testeqv (max 10197734562406803221/17452826108659293487 10/17452826108659293487) 10197734562406803221/17452826108659293487) + (testeqv (min 10197734562406803221/17452826108659293487 10197734562406803221/17) 10197734562406803221/17452826108659293487) + (testeqv (min 10197734562406803221/174 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487) + (testeqv (min 10/17452826108659293487 10197734562406803221/17452826108659293487) 10/17452826108659293487) + (testeqv (min 10197734562406803221/17452826108659293487 10/17452826108659293487) 10/17452826108659293487) + (testeqv (expt 2 1/2) (sqrt 2)) + (testeqv (expt 1/2 2) 1/4) + (testeqv (expt 2.0 1/2) (sqrt 2)) + (testeqv (expt 1/2 2.0) 1/4) + (testeqv (real-part 3/4) .75) + (testeqv (imag-part 3/4) 0) + (testeqv (numerator 3/4) 3) + (testeqv (denominator 3/4) 4) + (testeqv (numerator -3/4) -3) + (testeqv (denominator -3/4) 4) + (testeqv (numerator 10197734562406803221/17452826108659293487) 10197734562406803221) + (testeqv (denominator 10197734562406803221/17452826108659293487) 17452826108659293487) + (testeqv (numerator 1/17452826108659293487) 1) + (testeqv (denominator 10197734562406803221/17) 17) + (testeq (rational? 3/4) #t) + (testeq (rational? 1.5) #t) + (testeq (rational? 1) #t) + (testeq (rational? 10197734562406803221/17452826108659293487) #t) + (testeq (integer? 8/4) #t) + (testeq (rational? 6/3) #t) + (testeqv (angle 3/4) 0.0) + (testeqv (angle -3/4) (atan 0.0 -1.0)) + (testeqv (angle 10197734562406803221/17452826108659293487) 0.0) + (testeqv (magnitude 3/4) 3/4) + (testeqv (magnitude -3/4) 3/4) + (testeqv (magnitude 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487) + (testeqv (magnitude -10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487) + (testeqv (abs 3/4) 3/4) + (testeqv (abs -3/4) 3/4) + (testeqv (abs 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487) + (testeqv (abs -10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487) + (testeqv (abs 10197734562406803221/174) 10197734562406803221/174) + (testeqv (abs -10197734562406803221/174) 10197734562406803221/174) + (testeqv (abs 101/17452826108659293487) 101/17452826108659293487) + (testeqv (abs -101/17452826108659293487) 101/17452826108659293487) + (testeqv (exact->inexact 3/4) .75) + (testeqv (inexact->exact .3) 3/10) + (testeqv (inexact->exact -.3) -3/10) + (testeqv (inexact->exact .33) 33/10) + (testeq (< (- (exact->inexact 10197734562406803221/17452826108659293487) .584302765576009) .0000001) #t) + (testeqv (rationalize .76 .1) 3/4) + (testeqv (rationalize .723 .1) 2/3) + (testeqv (rationalize .723 .01) 5/7) + (testeqv (rationalize -.723 .01) -5/7) + (testeqv (rationalize 10.2 .01) 51/5) + (testeqv (rationalize -10.2 .01) -51/5) + (testeqv (rationalize 10197734562406803221/17452826108659293487 .1) 1/2) + (testeqv (rationalize 10197734562406803221/17452826108659293487 .01) 7/12) + (testeqv (rationalize 10197734562406803221/17452826108659293487 .001) 7/12) + (testeqv (rationalize 10197734562406803221/17452826108659293487 .0001) 52/89) + (testeqv (rationalize 3/10 1/10) 1/3) + (testeqv (rationalize 3/10 -1/10) 1/3) + (testeqv (rationalize -3/10 1/10) -1/3) + (testeqv (rationalize -3/10 -1/10) -1/3) + (testeqv (rationalize 3/10 4/10) 0) + (testeqv (rationalize .3 4/10) 0) + (testeqv (rationalize .3 0.0) 3/10) + (testeqv (rationalize -.3 0.0) -3/10) + (testeqv (rationalize .12345 0.0) 2469/2000) + (testeqv (rationalize 10.3 0.0) 103/10) + (testeq (exact? #i2/3) #f) + (testeq (exact? -15/16) #t) + (testeq (exact? (/ 2 3)) #t) + (testeq (exact? (/ 3000000000000 4000000000000)) #t) + (testeq (exact? (/ 3 4000000000)) #t) + (testeq (exact? (/ 4000000000 3)) #t) + (testeq (exact? (/ 10197734562406803221 17452826108659293487)) #t) + (testeq (exact? (/ 10197734562406803221 17)) #t) + (testeq (inexact? #i2/3) #t) + (testeq (inexact? -15/16) #f) + (testeq (inexact? (/ 2 3)) #f) + (testeq (inexact? (/ 3000000000000 4000000000000)) #f) + (testeq (inexact? (/ 3 4000000000)) #f) + (testeq (inexact? (/ 4000000000 3)) #f) + (testeq (inexact? (/ 10197734562406803221 17452826108659293487)) #f) + (testeq (inexact? (/ 10197734562406803221 17)) #f) + (testeq (= 2/3 .667) #f) + (testeq (< 1/2 2/3 3/4) #t) + (testeqv (+ 1/2 2/3) 7/6) + (testeqv (* 4 1/2) 2) + (testeqv (- -2/3) 2/3) + (testeqv (- 2/3) -2/3) + (testeqv (+ 2/3) 2/3) + (testeqv (* 2/3) 2/3) + (testeqv (/ 2/3) 3/2) + (testeqv (/ 3 4 5) 3/20) + (testeqv (* 1 1/2) 1/2) + (testeqv (+ 1 1/4 1/3) 19/12) + (testeqv (* 3/5 1/6 3) 3/10) + (testeqv 0/3 0) + (testeqv (1- 1/2) 1/2) + (testeqv (1+ 1/2) 3/2) + (testeq (zero? 3/4) #f) + (testeq (zero? 0/4) #t) + (testeq (positive? 3/4) #t) + (testeq (negative? 3/4) #f) + (testeq (positive? 10197734562406803221/17452826108659293487) #t) + (testeq (negative? 10197734562406803221/17452826108659293487) #f) + (testeqv (/ 17) 1/17) + (testeqv (/ 17452826108659293487) 1/17452826108659293487) + (testeqv (/ -17) -1/17) + (testeqv (/ -17452826108659293487) -1/17452826108659293487) + (testeqv (/ 1/2) 2) + (testeqv (/ 2 3) 2/3) + (testeqv (/ 2 -3) -2/3) + (testeq (zero? (+ 1/2 1/2)) #f) + (testeq (zero? (+ 1/2 -1/2)) #t) + (testeq (zero? (- 1/2 1/2)) #t) + (testeqv (/ 60 5 4 3 2) 1/2) + (test= (truncate 5/4) 1.0) + (test= (truncate 4/5) 0.0) + (test= (truncate -2/3) 0.0) + (test= (truncate 10197734562406803221/17452826108659293487) 0.0) + (test= (truncate 17452826108659293487/10197734562406803221) 1.0) + (test= (/ (log 1/2) (log 2)) -1.0) + (test= (floor 2/3) 0) + (test= (floor -2/3) -1) + (test= (floor 10197734562406803221/17452826108659293487) 0) + (test= (ceiling 2/3) 1) + (test= (ceiling -2/3) 0) + (test= (ceiling 10197734562406803221/17452826108659293487) 1) + (test= (round 2/3) 1.0) + (test= (round -2/3) -1.0) + (test= (round 1/3) 0.0) + (test= (round 10197734562406803221/17452826108659293487) 1.0) + (testeqv (max 1/2 3/4 4/5 5/6 6/7) 6/7) + (testeqv (min 1/2 3/4 4/5 5/6 6/7) 1/2) + (testeqv (expt -1/2 5) -1/32) + (testeqv (expt 1/2 -10) 1024) + (testeqv (rationalize .3 1/10) 1/3) + (test= (make-rectangular 1/2 -1/2) 0.5-0.5i) + (test= (sqrt 1/4) 0.5) + (testeqv (string->number "3/4") 3/4) + (testeqv (string->number "-3/4") -3/4) + (testeqv (string->number "10197734562406803221/17452826108659293487") 10197734562406803221/17452826108659293487) + (testeqv (string->number "-10197734562406803221/17452826108659293487") -10197734562406803221/17452826108659293487) + (testeqv (string->number "10/17452826108659293487") 10/17452826108659293487) + (testeqv (string->number "10197734562406803221/174") 10197734562406803221/174) + (teststr= (number->string 3/4) "3/4") + (teststr= (number->string 10197734562406803221/17452826108659293487) "10197734562406803221/17452826108659293487") + (testeq (eq? 3/4 .75) #f) + (testeq (eqv? 3/4 .75) #f) + (testeq (eqv? 3/4 3/4) #t) + (testeq (eqv? 10197734562406803221/17452826108659293487 10197734562406803221/17452826108659293487) #t) + (testeq (equal? 3/4 .75) #t) + (testeq (number? 3/4) #t) + (testeq (real? 3/4) #t) + (testeq (integer? 3/4) #f) + (test= (* 1/2 2.0e40) 1.0e40) + (test= (* 2.0e40 1/2) 1.0e40) + (test= (/ 3.0e40 3/2) 2.0e40) + (testeqv (case 1/2 ((1/2) 1) ((3/4) 2)) 1) + (testeqv (/ 1 -2) -1/2) + (testeqv (numerator (/ 1 -2)) -1) + (testeqv (denominator (/ 1 -2)) 2) + (testeq (negative? (/ 1 -2)) #t) + (testeq (positive? (/ 1 -2)) #f) + (testeqv (/ -1/2 -1/3) 3/2) + (testeqv (numerator (/ -1/2 -1/3)) 3) + (testeqv (denominator (/ -1/2 -1/3)) 2) + (testeq (negative? (/ -1/2 -1/3)) #f) + (testeq (positive? (/ -1/2 -1/3)) #t) + (testeqv (numerator 12) 12) + (testeqv (numerator -12) -12) + (testeqv (denominator 12) 1) + (testeqv (denominator -12) 1) + (testeqv (- 1/2 1/2) 0) + (testeqv (+ 1/2 1/2) 1) + (testeqv (/ 1/2 1/2) 1) + (testeqv (* 2/1 1/2) 1) + (testeq (complex? 1/2) #t) + (testeqv (+ (exact->inexact 3/10) (exact->inexact -3/10)) 0.0) + (testeqv (/ 1/2 1/4) 2) + (testeqv (/ 2 1/4) 8) + (testeqv (/ 1/4 2) 1/8) + (testeqv (ash 1/2 0) 1/2) + (testeqv (ash 1/2 1) 1) + ;;(testeqv (ash 1/2 -1) 1/4) + + (testeqv (floor 5/2) 2) + (testeqv (ceiling 5/2) 3) + (testeqv (round 5/2) 2) + (testeqv (truncate 5/2) 2) + (testeqv (floor -5/2) -3) + (testeqv (ceiling -5/2) -2) + (testeqv (round -5/2) -2) + (testeqv (truncate -5/2) -2) + (testeqv (floor 4/3) 1) + (testeqv (ceiling 4/3) 2) + (testeqv (round 4/3) 1) + (testeqv (truncate 4/3) 1) + (testeqv (floor -4/3) -2) + (testeqv (ceiling -4/3) -1) + (testeqv (round -4/3) -1) + (testeqv (truncate -4/3) -1) + (testeqv (floor 5/3) 1) + (testeqv (ceiling 5/3) 2) + (testeqv (round 5/3) 2) + (testeqv (truncate 5/3) 1) + (testeqv (floor -5/3) -2) + (testeqv (ceiling -5/3) -1) + (testeqv (round -5/3) -2) + (testeqv (truncate -5/3) -1) + (testeqv (floor 11/4) 2) + (testeqv (ceiling 11/4) 3) + (testeqv (round 11/4) 3) + (testeqv (truncate 11/4) 2) + (testeqv (floor -11/4) -3) + (testeqv (ceiling -11/4) -2) + (testeqv (round -11/4) -3) + (testeqv (truncate -11/4) -2) + (testeqv (floor 9/4) 2) + (testeqv (ceiling 9/4) 3) + (testeqv (round 9/4) 2) + (testeqv (truncate 9/4) 2) + (testeqv (floor -9/4) -3) + (testeqv (ceiling -9/4) -2) + (testeqv (round -9/4) -2) + (testeqv (truncate -9/4) -2) + + ;; from Dybvig + (testeqv (numerator 9.0) 9.0) + (testeqv (numerator 9) 9) + (testeqv (numerator -9/4) -9) + (testeqv (numerator -2.25) -9.0) ; -9/4! + (testeqv (denominator 0) 1) + (testeqv (denominator 9) 1) + (testeqv (denominator 2/3) 3) + (testeqv (denominator -9/4) 4) + (testeqv (denominator -2.25) 4.0) + (testeqv (denominator 9.0) 1.0) + (testeqv (expt 2 -2) 1/4) + (testeqv (expt 1/2 2) 1/4) + (testeqv (expt 1/2 -2) 4) + (testeqv (expt -1/2 3) -1/8) + + + + ;; from (GPL'd) Clisp tests + (test= (+ 1 1/2 0.5 3.0+5.5i) 5.0+5.5i) + (testeq (let ((error (catch #t (lambda () (/ 1 0)) (lambda args (car args))))) error) 'numerical-overflow) + (testeq (let ((error (catch #t (lambda () (/ 0)) (lambda args (car args))))) error) 'numerical-overflow) + (testeq (let ((error (catch #t (lambda () (modulo 1/2 1)) (lambda args (car args))))) error) 'wrong-type-arg) + (testeq (let ((error (catch #t (lambda () (logand 1/2 1)) (lambda args (car args))))) error) 'wrong-type-arg) + (testeq (let ((error (catch #t (lambda () (gcd 1/2 3)) (lambda args (car args))))) error) 'wrong-type-arg) + (testeq (let ((error (catch #t (lambda () (numerator 1+i)) (lambda args (car args))))) error) 'wrong-type-arg) + (test= (- 0+6i 1/4 0.5 7) -7.75+6.0i) + (testeqv (rationalize 2.5 .001) 5/2) + (testeqv (rationalize 7/3 .001) 7/3) + (testeqv (rationalize 3.14159265 .1) 22/7) + (testeqv (numerator (/ 8 -6)) -4) + (testeqv (denominator (/ 8 -6)) 3) + (testeqv (gcd (numerator 7/9) (denominator 7/9)) 1) + (testeqv (/ 10105597264942543888 14352488138967388642) 5052798632471271944/7176244069483694321) + (testeqv (/ -17631701977702695093 3931860028646338313) -17631701977702695093/3931860028646338313) + (testeqv (/ -1606495881715082381 16324360910828438638) -1606495881715082381/16324360910828438638) + (testeqv (/ -7960193178071300653 -10280747961248435844) 7960193178071300653/10280747961248435844) + (testeqv (+ -6069217517368004039/4076344942716985944 -399587800008780737/578697755310708616) -321318766345655960630110128852941297/147435729263904928853096856396980844) + (testeqv (+ -41285036778370718/305793940074617155 -1396094619926552183/15846027887642356854) -1081121118676718273499338028514700537/4845619302294419132297197085940230370) + (testeqv (+ 15975644088444536091/18063939613598316583 17501188199168431305/2979264551795273683) 363736076920798535449296038324193823968/53817254956563877935003279344562385189) + (testeqv (+ 10197734562406803221/17452826108659293487 14639450560606090654/236781760961536951) 257914422508077920978698094723491089669/4132510899763835955061848877304138137) + (testeqv (+ 2479135971595944301/28169711053558469409458629766960029324030958129245230797895768033968717159836 3427244662960653095/28446538857424788738244844756675951434179713170118835630969510829753715142438) 83533664807147783700314944003289704497366290621039272787320536148072960487262393639109696219129/400665390043739792096386856839000624247597803909916773326187593475005945995926511155915226239317839405221783416485999405286913042389632370302962776360084) + (testeqv (+ 14865500635281371370/56222262470894935247131881777606182311286871927285650835673424014252462156319 6436092572090050725/19282524131572095520593158313261757267758159099923763177708581262473988426947) 648496060602737474174747620183913927791943082591316359990137585798909535115053578637078811588665/1084107132826611778585714784136700465449309125114745313342842325649687943726086785657821763235618936882528385000712567133180567926723616940173290425928093) + (testeqv (+ 340196811925805824067049620503247332111/14422464039094716975 51285507111580975533385007190438537498/3230944134273302873) 1838820276033673324738967436225477772648372110186756083453/46598175588880723338390245118389369175) + (testeqv (+ -210449319160504160992731982827917332322/5436857856220342451 251628249079137248539965770847855056283/4323109210037952829) 458271632943884346915405609513071881239303671882386130695/23504130271893362375786510953364243879) + (testeqv (- 8229768172162771789/4094631553683915058 14916542302144281688/9648520391570031013) 18327341244785642013243791303754634353/39507136041685332578233153660317693754) + (testeqv (- 13554976081719376860/5850035209629724601 -6813034992928443315/16012083383654426278) 256899901877002811987490932642058619395/93671251573905451634945335611797465078) + (testeqv (- -221798849980968127/896588178875000428 -10118632981534633697/16809799818197706916) 333990778095757160537366868413422249/941966737890699707694484674257410003) + (testeqv (- -10398409463665680242/10672871071680021919 908300169382593227/1663860017749090135) -2076589873614048366639515256135965791/1366012573135328609279238070700513005) + (testeqv (- -2198518713248421187/494031967775171833 162489257999262168/3608560229859558061) -8013762081101965644053022173225152351/1782744111192743850497670941715295813) + (testeqv (- 4025149216228566945/640594137312937394 5467380276809034025/15813352732084653151) 60148732603712157399679443099667862845/10129941051434949990590527231467828494) + (testeqv (- 1543899448831604569141696144740105016328586790221799945430718394112623114412/1094690716976737526626281319975432667416762320123576900412499904933271786567 -101835025746074730017715423582062511397387458863000475669454309217160145993/55116548932808468782187525862059393507883043749327746382569396580129398962) 196572266866178229534134252625134989714563665559807019513454337864363053729628560611312158082929567528955985669620113192156991984486011150099776316375/60335574468539540262844259780498204139853746803235564167348945699931512713417761400790104247218084745081610815218855896912895393599203789305655343454) + (testeqv (- -37581128364300495505521143552535972339959603365602244668159915869829949338997/42947503543372015019662104425995959382231280059683481488692141811517675950053 -64888994735350842409379226446854438865448614840503930577860382883594178287934/83188698741706753136718468601650233481619465918167616089202536622553688681087) -339504834548876267781536981106771553482515399809961247195394672491113984585270709765073243997043174508213253440272888923497173265137136111635177948889237/3572746933977957867604303713153220827104741303667912510494658617478381525690274918494624922428110123336345510454960178899375325287131764283538305257747611) + (testeqv (* -6520062188352981842/3213004995534018829 -3812444292971845716/15284944374811818089) 24857373879807849010516976362973488872/49110602632729971801355498746248797781) + (testeqv (* -844583948128454879/4750740551331102615 -1309778567130405125/4885884698278749707) 221243590680205607733892613510570975/4642314113048197066962569716783636761) + (testeqv (* -4579815856418431271/16947444571374397297 7990245706938186906/12540719430158043191) -36593853985314806270746820601513137526/212533147427761354206383017714519654727) + (testeqv (* -3587966953201943536/3194797554208122281 975954052071387816/2707062718507963111) -3501690886675668292903668827990357376/8648517352177231144330968693325176191) + (testeqv (* 710265334225408429/567023629756400552 -5578988760400430103/4131535930210536898) -3962562316545608552741467762441538187/2342678499616965424161446427863567696) + (testeqv (* 18305319006789031727/4480148641441744463 -1641093267260986094/16028097657311023719) -30040735777106040963634910981471804338/71808259944297590021537032075729917897) + (testeqv (* 522499067029593907/142530390958606446621834761330018829110 1567459634764499377/31663510497342378306792964160850079086) 818996196770998943862055820464495939/4513012530308148429025282037949729145117603192483641232823845248212618993460) + (testeqv (* -280037880297253633994139513185953058494/23798550327416056573646642830182072429 13967268482262630670960486883264178489/7947215947745048068401387767511847243) -434596028812829556627014314125713048434599389957141408329542154357763726174/21014690966139335562014814134594464675233042588696546668504776333756662583) + (testeqv (* 87160410649223805266866345018804635271/204719779683096591635231158476535039583 91197762560765392928084914476898132964/277206223024759381433146631560580134513) 7948834435086720002947247338196997812861466884983039250681993725808882173244/56749596904412078223459353928850191672356004665473536520452927516595919428079) + (testeqv (/ 7013212896988366906/12397903473277899947 818833870013215068/2125577647443895255) 7453564285301859120853045020886215515/5075911640537211768265804260348400698) + (testeqv (/ -15781329068048599432/14942574238341613337 4388772934226358350/2640112802717985697) -20832244458230302534551181278529162052/32789782692450857054331267544650656975) + (testeqv (/ -9015230453321124271/17425619133302730035 -10422000746814766599/14972344381173680534) 134979135022768387806775446187867640714/181609815620990738305316999098032100965) + (testeqv (/ -14741075237791868512/12448692140900938227 -1090381863721238817/1060836378253796023) 15637868866825840780217685066084527776/13573828137487503515304766902031557459) + (testeqv (/ -7371815071140740177/4722722556038701367 3872455829192658988/994203944294825175) -7329087620340161131469364260313555975/18288534491791723206480607737200436596) + (testeqv (/ -9856364379969390509/7988230468709836259 -7208901117187058135/7430860779232874136) 1093153305924514768551484985555671272/859497963436269188803272225817371895) + (testeqv (/ -4420263280205408439/38682162086456801604593696710774835436326970692840048042132553053971380151628 -758651402628235427/1755534012040040367913026343944696058732638465867705260088080517539506722166) 3879961265286134914514096239640695384126081133972137242327715997675029567458817030555062379437/14673138261791601182714628661554161812345431143865809776872034934342213839184709418896670662578) + (testeqv (/ -54987418627898620923060954379316763081930842855917193391807940070173620336071/17370345837184638879794373707261631548922174314274224219546763452439685451597 107349939397731511365417710412808670916754334908520065561311453951414109180973/7800708635318451621630266369706695626474649690647985662113853436261704078874) -428940831324519456770429889832838610542119304716244392653623661175655561457214418178921042544524225772650432309479656622489393939407340321261255371264054/1864705572939408818246392762570376592749103793151936455808919833872532407312841098160841844995663367019074328670998871082130543124576872890789577304863881)) +;; end clisp borrowings + +(define-generic G) +(define-method (G (a )) 'integer) +(define-method (G (a )) 'fraction) + +(with-test-prefix "fraction generics" + (testeq (G 1) 'integer) + (testeq (G 2/3) 'fraction)) + diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index b2920a2f9..9e707d252 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -997,8 +997,9 @@ (for-each (lambda (couple) (apply (lambda (x y) - (let ((x (string->number x))) - (if (or (eq? x #f) (not (eqv? x y))) (throw 'fail)))) + (let ((xx (string->number x))) + (if (or (eq? xx #f) (not (eqv? xx y))) + (throw 'fail)))) couple)) `(;; Radix: ("#b0" 0) ("#B0" 0) ("#b1" 1) ("#B1" 1) ("#o0" 0) ("#O0" 0) @@ -1016,14 +1017,15 @@ ("#d1234567890" 1234567890) ("#x1234567890abcdef" 1311768467294899695) ;; Exactness: - ("#e1" 1) ("#e1.2" 1) ("#i1.1" 1.1) ("#i1" 1.0) + ("#e1" 1) ("#e1.2" ,(inexact->exact 1.2)) + ("#i1.1" 1.1) ("#i1" 1.0) ;; Integers: ("1" ,(1+ 0)) ("23" ,(+ 9 9 5)) ("-1" ,(- 0 1)) ("-45" ,(- 0 45)) ("2#" 20.0) ("2##" 200.0) ("12##" 1200.0) ("#b#i100" 4.0) - ;; Rationals: - ("1/1" 1) ("1/2" 0.5) ("-1/2" -0.5) ("1#/1" 10.0) - ("10/1#" 1.0) ("1#/1#" 1.0) ("#e9/10" 1) ("#e10/1#" 1) + ;; Fractions: + ("1/1" 1) ("1/2" 1/2) ("-1/2" -1/2) ("1#/1" 10.0) + ("10/1#" 1.0) ("1#/1#" 1.0) ("#e9/10" 9/10) ("#e10/1#" 1) ("#i6/8" 0.75) ("#i1/1" 1.0) ;; Decimal numbers: ;; * @@ -2186,13 +2188,13 @@ (with-test-prefix "inexact->exact" - (pass-if-exception "+inf" exception:numerical-overflow + (pass-if-exception "+inf" exception:out-of-range (inexact->exact +inf.0)) - (pass-if-exception "-inf" exception:numerical-overflow + (pass-if-exception "-inf" exception:out-of-range (inexact->exact -inf.0)) - (pass-if-exception "nan" exception:numerical-overflow + (pass-if-exception "nan" exception:out-of-range (inexact->exact +nan.0)) (with-test-prefix "2.0**i to exact and back" From f92e85f7352174c9fe0ac0e67e6c38cfce923300 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 18 Nov 2003 19:59:53 +0000 Subject: [PATCH 137/239] * print.c (scm_iprin1): Handle fractions. * objects.h (scm_class_fraction): New. * objects.c (scm_class_fraction): New. (scm_class_of): Handle fractions. * hash.c (scm_hasher): Handle fractions. * numbers.c: New code for handling fraction all over the place. (scm_odd_p, scm_even_p): Handle inexact integers. (scm_rational_p): New function, same as scm_real_p. (scm_round_number, scm_truncate_number, scm_ceiling, scm_floor): New exact functions that replace the inexact 'dsubr' implementations. (scm_numerator, scm_denominator): New. * numbers.h (SCM_NUMP): Recognize fractions. (SCM_FRACTIONP, SCM_SLOPPY_FRACTIONP, SCM_FRACTION_NUMERATOR, SCM_FRACTION_DENOMINATOR, SCM_FRACTION_SET_NUMERATOR, SCM_FRACTION_SET_DENOMINATOR, SCM_FRACTION_REDUCED_BIT, SCM_FRACTION_REDUCED_SET, SCM_FRACTION_REDUCED_CLEAR, SCM_FRACTION_REDUCED): New. (scm_floor, scm_ceiling, scm_truncate_number, scm_round_number): New prototypes. (scm_make_ratio, scm_rationalize, scm_numerator, scm_denominator, scm_rational_p): New prototypes. (scm_i_dbl2num, scm_i_fraction2double, scm_i_fraction_equalp, scm_i_print_fraction): New prototypes. * goops.c (create_standard_classes): Create "" class. * gc-mark.c (scm_gc_mark_dependencies): Handle fractions. * gc-card.c (scm_i_sweep_card): Include scm_tc16_fraction as a case in the switch, but do nothing for now. * eval.c (SCM_CEVAL, SCM_APPLY, call_dsubr_1): Convert fractions to doubles when calling 'dsubr' functions. * eq.c (scm_eqv_p, scm_equal_p): Handle fractions. --- libguile/eq.c | 35 +- libguile/eval.c | 22 +- libguile/gc-card.c | 4 + libguile/gc-mark.c | 6 + libguile/goops.c | 2 + libguile/hash.c | 1 + libguile/numbers.c | 971 +++++++++++++++++++++++++++++++++++++++++---- libguile/numbers.h | 34 +- libguile/objects.c | 4 +- libguile/objects.h | 1 + libguile/print.c | 3 + 11 files changed, 993 insertions(+), 90 deletions(-) diff --git a/libguile/eq.c b/libguile/eq.c index 06467c486..40d5d86ec 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -61,6 +61,7 @@ real_eqv (double x, double y) return !memcmp (&x, &y, sizeof(double)); } +#include SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, (SCM x, SCM y), "The @code{eqv?} procedure defines a useful equivalence relation on objects.\n" @@ -77,8 +78,14 @@ SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, if (SCM_IMP (y)) return SCM_BOOL_F; /* this ensures that types and scm_length are the same. */ + if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) { + /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer), + but this checks the entire type word, so fractions may be accidentally + flagged here as unequal. Perhaps I should use the 4th double_cell word? + */ + /* treat mixes of real and complex types specially */ if (SCM_INEXACTP (x)) { @@ -93,6 +100,9 @@ SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, SCM_REAL_VALUE (y)) && SCM_COMPLEX_IMAG (x) == 0.0); } + + if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y)) + return scm_i_fraction_equalp (x, y); return SCM_BOOL_F; } if (SCM_NUMP (x)) @@ -101,6 +111,8 @@ SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, return SCM_BOOL (scm_i_bigcmp (x, y) == 0); } else if (SCM_REALP (x)) { return SCM_BOOL (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y))); + } else if (SCM_FRACTIONP (x)) { + return scm_i_fraction_equalp (x, y); } else { /* complex */ return SCM_BOOL (real_eqv (SCM_COMPLEX_REAL (x), SCM_COMPLEX_REAL (y)) @@ -149,7 +161,7 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) { /* treat mixes of real and complex types specially */ - if (SCM_INEXACTP (x)) + if (SCM_INEXACTP (x) && SCM_INEXACTP (y)) { if (SCM_REALP (x)) return SCM_BOOL (SCM_COMPLEXP (y) @@ -160,6 +172,25 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, && SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y) && SCM_COMPLEX_IMAG (x) == 0.0); } + + /* should we handle fractions here also? */ + else if ((SCM_FRACTIONP (x)) && (SCM_INEXACTP (y))) + { + if (SCM_REALP (y)) + return SCM_BOOL (scm_i_fraction2double (x) == SCM_REAL_VALUE (y)); + else + return SCM_BOOL (SCM_COMPLEX_REAL (y) == scm_i_fraction2double (x) + && SCM_COMPLEX_IMAG (y) == 0.0); + } + else if ((SCM_FRACTIONP (y)) && (SCM_INEXACTP (x))) + { + if (SCM_REALP (x)) + return SCM_BOOL (scm_i_fraction2double (y) == SCM_REAL_VALUE (x)); + else + return SCM_BOOL (SCM_COMPLEX_REAL (x) == scm_i_fraction2double (y) + && SCM_COMPLEX_IMAG (x) == 0.0); + } + return SCM_BOOL_F; } switch (SCM_TYP7 (x)) @@ -175,6 +206,8 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, return scm_real_equalp (x, y); case scm_tc16_complex: return scm_complex_equalp (x, y); + case scm_tc16_fraction: + return scm_i_fraction_equalp (x, y); } case scm_tc7_vector: case scm_tc7_wvect: diff --git a/libguile/eval.c b/libguile/eval.c index d6135b407..913fe6243 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3856,7 +3856,11 @@ evapply: /* inputs: x, proc */ { RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); } - SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, + else if (SCM_FRACTIONP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); + } + SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); case scm_tc7_cxr: { @@ -4536,7 +4540,13 @@ tail: RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); } else if (SCM_BIGP (arg1)) - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + } + else if (SCM_FRACTIONP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); + } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); case scm_tc7_cxr: @@ -4882,7 +4892,13 @@ call_dsubr_1 (SCM proc, SCM arg1) RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); } else if (SCM_BIGP (arg1)) - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + } + else if (SCM_FRACTIONP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); + } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); } diff --git a/libguile/gc-card.c b/libguile/gc-card.c index 432ead5a9..7189927ec 100644 --- a/libguile/gc-card.c +++ b/libguile/gc-card.c @@ -186,6 +186,10 @@ scm_i_sweep_card (scm_t_cell * p, SCM *free_list, scm_t_heap_segment*seg) scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex), "complex"); break; + case scm_tc16_fraction: + /* nothing to do here since the num/denum of a fraction + are proper SCM objects themselves. */ + break; } break; case scm_tc7_string: diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c index 994d3aa88..10f1522e0 100644 --- a/libguile/gc-mark.c +++ b/libguile/gc-mark.c @@ -281,6 +281,12 @@ scm_gc_mark_dependencies (SCM p) break; case scm_tc7_number: + if (SCM_TYP16 (ptr) == scm_tc16_fraction) + { + scm_gc_mark (SCM_CELL_OBJECT_1 (ptr)); + ptr = SCM_CELL_OBJECT_2 (ptr); + goto gc_mark_loop; + } break; case scm_tc7_wvect: diff --git a/libguile/goops.c b/libguile/goops.c index cccdf205a..ea09366ad 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2406,6 +2406,8 @@ create_standard_classes (void) scm_class_class, scm_class_complex, SCM_EOL); make_stdcls (&scm_class_integer, "", scm_class_class, scm_class_real, SCM_EOL); + make_stdcls (&scm_class_fraction, "", + scm_class_class, scm_class_real, SCM_EOL); make_stdcls (&scm_class_keyword, "", scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&scm_class_unknown, "", diff --git a/libguile/hash.c b/libguile/hash.c index 37ff07797..4294556ba 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -103,6 +103,7 @@ scm_hasher(SCM obj, unsigned long n, size_t d) } /* Fall through */ case scm_tc16_complex: + case scm_tc16_fraction: obj = scm_number_to_string (obj, SCM_MAKINUM (10)); /* Fall through */ } diff --git a/libguile/numbers.c b/libguile/numbers.c index d36194f9e..311caf791 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -25,6 +25,7 @@ * All objects satisfying SCM_BIGP() are too large to fit in a fixnum. * If an object satisfies integer?, it's either an inum, a bignum, or a real. * If floor (r) == r, r is an int, and mpz_set_d will DTRT. + * All objects satisfying SCM_FRACTIONP are never an integer. */ /* TODO: @@ -50,6 +51,7 @@ #include #include #include + #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/ports.h" @@ -61,6 +63,8 @@ #include "libguile/numbers.h" #include "libguile/deprecation.h" +#include "libguile/eq.h" + /* @@ -79,6 +83,7 @@ : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \ : SCM_I_NUMTAG_NOTNUM))) */ +/* the macro above will not work as is with fractions */ #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0) @@ -119,6 +124,28 @@ isinf (double x) #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d) #endif +static int +xisinf (double x) +{ +#if defined (HAVE_ISINF) + return isinf (x); +#elif defined (HAVE_FINITE) && defined (HAVE_ISNAN) + return (! (finite (x) || isnan (x))); +#else + return 0; +#endif +} + +static int +xisnan (double x) +{ +#if defined (HAVE_ISNAN) + return isnan (x); +#else + return 0; +#endif +} + static SCM abs_most_negative_fixnum; @@ -167,6 +194,32 @@ scm_i_dbl2big (double d) return z; } +/* Convert a integer in double representation to a SCM number. */ + +SCM_C_INLINE_KEYWORD SCM +scm_i_dbl2num (double u) +{ + /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both + powers of 2, so there's no rounding when making "double" values + from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could + get rounded on a 64-bit machine, hence the "+1". + + The use of floor() to force to an integer value ensures we get a + "numerically closest" value without depending on how a + double->long cast or how mpz_set_d will round. For reference, + double->long probably follows the hardware rounding mode, + mpz_set_d truncates towards zero. */ + + /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not + representable as a double? */ + + if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1) + && u >= (double) SCM_MOST_NEGATIVE_FIXNUM) + return SCM_MAKINUM ((long) u); + else + return scm_i_dbl2big (u); +} + /* scm_i_big2dbl() rounds to the closest representable double, in accordance with R5RS exact->inexact. @@ -249,6 +302,134 @@ scm_i_normbig (SCM b) return b; } +static SCM_C_INLINE_KEYWORD SCM +scm_i_mpz2num (mpz_t b) +{ + /* convert a mpz number to a SCM number. */ + if (mpz_fits_slong_p (b)) + { + long val = mpz_get_si (b); + if (SCM_FIXABLE (val)) + return SCM_MAKINUM (val); + } + + { + SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + mpz_init_set (SCM_I_BIG_MPZ (z), b); + return z; + } +} + +/* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */ +static SCM scm_divide2real (SCM x, SCM y); + +SCM +scm_make_ratio (SCM numerator, SCM denominator) +{ +#if 0 + return scm_divide2real(numerator, denominator); +#else + #define FUNC_NAME "make-ratio" + if (SCM_INUMP (denominator)) + { + if (SCM_EQ_P (denominator, SCM_INUM0)) + scm_num_overflow ("make-ratio"); + if (SCM_EQ_P (denominator, SCM_MAKINUM(1))) + return numerator; + } + else + { + if (!(SCM_BIGP(denominator))) + SCM_WRONG_TYPE_ARG (2, denominator); + } + if (SCM_INUMP (numerator)) + { + if (SCM_EQ_P (numerator, SCM_INUM0)) + return SCM_INUM0; + if (SCM_INUMP (denominator)) + { + long x, y; + x = SCM_INUM (numerator); + y = SCM_INUM (denominator); + if (x == y) + return SCM_MAKINUM(1); + if ((x % y) == 0) + return SCM_MAKINUM (x / y); + if (y < 0) + return scm_double_cell (scm_tc16_fraction, (scm_t_bits)SCM_MAKINUM(-x), (scm_t_bits)SCM_MAKINUM(-y), 0); + else return scm_double_cell (scm_tc16_fraction, (scm_t_bits)numerator, (scm_t_bits)denominator, 0); + } + else + { + /* I assume bignums are actually big, so here there's no point in looking for a integer */ + int sgn = mpz_sgn (SCM_I_BIG_MPZ (denominator)); + if (sgn < 0) /* if denominator negative, flip signs */ + return scm_double_cell (scm_tc16_fraction, + (scm_t_bits)scm_difference (numerator, SCM_UNDEFINED), + (scm_t_bits)scm_difference (denominator, SCM_UNDEFINED), + 0); + else return scm_double_cell (scm_tc16_fraction, (scm_t_bits)numerator, (scm_t_bits)denominator, 0); + + /* should this use SCM_UNPACK for the bignums? */ + } + } + else + { + if (SCM_BIGP (numerator)) + { + /* can't use scm_divide to find integer here */ + if (SCM_INUMP (denominator)) + { + long yy = SCM_INUM (denominator); + long abs_yy = yy < 0 ? -yy : yy; + int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), abs_yy); + if (divisible_p) + return scm_divide(numerator, denominator); + else return scm_double_cell (scm_tc16_fraction, (scm_t_bits)numerator, (scm_t_bits)denominator, 0); + } + else + { + /* both are bignums */ + if (SCM_EQ_P (numerator, denominator)) + return SCM_MAKINUM(1); + int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (numerator), + SCM_I_BIG_MPZ (denominator)); + if (divisible_p) + return scm_divide(numerator, denominator); + else return scm_double_cell (scm_tc16_fraction, (scm_t_bits)numerator, (scm_t_bits)denominator, 0); + } + } + else SCM_WRONG_TYPE_ARG (1, numerator); + } + return SCM_BOOL_F; /* won't happen */ + #undef FUNC_NAME +#endif +} + +static void scm_i_fraction_reduce (SCM z) +{ + if (!(SCM_FRACTION_REDUCED (z))) + { + SCM divisor; + divisor = scm_gcd (SCM_FRACTION_NUMERATOR (z), SCM_FRACTION_DENOMINATOR (z)); + if (!(SCM_EQ_P (divisor, SCM_MAKINUM(1)))) + { + /* is this safe? */ + SCM_FRACTION_SET_NUMERATOR (z, scm_divide (SCM_FRACTION_NUMERATOR (z), divisor)); + SCM_FRACTION_SET_DENOMINATOR (z, scm_divide (SCM_FRACTION_DENOMINATOR (z), divisor)); + } + SCM_FRACTION_REDUCED_SET (z); + } +} + +double +scm_i_fraction2double (SCM z) +{ + return scm_num2dbl (scm_divide2real (SCM_FRACTION_NUMERATOR (z), + SCM_FRACTION_DENOMINATOR (z)), + "fraction2real"); +} + SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, (SCM x), "Return @code{#t} if @var{x} is an exact number, @code{#f}\n" @@ -259,6 +440,8 @@ SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, return SCM_BOOL_T; if (SCM_BIGP (x)) return SCM_BOOL_T; + if (SCM_FRACTIONP (x)) + return SCM_BOOL_T; return SCM_BOOL_F; } #undef FUNC_NAME @@ -283,6 +466,16 @@ SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, } else if (!SCM_FALSEP (scm_inf_p (n))) return SCM_BOOL_T; + else if (SCM_REALP (n)) + { + double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0)); + if (rem == 1.0) + return SCM_BOOL_T; + else if (rem == 0.0) + return SCM_BOOL_F; + else + SCM_WRONG_TYPE_ARG (1, n); + } else SCM_WRONG_TYPE_ARG (1, n); } @@ -308,33 +501,21 @@ SCM_DEFINE (scm_even_p, "even?", 1, 0, 0, } else if (!SCM_FALSEP (scm_inf_p (n))) return SCM_BOOL_T; + else if (SCM_REALP (n)) + { + double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0)); + if (rem == 1.0) + return SCM_BOOL_F; + else if (rem == 0.0) + return SCM_BOOL_T; + else + SCM_WRONG_TYPE_ARG (1, n); + } else SCM_WRONG_TYPE_ARG (1, n); } #undef FUNC_NAME -static int -xisinf (double x) -{ -#if defined (HAVE_ISINF) - return isinf (x); -#elif defined (HAVE_FINITE) && defined (HAVE_ISNAN) - return (! (finite (x) || isnan (x))); -#else - return 0; -#endif -} - -static int -xisnan (double x) -{ -#if defined (HAVE_ISNAN) - return isnan (x); -#else - return 0; -#endif -} - SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0, (SCM n), "Return @code{#t} if @var{n} is infinite, @code{#f}\n" @@ -469,6 +650,13 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, } else if (SCM_REALP (x)) return scm_make_real (fabs (SCM_REAL_VALUE (x))); + else if (SCM_FRACTIONP (x)) + { + if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (x)))) + return x; + return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED), + SCM_FRACTION_DENOMINATOR (x)); + } else SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs); } @@ -1462,6 +1650,8 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, */ SCM div = scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift)); + + /* scm_quotient assumes its arguments are integers, but it's legal to (ash 1/2 -1) */ if (SCM_FALSEP (scm_negative_p (n))) return scm_quotient (n, div); else @@ -1867,7 +2057,6 @@ scm_iint2str (long num, int rad, char *p) return j; } - SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, (SCM n, SCM radix), "Return a string holding the external representation of the\n" @@ -1899,6 +2088,13 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, scm_remember_upto_here_1 (n); return scm_take0str (str); } + else if (SCM_FRACTIONP (n)) + { + scm_i_fraction_reduce (n); + return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix), + scm_mem2string ("/", 1), + scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix))); + } else if (SCM_INEXACTP (n)) { char num_buf [FLOBUFLEN]; @@ -1923,12 +2119,24 @@ scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) int scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) + { char num_buf[FLOBUFLEN]; scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port); return !0; } +int +scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) +{ + SCM str; + scm_i_fraction_reduce (sexp); + str = scm_number_to_string (sexp, SCM_UNDEFINED); + scm_lfwrite (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), port); + scm_remember_upto_here_1 (str); + return !0; +} + int scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { @@ -2117,7 +2325,7 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, result = scm_sum (result, SCM_MAKINUM (add)); } - result = scm_divide (result, big_shift); + result = scm_divide2real (result, big_shift); /* We've seen a decimal point, thus the value is implicitly inexact. */ x = INEXACT; @@ -2188,7 +2396,7 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, if (sign == 1) result = scm_product (result, e); else - result = scm_divide (result, e); + result = scm_divide2real (result, e); /* We've seen an exponent, thus the value is implicitly inexact. */ x = INEXACT; @@ -2271,7 +2479,8 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, if (SCM_FALSEP (divisor)) return SCM_BOOL_F; - result = scm_divide (uinteger, divisor); + /* both are int/big here, I assume */ + result = scm_make_ratio (uinteger, divisor); } else if (radix == 10) { @@ -2604,6 +2813,14 @@ scm_complex_equalp (SCM x, SCM y) && SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)); } +SCM +scm_i_fraction_equalp (SCM x, SCM y) +{ + scm_i_fraction_reduce (x); + scm_i_fraction_reduce (y); + return SCM_BOOL (scm_equal_p (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_NUMERATOR (y)) + && scm_equal_p (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y))); +} SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p); @@ -2626,30 +2843,39 @@ SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0, #undef FUNC_NAME -SCM_REGISTER_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p); -/* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n" - * "Note that the sets of integer and rational values form a subset\n" - * "of the set of real numbers, i. e. the predicate will also\n" - * "be fulfilled if @var{x} is an integer or a rational number." - */ -SCM_DEFINE (scm_real_p, "rational?", 1, 0, 0, +SCM_DEFINE (scm_real_p, "real?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is a real number, @code{#f}\n" + "otherwise. Note that the set of integer values forms a subset of\n" + "the set of real numbers, i. e. the predicate will also be\n" + "fulfilled if @var{x} is an integer number.") +#define FUNC_NAME s_scm_real_p +{ + /* we can't represent irrational numbers. */ + return scm_rational_p (x); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0, (SCM x), "Return @code{#t} if @var{x} is a rational number, @code{#f}\n" "otherwise. Note that the set of integer values forms a subset of\n" "the set of rational numbers, i. e. the predicate will also be\n" - "fulfilled if @var{x} is an integer number. Real numbers\n" - "will also satisfy this predicate, because of their limited\n" - "precision.") -#define FUNC_NAME s_scm_real_p + "fulfilled if @var{x} is an integer number.") +#define FUNC_NAME s_scm_rational_p { if (SCM_INUMP (x)) return SCM_BOOL_T; else if (SCM_IMP (x)) return SCM_BOOL_F; - else if (SCM_REALP (x)) - return SCM_BOOL_T; else if (SCM_BIGP (x)) return SCM_BOOL_T; + else if (SCM_FRACTIONP (x)) + return SCM_BOOL_T; + else if (SCM_REALP (x)) + /* due to their limited precision, all floating point numbers are + rational as well. */ + return SCM_BOOL_T; else return SCM_BOOL_F; } @@ -2712,6 +2938,8 @@ scm_num_eq_p (SCM x, SCM y) else if (SCM_COMPLEXP (y)) return SCM_BOOL (((double) xx == SCM_COMPLEX_REAL (y)) && (0.0 == SCM_COMPLEX_IMAG (y))); + else if (SCM_FRACTIONP (y)) + return SCM_BOOL_F; else SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); } @@ -2745,6 +2973,8 @@ scm_num_eq_p (SCM x, SCM y) scm_remember_upto_here_1 (x); return SCM_BOOL (0 == cmp); } + else if (SCM_FRACTIONP (y)) + return SCM_BOOL_F; else SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); } @@ -2766,6 +2996,8 @@ scm_num_eq_p (SCM x, SCM y) else if (SCM_COMPLEXP (y)) return SCM_BOOL ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)) && (0.0 == SCM_COMPLEX_IMAG (y))); + else if (SCM_FRACTIONP (y)) + return SCM_BOOL (SCM_REAL_VALUE (x) == scm_i_fraction2double (y)); else SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); } @@ -2791,6 +3023,25 @@ scm_num_eq_p (SCM x, SCM y) else if (SCM_COMPLEXP (y)) return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)) && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y))); + else if (SCM_FRACTIONP (y)) + return SCM_BOOL ((SCM_COMPLEX_REAL (x) == scm_i_fraction2double (y)) + && (SCM_COMPLEX_IMAG (x) == 0.0)); + else + SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_INUMP (y)) + return SCM_BOOL_F; + else if (SCM_BIGP (y)) + return SCM_BOOL_F; + else if (SCM_REALP (y)) + return SCM_BOOL (scm_i_fraction2double (x) == SCM_REAL_VALUE (y)); + else if (SCM_COMPLEXP (y)) + return SCM_BOOL ((scm_i_fraction2double (x) == SCM_COMPLEX_REAL (y)) + && (0.0 == SCM_COMPLEX_IMAG (y))); + else if (SCM_FRACTIONP (y)) + return scm_i_fraction_equalp (x, y); else SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); } @@ -2822,6 +3073,8 @@ scm_less_p (SCM x, SCM y) } else if (SCM_REALP (y)) return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return SCM_BOOL ((double) xx < scm_i_fraction2double (y)); else SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } @@ -2848,6 +3101,13 @@ scm_less_p (SCM x, SCM y) scm_remember_upto_here_1 (x); return SCM_BOOL (cmp < 0); } + else if (SCM_FRACTIONP (y)) + { + int cmp; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), scm_i_fraction2double (y)); + scm_remember_upto_here_1 (x); + return SCM_BOOL (cmp < 0); + } else SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } @@ -2866,6 +3126,28 @@ scm_less_p (SCM x, SCM y) } else if (SCM_REALP (y)) return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return SCM_BOOL (SCM_REAL_VALUE (x) < scm_i_fraction2double (y)); + else + SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_INUMP (y)) + return SCM_BOOL (scm_i_fraction2double (x) < (double) SCM_INUM (y)); + else if (SCM_BIGP (y)) + { + int cmp; + if (xisnan (SCM_REAL_VALUE (x))) + return SCM_BOOL_F; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), scm_i_fraction2double (x)); + scm_remember_upto_here_1 (y); + return SCM_BOOL (cmp > 0); + } + else if (SCM_REALP (y)) + return SCM_BOOL (scm_i_fraction2double (x) < SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return SCM_BOOL (scm_i_fraction2double (x) < scm_i_fraction2double (y)); else SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } @@ -2948,6 +3230,8 @@ scm_zero_p (SCM z) else if (SCM_COMPLEXP (z)) return SCM_BOOL (SCM_COMPLEX_REAL (z) == 0.0 && SCM_COMPLEX_IMAG (z) == 0.0); + else if (SCM_FRACTIONP (z)) + return SCM_BOOL_F; else SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p); } @@ -2970,6 +3254,8 @@ scm_positive_p (SCM x) } else if (SCM_REALP (x)) return SCM_BOOL(SCM_REAL_VALUE (x) > 0.0); + else if (SCM_FRACTIONP (x)) + return scm_positive_p (SCM_FRACTION_NUMERATOR (x)); else SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p); } @@ -2992,6 +3278,8 @@ scm_negative_p (SCM x) } else if (SCM_REALP (x)) return SCM_BOOL(SCM_REAL_VALUE (x) < 0.0); + else if (SCM_FRACTIONP (x)) + return scm_negative_p (SCM_FRACTION_NUMERATOR (x)); else SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p); } @@ -3033,6 +3321,11 @@ scm_max (SCM x, SCM y) /* if y==NaN then ">" is false and we return NaN */ return (z > SCM_REAL_VALUE (y)) ? scm_make_real (z) : y; } + else if (SCM_FRACTIONP (y)) + { + double z = xx; + return (z > scm_i_fraction2double (y)) ? x : y; + } else SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); } @@ -3060,6 +3353,14 @@ scm_max (SCM x, SCM y) scm_remember_upto_here_1 (x); return (cmp > 0) ? x : y; } + else if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + int cmp; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy); + scm_remember_upto_here_1 (x); + return (cmp > 0) ? x : y; + } else SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); } @@ -3090,6 +3391,41 @@ scm_max (SCM x, SCM y) double xx = SCM_REAL_VALUE (x); return (xisnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y; } + else if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + double xx = SCM_REAL_VALUE (x); + return (xx < yy) ? scm_make_real (yy) : x; + } + else + SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_INUMP (y)) + { + double z = SCM_INUM (y); + return (scm_i_fraction2double (x) < z) ? y : x; + } + else if (SCM_BIGP (y)) + { + double xx = scm_i_fraction2double (x); + int cmp; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx); + scm_remember_upto_here_1 (y); + return (cmp < 0) ? x : y; + } + else if (SCM_REALP (y)) + { + double xx = scm_i_fraction2double (x); + return (xx < SCM_REAL_VALUE (y)) ? y : scm_make_real (xx); + } + else if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + double xx = scm_i_fraction2double (x); + return (xx < yy) ? y : x; + } else SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); } @@ -3134,6 +3470,11 @@ scm_min (SCM x, SCM y) /* if y==NaN then "<" is false and we return NaN */ return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y; } + else if (SCM_FRACTIONP (y)) + { + double z = xx; + return (z < scm_i_fraction2double (y)) ? x : y; + } else SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); } @@ -3161,6 +3502,14 @@ scm_min (SCM x, SCM y) scm_remember_upto_here_1 (x); return (cmp > 0) ? y : x; } + else if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + int cmp; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy); + scm_remember_upto_here_1 (x); + return (cmp > 0) ? y : x; + } else SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); } @@ -3191,9 +3540,44 @@ scm_min (SCM x, SCM y) double xx = SCM_REAL_VALUE (x); return (xisnan (xx) || xx < SCM_REAL_VALUE (y)) ? x : y; } + else if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + double xx = SCM_REAL_VALUE (x); + return (yy < xx) ? scm_make_real (yy) : x; + } else SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); } + else if (SCM_FRACTIONP (x)) + { + if (SCM_INUMP (y)) + { + double z = SCM_INUM (y); + return (scm_i_fraction2double (x) < z) ? x : y; + } + else if (SCM_BIGP (y)) + { + double xx = scm_i_fraction2double (x); + int cmp; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx); + scm_remember_upto_here_1 (y); + return (cmp < 0) ? y : x; + } + else if (SCM_REALP (y)) + { + double xx = scm_i_fraction2double (x); + return (SCM_REAL_VALUE (y) < xx) ? y : scm_make_real (xx); + } + else if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + double xx = scm_i_fraction2double (x); + return (xx < yy) ? x : y; + } + else + SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); + } else SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min); } @@ -3238,6 +3622,10 @@ scm_sum (SCM x, SCM y) return scm_make_complex (xx + SCM_COMPLEX_REAL (y), SCM_COMPLEX_IMAG (y)); } + else if (SCM_FRACTIONP (y)) + return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y), + scm_product (x, SCM_FRACTION_DENOMINATOR (y))), + SCM_FRACTION_DENOMINATOR (y)); else SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); } else if (SCM_BIGP (x)) @@ -3299,6 +3687,10 @@ scm_sum (SCM x, SCM y) scm_remember_upto_here_1 (x); return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y)); } + else if (SCM_FRACTIONP (y)) + return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y), + scm_product (x, SCM_FRACTION_DENOMINATOR (y))), + SCM_FRACTION_DENOMINATOR (y)); else SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); } @@ -3317,6 +3709,8 @@ scm_sum (SCM x, SCM y) else if (SCM_COMPLEXP (y)) return scm_make_complex (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y), SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + return scm_make_real (SCM_REAL_VALUE (x) + scm_i_fraction2double (y)); else SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); } @@ -3338,6 +3732,32 @@ scm_sum (SCM x, SCM y) else if (SCM_COMPLEXP (y)) return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y), SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + return scm_make_complex (SCM_COMPLEX_REAL (x) + scm_i_fraction2double (y), + SCM_COMPLEX_IMAG (x)); + else + SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_INUMP (y)) + return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x), + scm_product (y, SCM_FRACTION_DENOMINATOR (x))), + SCM_FRACTION_DENOMINATOR (x)); + else if (SCM_BIGP (y)) + return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x), + scm_product (y, SCM_FRACTION_DENOMINATOR (x))), + SCM_FRACTION_DENOMINATOR (x)); + else if (SCM_REALP (y)) + return scm_make_real (SCM_REAL_VALUE (y) + scm_i_fraction2double (x)); + else if (SCM_COMPLEXP (y)) + return scm_make_complex (SCM_COMPLEX_REAL (y) + scm_i_fraction2double (x), + SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + /* a/b + c/d = (ad + bc) / bd */ + return scm_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)), + scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))), + scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y))); else SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); } @@ -3375,6 +3795,9 @@ scm_difference (SCM x, SCM y) else if (SCM_COMPLEXP (x)) return scm_make_complex (-SCM_COMPLEX_REAL (x), -SCM_COMPLEX_IMAG (x)); + else if (SCM_FRACTIONP (x)) + return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED), + SCM_FRACTION_DENOMINATOR (x)); else SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference); } @@ -3431,6 +3854,11 @@ scm_difference (SCM x, SCM y) return scm_make_complex (xx - SCM_COMPLEX_REAL (y), - SCM_COMPLEX_IMAG (y)); } + else if (SCM_FRACTIONP (y)) + /* a - b/c = (ac - b) / c */ + return scm_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)), + SCM_FRACTION_NUMERATOR (y)), + SCM_FRACTION_DENOMINATOR (y)); else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); } @@ -3491,6 +3919,10 @@ scm_difference (SCM x, SCM y) scm_remember_upto_here_1 (x); return scm_make_complex (real_part, - SCM_COMPLEX_IMAG (y)); } + else if (SCM_FRACTIONP (y)) + return scm_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)), + SCM_FRACTION_NUMERATOR (y)), + SCM_FRACTION_DENOMINATOR (y)); else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); } else if (SCM_REALP (x)) @@ -3508,6 +3940,8 @@ scm_difference (SCM x, SCM y) else if (SCM_COMPLEXP (y)) return scm_make_complex (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y), -SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + return scm_make_real (SCM_REAL_VALUE (x) - scm_i_fraction2double (y)); else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); } @@ -3529,6 +3963,33 @@ scm_difference (SCM x, SCM y) else if (SCM_COMPLEXP (y)) return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y), SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + return scm_make_complex (SCM_COMPLEX_REAL (x) - scm_i_fraction2double (y), + SCM_COMPLEX_IMAG (x)); + else + SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_INUMP (y)) + /* a/b - c = (a - cb) / b */ + return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), + scm_product(y, SCM_FRACTION_DENOMINATOR (x))), + SCM_FRACTION_DENOMINATOR (x)); + else if (SCM_BIGP (y)) + return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), + scm_product(y, SCM_FRACTION_DENOMINATOR (x))), + SCM_FRACTION_DENOMINATOR (x)); + else if (SCM_REALP (y)) + return scm_make_real (scm_i_fraction2double (x) - SCM_REAL_VALUE (y)); + else if (SCM_COMPLEXP (y)) + return scm_make_complex (scm_i_fraction2double (x) - SCM_COMPLEX_REAL (y), + -SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + /* a/b - c/d = (ad - bc) / bd */ + return scm_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)), + scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))), + scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y))); else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); } @@ -3594,6 +4055,9 @@ scm_product (SCM x, SCM y) else if (SCM_COMPLEXP (y)) return scm_make_complex (xx * SCM_COMPLEX_REAL (y), xx * SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + return scm_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)), + SCM_FRACTION_DENOMINATOR (y)); else SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); } @@ -3626,6 +4090,9 @@ scm_product (SCM x, SCM y) return scm_make_complex (z * SCM_COMPLEX_REAL (y), z * SCM_COMPLEX_IMAG (y)); } + else if (SCM_FRACTIONP (y)) + return scm_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)), + SCM_FRACTION_DENOMINATOR (y)); else SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); } @@ -3644,6 +4111,8 @@ scm_product (SCM x, SCM y) else if (SCM_COMPLEXP (y)) return scm_make_complex (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y), SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + return scm_make_real (SCM_REAL_VALUE (x) * scm_i_fraction2double (y)); else SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); } @@ -3669,6 +4138,37 @@ scm_product (SCM x, SCM y) SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y) + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y)); } + else if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + return scm_make_complex (yy * SCM_COMPLEX_REAL (x), + yy * SCM_COMPLEX_IMAG (x)); + } + else + SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_INUMP (y)) + return scm_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)), + SCM_FRACTION_DENOMINATOR (x)); + else if (SCM_BIGP (y)) + return scm_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)), + SCM_FRACTION_DENOMINATOR (x)); + else if (SCM_REALP (y)) + return scm_make_real (scm_i_fraction2double (x) * SCM_REAL_VALUE (y)); + else if (SCM_COMPLEXP (y)) + { + double xx = scm_i_fraction2double (x); + return scm_make_complex (xx * SCM_COMPLEX_REAL (y), + xx * SCM_COMPLEX_IMAG (y)); + } + else if (SCM_FRACTIONP (y)) + /* a/b * c/d = ac / bd */ + return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_NUMERATOR (y)), + scm_product (SCM_FRACTION_DENOMINATOR (x), + SCM_FRACTION_DENOMINATOR (y))); else SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); } @@ -3690,6 +4190,8 @@ scm_num2dbl (SCM a, const char *why) } else if (SCM_REALP (a)) return (SCM_REAL_VALUE (a)); + else if (SCM_FRACTIONP (a)) + return scm_i_fraction2double (a); else SCM_WRONG_TYPE_ARG (SCM_ARGn, a); } @@ -3733,8 +4235,8 @@ SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide); arguments. If called with one argument @var{z1}, 1/@var{z1} is returned. */ #define FUNC_NAME s_divide -SCM -scm_divide (SCM x, SCM y) +static SCM +scm_i_divide (SCM x, SCM y, int inexact) { double a; @@ -3752,10 +4254,18 @@ scm_divide (SCM x, SCM y) scm_num_overflow (s_divide); #endif else - return scm_make_real (1.0 / (double) xx); + { + if (inexact) + return scm_make_real (1.0 / (double) xx); + else return scm_make_ratio (SCM_MAKINUM(1), x); + } } else if (SCM_BIGP (x)) - return scm_make_real (1.0 / scm_i_big2dbl (x)); + { + if (inexact) + return scm_make_real (1.0 / scm_i_big2dbl (x)); + else return scm_make_ratio (SCM_MAKINUM(1), x); + } else if (SCM_REALP (x)) { double xx = SCM_REAL_VALUE (x); @@ -3783,6 +4293,9 @@ scm_divide (SCM x, SCM y) return scm_make_complex (1.0 / d, -t / d); } } + else if (SCM_FRACTIONP (x)) + return scm_make_ratio (SCM_FRACTION_DENOMINATOR (x), + SCM_FRACTION_NUMERATOR (x)); else SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); } @@ -3802,7 +4315,11 @@ scm_divide (SCM x, SCM y) #endif } else if (xx % yy != 0) - return scm_make_real ((double) xx / (double) yy); + { + if (inexact) + return scm_make_real ((double) xx / (double) yy); + else return scm_make_ratio (x, y); + } else { long z = xx / yy; @@ -3813,7 +4330,11 @@ scm_divide (SCM x, SCM y) } } else if (SCM_BIGP (y)) - return scm_make_real ((double) xx / scm_i_big2dbl (y)); + { + if (inexact) + return scm_make_real ((double) xx / scm_i_big2dbl (y)); + else return scm_make_ratio (x, y); + } else if (SCM_REALP (y)) { double yy = SCM_REAL_VALUE (y); @@ -3845,6 +4366,10 @@ scm_divide (SCM x, SCM y) } } } + else if (SCM_FRACTIONP (y)) + /* a / b/c = ac / b */ + return scm_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)), + SCM_FRACTION_NUMERATOR (y)); else SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); } @@ -3888,7 +4413,11 @@ scm_divide (SCM x, SCM y) return scm_i_normbig (result); } else - return scm_make_real (scm_i_big2dbl (x) / (double) yy); + { + if (inexact) + return scm_make_real (scm_i_big2dbl (x) / (double) yy); + else return scm_make_ratio (x, y); + } } } else if (SCM_BIGP (y)) @@ -3920,10 +4449,14 @@ scm_divide (SCM x, SCM y) } else { - double dbx = mpz_get_d (SCM_I_BIG_MPZ (x)); - double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return scm_make_real (dbx / dby); + if (inexact) + { + double dbx = mpz_get_d (SCM_I_BIG_MPZ (x)); + double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_make_real (dbx / dby); + } + else return scm_make_ratio (x, y); } } } @@ -3942,6 +4475,9 @@ scm_divide (SCM x, SCM y) a = scm_i_big2dbl (x); goto complex_div; } + else if (SCM_FRACTIONP (y)) + return scm_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)), + SCM_FRACTION_NUMERATOR (y)); else SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); } @@ -3979,6 +4515,8 @@ scm_divide (SCM x, SCM y) a = rx; goto complex_div; } + else if (SCM_FRACTIONP (y)) + return scm_make_real (rx / scm_i_fraction2double (y)); else SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); } @@ -4032,12 +4570,67 @@ scm_divide (SCM x, SCM y) return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d); } } + else if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + return scm_make_complex (rx / yy, ix / yy); + } else SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); } + else if (SCM_FRACTIONP (x)) + { + if (SCM_INUMP (y)) + { + long int yy = SCM_INUM (y); +#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO + if (yy == 0) + scm_num_overflow (s_divide); + else +#endif + return scm_make_ratio (SCM_FRACTION_NUMERATOR (x), + scm_product (SCM_FRACTION_DENOMINATOR (x), y)); + } + else if (SCM_BIGP (y)) + { + return scm_make_ratio (SCM_FRACTION_NUMERATOR (x), + scm_product (SCM_FRACTION_DENOMINATOR (x), y)); + } + else if (SCM_REALP (y)) + { + double yy = SCM_REAL_VALUE (y); +#ifndef ALLOW_DIVIDE_BY_ZERO + if (yy == 0.0) + scm_num_overflow (s_divide); + else +#endif + return scm_make_real (scm_i_fraction2double (x) / yy); + } + else if (SCM_COMPLEXP (y)) + { + a = scm_i_fraction2double (x); + goto complex_div; + } + else if (SCM_FRACTIONP (y)) + return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)), + scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))); + else + SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); + } else SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide); } + +SCM +scm_divide (SCM x, SCM y) +{ + return scm_i_divide (x, y, 0); +} + +static SCM scm_divide2real (SCM x, SCM y) +{ + return scm_i_divide (x, y, 1); +} #undef FUNC_NAME @@ -4086,6 +4679,11 @@ SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) atanh, g_atanh); */ +/* XXX - eventually, we should remove this definition of scm_round and + rename scm_round_number to scm_round. Likewise for scm_truncate + and scm_truncate_number. + */ + double scm_truncate (double x) { @@ -4098,15 +4696,7 @@ scm_truncate (double x) return floor (x); #endif } -SCM_GPROC1 (s_truncate, "truncate", scm_tc7_dsubr, (SCM (*)()) trunc, g_truncate); -/* "Round the inexact number @var{x} towards zero." - */ - -SCM_GPROC1 (s_round, "round", scm_tc7_dsubr, (SCM (*)()) scm_round, g_round); -/* "Round the inexact number @var{x}. If @var{x} is halfway between two\n" - * "numbers, round towards even." - */ double scm_round (double x) { @@ -4118,13 +4708,100 @@ scm_round (double x) : result); } +SCM_DEFINE (scm_truncate_number, "truncate", 1, 0, 0, + (SCM x), + "Round the number @var{x} towards zero.") +#define FUNC_NAME s_scm_truncate_number +{ + if (SCM_FALSEP (scm_negative_p (x))) + return scm_floor (x); + else + return scm_ceiling (x); +} +#undef FUNC_NAME + +static SCM exactly_one_half; + +SCM_DEFINE (scm_round_number, "round", 1, 0, 0, + (SCM x), + "Round the number @var{x} towards the nearest integer. " + "When it is exactly halfway between two integers, " + "round towards the even one.") +#define FUNC_NAME s_scm_round_number +{ + SCM plus_half = scm_sum (x, exactly_one_half); + SCM result = scm_floor (plus_half); + /* Adjust so that the scm_round is towards even. */ + if (!SCM_FALSEP (scm_num_eq_p (plus_half, result)) + && !SCM_FALSEP (scm_odd_p (result))) + return scm_difference (result, SCM_MAKINUM (1)); + else + return result; +} +#undef FUNC_NAME + +SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0, + (SCM x), + "Round the number @var{x} towards minus infinity.") +#define FUNC_NAME s_scm_floor +{ + if (SCM_INUMP (x) || SCM_BIGP (x)) + return x; + else if (SCM_REALP (x)) + return scm_make_real (floor (SCM_REAL_VALUE (x))); + else if (SCM_FRACTIONP (x)) + { + SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_DENOMINATOR (x)); + if (SCM_FALSEP (scm_negative_p (x))) + { + /* For positive x, rounding towards zero is correct. */ + return q; + } + else + { + /* For negative x, we need to return q-1 unless x is an + integer. But fractions are never integer, per our + assumptions. */ + return scm_difference (q, SCM_MAKINUM (1)); + } + } + else + SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor); +} +#undef FUNC_NAME + +SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0, + (SCM x), + "Round the number @var{x} towards infinity.") +#define FUNC_NAME s_scm_ceiling +{ + if (SCM_INUMP (x) || SCM_BIGP (x)) + return x; + else if (SCM_REALP (x)) + return scm_make_real (ceil (SCM_REAL_VALUE (x))); + else if (SCM_FRACTIONP (x)) + { + SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_DENOMINATOR (x)); + if (SCM_FALSEP (scm_positive_p (x))) + { + /* For negative x, rounding towards zero is correct. */ + return q; + } + else + { + /* For positive x, we need to return q+1 unless x is an + integer. But fractions are never integer, per our + assumptions. */ + return scm_sum (q, SCM_MAKINUM (1)); + } + } + else + SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling); +} +#undef FUNC_NAME -SCM_GPROC1 (s_i_floor, "floor", scm_tc7_dsubr, (SCM (*)()) floor, g_i_floor); -/* "Round the number @var{x} towards minus infinity." - */ -SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_dsubr, (SCM (*)()) ceil, g_i_ceil); -/* "Round the number @var{x} towards infinity." - */ SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_dsubr, (SCM (*)()) sqrt, g_i_sqrt); /* "Return the square root of the real number @var{x}." */ @@ -4184,6 +4861,8 @@ scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy) xy->x = scm_i_big2dbl (x); else if (SCM_REALP (x)) xy->x = SCM_REAL_VALUE (x); + else if (SCM_FRACTIONP (x)) + xy->x = scm_i_fraction2double (x); else scm_wrong_type_arg (sstring, SCM_ARG1, x); @@ -4193,6 +4872,8 @@ scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy) xy->y = scm_i_big2dbl (y); else if (SCM_REALP (y)) xy->y = SCM_REAL_VALUE (y); + else if (SCM_FRACTIONP (y)) + xy->y = scm_i_fraction2double (y); else scm_wrong_type_arg (sstring, SCM_ARG2, y); } @@ -4274,6 +4955,8 @@ scm_real_part (SCM z) return z; else if (SCM_COMPLEXP (z)) return scm_make_real (SCM_COMPLEX_REAL (z)); + else if (SCM_FRACTIONP (z)) + return scm_make_real (scm_i_fraction2double (z)); else SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part); } @@ -4293,10 +4976,54 @@ scm_imag_part (SCM z) return scm_flo0; else if (SCM_COMPLEXP (z)) return scm_make_real (SCM_COMPLEX_IMAG (z)); + else if (SCM_FRACTIONP (z)) + return SCM_INUM0; else SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part); } +SCM_GPROC (s_numerator, "numerator", 1, 0, 0, scm_numerator, g_numerator); +/* "Return the numerator of the number @var{z}." + */ +SCM +scm_numerator (SCM z) +{ + if (SCM_INUMP (z)) + return z; + else if (SCM_BIGP (z)) + return z; + else if (SCM_FRACTIONP (z)) + { + scm_i_fraction_reduce (z); + return SCM_FRACTION_NUMERATOR (z); + } + else if (SCM_REALP (z)) + return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z))); + else + SCM_WTA_DISPATCH_1 (g_numerator, z, SCM_ARG1, s_numerator); +} + + +SCM_GPROC (s_denominator, "denominator", 1, 0, 0, scm_denominator, g_denominator); +/* "Return the denominator of the number @var{z}." + */ +SCM +scm_denominator (SCM z) +{ + if (SCM_INUMP (z)) + return SCM_MAKINUM (1); + else if (SCM_BIGP (z)) + return SCM_MAKINUM (1); + else if (SCM_FRACTIONP (z)) + { + scm_i_fraction_reduce (z); + return SCM_FRACTION_DENOMINATOR (z); + } + else if (SCM_REALP (z)) + return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z))); + else + SCM_WTA_DISPATCH_1 (g_denominator, z, SCM_ARG1, s_denominator); +} SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude); /* "Return the magnitude of the number @var{z}. This is the same as\n" @@ -4328,6 +5055,13 @@ scm_magnitude (SCM z) return scm_make_real (fabs (SCM_REAL_VALUE (z))); else if (SCM_COMPLEXP (z)) return scm_make_real (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z))); + else if (SCM_FRACTIONP (z)) + { + if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z)))) + return z; + return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED), + SCM_FRACTION_DENOMINATOR (z)); + } else SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude); } @@ -4368,6 +5102,12 @@ scm_angle (SCM z) } else if (SCM_COMPLEXP (z)) return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z))); + else if (SCM_FRACTIONP (z)) + { + if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z)))) + return scm_flo0; + else return scm_make_real (atan2 (0.0, -1.0)); + } else SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle); } @@ -4383,6 +5123,8 @@ scm_exact_to_inexact (SCM z) return scm_make_real ((double) SCM_INUM (z)); else if (SCM_BIGP (z)) return scm_make_real (scm_i_big2dbl (z)); + else if (SCM_FRACTIONP (z)) + return scm_make_real (scm_i_fraction2double (z)); else if (SCM_INEXACTP (z)) return z; else @@ -4401,32 +5143,91 @@ SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, return z; else if (SCM_REALP (z)) { - /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both - powers of 2, so there's no rounding when making "double" values - from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could get - rounded on a 64-bit machine, hence the "+1". - - The use of floor() to force to an integer value ensures we get a - "numerically closest" value without depending on how a double->long - cast or how mpz_set_d will round. For reference, double->long - probably follows the hardware rounding mode, mpz_set_d truncates - towards zero. */ - - double u = SCM_REAL_VALUE (z); - if (xisinf (u) || xisnan (u)) - scm_num_overflow (s_scm_inexact_to_exact); - u = floor (u + 0.5); - if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1) - && u >= (double) SCM_MOST_NEGATIVE_FIXNUM) - return SCM_MAKINUM ((long) u); + if (xisinf (SCM_REAL_VALUE (z)) || xisnan (SCM_REAL_VALUE (z))) + SCM_OUT_OF_RANGE (1, z); else - return scm_i_dbl2big (u); + { + mpq_t frac; + SCM q; + + mpq_init (frac); + mpq_set_d (frac, SCM_REAL_VALUE (z)); + q = scm_make_ratio (scm_i_mpz2num (mpq_numref (frac)), + scm_i_mpz2num (mpq_denref (frac))); + + /* When scm_make_ratio throws, we leak the memory allocated + for frac... + */ + mpq_clear (frac); + return q; + } } + else if (SCM_FRACTIONP (z)) + return z; else SCM_WRONG_TYPE_ARG (1, z); } #undef FUNC_NAME +SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, + (SCM x, SCM err), + "Return an exact number that is within @var{err} of @var{x}.") +#define FUNC_NAME s_scm_rationalize +{ + if (SCM_INUMP (x)) + return x; + else if (SCM_BIGP (x)) + return x; + else if ((SCM_REALP (x)) || SCM_FRACTIONP (x)) + { + /* Use continued fractions to find closest ratio. All + arithmetic is done with exact numbers. + */ + + SCM ex = scm_inexact_to_exact (x); + SCM int_part = scm_floor (ex); + SCM tt = SCM_MAKINUM (1); + SCM a1 = SCM_MAKINUM (0), a2 = SCM_MAKINUM (1), a = SCM_MAKINUM (0); + SCM b1 = SCM_MAKINUM (1), b2 = SCM_MAKINUM (0), b = SCM_MAKINUM (0); + SCM rx; + int i = 0; + + if (!SCM_FALSEP (scm_num_eq_p (ex, int_part))) + return ex; + + ex = scm_difference (ex, int_part); /* x = x-int_part */ + rx = scm_divide (ex, SCM_UNDEFINED); /* rx = 1/x */ + + /* We stop after a million iterations just to be absolutely sure + that we don't go into an infinite loop. The process normally + converges after less than a dozen iterations. + */ + + err = scm_abs (err); + while (++i < 1000000) + { + a = scm_sum (scm_product (a1, tt), a2); /* a = a1*tt + a2 */ + b = scm_sum (scm_product (b1, tt), b2); /* b = b1*tt + b2 */ + if (SCM_FALSEP (scm_zero_p (b)) && /* b != 0 */ + SCM_FALSEP + (scm_gr_p (scm_abs (scm_difference (ex, scm_divide (a, b))), + err))) /* abs(x-a/b) <= err */ + return scm_sum (int_part, scm_divide (a, b)); /* int_part+a/b */ + rx = scm_divide (scm_difference (rx, tt), /* rx = 1/(rx - tt) */ + SCM_UNDEFINED); + tt = scm_floor (rx); /* tt = floor (rx) */ + a2 = a1; + b2 = b1; + a1 = a; + b1 = b; + } + scm_num_overflow (s_scm_rationalize); + } + else + SCM_WRONG_TYPE_ARG (1, x); +} +#undef FUNC_NAME + /* if you need to change this, change test-num2integral.c as well */ #if SCM_SIZEOF_LONG_LONG != 0 # ifndef LLONG_MAX @@ -4721,7 +5522,9 @@ scm_init_numbers () #ifdef GUILE_DEBUG check_sanity (); #endif - + + exactly_one_half = scm_permanent_object (scm_divide (SCM_MAKINUM (1), + SCM_MAKINUM (2))); #include "libguile/numbers.x" } diff --git a/libguile/numbers.h b/libguile/numbers.h index 8bf211d6f..772a0ebe5 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -131,6 +131,7 @@ #define scm_tc16_big (scm_tc7_number + 1 * 256L) #define scm_tc16_real (scm_tc7_number + 2 * 256L) #define scm_tc16_complex (scm_tc7_number + 3 * 256L) +#define scm_tc16_fraction (scm_tc7_number + 4 * 256L) #define SCM_INEXACTP(x) \ (!SCM_IMP (x) && (0xfeff & SCM_CELL_TYPE (x)) == scm_tc16_real) @@ -148,7 +149,21 @@ #define SCM_NUMBERP(x) (SCM_INUMP(x) || SCM_NUMP(x)) #define SCM_NUMP(x) (!SCM_IMP(x) \ - && (0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) + && (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) \ + || ((0xfbff & SCM_CELL_TYPE (x)) == scm_tc7_number))) +/* 0xfcff (#b1100) for 0 free, 1 big, 2 real, 3 complex, then 0xfbff (#b1011) for 4 fraction */ + +#define SCM_FRACTIONP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_fraction) +#define SCM_SLOPPY_FRACTIONP(x) (SCM_TYP16 (x) == scm_tc16_fraction) +#define SCM_FRACTION_NUMERATOR(x) ((SCM) (SCM_CELL_WORD_1 (x))) +#define SCM_FRACTION_DENOMINATOR(x) ((SCM) (SCM_CELL_WORD_2 (x))) +#define SCM_FRACTION_SET_NUMERATOR(x, v) ((SCM) (SCM_SET_CELL_WORD_1 ((x), (v)))) +#define SCM_FRACTION_SET_DENOMINATOR(x, v) ((SCM) (SCM_SET_CELL_WORD_2 ((x), (v)))) + /* I think the left half word is free in the type, so I'll use bit 17 */ +#define SCM_FRACTION_REDUCED_BIT 0x10000 +#define SCM_FRACTION_REDUCED_SET(x) (SCM_SET_CELL_TYPE((x), (SCM_CELL_TYPE (x) | SCM_FRACTION_REDUCED_BIT))) +#define SCM_FRACTION_REDUCED_CLEAR(x) (SCM_SET_CELL_TYPE((x), (SCM_CELL_TYPE (x) & ~SCM_FRACTION_REDUCED_BIT))) +#define SCM_FRACTION_REDUCED(x) (0x10000 & SCM_CELL_TYPE (x)) @@ -223,11 +238,15 @@ SCM_API SCM scm_difference (SCM x, SCM y); SCM_API SCM scm_product (SCM x, SCM y); SCM_API double scm_num2dbl (SCM a, const char * why); SCM_API SCM scm_divide (SCM x, SCM y); +SCM_API SCM scm_floor (SCM x); +SCM_API SCM scm_ceiling (SCM x); SCM_API double scm_asinh (double x); SCM_API double scm_acosh (double x); SCM_API double scm_atanh (double x); SCM_API double scm_truncate (double x); SCM_API double scm_round (double x); +SCM_API SCM scm_truncate_number (SCM x); +SCM_API SCM scm_round_number (SCM x); SCM_API SCM scm_sys_expt (SCM z1, SCM z2); SCM_API SCM scm_sys_atan2 (SCM z1, SCM z2); SCM_API SCM scm_make_rectangular (SCM z1, SCM z2); @@ -286,6 +305,7 @@ SCM_API SCM scm_i_mkbig (void); SCM_API SCM scm_i_normbig (SCM x); SCM_API int scm_i_bigcmp (SCM a, SCM b); SCM_API SCM scm_i_dbl2big (double d); +SCM_API SCM scm_i_dbl2num (double d); SCM_API double scm_i_big2dbl (SCM b); SCM_API SCM scm_i_short2big (short n); SCM_API SCM scm_i_ushort2big (unsigned short n); @@ -302,6 +322,18 @@ SCM_API SCM scm_i_ulong_long2big (unsigned long long n); #endif +/* ratio functions */ +SCM_API SCM scm_make_ratio (SCM num, SCM den); +SCM_API SCM scm_rationalize (SCM x, SCM err); +SCM_API SCM scm_numerator (SCM z); +SCM_API SCM scm_denominator (SCM z); +SCM_API SCM scm_rational_p (SCM z); + +/* fraction internal functions */ +SCM_API double scm_i_fraction2double (SCM z); +SCM_API SCM scm_i_fraction_equalp (SCM x, SCM y); +SCM_API int scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate); + #ifdef GUILE_DEBUG SCM_API SCM scm_sys_check_number_conversions (void); diff --git a/libguile/objects.c b/libguile/objects.c index 12ee5a9c0..f655470da 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -48,7 +48,7 @@ SCM scm_class_boolean, scm_class_char, scm_class_pair; SCM scm_class_procedure, scm_class_string, scm_class_symbol; SCM scm_class_procedure_with_setter, scm_class_primitive_generic; SCM scm_class_vector, scm_class_null; -SCM scm_class_integer, scm_class_real, scm_class_complex; +SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction; SCM scm_class_unknown; SCM *scm_port_class = 0; @@ -110,6 +110,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return scm_class_real; case scm_tc16_complex: return scm_class_complex; + case scm_tc16_fraction: + return scm_class_fraction; } case scm_tc7_asubr: case scm_tc7_subr_0: diff --git a/libguile/objects.h b/libguile/objects.h index 3217df025..11ab78b5f 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -190,6 +190,7 @@ SCM_API SCM scm_class_vector, scm_class_null; SCM_API SCM scm_class_real; SCM_API SCM scm_class_complex; SCM_API SCM scm_class_integer; +SCM_API SCM scm_class_fraction; SCM_API SCM scm_class_unknown; SCM_API SCM *scm_port_class; SCM_API SCM *scm_smob_class; diff --git a/libguile/print.c b/libguile/print.c index 4ff0aeb3e..9e7fe1c06 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -529,6 +529,9 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc16_complex: scm_print_complex (exp, port, pstate); break; + case scm_tc16_fraction: + scm_i_print_fraction (exp, port, pstate); + break; } break; case scm_tc7_string: From bdf26b606bb5e5b993f2a8f7e83492cfc2ee62d8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 18 Nov 2003 20:01:57 +0000 Subject: [PATCH 138/239] *** empty log message *** --- NEWS | 42 +++++++++++++++++++++++++++++++++++++++++ THANKS | 1 + libguile/ChangeLog | 45 ++++++++++++++++++++++++++++++++++++++++++++ test-suite/ChangeLog | 11 +++++++++++ 4 files changed, 99 insertions(+) diff --git a/NEWS b/NEWS index e802eecd3..4c697aac1 100644 --- a/NEWS +++ b/NEWS @@ -452,6 +452,48 @@ platform supports this, too. The two zeros are equal according to (eqv? 0.0 (- 0.0)) => #f +** Guile now has exact rationals. + +Guile can now represent fractions such as 1/3 exactly. Computing with +them is also done exactly, of course: + + (* 1/3 3/2) + => 1/2 + +** 'floor', 'ceiling', 'round' and 'truncate' now return exact numbers + for exact arguments. + +For example: (floor 2) now returns an exact 2 where in the past it +returned an inexact 2.0. Likewise, (floor 5/4) returns an exact 1. + +** inexact->exact no longer returns only integers. + +Without exact rationals, the closest exact number was always an +integer, but now inexact->exact returns the fraction that is exactly +equal to a floating point number. For example: + + (inexact->exact 1.234) + => 694680242521899/562949953421312 + +When you want the old behavior, use 'round' explicitely: + + (inexact->exact (round 1.234)) + => 1 + +** New function 'rationalize'. + +This function finds a simple fraction that is close to a given real +number. For example (and compare with inexact->exact above): + + (rationalize 1.234 0.0005) + => 58/47 + +** 'odd?' and 'even?' work also for inexact integers. + +Previously, (odd? 1.0) would signal an error since only exact integers +were recognized as integers. Now (odd? 1.0) returns #t, (odd? 2.0) +returns #f and (odd? 1.5) signals an error. + ** We now have uninterned symbols. The new function 'make-symbol' will return a uninterned symbol. This diff --git a/THANKS b/THANKS index 336b1aa62..babdf2fd2 100644 --- a/THANKS +++ b/THANKS @@ -6,6 +6,7 @@ Contributors since the last release: Thien-Thi Nguyen Han-Wen Nienhuys Kevin Ryde + Bill Schottstaedt Sponsors since the last release: diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d69f16495..970c227e2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,48 @@ +2003-11-18 Marius Vollmer + + Support for exact fractions from Bill Schottstaedt! Thanks! + + * print.c (scm_iprin1): Handle fractions. + + * objects.h (scm_class_fraction): New. + * objects.c (scm_class_fraction): New. + (scm_class_of): Handle fractions. + + * hash.c (scm_hasher): Handle fractions. + + * numbers.c: New code for handling fraction all over the place. + (scm_odd_p, scm_even_p): Handle inexact integers. + (scm_rational_p): New function, same as scm_real_p. + (scm_round_number, scm_truncate_number, scm_ceiling, scm_floor): + New exact functions that replace the inexact 'dsubr' + implementations. + (scm_numerator, scm_denominator): New. + + * numbers.h (SCM_NUMP): Recognize fractions. + (SCM_FRACTIONP, SCM_SLOPPY_FRACTIONP, SCM_FRACTION_NUMERATOR, + SCM_FRACTION_DENOMINATOR, SCM_FRACTION_SET_NUMERATOR, + SCM_FRACTION_SET_DENOMINATOR, SCM_FRACTION_REDUCED_BIT, + SCM_FRACTION_REDUCED_SET, SCM_FRACTION_REDUCED_CLEAR, + SCM_FRACTION_REDUCED): New. + (scm_floor, scm_ceiling, scm_truncate_number, scm_round_number): + New prototypes. + (scm_make_ratio, scm_rationalize, scm_numerator, scm_denominator, + scm_rational_p): New prototypes. + (scm_i_dbl2num, scm_i_fraction2double, scm_i_fraction_equalp, + scm_i_print_fraction): New prototypes. + + * goops.c (create_standard_classes): Create "" class. + + * gc-mark.c (scm_gc_mark_dependencies): Handle fractions. + + * gc-card.c (scm_i_sweep_card): Include scm_tc16_fraction as a + case in the switch, but do nothing for now. + + * eval.c (SCM_CEVAL, SCM_APPLY, call_dsubr_1): Convert fractions + to doubles when calling 'dsubr' functions. + + * eq.c (scm_eqv_p, scm_equal_p): Handle fractions. + 2003-11-18 Rob Browning * gen-scmconfig.c (main): remove public definition of diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index b5de860d2..f80abc29f 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,14 @@ +2003-11-18 Marius Vollmer + + * tests/numbers.test ("string->number"): Expect exact rationals + for things like "1/2" and "#e1.2". + ("inexact->exact"): Expect overflow error for infs and nans. + + * tests/fractions.test: New file from Bill Schottstaedt. Thanks! + + * tests/bit-operations.test (fixnum-bit): Round the result so that + fixnum-bit really is an integer. + 2003-11-17 Marius Vollmer * tests/srfi-17.test: Expect a "Bad variable" error for (set! #f From cef6deaff1095e7cc259c5b3293e2379425aa3c3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 18 Nov 2003 23:18:19 +0000 Subject: [PATCH 139/239] (Manual Conventions): Double-quote some statements formerly single-quoted. Remove some redundant quotes around code. Clarify meaning of `iff' further for those that didn't get it the first time 'round (like me). Make graphical indicators samples, not code. Put results of evaluation on the same line as @result symbols. Use @print example as example of total usage, and remind readers not to forget the difference. --- doc/ref/preface.texi | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/doc/ref/preface.texi b/doc/ref/preface.texi index 0313f7337..357df45a9 100644 --- a/doc/ref/preface.texi +++ b/doc/ref/preface.texi @@ -121,12 +121,13 @@ We use some conventions in this manual. @itemize @bullet @item -For some procedures, notably type predicates, we use @dfn{iff} to -mean `if and only if'. The construct is usually something like: -`Return @var{val} iff @var{condition}', where @var{val} is usually -`@code{#t}' or `non-@code{#f}'. This typically means that @var{val} -is returned if @var{condition} holds, and that @samp{#f} is returned -otherwise. +For some procedures, notably type predicates, we use @dfn{iff} to mean +``if and only if''. The construct is usually something like: `Return +@var{val} iff @var{condition}', where @var{val} is usually +``@nicode{#t}'' or ``non-@nicode{#f}''. This typically means that +@var{val} is returned if @var{condition} holds, and that @samp{#f} is +returned otherwise. To clarify: @var{val} will @strong{only} be +returned when @var{condition} is true. @cindex iff @item @@ -134,25 +135,27 @@ In examples and procedure descriptions and all other places where the evaluation of Scheme expression is shown, we use some notation for denoting the output and evaluation results of expressions. -The symbol @code{@result{}} is used to tell which value is returned by +The symbol @samp{@result{}} is used to tell which value is returned by an evaluation: @lisp (+ 1 2) -@result{} -3 +@result{} 3 @end lisp Some procedures produce some output besides returning a value. This -is denoted by the symbol @code{@print{}}. +is denoted by the symbol @samp{@print{}}. @lisp (begin (display 1) (newline) 'hooray) @print{} 1 -@result{} -hooray +@result{} hooray @end lisp +As you can see, this code prints @samp{1} (denoted by +@samp{@print{}}), and returns @code{hooray} (denoted by +@samp{@result{}}). Do not confuse the two. + @c Add other conventions here. @end itemize From 64758fe259b72997110f6bdf916bc90efb9ffb5a Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 19 Nov 2003 01:16:16 +0000 Subject: [PATCH 140/239] Defer lookup of lazy-handler-dispatch. --- ice-9/ChangeLog | 5 +++++ ice-9/boot-9.scm | 13 ++++++++++++- 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 2cad1c17c..71020ef19 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2003-11-19 Neil Jerram + + * boot-9.scm (error-catching-loop): Defer lookup of + lazy-handler-dispatch. + 2003-11-17 Marius Vollmer * boot-9.scm (@, @@): New macros. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 3989f69e9..d65d99db1 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2315,7 +2315,18 @@ (loop (thunk))) #f))))) - lazy-handler-dispatch)) + ;; Use a closure here rather than + ;; just `lazy-handler-dispatch' so + ;; that lookup of + ;; lazy-handler-dispatch's value is + ;; deferred until a throw occurs. + ;; This means that if code executed + ;; in the REPL just above set!s + ;; lazy-handler-dispatch, the new + ;; value will be used to handle the + ;; next throw from the REPL. + (lambda args + (apply lazy-handler-dispatch args)))) (lambda (key . args) (case key From d9d022a7d6bba03574a3568680ff43c40a558083 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 19 Nov 2003 01:22:06 +0000 Subject: [PATCH 141/239] Work in progress. --- emacs/ChangeLog | 31 ++ emacs/gds.el | 799 ++++++++++++++++++++++++++---------------------- 2 files changed, 473 insertions(+), 357 deletions(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 5172cc312..fcb1d0aa7 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,34 @@ +2003-11-19 Neil Jerram + + * gds.el (gds-immediate-display): Removed. + +2003-11-19 Neil Jerram + + * gds.el (gds-update-buffers): Rewrite to only show one view at a + time. + (gds-display-buffers): Remove separate stack buffer display code. + (gds-switch-to-view), gds-view-interaction, gds-view-stack, + gds-view-breakpoints, gds-view-browser, gds-view-messages, + gds-view-menu): New. + (gds-maybe-skip-region): Removed. + (gds-maybe-delete-region): Removed. + (gds-display-types): Removed. + (gds-display-type-regexp): Removed. + (gds-displayed-modules): Removed. + +2003-11-19 Neil Jerram + + * gds.el (gds-views, gds-promote-view, gds-add-view, + gds-delete-view, gds-switch-to-view): New. + (gds-handle-client-input): Use gds-promote-view. + (gds-update-buffers): Remove unnecessary client arg. + (gds-module-notify, gds-handle-client-input): Update callers + accordingly. + (gds-insert-messages): New. + (gds-insert-interaction): New (using code from + gds-update-buffers). + (gds-update-buffers): Use gds-insert-interaction. + 2003-11-17 Rob Browning * .cvsignore: new file. diff --git a/emacs/gds.el b/emacs/gds.el index 5cefd8a06..709c81fd9 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -26,13 +26,6 @@ (require 'scheme) -;;;; Debugging (of this code!). - -(defsubst dmessage (msg &rest args) - ;;(apply (function message) msg args) - ) - - ;;;; Customization group setup. (defgroup gds nil @@ -122,26 +115,21 @@ ;; competing for user attention. ;; ;; - `gds-waiting' holds a list of clients that want attention but -;; haven't yet got it. A client is added to this list for two -;; reasons. (1) When it is blocked waiting for user input. (2) When -;; it first connects to GDS, even if not blocked. +;; haven't yet got it. A client is added to this list for two +;; reasons. (1) When it is blocked waiting for user input. +;; (2) When it first connects to GDS, even if not blocked. ;; ;; - `gds-focus-client' holds the client, if any, that currently has -;; the user's attention. A client can be given the focus if -;; `gds-focus-client' is nil at the time that the client wants -;; attention, or if another client relinquishes it. A client can -;; relinquish the focus in two ways. (1) If the client application -;; says that it is no longer blocked, and a small time passes without -;; it becoming blocked again. (2) If the user explicitly `quits' that -;; client. +;; the user's attention. A client can be given the focus if +;; `gds-focus-client' is nil at the time that the client wants +;; attention, or if another client relinquishes it. A client can +;; relinquish the focus in two ways. (1) If the client application +;; says that it is no longer blocked, and a small time passes without +;; it becoming blocked again. (2) If the user explicitly `quits' +;; that client. (defvar gds-focus-client nil) (defvar gds-waiting nil) -;; Sometimes we want to display a client buffer immediately even if it -;; isn't already in the selected window. To do we this, we bind the -;; following variable to non-nil. -(defvar gds-immediate-display nil) - (defun gds-request-focus (client) (cond ((eq client gds-focus-client) ;; CLIENT already has the focus. Display its buffer. @@ -162,8 +150,7 @@ (not (gds-client-blocked)) (y-or-n-p "Client is blocked and no others are waiting. Still quit? ")) - (let ((gds-immediate-display - (eq (window-buffer (selected-window)) (current-buffer)))) + (progn (bury-buffer (current-buffer)) ;; Pass on the focus. (setq gds-focus-client (car gds-waiting) @@ -176,8 +163,98 @@ (gds-request-focus gds-focus-client))))) +;;;; GDS protocol dispatch. + +;; General dispatch function called by the subprocess filter. +(defun gds-handle-input (form) + (let ((client (car form))) + (or (eq client '*) + (let* ((proc (cadr form)) + (args (cddr form)) + (buf (gds-client-buffer client proc args))) + (if buf (gds-handle-client-input buf client proc args)))))) + +(defun gds-handle-client-input (buf client proc args) + (with-current-buffer buf + (with-current-buffer gds-transcript + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (insert (format "<%S %S %S>" client proc args) "\n"))) + (cond (;; (name ...) - Client name. + (eq proc 'name) + (setq gds-pid (cadr args)) + (gds-promote-view 'interaction) + (gds-request-focus client)) + + (;; (current-module ...) - Current module. + (eq proc 'current-module) + (setq gds-current-module (car args))) + + (;; (stack ...) - Stack at an error or breakpoint. + (eq proc 'stack) + (setq gds-stack args) + (gds-promote-view 'stack)) + + (;; (modules ...) - Application's loaded modules. + (eq proc 'modules) + (while args + (or (assoc (car args) gds-modules) + (setq gds-modules (cons (list (car args)) gds-modules))) + (setq args (cdr args)))) + + (;; (output ...) - Last printed output. + (eq proc 'output) + (setq gds-output (car args)) + (gds-add-view 'messages)) + + (;; (status ...) - Application status indication. + (eq proc 'status) + (setq gds-status (car args)) + (if (eq gds-status 'running) + (gds-delete-view 'browser) + (gds-add-view 'browser)) + (if (eq gds-status 'waiting-for-input) + (progn + (gds-promote-view 'stack) + (gds-update-buffers) + (gds-request-focus client)) + (setq gds-stack nil) + (gds-delete-view 'stack) + (gds-update-buffers-in-a-while))) + + (;; (module MODULE ...) - The specified module's bindings. + (eq proc 'module) + (let ((minfo (assoc (car args) gds-modules))) + (if minfo + (setcdr (cdr minfo) (cdr args))))) + + (;; (closed) - Client has gone away. + (eq proc 'closed) + (setq gds-status 'closed) + (gds-update-buffers) + (setq gds-buffers + (delq (assq client gds-buffers) gds-buffers)) + (if (eq client gds-focus-client) + (gds-quit))) + + (;; (eval-results ...) - Results of evaluation. + (eq proc 'eval-results) + (gds-display-results client args)) + + ((eq proc 'completion-result) + (setq gds-completion-results (or (car args) t))) + + ))) + + ;;;; Per-client buffer state. +;; This section contains code that is specific to each Guile client's +;; buffer but independent of any particular `view'. + +;; Alist mapping each client port number to corresponding buffer. +(defvar gds-buffers nil) + (define-derived-mode gds-mode scheme-mode "Guile Interaction" @@ -187,46 +264,156 @@ "GDS client's port number.") (make-variable-buffer-local 'gds-client) +(defvar gds-status nil + "GDS client's latest status, one of the following symbols. +`running' - Application is running. +`waiting-for-input' - Application is blocked waiting for instruction + from the frontend. +`ready-for-input' - Application is not blocked but can also accept + asynchronous instructions from the frontend.") +(make-variable-buffer-local 'gds-status) + +(defvar gds-transcript nil + "Transcript buffer for this GDS client.") +(make-variable-buffer-local 'gds-transcript) + +;; Return client buffer for specified client and protocol input. +(defun gds-client-buffer (client proc args) + (if (eq proc 'name) + ;; Introduction from client - create a new buffer. + (with-current-buffer (generate-new-buffer (car args)) + (gds-mode) + (setq gds-client client) + (setq gds-transcript + (find-file-noselect + (expand-file-name (concat "~/.gds-transcript-" (car args))))) + (with-current-buffer gds-transcript + (goto-char (point-max)) + (insert "\nTranscript:\n")) + (setq gds-buffers + (cons (cons client (current-buffer)) + gds-buffers)) + (current-buffer)) + ;; Otherwise there should be an existing buffer that we can + ;; return. + (let ((existing (assq client gds-buffers))) + (if (buffer-live-p (cdr existing)) + (cdr existing) + (setq gds-buffers (delq existing gds-buffers)) + (gds-client-buffer client 'name '("(GDS buffer killed)")))))) + +(defun gds-client-blocked () + (eq gds-status 'waiting-for-input)) + +(defvar gds-delayed-update-timer nil) + +(defvar gds-delayed-update-buffers nil) + +(defun gds-update-delayed-update-buffers () + (while gds-delayed-update-buffers + (with-current-buffer (car gds-delayed-update-buffers) + (setq gds-delayed-update-buffers + (cdr gds-delayed-update-buffers)) + (gds-update-buffers)))) + +(defun gds-update-buffers () + (if (timerp gds-delayed-update-timer) + (cancel-timer gds-delayed-update-timer)) + (setq gds-delayed-update-timer nil) + (let ((view (car gds-views)) + (inhibit-read-only t)) + (cond ((eq view 'stack) + (gds-insert-stack)) + ((eq view 'interaction) + (gds-insert-interaction)) + ((eq view 'browser) + (gds-insert-modules)) + ((eq view 'messages) + (gds-insert-messages)) + (t + (error "Bad GDS view %S" view))) + ;; Finish off. + (widget-setup) + (force-mode-line-update t))) + +(defun gds-update-buffers-in-a-while () + (or (memq (current-buffer) gds-delayed-update-buffers) + (setq gds-delayed-update-buffers + (cons (current-buffer) gds-delayed-update-buffers))) + (if (timerp gds-delayed-update-timer) + nil + (setq gds-delayed-update-timer + (run-at-time 0.5 nil (function gds-update-delayed-update-buffers))))) + +(defun gds-display-buffers () + (if gds-focus-client + (let ((gds-focus-buffer (cdr (assq gds-focus-client gds-buffers)))) + ;; If there's already a window showing the buffer, use it. + (let ((window (get-buffer-window gds-focus-buffer t))) + (if window + (progn + (make-frame-visible (window-frame window)) + (select-frame (window-frame window)) + (select-window window)) + ;(select-window (display-buffer gds-focus-buffer)) + (display-buffer gds-focus-buffer))) + ;; If there is an associated source buffer, display it as well. + (if (and (eq (car gds-views) 'stack) + gds-frame-source-overlay + (> (overlay-end gds-frame-source-overlay) 0)) + (let ((window (display-buffer + (overlay-buffer gds-frame-source-overlay)))) + (set-window-point window + (overlay-start gds-frame-source-overlay))))))) + + +;;;; Management of `views'. + +;; The idea here is to keep the buffer describing a Guile client +;; relatively uncluttered by only showing one kind of information +;; about that client at a time. Menu items and key sequences are +;; provided to switch easily between the available views. + +(defvar gds-views nil + "List of available views for a GDS client. Each element is one of +the following symbols. +`interaction' - Interaction with running client. +`stack' - Call stack view. +`browser' - Modules and bindings browser view. +`breakpoints' - List of set breakpoints. +`messages' - Non-GDS-protocol output from the debugger.") +(make-variable-buffer-local 'gds-views) + +(defun gds-promote-view (view) + (setq gds-views (cons view (delq view gds-views)))) + +(defun gds-switch-to-view (view) + (or (memq view gds-views) + (error "View %S is not available" view)) + (gds-promote-view view) + (gds-update-buffers)) + +(defun gds-add-view (view) + (or (memq view gds-views) + (setq gds-views (append gds-views (list view))))) + +(defun gds-delete-view (view) + (setq gds-views (delq view gds-views))) + + +;;;; `Interaction' view. + +;; This view provides interaction with a normally running Guile +;; client, in other words one that is not stopped in the debugger but +;; is still available to take input from GDS (usually via a thread for +;; that purpose). The view supports evaluation, help requests, +;; control of `debug-on-exception' function, and methods for breaking +;; into the running code. + (defvar gds-current-module "()" "GDS client's current module.") (make-variable-buffer-local 'gds-current-module) -(defvar gds-stack nil - "GDS client's stack when last stopped.") -(make-variable-buffer-local 'gds-stack) - -(defvar gds-modules nil - "GDS client's module information. -Alist mapping module names to their symbols and related information. -This looks like: - - (((guile) t sym1 sym2 ...) - ((guile-user)) - ((ice-9 debug) nil sym3 sym4) - ...) - -The `t' or `nil' after the module name indicates whether the module is -displayed in expanded form (that is, showing the bindings in that -module). The syms are actually all strings because some Guile symbols -are not readable by Emacs.") -(make-variable-buffer-local 'gds-modules) - -(defvar gds-output nil - "GDS client's recent output (printed).") -(make-variable-buffer-local 'gds-output) - -(defvar gds-status nil - "GDS client's latest status, one of the following symbols. - -`running' - application is running. - -`waiting-for-input' - application is blocked waiting for instruction -from the frontend. - -`ready-for-input' - application is not blocked but can also accept -asynchronous instructions from the frontend.") -(make-variable-buffer-local 'gds-status) - (defvar gds-pid nil "GDS client's process ID.") (make-variable-buffer-local 'gds-pid) @@ -239,124 +426,36 @@ asynchronous instructions from the frontend.") "The exception keys for which to debug a GDS client.") (make-variable-buffer-local 'gds-exception-keys) -;; Cached display variables for `gds-update-buffers'. -(defvar gds-displayed-modules nil) -(make-variable-buffer-local 'gds-displayed-modules) - -;; Types of display areas in the *Guile* buffer. -(defvar gds-display-types '("\\`" - "^Modules:" - "^Transcript:")) -(defvar gds-display-type-regexp - (concat "\\(" - (substring (apply (function concat) - (mapcar (lambda (type) - (concat "\\|" type)) - gds-display-types)) - 2) - "\\)")) - -(defun gds-maybe-delete-region (regexp) - (let ((beg (save-excursion - (goto-char (point-min)) - (and (re-search-forward regexp nil t) - (match-beginning 0))))) - (if beg - (delete-region beg - (save-excursion - (goto-char beg) - (end-of-line) - (or (and (re-search-forward gds-display-type-regexp - nil t) - (match-beginning 0)) - (point-max))))))) - -(defun gds-maybe-skip-region (regexp) - (if (looking-at regexp) - (if (re-search-forward gds-display-type-regexp nil t 2) - (beginning-of-line) - (goto-char (point-max))))) - -(defun gds-update-buffers (client) - (dmessage "gds-update-buffers") - ;; Avoid continually popping up the last associated source buffer - ;; unless it really is still current. - (setq gds-selected-frame-source-buffer nil) - (set-buffer (cdr (assq client gds-buffers))) - (force-mode-line-update t) - (let ((inhibit-read-only t) - (p (if (eq client gds-focus-client) - (point) - (point-min))) - stack-changed) - ;; Start at top of buffer. - (goto-char (point-min)) - ;; Display status; too simple to be worth caching. - (gds-maybe-delete-region (concat "\\`" (regexp-quote (buffer-name)))) - (widget-insert (buffer-name) - ", " - (cdr (assq gds-status - '((running . "running (cannot accept input)") - (waiting-for-input . "waiting for input") - (ready-for-input . "running") - (closed . "closed")))) - ", in " - gds-current-module - "\n") - (widget-create 'push-button - :notify (function gds-sigint) - "SIGINT") - (widget-insert " ") - (widget-create 'push-button - :notify (function gds-async-break) - "Break") - (widget-insert "\n") - (widget-create 'checkbox - :notify (function gds-toggle-debug-exceptions) - gds-debug-exceptions) - (widget-insert " Debug exception keys: ") - (widget-create 'editable-field - :notify (function gds-set-exception-keys) - gds-exception-keys) - (widget-insert "\n") -; (widget-insert "\n\n") -; (if (> (length gds-output) 0) -; (widget-insert gds-output "\n\n")) - ;; Display stack. - (dmessage "insert stack") - (let ((stack gds-stack) - (buf (get-buffer-create (concat (buffer-name) " - stack")))) - (with-current-buffer buf - (if (equal stack gds-stack) - ;; No change needed. - nil - (erase-buffer) - (gds-mode) - ;; Insert new stack. - (if stack (gds-insert-stack stack)) - ;; Record displayed stack. - (setq gds-stack stack)))) - ;; Display module list. - (dmessage "insert modules") - (if (equal gds-modules gds-displayed-modules) - (gds-maybe-skip-region "^Modules:") - ;; Delete existing module list. - (gds-maybe-delete-region "^Modules:") - ;; Insert new list. - (if gds-modules (gds-insert-modules gds-modules)) - ;; Record displayed list. - (setq gds-displayed-modules (copy-tree gds-modules))) - ;; Finish off. - (dmessage "widget-setup") - (widget-setup) - (if stack-changed - ;; Stack is being seen for the first time, so make sure top of - ;; buffer is visible. - (progn - (goto-char (point-min)) - (forward-line (+ 1 (cadr gds-stack)))) - ;; Restore point from before buffer was redrawn. - (goto-char p)))) +(defun gds-insert-interaction () + (erase-buffer) + ;; Insert stuff for interacting with a running (non-blocked) Guile + ;; client. + (widget-insert (buffer-name) + ", " + (cdr (assq gds-status + '((running . "running (cannot accept input)") + (waiting-for-input . "waiting for input") + (ready-for-input . "running") + (closed . "closed")))) + ", in " + gds-current-module + "\n") + (widget-create 'push-button + :notify (function gds-sigint) + "SIGINT") + (widget-insert " ") + (widget-create 'push-button + :notify (function gds-async-break) + "Break") + (widget-insert "\n") + (widget-create 'checkbox + :notify (function gds-toggle-debug-exceptions) + gds-debug-exceptions) + (widget-insert " Debug exception keys: ") + (widget-create 'editable-field + :notify (function gds-set-exception-keys) + gds-exception-keys) + (widget-insert "\n")) (defun gds-sigint (w &rest ignore) (interactive) @@ -378,36 +477,25 @@ asynchronous instructions from the frontend.") (interactive) (setq gds-exception-keys (widget-value w))) -(defun gds-display-buffers () - (if gds-focus-client - (let ((gds-focus-buffer (cdr (assq gds-focus-client gds-buffers)))) - ;; If there's already a window showing the buffer, use it. - (let ((window (get-buffer-window gds-focus-buffer t))) - (if window - (progn - (make-frame-visible (window-frame window)) - (select-frame (window-frame window)) - (select-window window)) - ;(select-window (display-buffer gds-focus-buffer)) - (display-buffer gds-focus-buffer))) - ;; If there is an associated source buffer, display it as well. - (if gds-selected-frame-source-buffer - (let ((window (display-buffer gds-selected-frame-source-buffer))) - (set-window-point window - (overlay-start - gds-selected-frame-source-overlay)))) - ;; If there is a stack to display, display it. - (if gds-stack - (let ((buf (get-buffer (concat (buffer-name) " - stack")))) - (if (get-buffer-window buf) - nil - (split-window) - (set-window-buffer (selected-window) buf))))))) +(defun gds-view-interaction () + (interactive) + (gds-switch-to-view 'interaction)) -(defun gds-insert-stack (stack) - (let ((frames (car stack)) - (index (cadr stack)) - (flags (caddr stack)) + +;;;; `Stack' view. + +;; This view shows the Guile call stack after the application has hit +;; an error, or when it is stopped in the debugger. + +(defvar gds-stack nil + "GDS client's stack when last stopped.") +(make-variable-buffer-local 'gds-stack) + +(defun gds-insert-stack () + (erase-buffer) + (let ((frames (car gds-stack)) + (index (cadr gds-stack)) + (flags (caddr gds-stack)) frame items) (cond ((memq 'application flags) (widget-insert "Calling procedure:\n")) @@ -436,7 +524,8 @@ asynchronous instructions from the frontend.") :value (cadr (nth index items)) :notify (function gds-select-stack-frame) items) - (widget-insert "\n"))) + (widget-insert "\n") + (goto-char (point-min)))) (defun gds-select-stack-frame (widget &rest ignored) (let* ((s (widget-value widget)) @@ -447,27 +536,24 @@ asynchronous instructions from the frontend.") ;; Overlay used to highlight the source expression corresponding to ;; the selected frame. -(defvar gds-selected-frame-source-overlay nil) - -;; Buffer containing source for the selected frame. -(defvar gds-selected-frame-source-buffer nil) +(defvar gds-frame-source-overlay nil) (defun gds-show-selected-frame (source) ;; Highlight the frame source, if possible. (if (and source (file-readable-p (car source))) (with-current-buffer (find-file-noselect (car source)) - (if gds-selected-frame-source-overlay + (if gds-frame-source-overlay nil - (setq gds-selected-frame-source-overlay (make-overlay 0 0)) - (overlay-put gds-selected-frame-source-overlay 'face 'highlight)) + (setq gds-frame-source-overlay (make-overlay 0 0)) + (overlay-put gds-frame-source-overlay 'face 'highlight)) ;; Move to source line. Note that Guile line numbering is ;; 0-based, while Emacs numbering is 1-based. (save-restriction (widen) (goto-line (+ (cadr source) 1)) (move-to-column (caddr source)) - (move-overlay gds-selected-frame-source-overlay + (move-overlay gds-frame-source-overlay (point) (if (not (looking-at ")")) (save-excursion (forward-sexp 1) (point)) @@ -476,10 +562,27 @@ asynchronous instructions from the frontend.") ;; the sexp rather than the beginning... (save-excursion (forward-char 1) (backward-sexp 1) (point))) - (current-buffer))) - (setq gds-selected-frame-source-buffer (current-buffer))) - (if gds-selected-frame-source-overlay - (move-overlay gds-selected-frame-source-overlay 0 0)))) + (current-buffer)))) + (if gds-frame-source-overlay + (move-overlay gds-frame-source-overlay 0 0)))) + +(defun gds-view-stack () + (interactive) + (gds-switch-to-view 'stack)) + + +;;;; `Breakpoints' view. + +;; This view shows a list of breakpoints. + +(defun gds-view-breakpoints () + (interactive) + (gds-switch-to-view 'breakpoints)) + + +;;;; `Browser' view. + +;; This view shows a list of modules and module bindings. (defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil)) "Specification of which Guile modules the debugger should display. @@ -510,25 +613,47 @@ not of primary interest when debugging application code." (gds-show-module-p (cdr name))) default)))) -(defun gds-insert-modules (modules) - (insert "Modules:\n") - (while modules - (let ((minfo (car modules))) - (if (gds-show-module-p (car minfo)) - (let ((w (widget-create 'push-button - :notify (function gds-module-notify) - (if (and (cdr minfo) - (cadr minfo)) - "-" "+")))) - (widget-put w :module (cons client (car minfo))) - (widget-insert " " (prin1-to-string (car minfo)) "\n") - (if (cadr minfo) - (let ((syms (cddr minfo))) - (while syms - (widget-insert " > " (car syms) "\n") - (setq syms (cdr syms)))))))) - (setq modules (cdr modules))) - (insert "\n")) +(defvar gds-modules nil + "GDS client's module information. +Alist mapping module names to their symbols and related information. +This looks like: + + (((guile) t sym1 sym2 ...) + ((guile-user)) + ((ice-9 debug) nil sym3 sym4) + ...) + +The `t' or `nil' after the module name indicates whether the module is +displayed in expanded form (that is, showing the bindings in that +module). The syms are actually all strings because some Guile symbols +are not readable by Emacs.") +(make-variable-buffer-local 'gds-modules) + +(defun gds-insert-modules () + (let ((p (if (eq (window-buffer (selected-window)) (current-buffer)) + (point) + (point-min))) + (modules gds-modules)) + (erase-buffer) + (insert "Modules:\n") + (while modules + (let ((minfo (car modules))) + (if (gds-show-module-p (car minfo)) + (let ((w (widget-create 'push-button + :notify (function gds-module-notify) + (if (and (cdr minfo) + (cadr minfo)) + "-" "+")))) + (widget-put w :module (cons gds-client (car minfo))) + (widget-insert " " (prin1-to-string (car minfo)) "\n") + (if (cadr minfo) + (let ((syms (cddr minfo))) + (while syms + (widget-insert " > " (car syms) "\n") + (setq syms (cdr syms)))))))) + (setq modules (cdr modules))) + (insert "\n") + (goto-char p))) (defun gds-module-notify (w &rest ignore) (let* ((module (widget-get w :module)) @@ -539,7 +664,7 @@ not of primary interest when debugging application code." ;; Just toggle expansion state. (progn (setcar (cdr minfo) (not (cadr minfo))) - (gds-update-buffers client)) + (gds-update-buffers)) ;; Set flag to indicate module expanded. (setcdr minfo (list t)) ;; Get symlist from Guile. @@ -549,125 +674,35 @@ not of primary interest when debugging application code." (interactive) (gds-send (format "(%S query-modules)\n" gds-focus-client))) - -;;;; Handling debugging instructions. - -;; Alist mapping each client port number to corresponding buffer. -(defvar gds-buffers nil) - -;; Return client buffer for specified client and protocol input. -(defun gds-client-buffer (client proc args) - (if (eq proc 'name) - ;; Introduction from client - create a new buffer. - (with-current-buffer (generate-new-buffer (car args)) - (gds-mode) - (insert "Transcript:\n") - (setq gds-buffers - (cons (cons client (current-buffer)) - gds-buffers)) - (current-buffer)) - ;; Otherwise there should be an existing buffer that we can - ;; return. - (let ((existing (assq client gds-buffers))) - (if (buffer-live-p (cdr existing)) - (cdr existing) - (setq gds-buffers (delq existing gds-buffers)) - (gds-client-buffer client 'name '("(GDS buffer killed)")))))) - -;; General dispatch function called by the subprocess filter. -(defun gds-handle-input (form) - (dmessage "Form: %S" form) - (let ((client (car form))) - (or (eq client '*) - (let* ((proc (cadr form)) - (args (cddr form)) - (buf (gds-client-buffer client proc args))) - (if buf (gds-handle-client-input buf client proc args)))))) - -(defun gds-handle-client-input (buf client proc args) - (with-current-buffer buf - (save-excursion - (goto-char (point-max)) - (let ((inhibit-read-only t)) - (insert (format "<%S %S %S>" client proc args) "\n"))) - (dmessage "Buffer: %S" (current-buffer)) - (cond (;; (name ...) - Client name. - (eq proc 'name) - (setq gds-pid (cadr args)) - (gds-request-focus client)) - - (;; (current-module ...) - Current module. - (eq proc 'current-module) - (setq gds-current-module (car args)) - (dmessage "Current module: %S" gds-current-module)) - - (;; (stack ...) - Stack at an error or breakpoint. - (eq proc 'stack) - (setq gds-stack args)) - - (;; (modules ...) - Application's loaded modules. - (eq proc 'modules) - (while args - (or (assoc (car args) gds-modules) - (setq gds-modules (cons (list (car args)) gds-modules))) - (setq args (cdr args)))) - - (;; (output ...) - Last printed output. - (eq proc 'output) - (setq gds-output (car args))) - - (;; (status ...) - Application status indication. - (eq proc 'status) - (setq gds-status (car args)) - (or (eq gds-status 'waiting-for-input) - (setq gds-stack nil)) - (gds-update-buffers client) - (if (eq gds-status 'waiting-for-input) - (gds-request-focus client) - (setq gds-stack nil))) - - (;; (module MODULE ...) - The specified module's bindings. - (eq proc 'module) - (let ((minfo (assoc (car args) gds-modules))) - (if minfo - (setcdr (cdr minfo) (cdr args))))) - - (;; (closed) - Client has gone away. - (eq proc 'closed) - (setq gds-status 'closed) - (gds-update-buffers client) - (setq gds-buffers - (delq (assq client gds-buffers) gds-buffers)) - (if (eq client gds-focus-client) - (gds-quit))) - - (;; (eval-results ...) - Results of evaluation. - (eq proc 'eval-results) - (gds-display-results client args)) - - ((eq proc 'completion-result) - (setq gds-completion-results (or (car args) t))) - - ))) +(defun gds-view-browser () + (interactive) + (or gds-modules (gds-query-modules)) + (gds-switch-to-view 'browser)) -;;;; Guile Debugging keymap. +;;;; `Messages' view. -(set-keymap-parent gds-mode-map widget-keymap) -(define-key gds-mode-map "g" (function gds-go)) -(define-key gds-mode-map "b" (function gds-set-breakpoint)) -(define-key gds-mode-map "q" (function gds-quit)) -(define-key gds-mode-map " " (function gds-next)) -(define-key gds-mode-map "e" (function gds-evaluate)) -(define-key gds-mode-map "i" (function gds-step-in)) -(define-key gds-mode-map "o" (function gds-step-out)) -(define-key gds-mode-map "t" (function gds-trace-finish)) -(define-key gds-mode-map "I" (function gds-frame-info)) -(define-key gds-mode-map "A" (function gds-frame-args)) -(define-key gds-mode-map "M" (function gds-query-modules)) +;; This view shows recent non-GDS-protocol messages output from the +;; (ice-9 debugger) code. -(defun gds-client-blocked () - (eq gds-status 'waiting-for-input)) +(defvar gds-output nil + "GDS client's recent output (printed).") +(make-variable-buffer-local 'gds-output) + +(defun gds-insert-messages () + (erase-buffer) + ;; Insert recent non-protocol output from (ice-9 debugger). + (insert gds-output) + (goto-char (point-min))) + +(defun gds-view-messages () + (interactive) + (gds-switch-to-view 'messages)) + + +;;;; Debugger commands. + +;; Typically but not necessarily used from the `stack' view. (defun gds-go () (interactive) @@ -704,6 +739,9 @@ not of primary interest when debugging application code." (interactive) (gds-send (format "(%S debugger-command info-args)\n" gds-focus-client))) + +;;;; Setting breakpoints. + (defun gds-set-breakpoint () (interactive) (cond ((gds-in-source-buffer) @@ -1025,7 +1063,9 @@ Used for determining the default for the next `gds-load-file'.") (setq client (gds-choose-client client)) (gds-send (format "(%S load %S)\n" client file-name))) -;; Install the process communication commands in the scheme-mode keymap. + +;;;; Scheme mode keymap items. + (define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention (define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention (define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression) @@ -1036,7 +1076,50 @@ Used for determining the default for the next `gds-load-file'.") (define-key scheme-mode-map "\e\t" 'gds-complete-symbol) -;;;; Menu bar entries. +;;;; GDS (Guile Interaction) mode keymap and menu items. + +(set-keymap-parent gds-mode-map widget-keymap) + +(define-key gds-mode-map "M" (function gds-query-modules)) + +(define-key gds-mode-map "g" (function gds-go)) +(define-key gds-mode-map "q" (function gds-quit)) +(define-key gds-mode-map " " (function gds-next)) +(define-key gds-mode-map "e" (function gds-evaluate)) +(define-key gds-mode-map "i" (function gds-step-in)) +(define-key gds-mode-map "o" (function gds-step-out)) +(define-key gds-mode-map "t" (function gds-trace-finish)) +(define-key gds-mode-map "I" (function gds-frame-info)) +(define-key gds-mode-map "A" (function gds-frame-args)) + +(define-key gds-mode-map "b" (function gds-set-breakpoint)) + +(define-key gds-mode-map "vi" (function gds-view-interaction)) +(define-key gds-mode-map "vs" (function gds-view-stack)) +(define-key gds-mode-map "vb" (function gds-view-breakpoints)) +(define-key gds-mode-map "vB" (function gds-view-browser)) +(define-key gds-mode-map "vm" (function gds-view-messages)) + +(defvar gds-view-menu nil + "GDS view menu.") +(if gds-view-menu + nil + (setq gds-view-menu (make-sparse-keymap "View")) + (define-key gds-view-menu [messages] + '(menu-item "Messages" gds-view-messages + :enable (memq 'messages gds-views))) + (define-key gds-view-menu [browser] + '(menu-item "Browser" gds-view-browser + :enable (memq 'browser gds-views))) + (define-key gds-view-menu [breakpoints] + '(menu-item "Breakpoints" gds-view-breakpoints + :enable (memq 'breakpoints gds-views))) + (define-key gds-view-menu [stack] + '(menu-item "Stack" gds-view-stack + :enable (memq 'stack gds-views))) + (define-key gds-view-menu [interaction] + '(menu-item "Interaction" gds-view-interaction + :enable (memq 'interaction gds-views)))) (defvar gds-debug-menu nil "GDS debugging menu.") @@ -1106,6 +1189,8 @@ Used for determining the default for the next `gds-load-file'.") (cons "Advanced" gds-advanced-menu)) (define-key gds-menu [separator-1] '("--")) + (define-key gds-menu [view] + `(menu-item "View" ,gds-view-menu :enable gds-views)) (define-key gds-menu [debug] `(menu-item "Debug" ,gds-debug-menu :enable (and gds-focus-client (gds-client-blocked)))) From 0f8b558cbc7fca3234d6f25e66490fc1e9254a41 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 19 Nov 2003 01:27:31 +0000 Subject: [PATCH 142/239] Work in progress. --- emacs/ChangeLog | 5 +++++ emacs/gds-client.scm | 39 ++++++++++++++++++++++++++++++--------- 2 files changed, 35 insertions(+), 9 deletions(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index fcb1d0aa7..9ba7a77ae 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,5 +1,10 @@ 2003-11-19 Neil Jerram + * gds-client.scm (start-async-gds-thread): Changes to fix + interaction between async and debugger threads. + (gds-connect): Don't send module list immediately after initial + connection. + * gds.el (gds-immediate-display): Removed. 2003-11-19 Neil Jerram diff --git a/emacs/gds-client.scm b/emacs/gds-client.scm index a560a2cd1..f4101189c 100644 --- a/emacs/gds-client.scm +++ b/emacs/gds-client.scm @@ -67,7 +67,7 @@ decimal IP address where the UI server is running; default is "w")) ;; Write initial context to debug server. (write-form (list 'name name (getpid))) - (write-form (cons 'modules (map module-name (loaded-modules)))) + ;(write-form (cons 'modules (map module-name (loaded-modules)))) ;; Start the asynchronous UI thread. (start-async-gds-thread) ;; If `debug' is true, debug immediately. @@ -87,33 +87,43 @@ decimal IP address where the UI server is running; default is ;; Start the asynchronous UI thread. (begin-thread (set! async-gds-thread (current-thread)) - (lock-mutex mutex) ;;(write (cons admin gds-port)) ;;(newline) + (lock-mutex mutex) (catch 'server-died (lambda () (let loop ((avail '())) + (write-note 'startloop) ;;(write avail) ;;(newline) (cond ((not gds-port)) ; exit loop ((null? avail) (write-status 'ready-for-input) - (loop (car (select (list gds-port (car admin)) - '() '())))) + (unlock-mutex mutex) + (let ((ports (car (select (list gds-port (car admin)) + '() '())))) + (lock-mutex mutex) + (loop ports))) (else + (write-note 'sthg-to-read) (let ((port (car avail))) (if (eq? port gds-port) (handle-instruction #f (read gds-port)) (begin + (write-note 'debugger-takeover) ;; Notification from debugger that it ;; wants to take over. Read the ;; notification char. (read-char (car admin)) ;; Wait on condition variable - this allows the ;; debugger thread to grab the mutex. - (wait-condition-variable condition mutex))) + (write-note 'cond-wait) + (signal-condition-variable condition) + (wait-condition-variable condition mutex) + )) ;; Loop. - (loop (cdr avail))))))) + (loop '())))) + (write-note 'loopexited))) (lambda args #f)) (set! gds-disable-async-thread noop) (set! gds-continue-async-thread noop) @@ -122,15 +132,22 @@ decimal IP address where the UI server is running; default is ;; Redefine procs used by debugger thread to take control. (set! gds-disable-async-thread (lambda () + (lock-mutex mutex) (write-char #\x (cdr admin)) (force-output (cdr admin)) + (write-note 'char-written) + (wait-condition-variable condition mutex) ;;(display "gds-disable-async-thread: locking mutex...\n" ;; (current-error-port)) - (lock-mutex mutex))) + )) (set! gds-continue-async-thread (lambda () - (unlock-mutex mutex) - (signal-condition-variable condition))))) + (write-note 'cond-signal) + (signal-condition-variable condition) + ;; Make sure that the async thread has got the message + ;; before we could possibly try to grab the main mutex + ;; again. + (unlock-mutex mutex))))) (define accumulated-output '()) @@ -195,6 +212,10 @@ decimal IP address where the UI server is running; default is (newline gds-port) (force-output gds-port)) +(define (write-note note) + ;; Write a note (for debugging this code) to UI frontend. + (false-if-exception (write-form `(note ,note)))) + (define (stack->emacs-readable stack) ;; Return Emacs-readable representation of STACK. (map (lambda (index) From d8592269ab976774c02b742b5da9cfcfa12a5860 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Nov 2003 02:19:03 +0000 Subject: [PATCH 143/239] (mem2decimal_from_point): use scm_divide instead of scm_divide2real when forming the fractional part. This allows "#e1.2" to yield 6/5. --- libguile/numbers.c | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 311caf791..43a49c622 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2325,7 +2325,7 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, result = scm_sum (result, SCM_MAKINUM (add)); } - result = scm_divide2real (result, big_shift); + result = scm_divide (result, big_shift); /* We've seen a decimal point, thus the value is implicitly inexact. */ x = INEXACT; @@ -2438,8 +2438,8 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, { enum t_exactness x = EXACT; - /* Cobble up the fraction. We might want to set the NaN's - mantissa from it. */ + /* Cobble up the fractional part. We might want to set the + NaN's mantissa from it. */ idx += 4; mem2uinteger (mem, len, &idx, 10, &x); *p_idx = idx; @@ -2714,7 +2714,6 @@ scm_i_mem2number (const char* mem, size_t len, unsigned int default_radix) { case EXACT: if (SCM_INEXACTP (result)) - /* FIXME: This may change the value. */ return scm_inexact_to_exact (result); else return result; @@ -2755,8 +2754,8 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, SCM_VALIDATE_STRING (1, string); SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix,2,10, base); answer = scm_i_mem2number (SCM_STRING_CHARS (string), - SCM_STRING_LENGTH (string), - base); + SCM_STRING_LENGTH (string), + base); return scm_return_first (answer, string); } #undef FUNC_NAME From eb927cb95c332ad37b63426b49a93cf0c32995d9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Nov 2003 02:38:37 +0000 Subject: [PATCH 144/239] * numbers.c (scm_exact_p, scm_inexact_p): Throw error for non-numbers. --- libguile/numbers.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 43a49c622..4653621d9 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -442,7 +442,9 @@ SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, return SCM_BOOL_T; if (SCM_FRACTIONP (x)) return SCM_BOOL_T; - return SCM_BOOL_F; + if (SCM_NUMBERP (x)) + return SCM_BOOL_F; + SCM_WRONG_TYPE_ARG (1, x); } #undef FUNC_NAME @@ -2912,7 +2914,11 @@ SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0, "else.") #define FUNC_NAME s_scm_inexact_p { - return SCM_BOOL (SCM_INEXACTP (x)); + if (SCM_INEXACTP (x)) + return SCM_BOOL_T; + if (SCM_NUMBERP (x)) + return SCM_BOOL_F; + SCM_WRONG_TYPE_ARG (1, x); } #undef FUNC_NAME From 02164269a7167b111dd5cc7c3c1da6063b2fa833 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Nov 2003 03:50:26 +0000 Subject: [PATCH 145/239] * numbers.c (scm_i_fraction_equalp): Do not treat the return value of scm_equal_p as a C boolean, use SCM_FALSEP. Previously, all fractions were equal to each other regardless of value. Ooops. * numbers.c (scm_rationalize): Return an inexact result when given inexact arguments. --- libguile/numbers.c | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 4653621d9..fad644165 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2819,8 +2819,13 @@ scm_i_fraction_equalp (SCM x, SCM y) { scm_i_fraction_reduce (x); scm_i_fraction_reduce (y); - return SCM_BOOL (scm_equal_p (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_NUMERATOR (y)) - && scm_equal_p (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y))); + if (SCM_FALSEP (scm_equal_p (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_NUMERATOR (y))) + || SCM_FALSEP (scm_equal_p (SCM_FRACTION_DENOMINATOR (x), + SCM_FRACTION_DENOMINATOR (y)))) + return SCM_BOOL_F; + else + return SCM_BOOL_T; } @@ -5217,7 +5222,14 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, SCM_FALSEP (scm_gr_p (scm_abs (scm_difference (ex, scm_divide (a, b))), err))) /* abs(x-a/b) <= err */ - return scm_sum (int_part, scm_divide (a, b)); /* int_part+a/b */ + { + SCM res = scm_sum (int_part, scm_divide (a, b)); + if (SCM_FALSEP (scm_exact_p (x)) + || SCM_FALSEP (scm_exact_p (err))) + return scm_exact_to_inexact (res); + else + return res; + } rx = scm_divide (scm_difference (rx, tt), /* rx = 1/(rx - tt) */ SCM_UNDEFINED); tt = scm_floor (rx); /* tt = floor (rx) */ From 4bca30d83a58ab3c89ce3c31857beb66c5197513 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Nov 2003 03:51:21 +0000 Subject: [PATCH 146/239] *** empty log message *** --- libguile/ChangeLog | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 970c227e2..27f23965e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2003-11-19 Marius Vollmer + + * numbers.c (mem2decimal_from_point): use scm_divide instead of + scm_divide2real when forming the fractional part. This allows + "#e1.2" to yield 6/5. + + * numbers.c (scm_i_fraction_equalp): Do not treat the return value + of scm_equal_p as a C boolean, use SCM_FALSEP. Previously, all + fractions were equal to each other regardless of value. Ooops. + + * numbers.c (scm_rationalize): Return an inexact result when given + inexact arguments. + + * numbers.c (scm_exact_p, scm_inexact_p): Throw error for + non-numbers. + 2003-11-18 Marius Vollmer Support for exact fractions from Bill Schottstaedt! Thanks! From 0b0c8e3b4c5e4706ea3d4bc87670dbfb114101a5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Nov 2003 04:30:40 +0000 Subject: [PATCH 147/239] * numbers.c (scm_make_ratio): Don't declare divisible_p after statements. --- libguile/numbers.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index fad644165..a01464425 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -392,11 +392,13 @@ scm_make_ratio (SCM numerator, SCM denominator) /* both are bignums */ if (SCM_EQ_P (numerator, denominator)) return SCM_MAKINUM(1); - int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (numerator), - SCM_I_BIG_MPZ (denominator)); - if (divisible_p) + if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator), + SCM_I_BIG_MPZ (denominator))) return scm_divide(numerator, denominator); - else return scm_double_cell (scm_tc16_fraction, (scm_t_bits)numerator, (scm_t_bits)denominator, 0); + else + return scm_double_cell (scm_tc16_fraction, + (scm_t_bits)numerator, + (scm_t_bits)denominator, 0); } } else SCM_WRONG_TYPE_ARG (1, numerator); From c60e130c97f9f03da85762fc3db971d59067cfde Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Nov 2003 05:12:08 +0000 Subject: [PATCH 148/239] * numbers.c (scm_make_ratio): Rewritten to have a simpler structure. Previously, not all cases with a negative denominator were covered. --- libguile/numbers.c | 90 ++++++++++++++++++++-------------------------- 1 file changed, 39 insertions(+), 51 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index a01464425..df544654f 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -325,11 +325,10 @@ static SCM scm_divide2real (SCM x, SCM y); SCM scm_make_ratio (SCM numerator, SCM denominator) +#define FUNC_NAME "make-ratio" { -#if 0 - return scm_divide2real(numerator, denominator); -#else - #define FUNC_NAME "make-ratio" + /* First make sure the arguments are proper. + */ if (SCM_INUMP (denominator)) { if (SCM_EQ_P (denominator, SCM_INUM0)) @@ -342,6 +341,20 @@ scm_make_ratio (SCM numerator, SCM denominator) if (!(SCM_BIGP(denominator))) SCM_WRONG_TYPE_ARG (2, denominator); } + if (!SCM_INUMP (numerator) && !SCM_BIGP (numerator)) + SCM_WRONG_TYPE_ARG (1, numerator); + + /* Then flip signs so that the denominator is positive. + */ + if (SCM_NFALSEP (scm_negative_p (denominator))) + { + numerator = scm_difference (numerator, SCM_UNDEFINED); + denominator = scm_difference (denominator, SCM_UNDEFINED); + } + + /* Now consider for each of the four fixnum/bignum combinations + whether the rational number is really an integer. + */ if (SCM_INUMP (numerator)) { if (SCM_EQ_P (numerator, SCM_INUM0)) @@ -355,58 +368,33 @@ scm_make_ratio (SCM numerator, SCM denominator) return SCM_MAKINUM(1); if ((x % y) == 0) return SCM_MAKINUM (x / y); - if (y < 0) - return scm_double_cell (scm_tc16_fraction, (scm_t_bits)SCM_MAKINUM(-x), (scm_t_bits)SCM_MAKINUM(-y), 0); - else return scm_double_cell (scm_tc16_fraction, (scm_t_bits)numerator, (scm_t_bits)denominator, 0); + } + } + else if (SCM_BIGP (numerator)) + { + if (SCM_INUMP (denominator)) + { + long yy = SCM_INUM (denominator); + if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy)) + return scm_divide (numerator, denominator); } else { - /* I assume bignums are actually big, so here there's no point in looking for a integer */ - int sgn = mpz_sgn (SCM_I_BIG_MPZ (denominator)); - if (sgn < 0) /* if denominator negative, flip signs */ - return scm_double_cell (scm_tc16_fraction, - (scm_t_bits)scm_difference (numerator, SCM_UNDEFINED), - (scm_t_bits)scm_difference (denominator, SCM_UNDEFINED), - 0); - else return scm_double_cell (scm_tc16_fraction, (scm_t_bits)numerator, (scm_t_bits)denominator, 0); + if (SCM_EQ_P (numerator, denominator)) + return SCM_MAKINUM(1); + if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator), + SCM_I_BIG_MPZ (denominator))) + return scm_divide(numerator, denominator); + } + } - /* should this use SCM_UNPACK for the bignums? */ - } - } - else - { - if (SCM_BIGP (numerator)) - { - /* can't use scm_divide to find integer here */ - if (SCM_INUMP (denominator)) - { - long yy = SCM_INUM (denominator); - long abs_yy = yy < 0 ? -yy : yy; - int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), abs_yy); - if (divisible_p) - return scm_divide(numerator, denominator); - else return scm_double_cell (scm_tc16_fraction, (scm_t_bits)numerator, (scm_t_bits)denominator, 0); - } - else - { - /* both are bignums */ - if (SCM_EQ_P (numerator, denominator)) - return SCM_MAKINUM(1); - if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator), - SCM_I_BIG_MPZ (denominator))) - return scm_divide(numerator, denominator); - else - return scm_double_cell (scm_tc16_fraction, - (scm_t_bits)numerator, - (scm_t_bits)denominator, 0); - } - } - else SCM_WRONG_TYPE_ARG (1, numerator); - } - return SCM_BOOL_F; /* won't happen */ - #undef FUNC_NAME -#endif + /* No, it's a proper fraction. + */ + return scm_double_cell (scm_tc16_fraction, + SCM_UNPACK (numerator), + SCM_UNPACK (denominator), 0); } +#undef FUNC_NAME static void scm_i_fraction_reduce (SCM z) { From fb16d26e2330e49b5afacaaff029b53bd1c64775 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Nov 2003 05:13:53 +0000 Subject: [PATCH 149/239] *** empty log message *** --- NEWS | 5 ++++- libguile/ChangeLog | 4 ++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 4c697aac1..eda213135 100644 --- a/NEWS +++ b/NEWS @@ -485,9 +485,12 @@ When you want the old behavior, use 'round' explicitely: This function finds a simple fraction that is close to a given real number. For example (and compare with inexact->exact above): - (rationalize 1.234 0.0005) + (rationalize (inexact->exact 1.234) 1/2000) => 58/47 +Note that, as required by R5RS, rationalize returns only then an exact +result when both its arguments are exact. + ** 'odd?' and 'even?' work also for inexact integers. Previously, (odd? 1.0) would signal an error since only exact integers diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 27f23965e..7c73c47e1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,9 @@ 2003-11-19 Marius Vollmer + * numbers.c (scm_make_ratio): Rewritten to have a simpler + structure. Previously, not all cases with a negative denominator + were covered. + * numbers.c (mem2decimal_from_point): use scm_divide instead of scm_divide2real when forming the fractional part. This allows "#e1.2" to yield 6/5. From c1f1071afcd05c132ba0bfa849632df135c483b9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Nov 2003 05:15:51 +0000 Subject: [PATCH 150/239] Changed to reflect the fact that rationalize only returns an exact result for exact arguments. Fixed bugs in tests that were not caught previously since all fraction were treated as equal regardless of value. --- test-suite/tests/fractions.test | 44 +++++++++++++++------------------ 1 file changed, 20 insertions(+), 24 deletions(-) diff --git a/test-suite/tests/fractions.test b/test-suite/tests/fractions.test index 2e7e05e8c..90320f247 100644 --- a/test-suite/tests/fractions.test +++ b/test-suite/tests/fractions.test @@ -124,30 +124,26 @@ (testeqv (abs 101/17452826108659293487) 101/17452826108659293487) (testeqv (abs -101/17452826108659293487) 101/17452826108659293487) (testeqv (exact->inexact 3/4) .75) - (testeqv (inexact->exact .3) 3/10) - (testeqv (inexact->exact -.3) -3/10) - (testeqv (inexact->exact .33) 33/10) - (testeq (< (- (exact->inexact 10197734562406803221/17452826108659293487) .584302765576009) .0000001) #t) - (testeqv (rationalize .76 .1) 3/4) - (testeqv (rationalize .723 .1) 2/3) - (testeqv (rationalize .723 .01) 5/7) - (testeqv (rationalize -.723 .01) -5/7) - (testeqv (rationalize 10.2 .01) 51/5) - (testeqv (rationalize -10.2 .01) -51/5) - (testeqv (rationalize 10197734562406803221/17452826108659293487 .1) 1/2) - (testeqv (rationalize 10197734562406803221/17452826108659293487 .01) 7/12) - (testeqv (rationalize 10197734562406803221/17452826108659293487 .001) 7/12) - (testeqv (rationalize 10197734562406803221/17452826108659293487 .0001) 52/89) + (testeqv (inexact->exact .5) 1/2) + (testeqv (inexact->exact -.5) -1/2) + (testeqv (inexact->exact (exact->inexact 2135445/16777216)) 2135445/16777216) + (testeq (< (- (exact->inexact 10197734562406803221/17452826108659293487) + .584302765576009) .0000001) #t) + (testeqv (rationalize #e0.76 1/10) 3/4) + (testeqv (rationalize #e0.723 1/10) 2/3) + (testeqv (rationalize #e0.723 1/100) 5/7) + (testeqv (rationalize #e-0.723 1/100) -5/7) + (testeqv (rationalize #e10.2 1/100) 51/5) + (testeqv (rationalize #e-10.2 1/100) -51/5) + (testeqv (rationalize 10197734562406803221/17452826108659293487 1/10) 1/2) + (testeqv (rationalize 10197734562406803221/17452826108659293487 1/100) 7/12) + (testeqv (rationalize 10197734562406803221/17452826108659293487 1/1000) 7/12) + (testeqv (rationalize 10197734562406803221/17452826108659293487 1/10000) 52/89) (testeqv (rationalize 3/10 1/10) 1/3) (testeqv (rationalize 3/10 -1/10) 1/3) (testeqv (rationalize -3/10 1/10) -1/3) (testeqv (rationalize -3/10 -1/10) -1/3) (testeqv (rationalize 3/10 4/10) 0) - (testeqv (rationalize .3 4/10) 0) - (testeqv (rationalize .3 0.0) 3/10) - (testeqv (rationalize -.3 0.0) -3/10) - (testeqv (rationalize .12345 0.0) 2469/2000) - (testeqv (rationalize 10.3 0.0) 103/10) (testeq (exact? #i2/3) #f) (testeq (exact? -15/16) #t) (testeq (exact? (/ 2 3)) #t) @@ -178,7 +174,7 @@ (testeqv (+ 1 1/4 1/3) 19/12) (testeqv (* 3/5 1/6 3) 3/10) (testeqv 0/3 0) - (testeqv (1- 1/2) 1/2) + (testeqv (1- 1/2) -1/2) (testeqv (1+ 1/2) 3/2) (testeq (zero? 3/4) #f) (testeq (zero? 0/4) #t) @@ -217,7 +213,7 @@ (testeqv (min 1/2 3/4 4/5 5/6 6/7) 1/2) (testeqv (expt -1/2 5) -1/32) (testeqv (expt 1/2 -10) 1024) - (testeqv (rationalize .3 1/10) 1/3) + (testeqv (rationalize #e.3 1/10) 1/3) (test= (make-rectangular 1/2 -1/2) 0.5-0.5i) (test= (sqrt 1/4) 0.5) (testeqv (string->number "3/4") 3/4) @@ -335,9 +331,9 @@ (testeq (let ((error (catch #t (lambda () (gcd 1/2 3)) (lambda args (car args))))) error) 'wrong-type-arg) (testeq (let ((error (catch #t (lambda () (numerator 1+i)) (lambda args (car args))))) error) 'wrong-type-arg) (test= (- 0+6i 1/4 0.5 7) -7.75+6.0i) - (testeqv (rationalize 2.5 .001) 5/2) - (testeqv (rationalize 7/3 .001) 7/3) - (testeqv (rationalize 3.14159265 .1) 22/7) + (testeqv (rationalize #e2.5 1/1000) 5/2) + (testeqv (rationalize 7/3 1/1000) 7/3) + (testeqv (rationalize #e3.14159265 1/10) 22/7) (testeqv (numerator (/ 8 -6)) -4) (testeqv (denominator (/ 8 -6)) 3) (testeqv (gcd (numerator 7/9) (denominator 7/9)) 1) From 01b30204b5a15fca116ef5540f8565c5d078f568 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Nov 2003 18:12:11 +0000 Subject: [PATCH 151/239] (What is Guile?): Add @acronym for POSIX, R5RS, GUI, and HTTP. Conclude linking libguile. --- doc/ref/intro.texi | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/doc/ref/intro.texi b/doc/ref/intro.texi index 4d6109aeb..cf01e049f 100644 --- a/doc/ref/intro.texi +++ b/doc/ref/intro.texi @@ -11,10 +11,10 @@ Revised$^5$ @ifnottex Revised^5 @end ifnottex -Report on the Algorithmic Language Scheme (usually known as R5RS), +Report on the Algorithmic Language Scheme (usually known as @acronym{R5RS}), providing clean and general data and control structures. Guile goes -beyond the rather austere language presented in R5RS, extending it with -a module system, full access to POSIX system calls, networking support, +beyond the rather austere language presented in @acronym{R5RS}, extending it with +a module system, full access to @acronym{POSIX} system calls, networking support, multiple threads, dynamic linking, a foreign function call interface, powerful string processing, and many other features needed for programming in the real world. @@ -24,7 +24,7 @@ user, evaluating them, and displaying the results, or as a script interpreter, reading and executing Scheme code from a file. However, Guile is also packaged as an object library, allowing other applications to easily incorporate a complete Scheme interpreter. An application can -use Guile as an extension language, a clean and powerful configuration +then use Guile as an extension language, a clean and powerful configuration language, or as multi-purpose ``glue'', connecting primitives provided by the application. It is easy to call Scheme code from C code and vice versa, giving the application designer full control of how and when to @@ -34,13 +34,13 @@ language tailored to the task at hand, but based on a robust language design. Guile's module system allows one to break up a large program into -manageable sections with well-defined interfaces between them. Modules -may contain a mixture of interpreted and compiled code; Guile can use -either static or dynamic linking to incorporate compiled code. Modules -also encourage developers to package up useful collections of routines -for general distribution; as of this writing, one can find Emacs -interfaces, database access routines, compilers, GUI toolkit interfaces, -and HTTP client functions, among others. +manageable sections with well-defined interfaces between them. +Modules may contain a mixture of interpreted and compiled code; Guile +can use either static or dynamic linking to incorporate compiled code. +Modules also encourage developers to package up useful collections of +routines for general distribution; as of this writing, one can find +Emacs interfaces, database access routines, compilers, @acronym{GUI} +toolkit interfaces, and @acronym{HTTP} client functions, among others. In the future, we hope to expand Guile to support other languages like Tcl and Perl by translating them to Scheme code. This means that users From e23fec556181a2bebc35fca13e33c8be7f56cef1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Nov 2003 18:13:21 +0000 Subject: [PATCH 152/239] Include exact rationals. --- doc/ref/scheme-data.texi | 285 ++++++++++++++++++++++++++++----------- 1 file changed, 204 insertions(+), 81 deletions(-) diff --git a/doc/ref/scheme-data.texi b/doc/ref/scheme-data.texi index a05a07e62..07381ab16 100755 --- a/doc/ref/scheme-data.texi +++ b/doc/ref/scheme-data.texi @@ -98,7 +98,11 @@ other Scheme value. In particular, @code{#f} is not the same as the number 0 (like in C and C++), and not the same as the ``empty list'' (like in some Lisp dialects). -The @code{not} procedure returns the boolean inverse of its argument: +In C, the two Scheme boolean values are available as the two constants +@code{SCM_BOOL_T} for @code{#t} and @code{SCM_BOOL_F} for @code{#f}. +Care must be taken with the false value @code{SCM_BOOL_F}: it is not +false when used in C conditionals. In order to test for it, use +@code{SCM_FALSEP} or @code{SCM_NFALSEP}. @rnindex not @deffn {Scheme Procedure} not x @@ -106,15 +110,33 @@ The @code{not} procedure returns the boolean inverse of its argument: Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}. @end deffn -The @code{boolean?} procedure is a predicate that returns @code{#t} if -its argument is one of the boolean values, otherwise @code{#f}. - @rnindex boolean? @deffn {Scheme Procedure} boolean? obj @deffnx {C Function} scm_boolean_p (obj) Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}. @end deffn +@rnindex SCM_BOOL_T +@deffn {C Macro} SCM_BOOL_T +Represents a value that is true in the Scheme sense. +@end deffn + +@rnindex SCM_BOOL_T +@deffn {C Macro} SCM_BOOL_F +Represents a value that is false in the Scheme sense. +@end deffn + +@rnindex SCM_FALSEP +@deffn {C Macro} SCM_FALSEP (SCM obj) +Return true in the C sense when @var{obj} is false in the Scheme +sense; return false in the C sense otherwise. +@end deffn + +@rnindex SCM_NFALSEP +@deffn {C Macro} SCM_NFALSEP (SCM obj) +Return true in the C sense when @var{obj} is true in the Scheme +sense; return false in the C sense otherwise. +@end deffn @node Numbers @section Numerical data types @@ -183,10 +205,17 @@ follows it, in the sense that every integer is also a rational, every rational is also real, and every real number is also a complex number (but with zero imaginary part). -Of these, Guile implements integers, reals and complex numbers as -distinct types. Rationals are implemented as regards the read syntax -for rational numbers that is specified by R5RS, but are immediately -converted by Guile to the corresponding real number. +In addition to the classification into integers, rationals, reals and +complex numbers, Scheme also distinguishes between whether a number is +represented exactly or not. For example, the result of +@m{2\sin(\pi/4),sin(pi/4)} is exactly @m{\sqrt{2},2^(1/2)} but Guile +can neither represent @m{\pi/4,pi/4} nor @m{\sqrt{2},2^(1/2)} exactly. +Instead, it stores an inexact approximation, using the C type +@code{double}. + +Guile can represent exact rationals of any magnitude, inexact +rationals that fit into a C @code{double}, and inexact complex numbers +with @code{double} real and imaginary parts. The @code{number?} predicate may be applied to any Scheme value to discover whether the value is any of the supported numerical types. @@ -292,12 +321,25 @@ fractions @var{p}/@var{q}, where @var{p} and @var{q} are integers. All rational numbers are also real, but there are real numbers that are not rational, for example the square root of 2, and pi. -Guile represents both real and rational numbers approximately using a -floating point encoding with limited precision. Even though the actual -encoding is in binary, it may be helpful to think of it as a decimal -number with a limited number of significant figures and a decimal point -somewhere, since this corresponds to the standard notation for non-whole -numbers. For example: +Guile can represent both exact and inexact rational numbers, but it +can not represent irrational numbers. Exact rationals are represented +by storing the numerator and denominator as two exact integers. +Inexact rationals are stored as floating point numbers using the C +type @code{double}. + +Exact rationals are written as a fraction of integers. There must be +no whitespace around the slash: + +@lisp +1/2 +-22/7 +@end lisp + +Even though the actual encoding of inexact rationals is in binary, it +may be helpful to think of it as a decimal number with a limited +number of significant figures and a decimal point somewhere, since +this corresponds to the standard notation for non-whole numbers. For +example: @lisp 0.34 @@ -313,17 +355,6 @@ by sufficient powers of 10 (or in fact, 2). For example, 100000000000000000. In Guile's current incarnation, therefore, the @code{rational?} and @code{real?} predicates are equivalent. -Another aspect of this equivalence is that Guile currently does not -preserve the exactness that is possible with rational arithmetic. -If such exactness is needed, it is of course possible to implement -exact rational arithmetic at the Scheme level using Guile's arbitrary -size integers. - -A planned future revision of Guile's numerical tower will make it -possible to implement exact representations and arithmetic for both -rational numbers and real irrational numbers such as square roots, -and in such a way that the new kinds of number integrate seamlessly -with those that are already implemented. Dividing by an exact zero leads to a error message, as one might expect. However, dividing by an inexact zero does not produce an @@ -331,7 +362,7 @@ error. Instead, the result of the division is either plus or minus infinity, depending on the sign of the divided number. The infinities are written @samp{+inf.0} and @samp{-inf.0}, -respectibly. This syntax is also recognized by @code{read} as an +respectivly. This syntax is also recognized by @code{read} as an extension to the usual Scheme syntax. Dividing zero by zero yields something that is not a number at all: @@ -352,20 +383,37 @@ To test for the special values, use the functions @code{inf?} and @deffn {Scheme Procedure} real? obj @deffnx {C Function} scm_real_p (obj) -Return @code{#t} if @var{obj} is a real number, else @code{#f}. -Note that the sets of integer and rational values form subsets -of the set of real numbers, so the predicate will also be fulfilled -if @var{obj} is an integer number or a rational number. +Return @code{#t} if @var{obj} is a real number, else @code{#f}. Note +that the sets of integer and rational values form subsets of the set +of real numbers, so the predicate will also be fulfilled if @var{obj} +is an integer number or a rational number. @end deffn @deffn {Scheme Procedure} rational? x -@deffnx {C Function} scm_real_p (x) -Return @code{#t} if @var{x} is a rational number, @code{#f} -otherwise. Note that the set of integer values forms a subset of -the set of rational numbers, i. e. the predicate will also be -fulfilled if @var{x} is an integer number. Real numbers -will also satisfy this predicate, because of their limited -precision. +@deffnx {C Function} scm_rational_p (x) +Return @code{#t} if @var{x} is a rational number, @code{#f} otherwise. +Note that the set of integer values forms a subset of the set of +rational numbers, i. e. the predicate will also be fulfilled if +@var{x} is an integer number. + +Since Guile can not represent irrational numbers, every number +satisfying @code{real?} also satisfies @code{rational?} in Guile. +@end deffn + +@deffn {Scheme Procedure} rationalize x eps +@deffnx {C Function} scm_rationalize (x, eps) +Returns the @emph{simplest} rational number differing +from @var{x} by no more than @var{eps}. + +As required by @acronym{R5RS}, @code{rationalize} returns only then an +exact result when both its arguments are exact. Thus, you might need +to use @code{inexact->exact} on the arguments. + +@lisp +(rationalize (inexact->exact 1.2) 1/100) +@result{} 6/5 +@end lisp + @end deffn @deffn {Scheme Procedure} inf? x @@ -402,9 +450,11 @@ the imaginary part. 9.3-17.5i @end lisp -Guile represents a complex number as a pair of numbers both of which are -real, so the real and imaginary parts of a complex number have the same -properties of inexactness and limited precision as single real numbers. +Guile represents a complex number with a non-zero imaginary part as a +pair of inexact rationals, so the real and imaginary parts of a +complex number have the same properties of inexactness and limited +precision as single inexact rational numbers. Guile can not represent +exact complex numbers with non-zero imaginary parts. @deffn {Scheme Procedure} complex? x @deffnx {C Function} scm_number_p (x) @@ -434,25 +484,60 @@ available, has no fractional part, and is printed as @samp{5.0}. Guile will only convert the latter value to the former when forced to do so by an invocation of the @code{inexact->exact} procedure. -@deffn {Scheme Procedure} exact? x -@deffnx {C Function} scm_exact_p (x) -Return @code{#t} if @var{x} is an exact number, @code{#f} +@deffn {Scheme Procedure} exact? z +@deffnx {C Function} scm_exact_p (z) +Return @code{#t} if the number @var{z} is exact, @code{#f} otherwise. + +@lisp +(exact? 2) +@result{} #t + +(exact? 0.5) +@result{} #f + +(exact? (/ 2)) +@result{} #t +@end lisp + @end deffn -@deffn {Scheme Procedure} inexact? x -@deffnx {C Function} scm_inexact_p (x) -Return @code{#t} if @var{x} is an inexact number, @code{#f} +@deffn {Scheme Procedure} inexact? z +@deffnx {C Function} scm_inexact_p (z) +Return @code{#t} if the number @var{z} is inexact, @code{#f} else. @end deffn @deffn {Scheme Procedure} inexact->exact z @deffnx {C Function} scm_inexact_to_exact (z) -Return an exact number that is numerically closest to @var{z}. +Return an exact number that is numerically closest to @var{z}, when +there is one. For inexact rationals, Guile returns the exact rational +that is numerically equal to the inexact rational. Inexact complex +numbers with a non-zero imaginary part can not be made exact. + +@lisp +(inexact->exact 0.5) +@result{} 1/2 +@end lisp + +The following happens because 12/10 is not exactly representable as a +@code{double} (on most platforms). However, when reading a decimal +number that has been marked exact with the ``#e'' prefix, Guile is +able to represent it correctly. + +@lisp +(inexact->exact 1.2) +@result{} 5404319552844595/4503599627370496 + +#e1.2 +@result{} 6/5 +@end lisp + @end deffn @c begin (texi-doc-string "guile" "exact->inexact") @deffn {Scheme Procedure} exact->inexact z +@deffnx {C Function} scm_exact_to_inexact (z) Convert the number @var{z} to its inexact representation. @end deffn @@ -516,20 +601,28 @@ the number is exact the number is inexact. @end table -If the exactness indicator is omitted, the integer is assumed to be exact, -since Guile's internal representation for integers is always exact. -Real numbers have limited precision similar to the precision of the -@code{double} type in C. A consequence of the limited precision is that -all real numbers in Guile are also rational, since any number @var{r} with a -limited number of decimal places, say @var{n}, can be made into an integer by -multiplying by @math{10^n}. +If the exactness indicator is omitted, the number is exact unless it +contains a radix point. Since Guile can not represent exact complex +numbers, an error is signalled when asking for them. + +@lisp +(exact? 1.2) +@result{} #f + +(exact? #e1.2) +@result{} #t + +(exact? #e+1i) +ERROR: Wrong type argument +@end lisp Guile also understands the syntax @samp{+inf.0} and @samp{-inf.0} for plus and minus infinity, respectively. The value must be written -exactly as shown, that is, the always must have a sign and exactly one -zero digit after the decimal point. It also understands @samp{+nan.0} -and @samp{-nan.0} for the special `not-a-number' value. The sign is -ignored for `not-a-number' and the value is always printed as @samp{+nan.0}. +exactly as shown, that is, they always must have a sign and exactly +one zero digit after the decimal point. It also understands +@samp{+nan.0} and @samp{-nan.0} for the special `not-a-number' value. +The sign is ignored for `not-a-number' and the value is always printed +as @samp{+nan.0}. @node Integer Operations @subsection Operations on Integer Values @@ -557,6 +650,8 @@ otherwise. @c begin (texi-doc-string "guile" "remainder") @deffn {Scheme Procedure} quotient n d @deffnx {Scheme Procedure} remainder n d +@deffnx {C Function} scm_quotient (n, d) +@deffnx {C Function} scm_remainder (n, d) Return the quotient or remainder from @var{n} divided by @var{d}. The quotient is rounded towards zero, and the remainder will have the same sign as @var{n}. In all cases quotient and remainder satisfy @@ -570,6 +665,7 @@ sign as @var{n}. In all cases quotient and remainder satisfy @c begin (texi-doc-string "guile" "modulo") @deffn {Scheme Procedure} modulo n d +@deffnx {C Function} scm_modulo (n, d) Return the remainder from @var{n} divided by @var{d}, with the same sign as @var{d}. @@ -583,14 +679,22 @@ sign as @var{d}. @c begin (texi-doc-string "guile" "gcd") @deffn {Scheme Procedure} gcd +@deffnx {C Function} scm_gcd (x, y) Return the greatest common divisor of all arguments. If called without arguments, 0 is returned. + +The C function @code{scm_gcd} always takes two arguments, while the +Scheme function can take an arbitrary number. @end deffn @c begin (texi-doc-string "guile" "lcm") @deffn {Scheme Procedure} lcm +@deffnx {C Function} scm_lcm (x, y) Return the least common multiple of the arguments. If called without arguments, 1 is returned. + +The C function @code{scm_lcm} always takes two arguments, while the +Scheme function can take an arbitrary number. @end deffn @@ -600,49 +704,65 @@ If called without arguments, 1 is returned. @rnindex positive? @rnindex negative? +The C comparison functions below always takes two arguments, while the +Scheme functions can take an arbitrary number. Also keep in mind that +the C functions return one of the Scheme boolean values +@code{SCM_BOOL_T} or @code{SCM_BOOL_F} which are both true as far as C +is concerned. Thus, always write @code{SCM_NFALSEP (scm_num_eq_p (x, +y))} when testing the two Scheme numbers @code{x} and @code{y} for +equality, for example. + @c begin (texi-doc-string "guile" "=") @deffn {Scheme Procedure} = +@deffnx {C Function} scm_num_eq_p (x, y) Return @code{#t} if all parameters are numerically equal. @end deffn @c begin (texi-doc-string "guile" "<") @deffn {Scheme Procedure} < +@deffnx {C Function} scm_less_p (x, y) Return @code{#t} if the list of parameters is monotonically increasing. @end deffn @c begin (texi-doc-string "guile" ">") @deffn {Scheme Procedure} > +@deffnx {C Function} scm_gr_p (x, y) Return @code{#t} if the list of parameters is monotonically decreasing. @end deffn @c begin (texi-doc-string "guile" "<=") @deffn {Scheme Procedure} <= +@deffnx {C Function} scm_leq_p (x, y) Return @code{#t} if the list of parameters is monotonically non-decreasing. @end deffn @c begin (texi-doc-string "guile" ">=") @deffn {Scheme Procedure} >= +@deffnx {C Function} scm_geq_p (x, y) Return @code{#t} if the list of parameters is monotonically non-increasing. @end deffn @c begin (texi-doc-string "guile" "zero?") -@deffn {Scheme Procedure} zero? +@deffn {Scheme Procedure} zero? z +@deffnx {C Function} scm_zero_p (z) Return @code{#t} if @var{z} is an exact or inexact number equal to zero. @end deffn @c begin (texi-doc-string "guile" "positive?") -@deffn {Scheme Procedure} positive? +@deffn {Scheme Procedure} positive? x +@deffnx {C Function} scm_positive_p (x) Return @code{#t} if @var{x} is an exact or inexact number greater than zero. @end deffn @c begin (texi-doc-string "guile" "negative?") -@deffn {Scheme Procedure} negative? +@deffn {Scheme Procedure} negative? x +@deffnx {C Function} scm_negative_p (x) Return @code{#t} if @var{x} is an exact or inexact number less than zero. @end deffn @@ -695,22 +815,26 @@ Return the complex number @var{x} * e^(i * @var{y}). @c begin (texi-doc-string "guile" "real-part") @deffn {Scheme Procedure} real-part z +@deffnx {C Function} scm_real_part (z) Return the real part of the number @var{z}. @end deffn @c begin (texi-doc-string "guile" "imag-part") @deffn {Scheme Procedure} imag-part z +@deffnx {C Function} scm_imag_part (z) Return the imaginary part of the number @var{z}. @end deffn @c begin (texi-doc-string "guile" "magnitude") @deffn {Scheme Procedure} magnitude z +@deffnx {C Function} scm_magnitude (z) Return the magnitude of the number @var{z}. This is the same as @code{abs} for real arguments, but also allows complex numbers. @end deffn @c begin (texi-doc-string "guile" "angle") @deffn {Scheme Procedure} angle z +@deffnx {C Function} scm_angle (z) Return the angle of the complex number @var{z}. @end deffn @@ -729,14 +853,22 @@ Return the angle of the complex number @var{z}. @rnindex truncate @rnindex round +The C arithmetic functions below always takes two arguments, while the +Scheme functions can take an arbitrary number. When you need to +invoke them with just one argument, for example to compute the +equivalent od @code{(- x)}, pass @code{SCM_UNDEFINED} as the second +one: @code{scm_difference (x, SCM_UNDEFINED)}. + @c begin (texi-doc-string "guile" "+") @deffn {Scheme Procedure} + z1 @dots{} +@deffnx {C Function} scm_sum (z1, z2) Return the sum of all parameter values. Return 0 if called without any parameters. @end deffn @c begin (texi-doc-string "guile" "-") @deffn {Scheme Procedure} - z1 z2 @dots{} +@deffnx {C Function} scm_difference (z1, z2) If called with one argument @var{z1}, -@var{z1} is returned. Otherwise the sum of all but the first argument are subtracted from the first argument. @@ -744,12 +876,14 @@ argument. @c begin (texi-doc-string "guile" "*") @deffn {Scheme Procedure} * z1 @dots{} +@deffnx {C Function} scm_product (z1, z2) Return the product of all arguments. If called without arguments, 1 is returned. @end deffn @c begin (texi-doc-string "guile" "/") @deffn {Scheme Procedure} / z1 z2 @dots{} +@deffnx {C Function} scm_divide (z1, z2) Divide the first argument by the product of the remaining arguments. If called with one argument @var{z1}, 1/@var{z1} is returned. @end deffn @@ -765,55 +899,41 @@ magnitude of a complex number, use @code{magnitude} instead. @c begin (texi-doc-string "guile" "max") @deffn {Scheme Procedure} max x1 x2 @dots{} +@deffnx {C Function} scm_max (x1, x2) Return the maximum of all parameter values. @end deffn @c begin (texi-doc-string "guile" "min") @deffn {Scheme Procedure} min x1 x2 @dots{} +@deffnx {C Function} scm_min (x1, x2) Return the minimum of all parameter values. @end deffn @c begin (texi-doc-string "guile" "truncate") @deffn {Scheme Procedure} truncate +@deffnx {C Function} scm_truncate_number (x) Round the inexact number @var{x} towards zero. @end deffn @c begin (texi-doc-string "guile" "round") @deffn {Scheme Procedure} round x +@deffnx {C Function} scm_round_number (x) Round the inexact number @var{x} to the nearest integer. When exactly halfway between two integers, round to the even one. @end deffn @c begin (texi-doc-string "guile" "floor") @deffn {Scheme Procedure} floor x +@deffnx {C Function} scm_floor (x) Round the number @var{x} towards minus infinity. @end deffn @c begin (texi-doc-string "guile" "ceiling") @deffn {Scheme Procedure} ceiling x +@deffnx {C Function} scm_ceiling (x) Round the number @var{x} towards infinity. @end deffn -C functions for some of the above rounding functions are provided by -the standard C mathematics library. Naturally these expect and return -@code{double} arguments (@pxref{Rounding Functions,,, libc, GNU C -Library Reference Manual}). - -@multitable {xx} {Scheme Procedure} {C Function} -@item @tab Scheme Procedure @tab C Function -@item @tab @code{floor} @tab @code{floor} -@item @tab @code{ceiling} @tab @code{ceil} -@item @tab @code{truncate} @tab @code{trunc} -@end multitable - -@code{trunc} is C99 standard and might not be available on older -systems. Guile provides an @code{scm_truncate} equivalent (on all -systems), plus a C level version of the Scheme @code{round} procedure. - -@deftypefn {C Function} double scm_truncate (double x) -@deftypefnx {C Function} double scm_round (double x) -@end deftypefn - @node Scientific @subsection Scientific Functions @@ -1073,6 +1193,7 @@ be seen that adding 6 (binary 110) to such a bit pattern gives all zeros. @deffn {Scheme Procedure} logand n1 n2 @dots{} +@deffnx {C Function} scm_logand (n1, n2) Return the bitwise @sc{and} of the integer arguments. @lisp @@ -1083,6 +1204,7 @@ Return the bitwise @sc{and} of the integer arguments. @end deffn @deffn {Scheme Procedure} logior n1 n2 @dots{} +@deffnx {C Function} scm_logior (n1, n2) Return the bitwise @sc{or} of the integer arguments. @lisp @@ -1093,6 +1215,7 @@ Return the bitwise @sc{or} of the integer arguments. @end deffn @deffn {Scheme Procedure} logxor n1 n2 @dots{} +@deffnx {C Function} scm_loxor (n1, n2) Return the bitwise @sc{xor} of the integer arguments. A bit is set in the result if it is set in an odd number of arguments. From f24809dc2b51fce920507fb17059673ad40d6e47 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 19 Nov 2003 18:24:36 +0000 Subject: [PATCH 153/239] *** empty log message *** --- doc/ref/ChangeLog | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index e0a758c65..b06ef0240 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,20 @@ +2003-11-19 Marius Vollmer + + * scheme-data.texi: Include exact rationals. + + From Stephen Compall. Thanks! + + * intro.texi (What is Guile?): Add @acronym for POSIX, R5RS, GUI, + and HTTP. Conclude linking libguile. Say what one can find *for*. + + * preface.texi (Manual Conventions): Double-quote some statements + formerly single-quoted. Remove some redundant quotes around code. + Clarify meaning of `iff' further for those that didn't get it the + first time 'round (like me). Make graphical indicators samples, + not code. Put results of evaluation on the same line as @result + symbols. Use @print example as example of total usage, and remind + readers not to forget the difference. + 2003-11-17 Marius Vollmer * scheme-modules.texi: Document '@' and '@@'. From b10b93de99606a762c9f07d81016dce1ab77700f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 19 Nov 2003 21:39:07 +0000 Subject: [PATCH 154/239] * standalone/test-system-cmds: new test. --- test-suite/standalone/test-system-cmds | 42 ++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100755 test-suite/standalone/test-system-cmds diff --git a/test-suite/standalone/test-system-cmds b/test-suite/standalone/test-system-cmds new file mode 100755 index 000000000..d0e4a6991 --- /dev/null +++ b/test-suite/standalone/test-system-cmds @@ -0,0 +1,42 @@ +#!/bin/sh +exec guile -s "$0" "$@" +!# + +(define (test-system-cmd) + (if (not (boolean? (system))) + (begin + (simple-format + #t + "test-system-cmds: (system) did not return a boolean\n") + (exit 1))) + + (let ((rs (status:exit-val (system "guile -c '(exit 42)'")))) + (if (not (= 42 rs)) + (begin + (simple-format + #t + "test-system-cmds: system exit status was ~S rather than 42\n" + rs) + (exit 1))))) + +(define (test-system*-cmd) + (let ((rs (status:exit-val (system* "guile" "-c" "(exit 42)")))) + (if (not (= 42 rs)) + (begin + (simple-format + #t + "test-system-cmds: system* exit status was ~S rather than 42\n" + rs) + (exit 1))))) + +(if (defined? 'system) + (test-system-cmd)) + +(if (defined? 'system*) + (test-system*-cmd)) + +(exit 0) + +;; Local Variables: +;; mode: scheme +;; End: \ No newline at end of file From 060ffedfe1e7c9c9bdf12b505aae7cd0021fb198 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 19 Nov 2003 21:39:16 +0000 Subject: [PATCH 155/239] (check_SCRIPTS): add test-system-cmds. (TESTS): add test-system-cmds. --- test-suite/standalone/Makefile.am | 3 +++ 1 file changed, 3 insertions(+) diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index d9a841960..953b63763 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -21,6 +21,9 @@ CLEANFILES = *.x .DELETE_ON_ERROR: +check_SCRIPTS += test-system-cmds +TESTS += test-system-cmds + # test-num2integral test_num2integral_SOURCES = test-num2integral.c test_num2integral_CFLAGS = ${test_cflags} From d26af5b23ea38b34a63ca56cf87e1dafed677b17 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 19 Nov 2003 21:39:26 +0000 Subject: [PATCH 156/239] *** empty log message *** --- test-suite/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index f80abc29f..1b3ea457a 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,10 @@ +2003-11-19 Rob Browning + + * standalone/test-system-cmds: new test. + + * standalone/Makefile.am (check_SCRIPTS): add test-system-cmds. + (TESTS): add test-system-cmds. + 2003-11-18 Marius Vollmer * tests/numbers.test ("string->number"): Expect exact rationals From 8141bd983dc6f29445016e56c786bae26f705a4c Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 19 Nov 2003 21:39:35 +0000 Subject: [PATCH 157/239] (Processes): add documentation for system*. --- doc/ref/posix.texi | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 41215f438..584d5c848 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1470,6 +1470,26 @@ If @code{system} is called without arguments, return a boolean indicating whether the command processor is available. @end deffn +@deffn {Scheme Procedure} system* . args +@deffnx {C Function} scm_system_star (args) +Execute the command indicated by @var{args}. The first element must +be a string indicating the command to be executed, and the remaining +items must be strings representing each of the arguments to that +command. + +This function returns the exit status of the command as provided by +@code{waitpid}. This value can be handled with @code{status:exit-val} +and the related functions. + +@code{system*} is similar to @code{system}, but accepts only one +string per-argument, and performs no shell interpretation. The +command is executed using fork and execlp. Accordingly this function +may be safer than @code{system} in situations where shell +interpretation is not required. + +Example: (system* "echo" "foo" "bar") +@end deffn + @deffn {Scheme Procedure} primitive-exit [status] @deffnx {C Function} scm_primitive_exit (status) Terminate the current process without unwinding the Scheme stack. From 0db17ef9abd59da51ebc30d90fb2dc482b02a4a1 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 19 Nov 2003 21:40:32 +0000 Subject: [PATCH 158/239] (scm_system_star): new function. --- libguile/simpos.c | 117 +++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 115 insertions(+), 2 deletions(-) diff --git a/libguile/simpos.c b/libguile/simpos.c index c9c83935c..caeb753c4 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -39,13 +39,18 @@ #ifdef HAVE_UNISTD_H #include #endif +#if HAVE_SYS_WAIT_H +# include +#endif + +#include "posix.h" extern int system(); #ifdef HAVE_SYSTEM -SCM_DEFINE (scm_system, "system", 0, 1, 0, +SCM_DEFINE (scm_system, "system", 0, 1, 0, (SCM cmd), "Execute @var{cmd} using the operating system's \"command\n" "processor\". Under Unix this is usually the default shell\n" @@ -63,7 +68,7 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, { rv = system (NULL); return SCM_BOOL(rv); - } + } SCM_VALIDATE_STRING (1, cmd); errno = 0; rv = system (SCM_STRING_CHARS (cmd)); @@ -74,6 +79,114 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, #undef FUNC_NAME #endif /* HAVE_SYSTEM */ + +#ifdef HAVE_SYSTEM +#ifdef HAVE_WAITPID + +/* return a newly allocated array of char pointers to each of the strings + in args, with a terminating NULL pointer. */ +/* Note: a similar function is defined in dynl.c, but we don't necessarily + want to export it. */ +static char ** +allocate_string_pointers (SCM args) +{ + char **result; + int n_args = scm_ilength (args); + int i; + + SCM_ASSERT (n_args >= 0, args, SCM_ARGn, "allocate_string_pointers"); + result = (char **) scm_malloc ((n_args + 1) * sizeof (char *)); + result[n_args] = NULL; + for (i = 0; i < n_args; i++) + { + SCM car = SCM_CAR (args); + + if (!SCM_STRINGP (car)) + { + free (result); + scm_wrong_type_arg ("allocate_string_pointers", SCM_ARGn, car); + } + result[i] = SCM_STRING_CHARS (SCM_CAR (args)); + args = SCM_CDR (args); + } + return result; +} + +SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, + (SCM args), +"Execute the command indicated by @var{args}. The first element must\n" +"be a string indicating the command to be executed, and the remaining\n" +"items must be strings representing each of the arguments to that\n" +"command.\n" +"\n" +"This function returns the exit status of the command as provided by\n" +"@code{waitpid}. This value can be handled with @code{status:exit-val}\n" +"and the related functions.\n" +"\n" +"@code{system*} is similar to @code{system}, but accepts only one\n" +"string per-argument, and performs no shell interpretation. The\n" +"command is executed using fork and execlp. Accordingly this function\n" +"may be safer than @code{system} in situations where shell\n" +"interpretation is not required.\n" +"\n" +"Example: (system* \"echo\" \"foo\" \"bar\")") +#define FUNC_NAME s_scm_system_star +{ + if (SCM_NULLP (args)) + SCM_WRONG_NUM_ARGS (); + + if (SCM_CONSP (args)) + { + SCM oldint; + SCM oldquit; + SCM sig_ign; + SCM sigint; + SCM sigquit; + int pid; + char **execargv; + + SCM_VALIDATE_STRING (1, SCM_CAR (args)); + /* allocate before fork */ + execargv = allocate_string_pointers (args); + + /* make sure the child can't kill us (as per normal system call) */ + sig_ign = scm_long2num ((long) SIG_IGN); + sigint = scm_long2num (SIGINT); + sigquit = scm_long2num (SIGQUIT); + oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED); + oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED); + + pid = fork (); + if (pid == -1) + SCM_SYSERROR; + else if (pid) + { + int wait_result; + int status; + SCM_SYSCALL (wait_result = waitpid (pid, &status, 0)); + if (wait_result == -1) SCM_SYSERROR; + scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint)); + scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit)); + scm_remember_upto_here_2 (oldint, oldquit); + return SCM_MAKINUM (0L + status); + } + else + { + execvp (SCM_STRING_CHARS (SCM_CAR (args)), execargv); + scm_remember_upto_here_1 (args); + SCM_SYSERROR; + /* not reached. */ + return SCM_BOOL_F; + } + } + else + SCM_WRONG_TYPE_ARG (1, SCM_CAR (args)); +} +#undef FUNC_NAME +#endif /* HAVE_WAITPID */ +#endif /* HAVE_SYSTEM */ + + SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, (SCM nam), "Looks up the string @var{name} in the current environment. The return\n" From c412e408c527fa46bb44379fd4ade8a3cec69066 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 19 Nov 2003 21:40:42 +0000 Subject: [PATCH 159/239] (scm_system_star): new prototype. --- libguile/simpos.h | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/simpos.h b/libguile/simpos.h index 4755cafc9..7b0e5c2dc 100644 --- a/libguile/simpos.h +++ b/libguile/simpos.h @@ -27,6 +27,7 @@ SCM_API SCM scm_system (SCM cmd); +SCM_API SCM scm_system_star (SCM cmds); SCM_API SCM scm_getenv (SCM nam); SCM_API SCM scm_primitive_exit (SCM status); SCM_API void scm_init_simpos (void); From ca2b31fe085fa1faeebd38389e960bb203889d0e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 20 Nov 2003 23:55:51 +0000 Subject: [PATCH 160/239] #e1.2 is now exactly 12/10. Expect exceptions when calling inexact? with a non-number. --- test-suite/tests/numbers.test | 34 +++++++++++++++++++++++++--------- 1 file changed, 25 insertions(+), 9 deletions(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 9e707d252..82085036b 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -999,7 +999,9 @@ (lambda (x y) (let ((xx (string->number x))) (if (or (eq? xx #f) (not (eqv? xx y))) - (throw 'fail)))) + (begin + (pk x y) + (throw 'fail))))) couple)) `(;; Radix: ("#b0" 0) ("#B0" 0) ("#b1" 1) ("#B1" 1) ("#o0" 0) ("#O0" 0) @@ -1017,7 +1019,7 @@ ("#d1234567890" 1234567890) ("#x1234567890abcdef" 1311768467294899695) ;; Exactness: - ("#e1" 1) ("#e1.2" ,(inexact->exact 1.2)) + ("#e1" 1) ("#e1.2" 12/10) ("#i1.1" 1.1) ("#i1" 1.0) ;; Integers: ("1" ,(1+ 0)) ("23" ,(+ 9 9 5)) ("-1" ,(- 0 1)) @@ -1172,13 +1174,27 @@ (pass-if (not (inexact? (- 1 fixnum-min)))) (pass-if (inexact? 1.3)) (pass-if (inexact? 3.1+4.2i)) - (pass-if (not (inexact? #\a))) - (pass-if (not (inexact? "a"))) - (pass-if (not (inexact? (make-vector 0)))) - (pass-if (not (inexact? (cons 1 2)))) - (pass-if (not (inexact? #t))) - (pass-if (not (inexact? (lambda () #t)))) - (pass-if (not (inexact? (current-input-port))))) + (pass-if-exception "char" + exception:wrong-type-arg + (not (inexact? #\a))) + (pass-if-exception "string" + exception:wrong-type-arg + (not (inexact? "a"))) + (pass-if-exception "vector" + exception:wrong-type-arg + (not (inexact? (make-vector 0)))) + (pass-if-exception "cons" + exception:wrong-type-arg + (not (inexact? (cons 1 2)))) + (pass-if-exception "bool" + exception:wrong-type-arg + (not (inexact? #t))) + (pass-if-exception "procedure" + exception:wrong-type-arg + (not (inexact? (lambda () #t)))) + (pass-if-exception "port" + exception:wrong-type-arg + (not (inexact? (current-input-port))))) ;;; ;;; equal? From 753ac1e7e141850127f388007ad82597e6f38234 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 21 Nov 2003 00:03:54 +0000 Subject: [PATCH 161/239] (scm_integer_expt): Don't mpz_init after scm_i_clonebig or scm_i_mkbig, since they do so already. Don't mpz_clear a bignum SCM, since gc does this. --- libguile/numbers.c | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index df544654f..3a75aa0af 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1535,7 +1535,6 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, else if (SCM_BIGP (k)) { z_i2 = scm_i_clonebig (k, 1); - mpz_init_set (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (k)); scm_remember_upto_here_1 (k); i2_is_big = 1; } @@ -1547,7 +1546,7 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, if ((r > SCM_MOST_POSITIVE_FIXNUM) || (r < SCM_MOST_NEGATIVE_FIXNUM)) { z_i2 = scm_i_mkbig (); - mpz_init_set_d (SCM_I_BIG_MPZ (z_i2), r); + mpz_set_d (SCM_I_BIG_MPZ (z_i2), r); i2_is_big = 1; } else @@ -1569,12 +1568,10 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, { if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == 0) { - mpz_clear (SCM_I_BIG_MPZ (z_i2)); return acc; } if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2), 1) == 0) { - mpz_clear (SCM_I_BIG_MPZ (z_i2)); return scm_product (acc, n); } if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2), 0)) From ae38324d9ccf324c9473ab0ae851cbc473b72de2 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 21 Nov 2003 00:07:13 +0000 Subject: [PATCH 162/239] (scm_abs): Allocate a new real only for negatives, as done for bignums. --- libguile/numbers.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 3a75aa0af..415e265dc 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -641,7 +641,14 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, return x; } else if (SCM_REALP (x)) - return scm_make_real (fabs (SCM_REAL_VALUE (x))); + { + /* note that if x is a NaN then xx<0 is false so we return x unchanged */ + double xx = SCM_REAL_VALUE (x); + if (xx < 0.0) + return scm_make_real (-xx); + else + return x; + } else if (SCM_FRACTIONP (x)) { if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (x)))) From 7f8482426916b1712432077fc8e34f8dde411085 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 21 Nov 2003 00:33:44 +0000 Subject: [PATCH 163/239] (scm_bit_extract): Use mpz functions, rearrange inum case to share some shifting. --- libguile/numbers.c | 64 +++++++++++++++++++++++++++------------------- 1 file changed, 38 insertions(+), 26 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 415e265dc..8e78c56d6 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1661,6 +1661,8 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, #undef FUNC_NAME +#define MIN(x,y) ((x) < (y) ? (x) : (y)) + SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, (SCM n, SCM start, SCM end), "Return the integer composed of the @var{start} (inclusive)\n" @@ -1675,56 +1677,66 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, "@end lisp") #define FUNC_NAME s_scm_bit_extract { - unsigned long int istart, iend; + unsigned long int istart, iend, bits; SCM_VALIDATE_INUM_MIN_COPY (2, start,0, istart); SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend); SCM_ASSERT_RANGE (3, end, (iend >= istart)); + /* how many bits to keep */ + bits = iend - istart; + if (SCM_INUMP (n)) { long int in = SCM_INUM (n); - unsigned long int bits = iend - istart; + + /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to + SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". + FIXME: This shift relies on signed right shifts being arithmetic, + which is not guaranteed by C99. */ + in >>= MIN (istart, SCM_I_FIXNUM_BIT-1); if (in < 0 && bits >= SCM_I_FIXNUM_BIT) { /* Since we emulate two's complement encoded numbers, this * special case requires us to produce a result that has - * more bits than can be stored in a fixnum. Thus, we fall - * back to the more general algorithm that is used for - * bignums. + * more bits than can be stored in a fixnum. */ - goto generalcase; + SCM result = scm_i_long2big (in); + mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), + bits); + return result; } - if (istart < SCM_I_FIXNUM_BIT) - { - in = in >> istart; - if (bits < SCM_I_FIXNUM_BIT) - return SCM_MAKINUM (in & ((1L << bits) - 1)); - else /* we know: in >= 0 */ - return SCM_MAKINUM (in); - } - else if (in < 0) - return SCM_MAKINUM (-1L & ((1L << bits) - 1)); - else - return SCM_MAKINUM (0); + /* mask down to requisite bits */ + bits = MIN (bits, SCM_I_FIXNUM_BIT); + return SCM_MAKINUM (in & ((1L << bits) - 1)); } else if (SCM_BIGP (n)) { - generalcase: - { - SCM num1 = SCM_MAKINUM (1L); - SCM num2 = SCM_MAKINUM (2L); - SCM bits = SCM_MAKINUM (iend - istart); - SCM mask = scm_difference (scm_integer_expt (num2, bits), num1); - return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart))); - } + SCM result; + if (bits == 1) + { + result = SCM_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n), istart)); + } + else + { + /* ENHANCE-ME: It'd be nice not to allocate a new bignum when + bits Date: Fri, 21 Nov 2003 00:45:07 +0000 Subject: [PATCH 164/239] *** empty log message *** --- libguile/ChangeLog | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7c73c47e1..8c10ea7b3 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2003-11-21 Kevin Ryde + + * numbers.c (scm_abs): Allocate a new real only for negatives, as done + for bignums. + + * numbers.c (scm_bit_extract): Use mpz functions, rearrange inum case + to share some shifting. + + * numbers.c (scm_integer_expt): Don't mpz_init after scm_i_clonebig or + scm_i_mkbig, since they do so already. Don't mpz_clear a bignum SCM, + since gc does this. + 2003-11-19 Marius Vollmer * numbers.c (scm_make_ratio): Rewritten to have a simpler From 28a6e1b0b6be9f5d9ddd15b81f55da058d20f713 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 21 Nov 2003 17:08:31 +0000 Subject: [PATCH 165/239] (scm_drain_input): Bug fix: only access the port after checking that it indeed is one. --- libguile/ports.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/ports.c b/libguile/ports.c index 438d6b78b..e3419dc33 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -318,10 +318,11 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, #define FUNC_NAME s_scm_drain_input { SCM result; - scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt; long count; SCM_VALIDATE_OPINPORT (1, port); + pt = SCM_PTAB_ENTRY (port); count = pt->read_end - pt->read_pos; if (pt->read_buf == pt->putback_buf) From 6bff13687c489ba5f15b8b8c4ee5e5acd8c43acc Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 21 Nov 2003 23:21:34 +0000 Subject: [PATCH 166/239] * eval.c (s_bad_define): New static identifier. (m_body): Fixed comment. (scm_m_define): Don't generate memoized code for definitions that are not on the top level. As a consequence, no memoized code at all is generated for definitions any more: Top level definitions are executed immediately during memoization and internal definitions are handled separately in m_expand_body. (scm_unmemocopy, unmemocopy): Removed code for unmemoizing definitions. Consequently, there is no unmemoizing code any more that might modify the environment. Thus, the old scm_unmemocopy is removed and the old unmemocopy is renamed to scm_unmemocopy. (SCM_CEVAL): The SCM_IM_DEFINE keyword can no longer occur in memoized code. Call EVALCAR for continuations. Prefer !SCM_NULLP over SCM_NIMP in places, where the argument is known to be part of a proper list. --- libguile/eval.c | 135 ++++++++++++++++++------------------------------ 1 file changed, 49 insertions(+), 86 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 913fe6243..b23521128 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -137,9 +137,12 @@ static const char s_missing_body_expression[] = "Missing body expression in"; * expressions may be grouped arbitraryly with begin, but it is not allowed to * mix definitions and expressions. If a define form in a body mixes * definitions and expressions, a 'Mixed definitions and expressions' error is - * signalled. - */ + * signalled. */ static const char s_mixed_body_forms[] = "Mixed definitions and expressions in"; +/* Definitions are only allowed on the top level and at the start of a body. + * If a definition is detected anywhere else, a 'Bad define placement' error + * is signalled. */ +static const char s_bad_define[] = "Bad define placement"; /* Case or cond expressions must have at least one clause. If a case or cond * expression without any clauses is detected, a 'Missing clauses' error is @@ -746,9 +749,7 @@ scm_eval_car (SCM pair, SCM env) * just the body itself, but prefixed with an ISYM that denotes to what kind * of outer construct this body belongs: ( ...). A lambda body * starts with SCM_IM_LAMBDA, for example, a body of a let starts with - * SCM_IM_LET, etc. The one exception is a body that belongs to a letrec that - * has been formed by rewriting internal defines: It starts with SCM_IM_DEFINE - * (instead of SCM_IM_LETREC). + * SCM_IM_LET, etc. * * It is assumed that the calling expression has already made sure that the * body is a proper list. */ @@ -1197,38 +1198,32 @@ canonicalize_define (const SCM expr) SCM scm_m_define (SCM expr, SCM env) { - SCM canonical_definition; - SCM cdr_canonical_definition; - SCM body; + ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr); - canonical_definition = canonicalize_define (expr); - cdr_canonical_definition = SCM_CDR (canonical_definition); - body = SCM_CDR (cdr_canonical_definition); + { + const SCM canonical_definition = canonicalize_define (expr); + const SCM cdr_canonical_definition = SCM_CDR (canonical_definition); + const SCM variable = SCM_CAR (cdr_canonical_definition); + const SCM body = SCM_CDR (cdr_canonical_definition); + const SCM value = scm_eval_car (body, env); - if (SCM_TOP_LEVEL (env)) - { - SCM var; - const SCM variable = SCM_CAR (cdr_canonical_definition); - const SCM value = scm_eval_car (body, env); - if (SCM_REC_PROCNAMES_P) - { - SCM tmp = value; - while (SCM_MACROP (tmp)) - tmp = SCM_MACRO_CODE (tmp); - if (SCM_CLOSUREP (tmp) - /* Only the first definition determines the name. */ - && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) - scm_set_procedure_property_x (tmp, scm_sym_name, variable); - } - var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T); - SCM_VARIABLE_SET (var, value); - return SCM_UNSPECIFIED; - } - else - { - SCM_SETCAR (canonical_definition, SCM_IM_DEFINE); - return canonical_definition; - } + SCM var; + if (SCM_REC_PROCNAMES_P) + { + SCM tmp = value; + while (SCM_MACROP (tmp)) + tmp = SCM_MACRO_CODE (tmp); + if (SCM_CLOSUREP (tmp) + /* Only the first definition determines the name. */ + && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) + scm_set_procedure_property_x (tmp, scm_sym_name, variable); + } + + var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T); + SCM_VARIABLE_SET (var, value); + + return SCM_UNSPECIFIED; + } } @@ -2266,8 +2261,8 @@ scm_unmemocar (SCM form, SCM env) #endif -static SCM -unmemocopy (SCM x, SCM env) +SCM +scm_unmemocopy (SCM x, SCM env) { SCM ls, z; SCM p; @@ -2304,16 +2299,16 @@ unmemocopy (SCM x, SCM env) SCM names, inits, test, memoized_body, steps, bindings; x = SCM_CDR (x); - inits = scm_reverse (unmemocopy (SCM_CAR (x), env)); + inits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env)); x = SCM_CDR (x); names = SCM_CAR (x); env = SCM_EXTEND_ENV (names, SCM_EOL, env); x = SCM_CDR (x); - test = unmemocopy (SCM_CAR (x), env); + test = scm_unmemocopy (SCM_CAR (x), env); x = SCM_CDR (x); memoized_body = SCM_CAR (x); x = SCM_CDR (x); - steps = scm_reverse (unmemocopy (x, env)); + steps = scm_reverse (scm_unmemocopy (x, env)); /* build transformed binding list */ bindings = SCM_EOL; @@ -2349,7 +2344,7 @@ unmemocopy (SCM x, SCM env) x = SCM_CDR (x); rnames = SCM_CAR (x); x = SCM_CDR (x); - rinits = scm_reverse (unmemocopy (SCM_CAR (x), env)); + rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env)); env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); bindings = build_binding_list (rnames, rinits); @@ -2368,7 +2363,7 @@ unmemocopy (SCM x, SCM env) rnames = SCM_CAR (x); env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); x = SCM_CDR (x); - rinits = scm_reverse (unmemocopy (SCM_CAR (x), env)); + rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env)); bindings = build_binding_list (rnames, rinits); z = scm_cons (bindings, SCM_UNSPECIFIED); @@ -2388,7 +2383,7 @@ unmemocopy (SCM x, SCM env) } y = z = scm_acons (SCM_CAR (b), unmemocar ( - scm_cons (unmemocopy (SCM_CADR (b), env), SCM_EOL), env), + scm_cons (scm_unmemocopy (SCM_CADR (b), env), SCM_EOL), env), SCM_UNSPECIFIED); env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); b = SCM_CDDR (b); @@ -2403,7 +2398,7 @@ unmemocopy (SCM x, SCM env) { SCM_SETCDR (z, scm_acons (SCM_CAR (b), unmemocar ( - scm_list_1 (unmemocopy (SCM_CADR (b), env)), env), + scm_list_1 (scm_unmemocopy (SCM_CADR (b), env)), env), SCM_UNSPECIFIED)); z = SCM_CDR (z); env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); @@ -2435,19 +2430,6 @@ unmemocopy (SCM x, SCM env) z = SCM_CAR (x); switch (SCM_ISYMNUM (z)) { - case (SCM_ISYMNUM (SCM_IM_DEFINE)): - { - SCM n; - x = SCM_CDR (x); - n = SCM_CAR (x); - z = scm_cons (n, SCM_UNSPECIFIED); - ls = scm_cons (scm_sym_define, z); - if (!SCM_NULLP (env)) - env = scm_cons (scm_cons (scm_cons (n, SCM_CAAR (env)), - SCM_CDAR (env)), - SCM_CDR (env)); - break; - } case (SCM_ISYMNUM (SCM_IM_APPLY)): ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED); goto loop; @@ -2472,7 +2454,7 @@ unmemocopy (SCM x, SCM env) /* appease the Sun compiler god: */ ; } default: - ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env), + ls = z = unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x), env), SCM_UNSPECIFIED), env); } @@ -2483,7 +2465,7 @@ loop: SCM form = SCM_CAR (x); if (!SCM_ISYMP (form)) { - SCM copy = scm_cons (unmemocopy (form, env), SCM_UNSPECIFIED); + SCM copy = scm_cons (scm_unmemocopy (form, env), SCM_UNSPECIFIED); SCM_SETCDR (z, unmemocar (copy, env)); z = SCM_CDR (z); } @@ -2500,17 +2482,6 @@ loop: return ls; } -SCM -scm_unmemocopy (SCM x, SCM env) -{ - if (!SCM_NULLP (env)) - /* Make a copy of the lowest frame to protect it from - modifications by SCM_IM_DEFINE */ - return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env))); - else - return unmemocopy (x, env); -} - /*****************************************************************************/ /*****************************************************************************/ @@ -3280,20 +3251,13 @@ dispatch: { - case (SCM_ISYMNUM (SCM_IM_DEFINE)): - /* Top level defines are handled directly by the memoizer and thus - * will never generate memoized code with SCM_IM_DEFINE. Internal - * defines which occur at valid positions will be transformed into - * letrec expressions. Thus, whenever the executor detects - * SCM_IM_DEFINE, this must come from an internal definition at an - * illegal position. */ - scm_misc_error (NULL, "Bad define placement", SCM_EOL); - - case (SCM_ISYMNUM (SCM_IM_APPLY)): + /* Evaluate the procedure to be applied. */ x = SCM_CDR (x); proc = EVALCAR (x, env); PREP_APPLY (proc, SCM_EOL); + + /* Evaluate the argument holding the list of arguments */ x = SCM_CDR (x); arg1 = EVALCAR (x, env); @@ -3349,7 +3313,7 @@ dispatch: { arg1 = val; proc = SCM_CDR (x); - proc = scm_eval_car (proc, env); + proc = EVALCAR (proc, env); PREP_APPLY (proc, scm_list_1 (arg1)); ENTER_APPLY; goto evap1; @@ -3679,8 +3643,7 @@ dispatch: SCM_SET_MACROEXP (debug); #endif arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x, - scm_cons (env, scm_listofnull)); - + scm_cons (env, scm_listofnull)); #ifdef DEVAL SCM_CLEAR_MACROEXP (debug); #endif @@ -4172,7 +4135,7 @@ evapply: /* inputs: x, proc */ arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); x = SCM_CDR(x); } - while (SCM_NIMP (x)); + while (!SCM_NULLP (x)); RETURN (arg1); case scm_tc7_rpsubr: if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) @@ -4185,7 +4148,7 @@ evapply: /* inputs: x, proc */ arg2 = arg1; x = SCM_CDR (x); } - while (SCM_NIMP (x)); + while (!SCM_NULLP (x)); RETURN (SCM_BOOL_T); case scm_tc7_lsubr_2: RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc))); @@ -5467,6 +5430,7 @@ SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0, } #undef FUNC_NAME + /* Eval does not take the second arg optionally. This is intentional * in order to be R5RS compatible, and to prepare for the new module * system, where we would like to make the choice of evaluation @@ -5482,7 +5446,6 @@ change_environment (void *data) scm_set_current_module (new_module); } - static void restore_environment (void *data) { From 5c26400756886a5abb4cb7e3d5179bb40b8f1469 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 21 Nov 2003 23:28:15 +0000 Subject: [PATCH 167/239] * Forgot to submit the Changelog last time. --- libguile/ChangeLog | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8c10ea7b3..c03a27621 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2003-11-22 Dirk Herrmann + + * eval.c (s_bad_define): New static identifier. + + (m_body): Fixed comment. + + (scm_m_define): Don't generate memoized code for definitions that + are not on the top level. As a consequence, no memoized code at + all is generated for definitions any more: Top level definitions + are executed immediately during memoization and internal + definitions are handled separately in m_expand_body. + + (scm_unmemocopy, unmemocopy): Removed code for unmemoizing + definitions. Consequently, there is no unmemoizing code any more + that might modify the environment. Thus, the old scm_unmemocopy + is removed and the old unmemocopy is renamed to scm_unmemocopy. + + (SCM_CEVAL): The SCM_IM_DEFINE keyword can no longer occur in + memoized code. Call EVALCAR for continuations. Prefer !SCM_NULLP + over SCM_NIMP in places, where the argument is known to be part of + a proper list. + 2003-11-21 Kevin Ryde * numbers.c (scm_abs): Allocate a new real only for negatives, as done From 6117838eb1b1977432bb34196bd2dda3ba437b03 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 24 Nov 2003 22:13:26 +0000 Subject: [PATCH 168/239] Remove empty (duplicate) "Jump Start" entry. --- doc/tutorial/ChangeLog | 5 ----- 1 file changed, 5 deletions(-) diff --git a/doc/tutorial/ChangeLog b/doc/tutorial/ChangeLog index 7dd52f5d7..227f6fc2a 100644 --- a/doc/tutorial/ChangeLog +++ b/doc/tutorial/ChangeLog @@ -15,11 +15,6 @@ * guile-tut.texi (Jump Start): Apply patch from M. Luedde on use of tail recursion to avoid stack overflow (with minor editing). -2002-07-14 Neil Jerram - - * guile-tut.texi (Jump Start): - (Jump Start): - 2001-11-18 Neil Jerram * guile-tut.texi (History of Guile and its motivations): Update From 8c3b23b3aa762b7031589218a8c6a3fe1dd732d7 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 24 Nov 2003 22:17:13 +0000 Subject: [PATCH 169/239] (Macros guile-snarf recognizes): Correction to GOOPS cross reference. --- doc/ref/tools.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/tools.texi b/doc/ref/tools.texi index 92fda23c0..738db5a25 100644 --- a/doc/ref/tools.texi +++ b/doc/ref/tools.texi @@ -226,8 +226,8 @@ is a expression suitable for initializing a new variable. For procedures, you can use @code{SCM_DEFINE} for most purposes. Use @code{SCM_PROC} along with @code{SCM_REGISTER_PROC} when you don't want to be bothered with docstrings. Use @code{SCM_GPROC} for generic -functions (@pxref{GOOPS,,,goops}). All procedures are declared with -return type @code{SCM}. +functions (@pxref{Creating Generic Functions,,, goops, GOOPS}). All +procedures are declared with return type @code{SCM}. For everything else, use the appropriate macro (@code{SCM_SYMBOL} for symbols, and so on). Without "_GLOBAL_", the declarations are From 16f9b79576f50c8280887477ed73e70e1c6ddff6 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 24 Nov 2003 22:25:53 +0000 Subject: [PATCH 170/239] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index b06ef0240..d8f3afcdb 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2003-11-25 Kevin Ryde + + * tools.texi (Macros guile-snarf recognizes): Correction to GOOPS + cross reference. + 2003-11-19 Marius Vollmer * scheme-data.texi: Include exact rationals. From 7dd3f110af455b75f8a1b5df3d8b3ea8af15eb1e Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 27 Nov 2003 20:54:05 +0000 Subject: [PATCH 171/239] Initial support for setting source breakpoints. --- emacs/ChangeLog | 26 +++++++ emacs/gds-client.scm | 35 ++++++++- emacs/gds.el | 176 ++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 233 insertions(+), 4 deletions(-) diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 9ba7a77ae..9930c7881 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,29 @@ +2003-11-27 Neil Jerram + + Initial support for setting source breakpoints... + + * gds.el (gds-handle-client-input): Handle new `breakpoint-set' + protocol. + (gds-breakpoint-face): New. + (gds-new-breakpoint-before-string): New. + (gds-new-breakpoint-after-string): New. + (gds-active-breakpoint-before-string): New. + (gds-active-breakpoint-after-string): New. + (gds-source-breakpoint-pos): New. + (gds-source-breakpoint-overlay-at): New. + (gds-set-source-breakpoint): New. + (gds-delete-source-breakpoint): New. + (gds-region-breakpoint-info): New. + (gds-eval-region): Include bpinfo in `eval' protocol. + (scheme-mode-map): New keys for setting and deleting breakpoints. + (gds-breakpoint-menu): New. + (gds-menu): Include `gds-breakpoint-menu'. + + * gds-client.scm (handle-instruction-1): Handle bpinfo protocol + field and pass to `gds-eval'. + (install-breakpoints): New. + (gds-eval): Call `install-breakpoints'. + 2003-11-19 Neil Jerram * gds-client.scm (start-async-gds-thread): Changes to fix diff --git a/emacs/gds-client.scm b/emacs/gds-client.scm index f4101189c..ea54c43df 100644 --- a/emacs/gds-client.scm +++ b/emacs/gds-client.scm @@ -21,6 +21,7 @@ #:use-module (ice-9 debugger behaviour) #:use-module (ice-9 debugger breakpoints) #:use-module (ice-9 debugger breakpoints procedural) + #:use-module (ice-9 debugger breakpoints source) #:use-module (ice-9 debugger state) #:use-module (ice-9 debugger utils) #:use-module (ice-9 optargs) @@ -347,7 +348,7 @@ decimal IP address where the UI server is running; default is (module-ref (resolve-module (cadr ins)) (caddr ins))) state) ((eval) - (apply (lambda (module port-name line column code) + (apply (lambda (module port-name line column bpinfo code) (with-input-from-string code (lambda () (set-port-filename! (current-input-port) port-name) @@ -357,7 +358,7 @@ decimal IP address where the UI server is running; default is (let loop ((results '()) (x (read))) (if (eof-object? x) (write-form `(eval-results ,@results)) - (loop (append results (gds-eval x m)) + (loop (append results (gds-eval x bpinfo m)) (read)))))))) (cdr ins)) state) @@ -402,7 +403,31 @@ decimal IP address where the UI server is running; default is state) (else state))) -(define (gds-eval x m) +(define (install-breakpoints x bpinfo) + (define (install-recursive x) + (if (list? x) + (begin + ;; Check source properties of x itself. + (let* ((infokey (cons (source-property x 'line) + (source-property x 'column))) + (bpentry (assoc infokey bpinfo))) + (if bpentry + (let ((bp (set-breakpoint! debug-here x x))) + ;; FIXME: Here should transfer properties from the + ;; old breakpoint with index (cdr bpentry) to the + ;; new breakpoint. (Or else provide an alternative + ;; to set-breakpoint! that reuses the same + ;; breakpoint.) + (write-form (list 'breakpoint-set + (source-property x 'filename) + (car infokey) + (cdr infokey) + (bp-number bp)))))) + ;; Check each of x's elements. + (for-each install-recursive x)))) + (install-recursive x)) + +(define (gds-eval x bpinfo m) ;; Consumer to accept possibly multiple values and present them for ;; Emacs as a list of strings. (define (value-consumer . values) @@ -411,6 +436,10 @@ decimal IP address where the UI server is running; default is (map (lambda (value) (with-output-to-string (lambda () (write value)))) values))) + ;; Before evaluation, set breakpoints in the read code as specified + ;; by bpinfo. + (install-breakpoints x bpinfo) + ;; Now do evaluation. (let ((value #f)) (let* ((do-eval (if m (lambda () diff --git a/emacs/gds.el b/emacs/gds.el index 709c81fd9..865f9ee5c 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -244,6 +244,35 @@ ((eq proc 'completion-result) (setq gds-completion-results (or (car args) t))) + (;; (breakpoint-set FILE LINE COLUMN INFO) - Breakpoint set. + (eq proc 'breakpoint-set) + (let ((file (nth 0 args)) + (line (nth 1 args)) + (column (nth 2 args)) + (info (nth 3 args))) + (with-current-buffer (find-file-noselect file) + (save-excursion + (goto-char (point-min)) + (or (zerop line) + (forward-line line)) + (move-to-column column) + (let ((os (overlays-at (point))) o) + (while os + (if (and (overlay-get (car os) 'gds-breakpoint-info) + (= (overlay-start (car os)) (point))) + (progn + (overlay-put (car os) + 'gds-breakpoint-info + info) + (overlay-put (car os) + 'before-string + gds-active-breakpoint-before-string) + (overlay-put (car os) + 'after-string + gds-active-breakpoint-after-string) + (setq os nil)) + (setq os (cdr os))))))))) + ))) @@ -799,6 +828,136 @@ are not readable by Emacs.") behaviour))))) +;;;; Scheme source breakpoints. + +(defcustom gds-breakpoint-face 'default + "*Face used to highlight the location of a source breakpoint. +Specifically, this face highlights the opening parenthesis of the +form where the breakpoint is set." + :type 'face + :group 'gds) + +(defcustom gds-new-breakpoint-before-string "" + "*String used to show the presence of a new source breakpoint. +`New' means that the breakpoint has been set but isn't yet known to +Guile because the containing code hasn't been reevaluated yet. +This string appears before the opening parenthesis of the form where +the breakpoint is set. If you prefer a marker to appear after the +opening parenthesis, make this string empty and use +`gds-new-breakpoint-after-string'." + :type 'string + :group 'gds) + +(defcustom gds-new-breakpoint-after-string "=?= " + "*String used to show the presence of a new source breakpoint. +`New' means that the breakpoint has been set but isn't yet known to +Guile because the containing code hasn't been reevaluated yet. +This string appears after the opening parenthesis of the form where +the breakpoint is set. If you prefer a marker to appear before the +opening parenthesis, make this string empty and use +`gds-new-breakpoint-before-string'." + :type 'string + :group 'gds) + +(defcustom gds-active-breakpoint-before-string "" + "*String used to show the presence of a source breakpoint. +`Active' means that the breakpoint is known to Guile. +This string appears before the opening parenthesis of the form where +the breakpoint is set. If you prefer a marker to appear after the +opening parenthesis, make this string empty and use +`gds-active-breakpoint-after-string'." + :type 'string + :group 'gds) + +(defcustom gds-active-breakpoint-after-string "=|= " + "*String used to show the presence of a source breakpoint. +`Active' means that the breakpoint is known to Guile. +This string appears after the opening parenthesis of the form where +the breakpoint is set. If you prefer a marker to appear before the +opening parenthesis, make this string empty and use +`gds-active-breakpoint-before-string'." + :type 'string + :group 'gds) + +(defun gds-source-breakpoint-pos () + "Return the position of the starting parenthesis of the innermost +Scheme pair around point." + (if (eq (char-syntax (char-after)) ?\() + (point) + (save-excursion + (condition-case nil + (while t (forward-sexp -1)) + (error)) + (forward-char -1) + (while (not (eq (char-syntax (char-after)) ?\()) + (forward-char -1)) + (point)))) + +(defun gds-source-breakpoint-overlay-at (pos) + "Return the source breakpoint overlay at POS, if any." + (let* (o (os (overlays-at pos))) + (while os + (if (and (overlay-get (car os) 'gds-breakpoint-info) + (= (overlay-start (car os)) pos)) + (setq o (car os) + os nil)) + (setq os (cdr os))) + o)) + +(defun gds-set-source-breakpoint () + (interactive) + (let* ((pos (gds-source-breakpoint-pos)) + (o (gds-source-breakpoint-overlay-at pos))) + (if o + (error "There is already a breakpoint here!") + (setq o (make-overlay pos (+ pos 1))) + (overlay-put o 'evaporate t) + (overlay-put o 'face gds-breakpoint-face) + (overlay-put o 'gds-breakpoint-info 0) + (overlay-put o 'before-string gds-new-breakpoint-before-string) + (overlay-put o 'after-string gds-new-breakpoint-after-string)))) + +(defun gds-delete-source-breakpoint () + (interactive) + (let* ((pos (gds-source-breakpoint-pos)) + (o (gds-source-breakpoint-overlay-at pos))) + (or o + (error "There is no breakpoint here to delete!")) + (delete-overlay o))) + +(defun gds-region-breakpoint-info (beg end) + "Return an alist of breakpoints in REGION. +The car of each alist element is a cons (LINE . COLUMN) giving the +source location of the breakpoint. The cdr is information describing +breakpoint properties. Currently `information' is just the breakpoint +index, for an existing Guile breakpoint, or 0 for a breakpoint that +isn't yet known to Guile." + (interactive "r") + (let ((os (overlays-in beg end)) + info o) + (while os + (setq o (car os) + os (cdr os)) + (if (overlay-get o 'gds-breakpoint-info) + (progn + (setq info + (cons (cons (save-excursion + (goto-char (overlay-start o)) + (cons (save-excursion + (beginning-of-line) + (count-lines (point-min) (point))) + (current-column))) + (overlay-get o 'gds-breakpoint-info)) + info)) + ;; Also now mark the breakpoint as `new'. It will become + ;; `active' (again) when we receive a notification from + ;; Guile that the breakpoint has been set. + (overlay-put o 'gds-breakpoint-info 0) + (overlay-put o 'before-string gds-new-breakpoint-before-string) + (overlay-put o 'after-string gds-new-breakpoint-after-string)))) + (nreverse info))) + + ;;;; Evaluating code. ;; The following commands send code for evaluation through the GDS TCP @@ -897,10 +1056,11 @@ region's code." (setq column (current-column)) ; 0-based (beginning-of-line) (setq line (count-lines (point-min) (point)))) ; 0-based - (gds-send (format "(%S eval %s %S %d %d %S)\n" + (gds-send (format "(%S eval %s %S %d %d %S %S)\n" client (if module (prin1-to-string module) "#f") port-name line column + (gds-region-breakpoint-info start end) (buffer-substring-no-properties start end))))) (defun gds-eval-expression (expr &optional client) @@ -1074,6 +1234,8 @@ Used for determining the default for the next `gds-load-file'.") (define-key scheme-mode-map "\C-hg" 'gds-help-symbol) (define-key scheme-mode-map "\C-h\C-g" 'gds-apropos) (define-key scheme-mode-map "\e\t" 'gds-complete-symbol) +(define-key scheme-mode-map "\C-x " 'gds-set-source-breakpoint) +(define-key scheme-mode-map "\C-x\e " 'gds-delete-source-breakpoint) ;;;; GDS (Guile Interaction) mode keymap and menu items. @@ -1139,6 +1301,16 @@ Used for determining the default for the next `gds-load-file'.") (define-key gds-debug-menu [eval] '(menu-item "Eval In This Frame..." gds-evaluate))) +(defvar gds-breakpoint-menu nil + "GDS breakpoint menu.") +(if gds-breakpoint-menu + nil + (setq gds-breakpoint-menu (make-sparse-keymap "Breakpoint")) + (define-key gds-breakpoint-menu [last-sexp] + '(menu-item "Delete Breakpoint" gds-delete-source-breakpoint)) + (define-key gds-breakpoint-menu [set] + '(menu-item "Set Breakpoint" gds-set-source-breakpoint))) + (defvar gds-eval-menu nil "GDS evaluation menu.") (if gds-eval-menu @@ -1194,6 +1366,8 @@ Used for determining the default for the next `gds-load-file'.") (define-key gds-menu [debug] `(menu-item "Debug" ,gds-debug-menu :enable (and gds-focus-client (gds-client-blocked)))) + (define-key gds-menu [breakpoint] + `(menu-item "Breakpoints" ,gds-breakpoint-menu :enable t)) (define-key gds-menu [eval] `(menu-item "Evaluate" ,gds-eval-menu :enable (or gds-buffers gds-autostart-captive))) From b645ea8c7eb2cb4bbe48e1ba90477b403e649211 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 30 Nov 2003 00:57:03 +0000 Subject: [PATCH 172/239] (scm_lreadr): Signal an error for invalid escape sequences in strings. Code cleanups too. --- libguile/read.c | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 2d391d973..718d4097b 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -499,6 +499,9 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) { case EOF: goto str_eof; + case '"': + case '\\': + break; case '\n': continue; case '0': @@ -524,28 +527,27 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) break; case 'x': { - int a, b, a_09 = 0, b_09 = 0, a_AF = 0, b_AF = 0, a_af = 0, - b_af = 0; + int a, b; a = scm_getc (port); if (a == EOF) goto str_eof; b = scm_getc (port); if (b == EOF) goto str_eof; - if ('0' <= a && a <= '9') a_09 = 1; - else if ('A' <= a && a <= 'F') a_AF = 1; - else if ('a' <= a && a <= 'f') a_af = 1; - if ('0' <= b && b <= '9') b_09 = 1; - else if ('A' <= b && b <= 'F') b_AF = 1; - else if ('a' <= b && b <= 'f') b_af = 1; - if ((a_09 || a_AF || a_af) && (b_09 || b_AF || b_af)) - c = (a_09? a - '0': a_AF? a - 'A' + 10: a - 'a' + 10) * 16 - + (b_09? b - '0': b_AF? b - 'A' + 10: b - 'a' + 10); - else - { - scm_ungetc (b, port); - scm_ungetc (a, port); - } + if ('0' <= a && a <= '9') a -= '0'; + else if ('A' <= a && a <= 'F') a = a - 'A' + 10; + else if ('a' <= a && a <= 'f') a = a - 'a' + 10; + else goto bad_escaped; + if ('0' <= b && b <= '9') b -= '0'; + else if ('A' <= b && b <= 'F') b = b - 'A' + 10; + else if ('a' <= b && b <= 'f') b = b - 'a' + 10; + else goto bad_escaped; + c = a * 16 + b; break; } + default: + bad_escaped: + scm_input_error(FUNC_NAME, port, + "illegal character in escape sequence: ~S", + scm_list_1 (SCM_MAKE_CHAR (c))); } SCM_STRING_CHARS (*tok_buf)[j] = c; ++j; From fea8e1423956c5fb9cec36e753cebf4fcfcc5ce5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 30 Nov 2003 00:57:14 +0000 Subject: [PATCH 173/239] (scm_iprin1): use \xNN hexadecimal sequences when writing control characters in strings. --- libguile/print.c | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index 9e7fe1c06..6f8545dd6 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -541,19 +541,28 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_putc ('"', port); for (i = 0; i < SCM_STRING_LENGTH (exp); ++i) - switch (SCM_STRING_CHARS (exp)[i]) - { - case '"': - case '\\': - scm_putc ('\\', port); - default: - scm_putc (SCM_STRING_CHARS (exp)[i], port); - } + { + unsigned char ch = SCM_STRING_CHARS (exp)[i]; + if ((ch < 32 && ch != '\n') || (127 <= ch && ch < 148)) + { + static char const hex[]="0123456789abcdef"; + scm_putc ('\\', port); + scm_putc ('x', port); + scm_putc (hex [ch / 16], port); + scm_putc (hex [ch % 16], port); + } + else + { + if (ch == '"' || ch == '\\') + scm_putc ('\\', port); + scm_putc (ch, port); + } + } scm_putc ('"', port); - break; } else - scm_lfwrite (SCM_STRING_CHARS (exp), SCM_STRING_LENGTH (exp), port); + scm_lfwrite (SCM_STRING_CHARS (exp), SCM_STRING_LENGTH (exp), + port); break; case scm_tc7_symbol: if (SCM_SYMBOL_INTERNED_P (exp)) From 96dfea7d7e2663a84e04950f58484ee9ec36f640 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 30 Nov 2003 00:58:25 +0000 Subject: [PATCH 174/239] It's "#\\space", not "#\space". --- test-suite/tests/syntax.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index e7a6458fb..b01c1633b 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -703,7 +703,7 @@ (eval '(set! #f #t) (interaction-environment))) - (pass-if-exception "(set! #\space #f)" + (pass-if-exception "(set! #\\space #f)" exception:bad-variable (eval '(set! #\space #f) (interaction-environment))))) From 535f2a516a31d6ca7312e328cc9d0b76f7e19c0d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 30 Nov 2003 00:59:40 +0000 Subject: [PATCH 175/239] (scm_logand): It's "#b...", not "#\b...". --- libguile/numbers.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 8e78c56d6..50ada27a1 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1164,7 +1164,7 @@ SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, "@lisp\n" "(logand) @result{} -1\n" "(logand 7) @result{} 7\n" - "(logand #b111 #b011 #\b001) @result{} 1\n" + "(logand #b111 #b011 #b001) @result{} 1\n" "@end lisp") #define FUNC_NAME s_scm_logand { From 2297981ddefd43c9c7ae1fc8d47243c721c14683 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 30 Nov 2003 01:00:16 +0000 Subject: [PATCH 176/239] *** empty log message *** --- libguile/ChangeLog | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c03a27621..7df13061e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,20 @@ +2003-11-30 Marius Vollmer + + * numbers.c (scm_logand): It's "#b...", not "#\b...". + + From Paul Jarc: + + * read.c (scm_lreadr): Signal an error for invalid escape + sequences in strings. Code cleanups too. + + * print.c (scm_iprin1): use \xNN hexadecimal sequences when + writing control characters in strings. + +2003-11-21 Marius Vollmer + + * ports.c (scm_drain_input): Bug fix: only access the port after + checking that it indeed is one. + 2003-11-22 Dirk Herrmann * eval.c (s_bad_define): New static identifier. From 2d0b85acf860cc48c9d66be21c564f2c21305569 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 30 Nov 2003 12:41:34 +0000 Subject: [PATCH 177/239] * modules.c (module_variable): Fixed (and thus simplified) the definition of SCM_BOUND_THING_P to reflect the fact that since after the 1.4 series of guile, obarrays only hold variable objects. --- libguile/ChangeLog | 7 +++++++ libguile/modules.c | 3 +-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7df13061e..11b27384f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2003-11-30 Dirk Herrmann + + * modules.c (module_variable): Fixed (and thus simplified) the + definition of SCM_BOUND_THING_P to reflect the fact that since + after the 1.4 series of guile, obarrays only hold variable + objects. + 2003-11-30 Marius Vollmer * numbers.c (scm_logand): It's "#b...", not "#\b...". diff --git a/libguile/modules.c b/libguile/modules.c index f034426ab..7d578dcd6 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -277,8 +277,7 @@ static SCM module_variable (SCM module, SCM sym) { #define SCM_BOUND_THING_P(b) \ - (!SCM_FALSEP(b) && \ - (!SCM_VARIABLEP(b) || !SCM_UNBNDP (SCM_VARIABLE_REF (b)))) + (SCM_VARIABLEP (b) && !SCM_UNBNDP (SCM_VARIABLE_REF (b))) /* 1. Check module obarray */ SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED); From f1efbdf3f119cfede7a544d1a723dd926a08936f Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Mon, 1 Dec 2003 18:49:38 +0000 Subject: [PATCH 178/239] (snarfcppopts): Added -I$(top_srcdir). --- test-suite/ChangeLog | 4 ++++ test-suite/standalone/Makefile.am | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 1b3ea457a..6ce29d21a 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2003-12-01 Mikael Djurfeldt + + * standalone/Makefile.am (snarfcppopts): Added -I$(top_srcdir). + 2003-11-19 Rob Browning * standalone/test-system-cmds: new test. diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index 953b63763..d9969f349 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -13,7 +13,8 @@ test_cflags := \ -I$(top_srcdir) \ -I$(top_srcdir)/libguile-ltdl $(EXTRA_DEFS) -snarfcppopts = $(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS) +snarfcppopts = \ + $(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS) -I$(top_srcdir) %.x: %.c ${top_builddir}/libguile/guile-snarf -o $@ $< $(snarfcppopts) From 110348aee92a143f66a905f9b631d190e374e15e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Dec 2003 21:12:20 +0000 Subject: [PATCH 179/239] (count): Rewrite in C, avoiding non-tail recursion. --- srfi/srfi-1.c | 103 ++++++++++++++++++++++++++++++++++++++++++++++++ srfi/srfi-1.h | 1 + srfi/srfi-1.scm | 19 --------- 3 files changed, 104 insertions(+), 19 deletions(-) diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index 76d5678af..c50b47850 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -71,6 +71,109 @@ SCM_REGISTER_PROC (s_srfi1_concatenate, "concatenate", 1, 0, 0, scm_append); SCM_REGISTER_PROC (s_srfi1_concatenate_x, "concatenate!", 1, 0, 0, scm_append_x); +SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1, + (SCM pred, SCM lst1, SCM rest), + "Return a count of the number of times @var{pred} returns true\n" + "when called on elements from the given lists.\n" + "\n" + "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n" + "@var{elem1} @dots{} @var{elemN})}, each element being from the\n" + "corresponding @var{lst1} @dots{} @var{lstN}. The first call is\n" + "with the first element of each list, the second with the second\n" + "element from each, and so on.\n" + "\n" + "Counting stops when the end of the shortest list is reached.\n" + "At least one list must be non-circular.") +#define FUNC_NAME s_scm_srfi1_count +{ + long count; + SCM_VALIDATE_REST_ARGUMENT (rest); + + count = 0; + + if (SCM_NULLP (rest)) + { + /* one list */ + scm_t_trampoline_1 pred_tramp; + pred_tramp = scm_trampoline_1 (pred); + SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME); + + for ( ; SCM_CONSP (lst1); lst1 = SCM_CDR (lst1)) + count += ! SCM_FALSEP (pred_tramp (pred, SCM_CAR (lst1))); + + end_lst1: + SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst1), lst1, SCM_ARG2, FUNC_NAME, + "list"); + } + else if (SCM_CONSP (rest) && SCM_NULLP (SCM_CDR (rest))) + { + /* two lists */ + scm_t_trampoline_2 pred_tramp; + SCM lst2; + + pred_tramp = scm_trampoline_2 (pred); + SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME); + + lst2 = SCM_CAR (rest); + for (;;) + { + if (! SCM_CONSP (lst1)) + goto end_lst1; + if (! SCM_CONSP (lst2)) + { + SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst2), lst2, SCM_ARG3, + FUNC_NAME, "list"); + break; + } + count += ! SCM_FALSEP (pred_tramp + (pred, SCM_CAR (lst1), SCM_CAR (lst2))); + lst1 = SCM_CDR (lst1); + lst2 = SCM_CDR (lst2); + } + } + else + { + /* three or more lists */ + SCM lstlst, args, l, a, lst; + int argnum; + + /* lstlst is a list of the list arguments */ + lstlst = scm_cons (lst1, rest); + + /* args is the argument list to pass to pred, same length as lstlst, + re-used for each call */ + args = SCM_EOL; + for (l = lstlst; SCM_CONSP (l); l = SCM_CDR (l)) + args = scm_cons (SCM_BOOL_F, args); + + for (;;) + { + /* first elem of each list in lstlst into args, and step those + lstlst entries onto their next element */ + for (l = lstlst, a = args, argnum = 2; + SCM_CONSP (l); + l = SCM_CDR (l), a = SCM_CDR (a), argnum++) + { + lst = SCM_CAR (l); /* list argument */ + if (! SCM_CONSP (lst)) + { + SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, + argnum, FUNC_NAME, "list"); + goto done; + } + SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */ + SCM_SETCAR (l, SCM_CDR (lst)); /* keep rest of lst */ + } + + count += ! SCM_FALSEP (scm_apply (pred, args, SCM_EOL)); + } + } + done: + return SCM_MAKINUM (count); +} +#undef FUNC_NAME + + SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0, (SCM x, SCM lst, SCM pred), "Return a list containing the elements of @var{lst} but with\n" diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h index 3d23c0d4a..e53fd4e63 100644 --- a/srfi/srfi-1.h +++ b/srfi/srfi-1.h @@ -32,6 +32,7 @@ # define SCM_SRFI1_API extern #endif +SCM_SRFI1_API SCM scm_srfi1_count (SCM pred, SCM lst1, SCM rest); SCM_SRFI1_API SCM scm_srfi1_delete (SCM x, SCM lst, SCM pred); SCM_SRFI1_API SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred); SCM_SRFI1_API SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred); diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index b22806ad2..171c98c1b 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -442,25 +442,6 @@ (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l) (map1 fifth l))) -(define (count pred clist1 . rest) - (if (null? rest) - (count1 pred clist1) - (let lp ((lists (cons clist1 rest))) - (cond ((any1 null? lists) - 0) - (else - (if (apply pred (map1 car lists)) - (+ 1 (lp (map1 cdr lists))) - (lp (map1 cdr lists)))))))) - -(define (count1 pred clist) - (let lp ((result 0) (rest clist)) - (if (null? rest) - result - (if (pred (car rest)) - (lp (+ 1 result) (cdr rest)) - (lp result (cdr rest)))))) - ;;; Fold, unfold & map (define (fold kons knil list1 . rest) From c6424115feccb175690eab6fd84e1cb1ef441e61 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Dec 2003 21:13:42 +0000 Subject: [PATCH 180/239] (map!): Define as an alias for map, previous definition was not tail-recursive. --- srfi/srfi-1.scm | 18 ++---------------- 1 file changed, 2 insertions(+), 16 deletions(-) diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index 171c98c1b..a4ce2addb 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -553,22 +553,8 @@ '() (append! (apply f (map1 car l)) (lp (map1 cdr l))))))) -(define (map! f list1 . rest) - (if (null? rest) - (let lp ((l list1)) - (if (null? l) - '() - (begin - (set-car! l (f (car l))) - (set-cdr! l (lp (cdr l))) - l))) - (let lp ((l (cons list1 rest)) (res list1)) - (if (any1 null? l) - '() - (begin - (set-car! res (apply f (map1 car l))) - (set-cdr! res (lp (map1 cdr l) (cdr res))) - res))))) +;; OPTIMIZE-ME: Re-use cons cells of list1 +(define map! map) (define (pair-for-each f clist1 . rest) (if (null? rest) From b35072cde669a0e34a6005284f7e9175bbc76f58 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Dec 2003 21:14:03 +0000 Subject: [PATCH 181/239] *** empty log message *** --- srfi/ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index d41251149..110d02933 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,11 @@ +2003-12-03 Kevin Ryde + + * srfi-1.c, srfi-1.h, srfi-1.scm (count): Rewrite in C, avoiding + non-tail recursion. + + * srfi-1.scm (map!): Define as an alias for map, previous definition + was not tail-recursive. + 2003-08-23 Kevin Ryde * srfi-1.c, srfi-1.h, srfi-1.scm (list-copy): New function, derived From f39032937e95cc30060245848c3e51b52fb10685 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Dec 2003 21:17:33 +0000 Subject: [PATCH 182/239] (count): New tests. --- test-suite/tests/srfi-1.test | 161 +++++++++++++++++++++++++++++++++++ 1 file changed, 161 insertions(+) diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index f3f898bf5..236905e28 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -85,6 +85,167 @@ (with-test-prefix "concatenate!" (common-tests concatenate! #f))) +;; +;; count +;; + +(with-test-prefix "count" + (pass-if-exception "no args" exception:wrong-num-args + (count)) + + (pass-if-exception "one arg" exception:wrong-num-args + (count noop)) + + (with-test-prefix "one list" + (define (or1 x) + x) + + (pass-if "empty list" (= 0 (count or1 '()))) + + (pass-if-exception "pred arg count 0" exception:wrong-type-arg + (count (lambda () x) '(1 2 3))) + (pass-if-exception "pred arg count 2" exception:wrong-type-arg + (count (lambda (x y) x) '(1 2 3))) + + (pass-if-exception "improper 1" exception:wrong-type-arg + (count or1 1)) + (pass-if-exception "improper 2" exception:wrong-type-arg + (count or1 '(1 . 2))) + (pass-if-exception "improper 3" exception:wrong-type-arg + (count or1 '(1 2 . 3))) + + (pass-if (= 0 (count or1 '(#f)))) + (pass-if (= 1 (count or1 '(#t)))) + + (pass-if (= 0 (count or1 '(#f #f)))) + (pass-if (= 1 (count or1 '(#f #t)))) + (pass-if (= 1 (count or1 '(#t #f)))) + (pass-if (= 2 (count or1 '(#t #t)))) + + (pass-if (= 0 (count or1 '(#f #f #f)))) + (pass-if (= 1 (count or1 '(#f #f #t)))) + (pass-if (= 1 (count or1 '(#t #f #f)))) + (pass-if (= 2 (count or1 '(#t #f #t)))) + (pass-if (= 3 (count or1 '(#t #t #t))))) + + (with-test-prefix "two lists" + (define (or2 x y) + (or x y)) + + (pass-if "arg order" + (= 1 (count (lambda (x y) + (and (= 1 x) + (= 2 y))) + '(1) '(2)))) + + (pass-if "empty lists" (= 0 (count or2 '() '()))) + + (pass-if-exception "pred arg count 0" exception:wrong-type-arg + (count (lambda () #t) '(1 2 3) '(1 2 3))) + (pass-if-exception "pred arg count 1" exception:wrong-type-arg + (count (lambda (x) x) '(1 2 3) '(1 2 3))) + (pass-if-exception "pred arg count 3" exception:wrong-type-arg + (count (lambda (x y z) x) '(1 2 3) '(1 2 3))) + + (pass-if-exception "improper first 1" exception:wrong-type-arg + (count or2 1 '(1 2 3))) + (pass-if-exception "improper first 2" exception:wrong-type-arg + (count or2 '(1 . 2) '(1 2 3))) + (pass-if-exception "improper first 3" exception:wrong-type-arg + (count or2 '(1 2 . 3) '(1 2 3))) + + (pass-if-exception "improper second 1" exception:wrong-type-arg + (count or2 '(1 2 3) 1)) + (pass-if-exception "improper second 2" exception:wrong-type-arg + (count or2 '(1 2 3) '(1 . 2))) + (pass-if-exception "improper second 3" exception:wrong-type-arg + (count or2 '(1 2 3) '(1 2 . 3))) + + (pass-if (= 0 (count or2 '(#f) '(#f)))) + (pass-if (= 1 (count or2 '(#t) '(#f)))) + (pass-if (= 1 (count or2 '(#f) '(#t)))) + + (pass-if (= 0 (count or2 '(#f #f) '(#f #f)))) + (pass-if (= 1 (count or2 '(#t #f) '(#t #f)))) + (pass-if (= 2 (count or2 '(#t #t) '(#f #f)))) + (pass-if (= 2 (count or2 '(#t #f) '(#f #t)))) + + (with-test-prefix "stop shortest" + (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t)))) + (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t)))) + (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t)))) + (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t)))))) + + (with-test-prefix "three lists" + (define (or3 x y z) + (or x y z)) + + (pass-if "arg order" + (= 1 (count (lambda (x y z) + (and (= 1 x) + (= 2 y) + (= 3 z))) + '(1) '(2) '(3)))) + + (pass-if "empty lists" (= 0 (count or3 '() '() '()))) + + ;; currently bad pred argument gives wrong-num-args when 3 or more + ;; lists, as opposed to wrong-type-arg for 1 or 2 lists + (pass-if-exception "pred arg count 0" exception:wrong-num-args + (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3))) + (pass-if-exception "pred arg count 2" exception:wrong-num-args + (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) )) + (pass-if-exception "pred arg count 4" exception:wrong-num-args + (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3))) + + (pass-if-exception "improper first 1" exception:wrong-type-arg + (count or3 1 '(1 2 3) '(1 2 3))) + (pass-if-exception "improper first 2" exception:wrong-type-arg + (count or3 '(1 . 2) '(1 2 3) '(1 2 3))) + (pass-if-exception "improper first 3" exception:wrong-type-arg + (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3))) + + (pass-if-exception "improper second 1" exception:wrong-type-arg + (count or3 '(1 2 3) 1 '(1 2 3))) + (pass-if-exception "improper second 2" exception:wrong-type-arg + (count or3 '(1 2 3) '(1 . 2) '(1 2 3))) + (pass-if-exception "improper second 3" exception:wrong-type-arg + (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3))) + + (pass-if-exception "improper third 1" exception:wrong-type-arg + (count or3 '(1 2 3) '(1 2 3) 1)) + (pass-if-exception "improper third 2" exception:wrong-type-arg + (count or3 '(1 2 3) '(1 2 3) '(1 . 2))) + (pass-if-exception "improper third 3" exception:wrong-type-arg + (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3))) + + (pass-if (= 0 (count or3 '(#f) '(#f) '(#f)))) + (pass-if (= 1 (count or3 '(#t) '(#f) '(#f)))) + (pass-if (= 1 (count or3 '(#f) '(#t) '(#f)))) + (pass-if (= 1 (count or3 '(#f) '(#f) '(#t)))) + + (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f)))) + + (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f)))) + (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f)))) + (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f)))) + (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f)))) + (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f)))) + (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t)))) + + (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f)))) + (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f)))) + (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t)))) + (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t)))) + + (with-test-prefix "stop shortest" + (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t)))) + (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t)))) + (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '()))) + + (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t)))) + (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t)))) + (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t))))))) ;; ;; delete and delete! From dd5130cadf7252f0bba072109ebfa20cd34a1602 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Dec 2003 21:21:14 +0000 Subject: [PATCH 183/239] (scm_make_ratio): Check for numerator equal to SCM_MOST_NEGATIVE_FIXNUM and bignum denominator the negative of that, giving integer -1. --- libguile/numbers.c | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 50ada27a1..31bd94c32 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -357,18 +357,26 @@ scm_make_ratio (SCM numerator, SCM denominator) */ if (SCM_INUMP (numerator)) { + long x = SCM_INUM (numerator); if (SCM_EQ_P (numerator, SCM_INUM0)) return SCM_INUM0; if (SCM_INUMP (denominator)) { - long x, y; - x = SCM_INUM (numerator); + long y; y = SCM_INUM (denominator); if (x == y) return SCM_MAKINUM(1); if ((x % y) == 0) return SCM_MAKINUM (x / y); } + else + { + /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative + of that value for the denominator, as a bignum. */ + long abs_x = (x >= 0 ? x : -x); + if (mpz_cmpabs_ui (SCM_I_BIG_MPZ (denominator), abs_x) == 0) + return SCM_MAKINUM(-1); + } } else if (SCM_BIGP (numerator)) { From 76903a316a0a2ba6b52a4dcdb7465ec7bd4967cd Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Dec 2003 21:23:31 +0000 Subject: [PATCH 184/239] (abs): Add a few more tests. --- test-suite/tests/numbers.test | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 82085036b..323ad8675 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -172,9 +172,13 @@ (pass-if (= 1 (abs -1))) (pass-if (= (+ fixnum-max 1) (abs (+ fixnum-max 1)))) (pass-if (= (+ (- fixnum-min) 1) (abs (- fixnum-min 1)))) - (pass-if (positive? (abs 1.0))) - (pass-if (positive? (abs -1.0)))) - + (pass-if (= 0.0 (abs 0.0))) + (pass-if (= 1.0 (abs 1.0))) + (pass-if (= 1.0 (abs -1.0))) + (pass-if (nan? (abs +nan.0))) + (pass-if (= +inf.0 (abs +inf.0))) + (pass-if (= +inf.0 (abs -inf.0)))) + ;;; ;;; quotient ;;; From 64b4cbe4f37fd266b7b3b0610e1ca78a81523e96 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Dec 2003 21:24:58 +0000 Subject: [PATCH 185/239] Exercise most-negative-fixnum over -ve of most-negative-fixnum. --- test-suite/tests/fractions.test | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test-suite/tests/fractions.test b/test-suite/tests/fractions.test index 90320f247..47168bf64 100644 --- a/test-suite/tests/fractions.test +++ b/test-suite/tests/fractions.test @@ -25,6 +25,10 @@ (testeqv 3/4 3000000000000/4000000000000) (testeqv 3 3/1) (test= 1/3 (/ 1.0 3.0)) + + (test= -1 (/ most-negative-fixnum (- most-negative-fixnum))) + (testeq #t (integer? (/ most-negative-fixnum (- most-negative-fixnum)))) + (testeqv (+ 1/4 1/2) 3/4) (testeqv (* 1/4 2/3) 1/6) (testeqv (/ 1/4 2/3) 3/8) From 2fa2d8793748b5e3dfc04cea28b0d08ada5aa3f8 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Dec 2003 21:27:13 +0000 Subject: [PATCH 186/239] (scm_real_part): Return fraction unchanged rather than converting to flonum. --- libguile/numbers.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 31bd94c32..c3c4e3c90 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4980,7 +4980,7 @@ scm_real_part (SCM z) else if (SCM_COMPLEXP (z)) return scm_make_real (SCM_COMPLEX_REAL (z)); else if (SCM_FRACTIONP (z)) - return scm_make_real (scm_i_fraction2double (z)); + return z; else SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part); } From fc5f3d51c1b13e6c0e5f798c3dd7e2d4e979719b Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Dec 2003 21:32:43 +0000 Subject: [PATCH 187/239] (real-part): Expect fraction return, not converted to flonum. --- test-suite/tests/fractions.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/tests/fractions.test b/test-suite/tests/fractions.test index 47168bf64..02bfa22e8 100644 --- a/test-suite/tests/fractions.test +++ b/test-suite/tests/fractions.test @@ -96,7 +96,7 @@ (testeqv (expt 1/2 2) 1/4) (testeqv (expt 2.0 1/2) (sqrt 2)) (testeqv (expt 1/2 2.0) 1/4) - (testeqv (real-part 3/4) .75) + (testeqv (real-part 3/4) 3/4) (testeqv (imag-part 3/4) 0) (testeqv (numerator 3/4) 3) (testeqv (denominator 3/4) 4) From 084b1d8eecc543ab6f523c100913bd32db9acf93 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Dec 2003 21:36:39 +0000 Subject: [PATCH 188/239] (scm_less_p): Remove spurious xisnan from frac+big case. --- libguile/numbers.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index c3c4e3c90..58cd1e8cb 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3162,8 +3162,6 @@ scm_less_p (SCM x, SCM y) else if (SCM_BIGP (y)) { int cmp; - if (xisnan (SCM_REAL_VALUE (x))) - return SCM_BOOL_F; cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), scm_i_fraction2double (x)); scm_remember_upto_here_1 (y); return SCM_BOOL (cmp > 0); From caff34d4faf858b5620e7bbea9a545c6502cc14c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Dec 2003 21:38:04 +0000 Subject: [PATCH 189/239] *** empty log message *** --- libguile/ChangeLog | 11 +++++++++++ test-suite/ChangeLog | 12 ++++++++++++ 2 files changed, 23 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 11b27384f..f56bec960 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2003-12-03 Kevin Ryde + + * numbers.c (scm_less_p): Remove spurious xisnan from frac+big case. + + * numbers.c (scm_make_ratio): Check for numerator equal to + SCM_MOST_NEGATIVE_FIXNUM and bignum denominator the negative of that, + giving integer -1. + + * numbers.c (scm_real_part): Return fraction unchanged rather than + converting to flonum. + 2003-11-30 Dirk Herrmann * modules.c (module_variable): Fixed (and thus simplified) the diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 6ce29d21a..be13d3729 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,15 @@ +2003-12-03 Kevin Ryde + + * tests/fractions.test: Exercise most-negative-fixnum over -ve of + most-negative-fixnum. + + * tests/fractions.test (real-part): Expect fraction return, not + converted to flonum. + + * tests/numbers.test (abs): Add a few more tests. + + * tests/srfi-1.test (count): New tests. + 2003-12-01 Mikael Djurfeldt * standalone/Makefile.am (snarfcppopts): Added -I$(top_srcdir). From eb1f89f652f2606dba3ae6ccb74363c412eb952a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 26 Dec 2003 19:00:47 +0000 Subject: [PATCH 190/239] Find a suitable type for the new scm_t_intmax and scm_t_uintmax. --- configure.in | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/configure.in b/configure.in index 00724b88c..740acf725 100644 --- a/configure.in +++ b/configure.in @@ -296,6 +296,8 @@ if test "$ac_cv_header_stdint_h" = yes; then AC_CHECK_TYPE([uint32_t],[scm_stdint_has_uint32=1],,[#include ]) AC_CHECK_TYPE([int64_t],[scm_stdint_has_int64=1],,[#include ]) AC_CHECK_TYPE([uint64_t],[scm_stdint_has_uint64=1],,[#include ]) + AC_CHECK_TYPE([intmax_t],[scm_stdint_has_intmax=1],,[#include ]) + AC_CHECK_TYPE([uintmax_t],[scm_stdint_has_uintmax=1],,[#include ]) fi # so we don't get confused by the cache (wish there was a better way @@ -309,6 +311,8 @@ unset ac_cv_type_int32_t unset ac_cv_type_uint32_t unset ac_cv_type_int64_t unset ac_cv_type_uint64_t +unset ac_cv_type_intmax_t +unset ac_cv_type_uintmax_t ### See what's provided by inttypes.h if test "$ac_cv_header_inttypes_h" = yes; then @@ -320,6 +324,8 @@ if test "$ac_cv_header_inttypes_h" = yes; then AC_CHECK_TYPE([uint32_t],[scm_inttypes_has_uint32=1],,[#include ]) AC_CHECK_TYPE([int64_t],[scm_inttypes_has_int64=1],,[#include ]) AC_CHECK_TYPE([uint64_t],[scm_inttypes_has_uint64=1],,[#include ]) + AC_CHECK_TYPE([intmax_t],[scm_inttypes_has_intmax=1],,[#include ]) + AC_CHECK_TYPE([uintmax_t],[scm_inttypes_has_uintmax=1],,[#include ]) fi # Try hard to find definitions for some required scm_t_*int* types. @@ -470,6 +476,48 @@ else fi AC_SUBST([SCM_I_GSC_T_UINT64]) +### Required type scm_t_intmax +### +### We try 'intmax_t', '__int64', 'long long' in this order. When +### none of them is available, we use 'long'. +### +SCM_I_GSC_T_INTMAX=0 +if test "$scm_stdint_has_intmax"; then + SCM_I_GSC_T_INTMAX='"intmax_t"' + SCM_I_GSC_NEEDS_STDINT_H=1 +elif test "$scm_inttypes_has_intmax"; then + SCM_I_GSC_T_INTMAX='"intmax_t"' + SCM_I_GSC_NEEDS_INTTYPES_H=1 +elif test "$ac_cv_sizeof___int64" -ne 0; then + SCM_I_GSC_T_INTMAX='"__int64"' +elif test "$ac_cv_sizeof_long_long" -ne 0; then + SCM_I_GSC_T_INTMAX='"long long"' +else + SCM_I_GSC_T_INTMAX='"long"' +fi +AC_SUBST([SCM_I_GSC_T_INTMAX]) + +### Required type scm_t_uintmax +### +### We try 'uintmax_t', 'unsigned __int64', 'unsigned long long' in +### this order. When none of them is available, we use 'unsigned long'. +### +SCM_I_GSC_T_UINTMAX=0 +if test "$scm_stdint_has_uintmax"; then + SCM_I_GSC_T_UINTMAX='"uintmax_t"' + SCM_I_GSC_NEEDS_STDINT_H=1 +elif test "$scm_inttypes_has_uintmax"; then + SCM_I_GSC_T_UINTMAX='"uintmax_t"' + SCM_I_GSC_NEEDS_INTTYPES_H=1 +elif test "$ac_cv_sizeof_unsigned___int64" -ne 0; then + SCM_I_GSC_T_UINTMAX='"unsigned __int64"' +elif test "$ac_cv_sizeof_unsigned_long_long" -ne 0; then + SCM_I_GSC_T_UINTMAX='"unsigned long long"' +else + SCM_I_GSC_T_UINTMAX='"unsigned long"' +fi +AC_SUBST([SCM_I_GSC_T_UINTMAX]) + AC_SUBST([SCM_I_GSC_NEEDS_STDINT_H]) AC_SUBST([SCM_I_GSC_NEEDS_INTTYPES_H]) From fc54d9376d2bd1542022776c18d27b2ad54439e2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 26 Dec 2003 19:04:55 +0000 Subject: [PATCH 191/239] Arrange for scm_t_intmax and scm_t_uintmax to be defined in scmconfig.h --- libguile/gen-scmconfig.c | 2 ++ libguile/gen-scmconfig.h.in | 2 ++ 2 files changed, 4 insertions(+) diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 481b4ee6a..3fd2df569 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -300,6 +300,8 @@ main (int argc, char *argv[]) pf ("typedef %s scm_t_uint16;\n", SCM_I_GSC_T_UINT16); pf ("typedef %s scm_t_int32;\n", SCM_I_GSC_T_INT32); pf ("typedef %s scm_t_uint32;\n", SCM_I_GSC_T_UINT32); + pf ("typedef %s scm_t_intmax;\n", SCM_I_GSC_T_INTMAX); + pf ("typedef %s scm_t_uintmax;\n", SCM_I_GSC_T_UINTMAX); pf ("\n"); pf ("/* 64-bit integer -- if available SCM_HAVE_T_INT64 will be 1 and\n" diff --git a/libguile/gen-scmconfig.h.in b/libguile/gen-scmconfig.h.in index 2148b6026..f48288672 100644 --- a/libguile/gen-scmconfig.h.in +++ b/libguile/gen-scmconfig.h.in @@ -23,6 +23,8 @@ #define SCM_I_GSC_T_UINT32 @SCM_I_GSC_T_UINT32@ #define SCM_I_GSC_T_INT64 @SCM_I_GSC_T_INT64@ #define SCM_I_GSC_T_UINT64 @SCM_I_GSC_T_UINT64@ +#define SCM_I_GSC_T_INTMAX @SCM_I_GSC_T_INTMAX@ +#define SCM_I_GSC_T_UINTMAX @SCM_I_GSC_T_UINTMAX@ #define SCM_I_GSC_T_PTRDIFF @SCM_I_GSC_T_PTRDIFF@ #define SCM_I_GSC_USE_PTHREAD_THREADS @SCM_I_GSC_USE_PTHREAD_THREADS@ #define SCM_I_GSC_USE_NULL_THREADS @SCM_I_GSC_USE_NULL_THREADS@ From 89fcf1b4aaad96028077ea7cce01998f8530bb55 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 26 Dec 2003 19:09:03 +0000 Subject: [PATCH 192/239] *** empty log message *** --- ChangeLog | 5 +++++ NEWS | 6 ++++++ libguile/ChangeLog | 5 +++++ test-suite/ChangeLog | 9 +++++++++ 4 files changed, 25 insertions(+) diff --git a/ChangeLog b/ChangeLog index 1f4a948f1..9de813d60 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2003-12-26 Marius Vollmer + + * configure.in: Find a suitable type for the new scm_t_intmax and + scm_t_uintmax. + 2003-11-17 Rob Browning * configure.in: rewrite ALLOCA related code as multiple lines so diff --git a/NEWS b/NEWS index eda213135..663d8608c 100644 --- a/NEWS +++ b/NEWS @@ -578,6 +578,12 @@ starting the week. * Changes to the C interface +** New types scm_t_intmax and scm_t_uintmax. + +On platforms that have them, these types are identical to intmax_t and +uintmax_t, respectively. On other platforms, they are identical to +the largest integer types that Guile knows about. + ** Many public #defines with generic names have been made private. #defines with generic names like HAVE_FOO or SIZEOF_FOO have been made diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f56bec960..929e3d881 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-12-26 Marius Vollmer + + * gen-scmconfig.h.in, gen-scmconfig.c: Arrange for scm_t_intmax + and scm_t_uintmax to be defined in scmconfig.h + 2003-12-03 Kevin Ryde * numbers.c (scm_less_p): Remove spurious xisnan from frac+big case. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index be13d3729..1334e6d78 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,12 @@ +2003-11-30 Marius Vollmer + + * tests/syntax.test: It's "#\\space", not "#\space". + +2003-11-21 Marius Vollmer + + * tests/numbers.test: #e1.2 is now exactly 12/10. Expect + exceptions when calling inexact? with a non-number. + 2003-12-03 Kevin Ryde * tests/fractions.test: Exercise most-negative-fixnum over -ve of From ea6ea01bcabd78d186baa4e0e5c35061db761324 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 21:03:02 +0000 Subject: [PATCH 193/239] (SRFI-1 Searching, SRFI-1 Deleting, SRFI-1 Association Lists): Note how member, delete, delete! and assoc extend the corresponding core functions. --- doc/ref/srfi-modules.texi | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 82209ffe7..ba9dd9e0b 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -695,6 +695,9 @@ Return the first sublist of @var{lst} whose @sc{car} is equal to @var{x}. If @var{x} does no appear in @var{lst}, return @code{#f}. Equality is determined by the equality predicate @var{=}, or @code{equal?} if @var{=} is not given. + +This function extends the core @code{member} by accepting an equality +predicate. (@pxref{List Searching}) @end deffn @@ -720,6 +723,9 @@ deleted with @code{(delete 5 lst <)}. @code{delete} does not modify @var{lst}, but the return might share a common tail with @var{lst}. @code{delete!} may modify the structure of @var{lst} to construct its return. + +These functions extend the core @code{delete} and @code{delete!} in +accepting an equality predicate. (@pxref{List Modification}) @end deffn @deffn {Scheme Procedure} delete-duplicates lst [=] @@ -761,6 +767,9 @@ for dealing with association lists defined by SRFI-1. Return the pair from @var{alist} which matches @var{key}. Equality is determined by @var{=}, which defaults to @code{equal?} if not given. @var{alist} must be an association lists---a list of pairs. + +This function extends the core @code{assoc} by accepting an equality +predicate. (@pxref{Association Lists}) @end deffn @deffn {Scheme Procedure} alist-cons key datum alist From 193239f1e958c000059909800b0c7c77c65e0017 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 21:08:13 +0000 Subject: [PATCH 194/239] (SRFI-1 Filtering and Partitioning): For partition and partition!, emphasise the multi-value return, note partition may share a tail with the given list. --- doc/ref/srfi-modules.texi | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index ba9dd9e0b..440a26bcb 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -599,14 +599,20 @@ Guile core, @xref{List Modification}. @deffn {Scheme Procedure} partition pred lst @deffnx {Scheme Procedure} partition! pred lst -Return two lists, one containing all elements from @var{lst} which -satisfy the predicate @var{pred}, and one list containing the elements -which do not satisfy the predicated. The elements in the result lists -have the same order as in @var{lst}. The order in which @var{pred} is -applied to the list elements is not specified. +Split @var{lst} into those elements which do and don't satisfy the +predicate @var{pred}. -@code{partition!} is allowed, but not required to modify the structure of -the input list. +The return is two values (@pxref{Multiple Values}), the first being a +list of all elements from @var{lst} which satisfy @var{pred}, the +second a list of those which do not. + +The elements in the result lists are in the same order as in @var{lst} +but the order in which the calls @code{(@var{pred} elem)} are made on +the list elements is unspecified. + +@code{partition} does not change @var{lst}, but one of the returned +lists may share a tail with it. @code{partition!} may modify +@var{lst} to construct its return. @end deffn @deffn {Scheme Procedure} remove pred lst @@ -2922,3 +2928,7 @@ change in the future. @c srfi-modules.texi ends here + +@c Local Variables: +@c TeX-master: "guile.texi" +@c End: From b83fc1070c8d8c97c3f47510b1887a53217e1897 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 21:10:27 +0000 Subject: [PATCH 195/239] (false-if-exception): Unquote catch and lambda, so as not to depend on expansion environment. --- ice-9/boot-9.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index d65d99db1..f41420006 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003, 2004 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -3326,8 +3326,8 @@ signals old-handlers)))))) (defmacro false-if-exception (expr) - `(catch #t (lambda () ,expr) - (lambda args #f))) + `(,catch #t (,lambda () ,expr) + (,lambda args #f))) ;;; This hook is run at the very end of an interactive session. ;;; From 9bc915bb075c1a72a45cbd8a5dc52a36d945834a Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 21:12:01 +0000 Subject: [PATCH 196/239] (false-if-exception): Add tests. --- test-suite/tests/exceptions.test | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index cb3fcfa38..05f464563 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -1,5 +1,5 @@ ;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*- -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2003, 2004 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -16,6 +16,8 @@ ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +(use-modules (test-suite lib)) + (with-test-prefix "throw/catch" (with-test-prefix "wrong type argument" @@ -59,3 +61,24 @@ (catch 'a (lambda () (throw 'a)) (lambda (x y . rest) #f))))) + +(with-test-prefix "false-if-exception" + + (pass-if (false-if-exception #t)) + (pass-if (not (false-if-exception #f))) + (pass-if (not (false-if-exception (error "xxx")))) + + (with-test-prefix "in empty environment" + ;; an environment with no bindings at all + (define empty-environment + (make-module 1)) + + (pass-if "#t" + (eval `(,false-if-exception #t) + empty-environment)) + (pass-if "#f" + (not (eval `(,false-if-exception #f) + empty-environment))) + (pass-if "exception" + (not (eval `(,false-if-exception (,error "xxx")) + empty-environment))))) From 6d611fedcc90432ddae19ab9e468254655874d60 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 21:12:45 +0000 Subject: [PATCH 197/239] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ test-suite/ChangeLog | 4 ++++ 2 files changed, 9 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 71020ef19..4d54bb2b8 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2004-01-04 Kevin Ryde + + * boot-9.scm (false-if-exception): Unquote catch and lambda, so as not + to depend on expansion environment. + 2003-11-19 Neil Jerram * boot-9.scm (error-catching-loop): Defer lookup of diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 1334e6d78..5273dce93 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2004-01-04 Kevin Ryde + + * tests/exceptions.test (false-if-exception): Add tests. + 2003-11-30 Marius Vollmer * tests/syntax.test: It's "#\\space", not "#\space". From 9b2416ea7125f8f6c0ef32939fd751ca324d9d5e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 21:15:40 +0000 Subject: [PATCH 198/239] =?UTF-8?q?(-1+,=20<=3F,=20<=3D=3F,=20=3D=3F,=20>?= =?UTF-8?q?=3F,=20>=3D=3F):=20Define=20as=20aliases=20for=201-,=20<,=20,=20>=3D=20respectively,=20required=20by=20slib?= =?UTF-8?q?=20'rev2-procedures=20but=20no=20longer=20in=20the=20guile=20co?= =?UTF-8?q?re.?= --- ice-9/slib.scm | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/ice-9/slib.scm b/ice-9/slib.scm index 534adcae9..55430068b 100644 --- a/ice-9/slib.scm +++ b/ice-9/slib.scm @@ -1,6 +1,6 @@ ;;;; slib.scm --- definitions needed to get SLIB to work with Guile ;;;; -;;;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -21,7 +21,9 @@ implementation-vicinity library-vicinity home-vicinity scheme-implementation-type scheme-implementation-version output-port-width output-port-height array-indexes - make-random-state require slib:error slib:exit slib:warn slib:eval + make-random-state + -1+ ? >=? + require slib:error slib:exit slib:warn slib:eval defmacro:eval logical:logand logical:logior logical:logxor logical:lognot logical:ash logical:logcount logical:integer-length logical:bit-extract logical:integer-expt logical:ipow-by-squaring @@ -234,6 +236,16 @@ (set! seed (object->limited-string seed 50))))) (seed->random-state seed))) +;;; {rev2-procedures} +;;; + +(define -1+ 1-) +(define ? >) +(define >=? >=) + ;;; {Time} ;;; From 97ac013a0696b3a9a995ccc5ead8c1c24607822c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 21:27:51 +0000 Subject: [PATCH 199/239] *** empty log message *** --- ice-9/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 4d54bb2b8..5d50d06bd 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -3,6 +3,10 @@ * boot-9.scm (false-if-exception): Unquote catch and lambda, so as not to depend on expansion environment. + * slib.scm (-1+, ?, >=?): Define as aliases for 1-, <, + <=, =, >, >= respectively, required by slib 'rev2-procedures but no + longer in the guile core. + 2003-11-19 Neil Jerram * boot-9.scm (error-catching-loop): Defer lookup of From a5f0b599885a33fa6c22108c0a2f3caaaf0dc494 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 21:38:38 +0000 Subject: [PATCH 200/239] (scm_less_p): Don't convert frac to float for compares, can give wrong results due to rounding. --- libguile/numbers.c | 69 +++++++++++++++++++++++++++++++++------------- 1 file changed, 50 insertions(+), 19 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 58cd1e8cb..f7faf7004 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3074,6 +3074,12 @@ scm_num_eq_p (SCM x, SCM y) } +/* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications + done are good for inums, but for bignums an answer can almost always be + had by just examining a few high bits of the operands, as done by GMP in + mpq_cmp. flonum/frac compares likewise, but with the slight complication + of the float exponent to take into account. */ + SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p); /* "Return @code{#t} if the list of parameters is monotonically\n" * "increasing." @@ -3081,6 +3087,7 @@ SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p); SCM scm_less_p (SCM x, SCM y) { + again: if (SCM_INUMP (x)) { long xx = SCM_INUM (x); @@ -3098,7 +3105,13 @@ scm_less_p (SCM x, SCM y) else if (SCM_REALP (y)) return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y)); else if (SCM_FRACTIONP (y)) - return SCM_BOOL ((double) xx < scm_i_fraction2double (y)); + { + /* "x < a/b" becomes "x*b < a" */ + int_frac: + x = scm_product (x, SCM_FRACTION_DENOMINATOR (y)); + y = SCM_FRACTION_NUMERATOR (y); + goto again; + } else SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } @@ -3126,12 +3139,7 @@ scm_less_p (SCM x, SCM y) return SCM_BOOL (cmp < 0); } else if (SCM_FRACTIONP (y)) - { - int cmp; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), scm_i_fraction2double (y)); - scm_remember_upto_here_1 (x); - return SCM_BOOL (cmp < 0); - } + goto int_frac; else SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } @@ -3151,25 +3159,48 @@ scm_less_p (SCM x, SCM y) else if (SCM_REALP (y)) return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)); else if (SCM_FRACTIONP (y)) - return SCM_BOOL (SCM_REAL_VALUE (x) < scm_i_fraction2double (y)); + { + double xx = SCM_REAL_VALUE (x); + if (xisnan (xx)) + return SCM_BOOL_F; + if (xisinf (xx)) + return SCM_BOOL (xx < 0.0); + x = scm_inexact_to_exact (x); /* with x as frac or int */ + goto again; + } else SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } else if (SCM_FRACTIONP (x)) { - if (SCM_INUMP (y)) - return SCM_BOOL (scm_i_fraction2double (x) < (double) SCM_INUM (y)); - else if (SCM_BIGP (y)) - { - int cmp; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), scm_i_fraction2double (x)); - scm_remember_upto_here_1 (y); - return SCM_BOOL (cmp > 0); - } + if (SCM_INUMP (y) || SCM_BIGP (y)) + { + /* "a/b < y" becomes "a < y*b" */ + y = scm_product (y, SCM_FRACTION_DENOMINATOR (x)); + x = SCM_FRACTION_NUMERATOR (x); + goto again; + } else if (SCM_REALP (y)) - return SCM_BOOL (scm_i_fraction2double (x) < SCM_REAL_VALUE (y)); + { + double yy = SCM_REAL_VALUE (y); + if (xisnan (yy)) + return SCM_BOOL_F; + if (xisinf (yy)) + return SCM_BOOL (0.0 < yy); + y = scm_inexact_to_exact (y); /* with y as frac or int */ + goto again; + } else if (SCM_FRACTIONP (y)) - return SCM_BOOL (scm_i_fraction2double (x) < scm_i_fraction2double (y)); + { + /* "a/b < c/d" becomes "a*d < c*b" */ + SCM new_x = scm_product (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_DENOMINATOR (y)); + SCM new_y = scm_product (SCM_FRACTION_NUMERATOR (y), + SCM_FRACTION_DENOMINATOR (x)); + x = new_x; + y = new_y; + goto again; + } else SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } From 441a25d9e7055258cd25944d36dbcbddbe8cff65 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 21:41:31 +0000 Subject: [PATCH 201/239] *** empty log message *** --- doc/ref/ChangeLog | 10 ++++++++++ libguile/ChangeLog | 5 +++++ 2 files changed, 15 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index d8f3afcdb..a2f53fc9e 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,13 @@ +2004-01-04 Kevin Ryde + + * srfi-modules.texi (SRFI-1 Filtering and Partitioning): For partition + and partition!, emphasise the multi-value return, note partition may + share a tail with the given list. + + * srfi-modules.texi (SRFI-1 Searching, SRFI-1 Deleting, SRFI-1 + Association Lists): Note how member, delete, delete! and assoc extend + the corresponding core functions. + 2003-11-25 Kevin Ryde * tools.texi (Macros guile-snarf recognizes): Correction to GOOPS diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 929e3d881..74bcb7d13 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2004-01-04 Kevin Ryde + + * numbers.c (scm_less_p): Don't convert frac to float for compares, + can give results due to rounding. + 2003-12-26 Marius Vollmer * gen-scmconfig.h.in, gen-scmconfig.c: Arrange for scm_t_intmax From 4845bbae3a0b568ae00e4ba491a1304c9f052b8f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Jan 2004 21:49:16 +0000 Subject: [PATCH 202/239] (scm_t_frame_flags, scm_t_wind_flags, scm_begin_frame, scm_end_frame, scm_on_unwind, scm_on_rewind): New. (scm_dowinds, scm_i_dowinds): scm_dowinds has been renamed to scm_i_dowinds and extended to handle frames and to invoke a 'turn' function when the outermost wind point has been reached. The latter is used to copy a continuation stack at the right time. scm_dowinds remains available. (SCM_GUARDSP, SCM_BEFORE_GUARD, SCM_AFTER_GUARD, SCM_GUARD_DATA, tc16_guard, guards_print): Removed. (scm_internal_dynamic_wind): Reimplemented using frames. --- libguile/dynwind.c | 229 +++++++++++++++++++++++++++++++++------------ libguile/dynwind.h | 20 +++- 2 files changed, 187 insertions(+), 62 deletions(-) diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 78c2676aa..ca934c912 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -18,6 +18,8 @@ +#include + #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/alist.h" @@ -32,6 +34,8 @@ Things that can be on the wind list: + # + # (enter-proc . leave-proc) dynamic-wind (tag . jmpbuf) catch (tag . lazy-catch) lazy-catch @@ -108,27 +112,6 @@ SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0, } #undef FUNC_NAME -/* The implementation of a C-callable dynamic-wind, - * scm_internal_dynamic_wind, requires packaging of C pointers in a - * smob. Objects of this type are pushed onto the dynwind chain. - */ - -#define SCM_GUARDSP(obj) SCM_TYP16_PREDICATE (tc16_guards, obj) -#define SCM_BEFORE_GUARD(obj) ((scm_t_guard) SCM_CELL_WORD (obj, 1)) -#define SCM_AFTER_GUARD(obj) ((scm_t_guard) SCM_CELL_WORD (obj, 2)) -#define SCM_GUARD_DATA(obj) ((void *) SCM_CELL_WORD (obj, 3)) - -static scm_t_bits tc16_guards; - -static int -guards_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) -{ - scm_puts ("#', port); - return 1; -} - SCM scm_internal_dynamic_wind (scm_t_guard before, scm_t_inner inner, @@ -136,17 +119,96 @@ scm_internal_dynamic_wind (scm_t_guard before, void *inner_data, void *guard_data) { - SCM guards, ans; - before (guard_data); - SCM_NEWSMOB3 (guards, tc16_guards, (scm_t_bits) before, - (scm_t_bits) after, (scm_t_bits) guard_data); - scm_dynwinds = scm_acons (guards, SCM_BOOL_F, scm_dynwinds); + SCM ans; + + scm_begin_frame (SCM_F_FRAME_REWINDABLE); + scm_on_rewind (before, guard_data, SCM_F_WIND_EXPLICITELY); + scm_on_unwind (after, guard_data, SCM_F_WIND_EXPLICITELY); ans = inner (inner_data); - scm_dynwinds = SCM_CDR (scm_dynwinds); - after (guard_data); + scm_end_frame (); return ans; } +/* Frames and winders. */ + +static scm_t_bits tc16_frame; +#define FRAME_P(f) SCM_SMOB_PREDICATE (tc16_frame, (f)) + +#define FRAME_F_REWINDABLE (1 << 16) +#define FRAME_REWINDABLE_P(f) (SCM_CELL_WORD_0(f) & FRAME_F_REWINDABLE) + +static scm_t_bits tc16_winder; +#define WINDER_P(w) SCM_SMOB_PREDICATE (tc16_winder, (w)) +#define WINDER_PROC(w) ((void (*)(void *))SCM_CELL_WORD_1 (w)) +#define WINDER_DATA(w) ((void *)SCM_CELL_WORD_2 (w)) + +#define WINDER_F_EXPLICIT (1 << 16) +#define WINDER_F_REWIND (1 << 17) +#define WINDER_EXPLICIT_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_EXPLICIT) +#define WINDER_REWIND_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_REWIND) + +static int +frame_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED) +{ + scm_puts ("#", port); + return 1; +} + +void +scm_begin_frame (scm_t_frame_flags flags) +{ + SCM f; + scm_t_bits fl = ((flags&SCM_F_FRAME_REWINDABLE)? FRAME_F_REWINDABLE : 0); + SCM_NEWSMOB (f, tc16_frame | fl, 0); + scm_dynwinds = scm_cons (f, scm_dynwinds); +} + +void +scm_end_frame (void) +{ + long delta; + SCM to; + + /* Unwind upto and including the next frame entry. + */ + + for (to = scm_dynwinds, delta = 1; + SCM_CONSP (to); + to = SCM_CDR (to), delta++) + { + if (FRAME_P (SCM_CAR (to))) + { + scm_i_dowinds (SCM_CDR (to), delta, 1, NULL, NULL); + return; + } + } + + assert (0); +} + +void +scm_on_unwind (void (*proc) (void *), void *data, + scm_t_wind_flags flags) +{ + SCM w; + scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITELY)? WINDER_F_EXPLICIT : 0); + SCM_NEWSMOB2 (w, tc16_winder | fl, + (scm_t_bits) proc, (scm_t_bits) data); + scm_dynwinds = scm_cons (w, scm_dynwinds); +} + +void +scm_on_rewind (void (*proc) (void *), void *data, + scm_t_wind_flags flags) +{ + SCM w; + SCM_NEWSMOB2 (w, tc16_winder | WINDER_F_REWIND, + (scm_t_bits) proc, (scm_t_bits) data); + scm_dynwinds = scm_cons (w, scm_dynwinds); + if (flags & SCM_F_WIND_EXPLICITELY) + proc (data); +} + #ifdef GUILE_DEBUG SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0, (), @@ -174,18 +236,31 @@ scm_swap_bindings (SCM vars, SCM vals) } } -void +void scm_dowinds (SCM to, long delta) +{ + scm_i_dowinds (to, delta, 0, NULL, NULL); +} + +void +scm_i_dowinds (SCM to, long delta, int explicit, + void (*turn_func) (void *), void *data) { tail: - if (SCM_EQ_P (to, scm_dynwinds)); + if (SCM_EQ_P (to, scm_dynwinds)) + { + if (turn_func) + turn_func (data); + } else if (delta < 0) { SCM wind_elt; SCM wind_key; - scm_dowinds (SCM_CDR (to), 1 + delta); + scm_i_dowinds (SCM_CDR (to), 1 + delta, explicit, + turn_func, data); wind_elt = SCM_CAR (to); + #if 0 if (SCM_INUMP (wind_elt)) { @@ -194,34 +269,50 @@ scm_dowinds (SCM to, long delta) else #endif { - wind_key = SCM_CAR (wind_elt); - /* key = #t | symbol | thunk | list of variables | list of fluids */ - if (SCM_NIMP (wind_key)) + if (FRAME_P (wind_elt)) { - if (SCM_CONSP (wind_key)) + if (!FRAME_REWINDABLE_P (wind_elt)) + scm_misc_error ("dowinds", + "cannot invoke continuation from this context", + SCM_EOL); + } + else if (WINDER_P (wind_elt)) + { + if (WINDER_REWIND_P (wind_elt)) { - if (SCM_VARIABLEP (SCM_CAR (wind_key))) - scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); - else if (SCM_FLUIDP (SCM_CAR (wind_key))) - scm_swap_fluids (wind_key, SCM_CDR (wind_elt)); + void (*proc) (void *) = WINDER_PROC (wind_elt); + void *data = WINDER_DATA (wind_elt); + proc (data); + } + } + else + { + wind_key = SCM_CAR (wind_elt); + /* key = #t | symbol | thunk | list of variables | list of fluids */ + if (SCM_NIMP (wind_key)) + { + if (SCM_CONSP (wind_key)) + { + if (SCM_VARIABLEP (SCM_CAR (wind_key))) + scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); + else if (SCM_FLUIDP (SCM_CAR (wind_key))) + scm_swap_fluids (wind_key, SCM_CDR (wind_elt)); + } + else if (SCM_TYP3 (wind_key) == scm_tc3_closure) + scm_call_0 (wind_key); } - else if (SCM_GUARDSP (wind_key)) - SCM_BEFORE_GUARD (wind_key) (SCM_GUARD_DATA (wind_key)); - else if (SCM_TYP3 (wind_key) == scm_tc3_closure) - scm_call_0 (wind_key); } } scm_dynwinds = to; } else { - SCM from; SCM wind_elt; SCM wind_key; - from = SCM_CDR (SCM_CAR (scm_dynwinds)); wind_elt = SCM_CAR (scm_dynwinds); scm_dynwinds = SCM_CDR (scm_dynwinds); + #if 0 if (SCM_INUMP (wind_elt)) { @@ -230,20 +321,35 @@ scm_dowinds (SCM to, long delta) else #endif { - wind_key = SCM_CAR (wind_elt); - if (SCM_NIMP (wind_key)) + if (FRAME_P (wind_elt)) { - if (SCM_CONSP (wind_key)) + /* Nothing to do. */ + } + else if (WINDER_P (wind_elt)) + { + if (!WINDER_REWIND_P (wind_elt) + && (!explicit || WINDER_EXPLICIT_P (wind_elt))) { - if (SCM_VARIABLEP (SCM_CAR (wind_key))) - scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); - else if (SCM_FLUIDP (SCM_CAR (wind_key))) - scm_swap_fluids_reverse (wind_key, SCM_CDR (wind_elt)); + void (*proc) (void *) = WINDER_PROC (wind_elt); + void *data = WINDER_DATA (wind_elt); + proc (data); + } + } + else + { + wind_key = SCM_CAR (wind_elt); + if (SCM_NIMP (wind_key)) + { + if (SCM_CONSP (wind_key)) + { + if (SCM_VARIABLEP (SCM_CAR (wind_key))) + scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); + else if (SCM_FLUIDP (SCM_CAR (wind_key))) + scm_swap_fluids_reverse (wind_key, SCM_CDR (wind_elt)); + } + else if (SCM_TYP3 (wind_key) == scm_tc3_closure) + scm_call_0 (SCM_CDR (wind_elt)); } - else if (SCM_GUARDSP (wind_key)) - SCM_AFTER_GUARD (wind_key) (SCM_GUARD_DATA (wind_key)); - else if (SCM_TYP3 (wind_key) == scm_tc3_closure) - scm_call_0 (from); } } delta--; @@ -251,13 +357,14 @@ scm_dowinds (SCM to, long delta) } } - - void scm_init_dynwind () { - tc16_guards = scm_make_smob_type ("guards", 0); - scm_set_smob_print (tc16_guards, guards_print); + tc16_frame = scm_make_smob_type ("frame", 0); + scm_set_smob_print (tc16_frame, frame_print); + + tc16_winder = scm_make_smob_type ("winder", 0); + #include "libguile/dynwind.x" } diff --git a/libguile/dynwind.h b/libguile/dynwind.h index dfdb96ea7..b207d83b8 100644 --- a/libguile/dynwind.h +++ b/libguile/dynwind.h @@ -3,7 +3,7 @@ #ifndef SCM_DYNWIND_H #define SCM_DYNWIND_H -/* Copyright (C) 1995,1996,1998,1999,2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2003,2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -36,10 +36,28 @@ SCM_API SCM scm_internal_dynamic_wind (scm_t_guard before, void *inner_data, void *guard_data); SCM_API void scm_dowinds (SCM to, long delta); +SCM_API void scm_i_dowinds (SCM to, long delta, int explicit, + void (*turn_func) (void *), void *data); SCM_API void scm_init_dynwind (void); SCM_API void scm_swap_bindings (SCM vars, SCM vals); +typedef enum { + SCM_F_FRAME_REWINDABLE = (1 << 0) +} scm_t_frame_flags; + +typedef enum { + SCM_F_WIND_EXPLICITELY = (1 << 0) +} scm_t_wind_flags; + +SCM_API void scm_begin_frame (scm_t_frame_flags); +SCM_API void scm_end_frame (void); + +SCM_API void scm_on_unwind (void (*func) (void *), void *data, + scm_t_wind_flags); +SCM_API void scm_on_rewind (void (*func) (void *), void *data, + scm_t_wind_flags); + #ifdef GUILE_DEBUG SCM_API SCM scm_wind_chain (void); #endif /*GUILE_DEBUG*/ From d3c6aef934cf34b1db1835ec172156c04f9378cb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Jan 2004 21:52:34 +0000 Subject: [PATCH 203/239] (copy_stack): New, do only the stack copying part of copy_stack_and_call. (copy_stack_and_call): Copy the stack after unwinding and before rewinding. (scm_dynthrow): Do not call scm_dowinds, this is now done by copy_stack_and_call. --- libguile/continuations.c | 44 ++++++++++++++++++++++++++++++++-------- 1 file changed, 36 insertions(+), 8 deletions(-) diff --git a/libguile/continuations.c b/libguile/continuations.c index 672a035eb..996d5eebf 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -177,6 +177,19 @@ scm_make_continuation (int *first) } #undef FUNC_NAME + +/* Invoking a continuation proceeds as follows: + * + * - the stack is made large enough for the called continuation + * - the old windchain is unwound down to the branching point + * - the continuation stack is copied into place + * - the windchain is rewound up to the continuation's context + * - the continuation is invoked via longjmp (or setcontext) + * + * This order is important so that unwind and rewind handlers are run + * with their correct stack. + */ + static void scm_dynthrow (SCM, SCM); /* Grow the stack by a fixed amount to provide space to copy in the @@ -202,12 +215,32 @@ grow_stack (SCM cont, SCM val) * within this function is safe, since only stack frames below this function's * own frame are overwritten. Thus, memcpy can be used for best performance. */ + +typedef struct { + scm_t_contregs *continuation; + SCM_STACKITEM *dst; +} copy_stack_data; + static void -copy_stack_and_call (scm_t_contregs *continuation, SCM val, +copy_stack (void *data) +{ + copy_stack_data *d = (copy_stack_data *)data; + memcpy (d->dst, d->continuation->stack, + sizeof (SCM_STACKITEM) * d->continuation->num_stack_items); +} + +static void +copy_stack_and_call (scm_t_contregs *continuation, SCM val, SCM_STACKITEM * dst) { - memcpy (dst, continuation->stack, - sizeof (SCM_STACKITEM) * continuation->num_stack_items); + long delta; + copy_stack_data data; + + delta = scm_ilength (scm_dynwinds) - scm_ilength (continuation->dynenv); + data.continuation = continuation; + data.dst = dst; + scm_i_dowinds (continuation->dynenv, delta, 0, + copy_stack, &data); scm_last_debug_frame = continuation->dframe; @@ -222,7 +255,6 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val, #endif } - /* Call grow_stack until the stack space is large enough, then, as the current * stack frame might get overwritten, let copy_stack_and_call perform the * actual copying and continuation calling. @@ -263,10 +295,6 @@ continuation_apply (SCM cont, SCM args) scm_list_1 (cont)); } - scm_dowinds (continuation->dynenv, - scm_ilength (scm_dynwinds) - - scm_ilength (continuation->dynenv)); - scm_dynthrow (cont, scm_values (args)); return SCM_UNSPECIFIED; /* not reached */ } From 81b0a6c1ae5a9fa796f5612a0cae16204b6d36d6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Jan 2004 21:53:21 +0000 Subject: [PATCH 204/239] added test-unwind --- test-suite/standalone/.cvsignore | 1 + 1 file changed, 1 insertion(+) diff --git a/test-suite/standalone/.cvsignore b/test-suite/standalone/.cvsignore index e71fc02b2..1684bc44b 100644 --- a/test-suite/standalone/.cvsignore +++ b/test-suite/standalone/.cvsignore @@ -7,3 +7,4 @@ Makefile Makefile.in test-gh test-num2integral +test-unwind From 3c8fb18ef67175192de205e6c8f28d5e50b44e93 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Jan 2004 21:54:23 +0000 Subject: [PATCH 205/239] * standalone/test-unwind.c: New test, for the frames stuff. * standalone/Makefile.am: Compile and run it. --- test-suite/standalone/Makefile.am | 7 ++ test-suite/standalone/test-unwind.c | 172 ++++++++++++++++++++++++++++ 2 files changed, 179 insertions(+) create mode 100644 test-suite/standalone/test-unwind.c diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index d9969f349..629bec662 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -49,6 +49,13 @@ BUILT_SOURCES += test-asmobs-lib.x check_SCRIPTS += test-asmobs TESTS += test-asmobs +# test-unwind +test_unwind_SOURCES = test-unwind.c +test_unwind_CFLAGS = ${test_cflags} +test_unwind_LDADD = ${top_builddir}/libguile/libguile.la +check_PROGRAMS += test-unwind +TESTS += test-unwind + all-local: cd ${srcdir} && chmod u+x ${check_SCRIPTS} diff --git a/test-suite/standalone/test-unwind.c b/test-suite/standalone/test-unwind.c new file mode 100644 index 000000000..7ccfef55a --- /dev/null +++ b/test-suite/standalone/test-unwind.c @@ -0,0 +1,172 @@ +#include +#include +#include + +void set_flag (void *data); +void func1 (void); +void func2 (void); +void func3 (void); +void func4 (void); +void check_flag1 (const char *msg, void (*func)(void), int val); +SCM check_flag1_body (void *data); +SCM return_tag (void *data, SCM tag, SCM args); +void check_cont (int rewindable); +SCM check_cont_body (void *data); + +int flag1, flag2, flag3; + +void +set_flag (void *data) +{ + int *f = (int *)data; + *f = 1; +} + +/* FUNC1 should leave flag1 zero. + */ + +void +func1 () +{ + scm_begin_frame (0); + flag1 = 0; + scm_on_unwind (set_flag, &flag1, 0); + scm_end_frame (); +} + +/* FUNC2 should set flag1. + */ + +void +func2 () +{ + scm_begin_frame (0); + flag1 = 0; + scm_on_unwind (set_flag, &flag1, SCM_F_WIND_EXPLICITELY); + scm_end_frame (); +} + +/* FUNC3 should set flag1. + */ + +void +func3 () +{ + scm_begin_frame (0); + flag1 = 0; + scm_on_unwind (set_flag, &flag1, 0); + scm_misc_error ("func3", "gratuitous error", SCM_EOL); + scm_end_frame (); +} + +/* FUNC4 should set flag1. + */ + +void +func4 () +{ + scm_begin_frame (0); + flag1 = 0; + scm_on_unwind (set_flag, &flag1, SCM_F_WIND_EXPLICITELY); + scm_misc_error ("func4", "gratuitous error", SCM_EOL); + scm_end_frame (); +} + +SCM +check_flag1_body (void *data) +{ + void (*f)(void) = (void (*)(void))data; + f (); + return SCM_UNSPECIFIED; +} + +SCM +return_tag (void *data, SCM tag, SCM args) +{ + return tag; +} + +void +check_flag1 (const char *tag, void (*func)(void), int val) +{ + scm_internal_catch (SCM_BOOL_T, + check_flag1_body, func, + return_tag, NULL); + if (flag1 != val) + { + printf ("%s failed\n", tag); + exit (1); + } +} + +SCM +check_cont_body (void *data) +{ + scm_t_frame_flags flags = (data? SCM_F_FRAME_REWINDABLE : 0); + int first; + SCM val; + + scm_begin_frame (flags); + + val = scm_make_continuation (&first); + scm_end_frame (); + return val; +} + +void +check_cont (int rewindable) +{ + SCM res; + + res = scm_internal_catch (SCM_BOOL_T, + check_cont_body, (void *)rewindable, + return_tag, NULL); + + /* RES is now either the created continuation, the value passed to + the continuation, or a catch-tag, such as 'misc-error. + */ + + if (SCM_NFALSEP (scm_procedure_p (res))) + { + /* a continuation, invoke it */ + scm_call_1 (res, SCM_BOOL_F); + } + else if (SCM_FALSEP (res)) + { + /* the result of invoking the continuation, frame must be + rewindable */ + if (rewindable) + return; + printf ("continuation not blocked\n"); + exit (1); + } + else + { + /* the catch tag, frame must not have been rewindable. */ + if (!rewindable) + return; + printf ("continuation didn't work\n"); + exit (1); + } +} + +static void +inner_main (void *data, int argc, char **argv) +{ + check_flag1 ("func1", func1, 0); + check_flag1 ("func2", func2, 1); + check_flag1 ("func3", func3, 1); + check_flag1 ("func4", func4, 1); + + check_cont (0); + check_cont (1); + + exit (0); +} + +int +main (int argc, char **argv) +{ + scm_boot_guile (argc, argv, inner_main, 0); + return 0; +} From 86272eedd08e9f25b21cb9c504c0cb48a663168e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Jan 2004 21:56:18 +0000 Subject: [PATCH 206/239] Document the frames stuff and other random changes. --- doc/ref/scheme-control.texi | 284 ++++++++++++++++++++++++++++-------- 1 file changed, 223 insertions(+), 61 deletions(-) diff --git a/doc/ref/scheme-control.texi b/doc/ref/scheme-control.texi index d7a7f5294..49632ea7e 100644 --- a/doc/ref/scheme-control.texi +++ b/doc/ref/scheme-control.texi @@ -2,6 +2,63 @@ @node Control Mechanisms @chapter Controlling the Flow of Program Execution +Scheme has a more general view of program flow than C, both locally and +non-locally. + +Controlling the local flow of control involves things like gotos, loops, +calling functions and returning from them. Non-local control flow +refers to situations where the program jumps across one or more levels +of function activations without using the normal call or return +operations. + +[ XXX - tail calls instead of goto. ] + +In addition to calling functions and returning from them, a Scheme +program can also exit non-locally from a function so that the control +flow returns directly to an outer level. This means that some functions +might not return at all. + +Even more, it is not only possible to jump to some outer level of +control, a Scheme program can also jump back into the middle of a +function that has already exited. This might cause some functions to +return more than once. + +In general, these non-local jumps are done by invoking +@emph{continuations} that have previously been captured using +@code{call-with-current-continuation}. Guile also offers a slightly +restricted set of functions, @code{catch} and @code{throw}, that can +only be used for non-local exits. This restriction makes them more +efficient. Error reporting (with the function @code{error}) is done by +invoking @code{throw}, for example. The functions @code{catch} and +@code{throw} belong to the topic of @dfn{exceptions}. + +Since Scheme functions can call C functions and vice versa, C code can +experience the more general flow of control of Scheme as well. It is +possible that a C function will not return at all, or will return more +than once. While C does offer @code{setjmp} and @code{longjmp} for +non-local exits, it is still a unusual thing for C code. In contrast, +non-local exits are very common in Scheme, mostly to report errors. + +You need to be prepared for the non-local jumps in the control flow +whenever you use a function from @code{libguile}: it is best to assume +that any @code{libguile} function might signal an error or run a pending +signal handler (which in turn can do arbitrary things). + +It is often necessary to take cleanup actions when the control leaves a +function non-locally. Also, when the control returns non-locally, some +setup actions might be called for. For example, the Scheme function +@code{with-output-to-port} needs to modify the global state so that +@code{current-output-port} returns the port passed to +@code{with-output-to-port}. The global output port needs to be reset to +its previous value when @code{with-output-to-port} returns normally or +when it is exited non-locally. Likewise, the port needs to be set again +when control enters non-locally. + +Scheme code can use the @code{dynamic-wind} function to arrange the +setting and resetting of the global state. C code could use the +corresponding @code{scm_internal_dynamic_wind} function, but it might +prefer to use the @emph{frames} concept that is more natural for C code. + @menu * begin:: Evaluating a sequence of expressions. * if cond case:: Simple conditional evaluation. @@ -12,6 +69,7 @@ * Exceptions:: Throwing and catching exceptions. * Error Reporting:: Procedures for signaling errors. * Dynamic Wind:: Guarding against non-local entrance/exit. +* Frames:: Another way to handle non-localness * Handling Errors:: How to handle errors in C code. @end menu @@ -19,15 +77,11 @@ @node begin @section Evaluating a Sequence of Expressions -@c FIXME::martin: Review me! - -@c FIXME::martin: Maybe add examples? - @cindex begin @cindex sequencing @cindex expression sequencing -@code{begin} is used for grouping several expression together so that +@code{begin} is used for grouping several expressions together so that they syntactically are treated as if they were one expression. This is particularly important when syntactic expressions are used which only allow one expression, but the programmer wants to use more than one @@ -48,15 +102,14 @@ The expression(s) are evaluated in left-to-right order and the value of the last expression is returned as the value of the @code{begin}-expression. This expression type is used when the expressions before the last one are evaluated for their side effects. + +Guile also allows the expression @code{(begin)}, a @code{begin} with no +sub-expressions. Such an expression returns the `unspecified' value. @end deffn @node if cond case @section Simple Conditional Evaluation -@c FIXME::martin: Review me! - -@c FIXME::martin: Maybe add examples? - @cindex conditional evaluation @cindex if @cindex case @@ -91,7 +144,7 @@ where @var{test} and @var{expression} are arbitrary expression, or like this @lisp -(@var{test} => @var{expression} +(@var{test} => @var{expression}) @end lisp where @var{expression} must evaluate to a procedure. @@ -104,8 +157,10 @@ the @code{cond}-expression. For the @code{=>} clause type, the value of @var{test}. The result of this procedure application is then the result of the @code{cond}-expression. -The @var{test} of the last @var{clause} may be the keyword @code{else}. -Then, if none of the preceding @var{test}s is true, the @var{expression}s following the @code{else} are evaluated to produce the result of the @code{cond}-expression. +The @var{test} of the last @var{clause} may be the symbol @code{else}. +Then, if none of the preceding @var{test}s is true, the +@var{expression}s following the @code{else} are evaluated to produce the +result of the @code{cond}-expression. @end deffn @deffn syntax case key clause1 clause2 @dots{} @@ -137,12 +192,8 @@ unspecified. @node and or @section Conditional Evaluation of a Sequence of Expressions -@c FIXME::martin: Review me! - -@c FIXME::martin: Maybe add examples? - -@code{and} and @code{or} evaluate all their arguments, similar to -@code{begin}, but evaluation stops as soon as one of the expressions +@code{and} and @code{or} evaluate all their arguments in order, similar +to @code{begin}, but evaluation stops as soon as one of the expressions evaluates to false or true, respectively. @deffn syntax and expr @dots{} @@ -169,10 +220,6 @@ If used without expressions, @code{#f} is returned. @node while do @section Iteration mechanisms -@c FIXME::martin: Review me! - -@c FIXME::martin: Maybe add examples? - @cindex iteration @cindex looping @cindex named let @@ -330,9 +377,9 @@ created (@pxref{Dynamic Roots}), and in a multi-threaded program only from the thread in which it was created, since each thread is a separate dynamic root. -The call to @var{proc} is not part of the continuation captured, it -runs only when the continuation is created. Often a program will want -to store @var{cont} somewhere for later use, this can be done in +The call to @var{proc} is not part of the continuation captured, it runs +only when the continuation is created. Often a program will want to +store @var{cont} somewhere for later use; this can be done in @var{proc}. The @code{call} in the name @code{call-with-current-continuation} @@ -395,10 +442,10 @@ a function returning more times than it was called. It may help instead to think of it being stealthily re-entered and then program flow going on as normal. -@code{dynamic-wind} (@pxref{Dynamic Wind}) can be used to ensure setup -and cleanup code is run when a program locus is resumed or abandoned -through the continuation mechanism. For instance locking and -unlocking database records in use, or similar. +The functions @code{dynamic-wind} (@pxref{Dynamic Wind}) can be used to +ensure setup and cleanup code is run when a program locus is resumed or +abandoned through the continuation mechanism. C code can use the +functions explained in @pxref{Frames}. @sp 1 Continuations are a powerful mechanism, and can be used to implement @@ -426,7 +473,6 @@ do). @node Multiple Values @section Returning and Accepting Multiple Values -@c FIXME::martin: Review me! @cindex multiple values @cindex receive @@ -565,9 +611,7 @@ condition is involved, @dfn{error}. @end itemize Where @dfn{signal} and @dfn{signalling} are used, special care is needed -to avoid the risk of confusion with POSIX signals. (Especially -considering that Guile handles POSIX signals by throwing a corresponding -kind of exception: REFFIXME.) +to avoid the risk of confusion with POSIX signals. This manual prefers to speak of throwing and catching exceptions, since this terminology matches the corresponding Guile primitives. @@ -579,13 +623,13 @@ this terminology matches the corresponding Guile primitives. @code{catch} is used to set up a target for a possible non-local jump. The arguments of a @code{catch} expression are a @dfn{key}, which restricts the set of exceptions to which this @code{catch} applies, a -thunk that specifies the @dfn{normal case} code --- i.e. what should -happen if no exceptions are thrown --- and a @dfn{handler} procedure -that says what to do if an exception is thrown. Note that if the -@dfn{normal case} thunk executes @dfn{normally}, which means without -throwing any exceptions, the handler procedure is not executed at all. +thunk that specifies the code to execute and a @dfn{handler} procedure +that says what to do if an exception is thrown while executing the code. +Note that if the execution thunk executes @dfn{normally}, which means +without throwing any exceptions, the handler procedure is not called at +all. -When an exception is thrown using the @code{throw} primitive, the first +When an exception is thrown using the @code{throw} function, the first argument of the @code{throw} is a symbol that indicates the type of the exception. For example, Guile throws an exception using the symbol @code{numerical-overflow} to indicate numerical overflow errors such as @@ -943,9 +987,6 @@ if an exception occurs then @code{#f} is returned instead. @node Dynamic Wind @section Dynamic Wind -[FIXME: this is pasted in from Tom Lord's original guile.texi and should -be reviewed] - @rnindex dynamic-wind @deffn {Scheme Procedure} dynamic-wind in_guard thunk out_guard @deffnx {C Function} scm_dynamic_wind (in_guard, thunk, out_guard) @@ -954,8 +995,8 @@ All three arguments must be 0-argument procedures. @var{out_guard}. If, any time during the execution of @var{thunk}, the -continuation of the @code{dynamic_wind} expression is escaped -non-locally, @var{out_guard} is called. If the continuation of +dynamic extent of the @code{dynamic-wind} expression is escaped +non-locally, @var{out_guard} is called. If the dynamic extent of the dynamic-wind is re-entered, @var{in_guard} is called. Thus @var{in_guard} and @var{out_guard} may be called any number of times. @@ -999,9 +1040,145 @@ a-cont @end lisp @end deffn +@node Frames +@section Frames + +For Scheme code, the fundamental procedure to react to non-local entry +and exits of dynamic contexts is @code{dynamic-wind}. C code could use +@code{scm_internal_dynamic_wind}, but since C does not allow the +convenient construction of anonymous procedures that close over lexical +variables, this will be, well, inconvenient. Instead, C code can use +@dfn{frames}. + +Guile offers the functions @code{scm_begin_frame} and +@code{scm_end_frame} to delimit a dynamic extent. Within this dynamic +extent, which is called a @dfn{frame}, you can perform various +@dfn{frame actions} that control what happens when the frame is entered +or left. For example, you can register a cleanup routine with +@code{scm_on_unwind} that is executed when the frame is left. There are +several other more specialized frame actions as well, for example to +temporarily block the execution of asyncs or to temporarily change the +current output port. They are described elsewhere in this manual. + +Here is an example that shows how to prevent memory leaks. + +@example + +/* Suppose there is a function called FOO in some library that you + would like to make available to Scheme code (or to C code that + follows the Scheme conventions). + + FOO takes two C strings and returns a new string. When an error has + occurred in FOO, it returns NULL. +*/ + +char *foo (char *s1, char *s2); + +/* SCM_FOO interfaces the C function FOO to the Scheme way of life. + It takes care to free up all temporary strings in the case of + non-local exits. + + It uses SCM_TO_STRING as a helper procedure. + */ + +char * +scm_to_string (SCM obj) +@{ + if (SCM_STRINGP (obj)) + @{ + char *res = scm_malloc (SCM_STRING_LENGTH (obj)+1); + strcpy (res, SCM_STRING_CHARS (obj)); + scm_remember_upto_here_1 (obj); + return res; + @} + else + scm_wrong_type_arg ("scm_to_string", 1, obj); +@} + +SCM +scm_foo (SCM s1, SCM s2) +@{ + char *c_s1, *c_s2, *c_res; + + scm_begin_frame (0); + + c_s1 = scm_to_string (s1); + scm_on_unwind (free, s1, SCM_F_EXPLICIT); + + c_s2 = scm_to_string (s2); + scm_on_unwind (free, s2, SCM_F_EXPLICIT); + + c_res = foo (c_s1, c_s2); + if (c_res == NULL) + scm_memory_error ("foo"); + + scm_end_frame (); + + return scm_take0str (res); +@} +@end example + +@deftp {C Type} scm_t_frame_flags +This is an enumeration of several flags that modify the behavior of +@code{scm_begin_frame}. The flags are listed in the following table. + +@table @code +@item SCM_F_FRAME_REWINDABLE +The frame is @dfn{rewindable}. This means that it can be reentered +non-locally (via the invokation of a continuation). The default is that +a frame can not be reentered non-locally. +@end table + +@end deftp + +@deftypefn {C Function} void scm_begin_frame (scm_t_frame_flags flags) +The function @code{scm_begin_frame} starts a new frame and makes it the +`current' one. + +The @var{flags} argument determines the default behavior of the frame. +For normal frames, use 0. This will result in a frame that can not be +reentered with a captured continuation. When you are prepared to handle +reentries, include @code{SCM_F_FRAME_REWINDABLE} in @var{flags}. + +The frame is ended either implicitly when a non-local exit happens, or +explicitly with @code{scm_end_frame}. You must make sure that a frame +is indeed ended properly. If you fail to call @code{scm_end_frame} each +@code{scm_begin_frame}, the behavior is undefined. +@end deftypefn + +@deftypefn {C Function} void scm_end_frame () +End the current frame explicitly and make the previous frame current. +@end deftypefn + +@deftp {C Type} scm_t_wind_flags +This is an enumeration of several flags that modify the behavior of +@code{scm_on_unwind} and @code{scm_on_rewind}. The flags are listed in +the following table. + +@table @code +@item SCM_F_WIND_EXPLICITELY +The registered action is also carried out when the frame is entered or +left locally. +@end table +@end deftp + +@deftypefn {C Function} void scm_on_unwind (void (*func)(void *), void *data, scm_t_wind_flags flags) +Arranges for @var{func} to be called with @var{data} as its arguments +when the current frame ends implicitly. If @var{flags} contains +@code{SCM_F_WIND_EXPLICITELY}, @var{func} is also called when the frame +ends explicitly with @code{scm_end_frame}. +@end deftypefn + +@deftypefn {C Function} void scm_on_rewind (void (*func)(void *), void *data, scm_t_wind_flags flags) +Arrange for @var{func} to be called with @var{data} as its argument when +the current frame is restarted by rewinding the stack. When @var{flags} +contains @code{SCM_F_WIND_EXPLICITELY}, @var{func} is called immediately +as well. +@end deftypefn + @node Handling Errors -@section How to Handle Errors in C Code +@section How to Handle Errors Error handling is based on @code{catch} and @code{throw}. Errors are always thrown with a @var{key} and four arguments: @@ -1040,16 +1217,6 @@ be @code{#f} if no additional objects are required. In addition to @code{catch} and @code{throw}, the following Scheme facilities are available: -@deffn {Scheme Procedure} scm-error key subr message args rest -Throw an error, with arguments -as described above. -@end deffn - -@deffn {Scheme Procedure} error msg arg @dots{} -Throw an error using the key @code{'misc-error}. The error -message is created by displaying @var{msg} and writing the @var{args}. -@end deffn - @deffn {Scheme Procedure} display-error stack port subr message args rest @deffnx {C Function} scm_display_error (stack, port, subr, message, args, rest) Display an error message to the output port @var{port}. @@ -1118,7 +1285,7 @@ expression library. @subsection C Support In the following C functions, @var{SUBR} and @var{MESSAGE} parameters -can be @code{NULL} to give the @code{#f} described above. +can be @code{NULL} to give the effect of @code{#f} described above. @deftypefn {C Function} SCM scm_error (SCM @var{key}, char *@var{subr}, char *@var{message}, SCM @var{args}, SCM @var{rest}) Throw an error, as per @code{scm-error} above. @@ -1145,11 +1312,6 @@ For @code{scm_wrong_num_args}, @var{proc} should be a Scheme symbol which is the name of the procedure incorrectly invoked. @end deftypefn -Exception handlers can also be installed from C, using -@code{scm_internal_catch}, @code{scm_lazy_catch}, or -@code{scm_stack_catch} from @file{libguile/throw.c}. These have not -yet been documented, but the source contains some useful comments. - @c Local Variables: @c TeX-master: "guile.texi" From dab514a843f3d515e1ab022e5aa16a5e828b8abf Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Jan 2004 21:56:35 +0000 Subject: [PATCH 207/239] *** empty log message *** --- doc/ref/ChangeLog | 5 +++ libguile/ChangeLog | 23 +++++++++++- test-suite/ChangeLog | 5 +++ test-suite/tests/continuations.test | 54 +++++++++++++++++++++++++++++ 4 files changed, 86 insertions(+), 1 deletion(-) create mode 100644 test-suite/tests/continuations.test diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index a2f53fc9e..6e879f2c2 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2004-01-03 Marius Vollmer + + * scheme-control.texi: Document the frames stuff and other random + changes. + 2004-01-04 Kevin Ryde * srfi-modules.texi (SRFI-1 Filtering and Partitioning): For partition diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 74bcb7d13..7491f45d9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,7 +1,28 @@ +2004-01-03 Marius Vollmer + + * dynwind.h, scm_dynwind.c (scm_t_frame_flags, scm_t_wind_flags, + scm_begin_frame, scm_end_frame, scm_on_unwind, scm_on_rewind): + New. + (scm_dowinds, scm_i_dowinds): scm_dowinds has been renamed to + scm_i_dowinds and extended to handle frames and to invoke a 'turn' + function when the outermost wind point has been reached. The + latter is used to copy a continuation stack at the right time. + scm_dowinds remains available. + (SCM_GUARDSP, SCM_BEFORE_GUARD, SCM_AFTER_GUARD, SCM_GUARD_DATA, + tc16_guard, guards_print): Removed. + (scm_internal_dynamic_wind): Reimplemented using frames. + + * continuations.c (copy_stack): New, do only the stack copying + part of copy_stack_and_call. + (copy_stack_and_call): Copy the stack after unwinding and before + rewinding. + (scm_dynthrow): Do not call scm_dowinds, this is now done by + copy_stack_and_call. + 2004-01-04 Kevin Ryde * numbers.c (scm_less_p): Don't convert frac to float for compares, - can give results due to rounding. + can give bad results due to rounding. 2003-12-26 Marius Vollmer diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 5273dce93..5f726969b 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-01-03 Marius Vollmer + + * standalone/test-unwind.c: New test, for the frames stuff. + * standalone/Makefile.am: Compile and run it. + 2004-01-04 Kevin Ryde * tests/exceptions.test (false-if-exception): Add tests. diff --git a/test-suite/tests/continuations.test b/test-suite/tests/continuations.test new file mode 100644 index 000000000..04b6a85c3 --- /dev/null +++ b/test-suite/tests/continuations.test @@ -0,0 +1,54 @@ +;;;; -*- scheme -*- +;;;; continuations.test --- test suite for continutations +;;;; +;;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(define-module (test-suite test-continuations) + :use-module (test-suite lib)) + +(define (block-reentry body) + (let ((active #f)) + (dynamic-wind + (lambda () + (if active + (throw 'no-reentry))) + (lambda () + (set! active #t) + (body)) + (lambda () #f)))) + +(define (catch-tag body) + (catch #t + body + (lambda (tag . args) tag))) + +(define (check-cont) + (catch-tag + (lambda () + (block-reentry (lambda () (call/cc identity)))))) + +(define (dont-crash-please) + (let ((k (check-cont))) + (if (procedure? k) + (k 12) + k))) + +(with-test-prefix "continuations" + + (pass-if "throwing to a rewound catch context" + (eq? (dont-crash-please) 'no-reentry))) From 9879d3906e5a4de245d049fc92f4847941228143 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 3 Jan 2004 21:57:11 +0000 Subject: [PATCH 208/239] Added section about frames. --- NEWS | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 663d8608c..c8aff5b97 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,5 @@ Guile NEWS --- history of user-visible changes. -Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. +Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc. See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. @@ -578,6 +578,36 @@ starting the week. * Changes to the C interface +** New way to deal with non-local exits and reentries. + +There is a new set of functions that essentially do what +scm_internal_dynamic_wind does, but in a more convenient way. Here is +a quick example of how to prevent a potential memory leak: + + void + foo () + { + char *mem; + + scm_begin_frame (0); + + mem = scm_malloc (100); + scm_on_unwind (free, mem, SCM_F_WIND_EXPLICITELY); + + /* MEM would leak if BAR throws an error. SCM_ON_UNWIND frees it + nevertheless. + */ + bar (); + + scm_end_frame (); + + /* Because of SCM_F_WIND_EXPLICITELY, MEM will be freed by + SCM_END_FRAME as well. + */ + } + +For full documentation, see the node "Frames" in the manual. + ** New types scm_t_intmax and scm_t_uintmax. On platforms that have them, these types are identical to intmax_t and From aed92eab27a8f4fefc061119a7257153dccc9d54 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 21:58:04 +0000 Subject: [PATCH 209/239] (Threads): Note Guile uses POSIX threads, for concurrency and preemption. (C level thread interface): Note periodic libguile call required for C code in threads, add commented out reminders for SCM_TICK and guile-mode, for when those features are ready. --- doc/ref/scheme-scheduling.texi | 56 +++++++++++++++++++++++++--------- 1 file changed, 42 insertions(+), 14 deletions(-) diff --git a/doc/ref/scheme-scheduling.texi b/doc/ref/scheme-scheduling.texi index 8512cde92..b25dabd57 100644 --- a/doc/ref/scheme-scheduling.texi +++ b/doc/ref/scheme-scheduling.texi @@ -280,21 +280,12 @@ The @code{#f} case has not been implemented. @section Threads @cindex threads @cindex Guile threads +@cindex POSIX threads -@strong{[NOTE: this chapter was written for Cygnus Guile and has not yet -been updated for the Guile 1.x release.]} - -Here is a the reference for Guile's threads. In this chapter I simply -quote verbatim Tom Lord's description of the low-level primitives -written in C (basically an interface to the POSIX threads library) and -Anthony Green's description of the higher-level thread procedures -written in scheme. -@cindex posix threads -@cindex Lord, Tom -@cindex Green, Anthony - -When using Guile threads, keep in mind that each guile thread is -executed in a new dynamic root. +Guile threads are implemented using POSIX threads, they run +pre-emptively and concurrently through both Scheme code and system +calls. The only exception is for garbage collection, where all +threads must rendezvous. @menu * Low level thread primitives:: @@ -450,6 +441,43 @@ Furthermore, they are the primitives that Guile relies on for its own higher level threads. By reimplementing them, you can adapt Guile to different low-level thread implementations. +C code in a thread must call a libguile function periodically. When +one thread finds garbage collection is required, it waits for all +threads to rendezvous before doing that GC. Such a rendezvous is +checked within libguile functions. If C code wants to sleep or block +in a thread it should use one of the libguile functions provided. + +Only threads created by Guile can use the libguile functions. Threads +created directly with say @code{pthread_create} are unknown to Guile +and they cannot call libguile. The stack in such foreign threads is +not scanned during GC, so @code{SCM} values generally cannot be held +there. + +@c FIXME: +@c +@c Describe SCM_TICK which can be called if no other libguile +@c function is being used by a C function. +@c +@c Describe "Guile mode", which a thread can enter and exit. There +@c are no functions for doing this yet. +@c +@c When in guile mode a thread can call libguile, is subject to the +@c tick rule, and its stack is scanned. When not in guile mode it +@c cannot call libguile, it doesn't have to tick, and its stack is +@c not scanned. The strange guile control flow things like +@c exceptions, continuations and asyncs only occur when in guile +@c mode. +@c +@c When guile mode is exited, the portion of the stack allocated +@c while it was in guile mode is still scanned. This portion may not +@c be modified when outside guile mode. The stack ends up +@c partitioned into alternating guile and non-guile regions. +@c +@c Leaving guile mode is convenient when running an extended +@c calculation not involving guile, since one doesn't need to worry +@c about SCM_TICK calls. + + @deftp {C Data Type} scm_t_thread This data type represents a thread, to be used with scm_thread_create, etc. From ec76b8f94fb27c140a1947bcee854f76d933ddba Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 22:04:37 +0000 Subject: [PATCH 210/239] *** empty log message *** --- doc/ref/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 6e879f2c2..a4dd88e34 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -5,6 +5,12 @@ 2004-01-04 Kevin Ryde + * scheme-scheduling.texi (Threads): Note Guile uses POSIX threads, for + concurrency and preemption. + (C level thread interface): Note periodic libguile call required for C + code in threads, add commented out reminders for SCM_TICK and + guile-mode, for when those features are ready. + * srfi-modules.texi (SRFI-1 Filtering and Partitioning): For partition and partition!, emphasise the multi-value return, note partition may share a tail with the given list. From f40771d8833d5d9a1bd9dbb9aa468c9a27360c0a Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 22:25:24 +0000 Subject: [PATCH 211/239] (scm_current_time, scm_gettimeofday): Add a comment about setzone/restorezone protection for DOS. --- libguile/stime.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/libguile/stime.c b/libguile/stime.c index e792eba08..6bf212210 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -180,6 +180,13 @@ SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0, } #undef FUNC_NAME +/* For reference, note that current-time and gettimeofday both should be + protected against setzone/restorezone changes in another thread, since on + DOS the system time is normally kept as local time, which means TZ + affects the return from current-time and gettimeofday. Not sure if DJGPP + etc actually has concurrent multi-threading, but it seems prudent not to + make assumptions about this. */ + SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0, (void), "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n" From e0499207154aa2ceff06e7679cd94afc25b3001e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 3 Jan 2004 22:34:05 +0000 Subject: [PATCH 212/239] *** empty log message *** --- libguile/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7491f45d9..03db8277b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -24,6 +24,9 @@ * numbers.c (scm_less_p): Don't convert frac to float for compares, can give bad results due to rounding. + * stime.c (scm_current_time, scm_gettimeofday): Add a comment about + setzone/restorezone protection for DOS. + 2003-12-26 Marius Vollmer * gen-scmconfig.h.in, gen-scmconfig.c: Arrange for scm_t_intmax From b57a0953fe589a52a5460526e1eda42b8a10e6a1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 4 Jan 2004 23:36:49 +0000 Subject: [PATCH 213/239] (scm_with_blocked_asyncs, scm_with_unblocked_asyncs): New. --- libguile/async.c | 20 +++++++++++++++++++- libguile/async.h | 4 +++- 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index 2edfa8329..ff4c9fc5a 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -364,6 +364,24 @@ scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data) data, NULL); } +void +scm_with_blocked_asyncs () +{ + scm_on_rewind (increase_block, NULL, SCM_F_WIND_EXPLICITELY); + scm_on_unwind (decrease_block, NULL, SCM_F_WIND_EXPLICITELY); +} + +void +scm_with_unblocked_asyncs () +{ + if (scm_root->block_asyncs == 0) + scm_misc_error ("scm_with_unblocked_asyncs", + "asyncs already unblocked", SCM_EOL); + scm_on_rewind (decrease_block, NULL, SCM_F_WIND_EXPLICITELY); + scm_on_unwind (increase_block, NULL, SCM_F_WIND_EXPLICITELY); +} + + void diff --git a/libguile/async.h b/libguile/async.h index 5e18a04e5..3174c7a48 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -3,7 +3,7 @@ #ifndef SCM_ASYNC_H #define SCM_ASYNC_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -44,6 +44,8 @@ SCM_API SCM scm_call_with_blocked_asyncs (SCM proc); SCM_API SCM scm_call_with_unblocked_asyncs (SCM proc); void *scm_c_call_with_blocked_asyncs (void *(*p) (void *d), void *d); void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d); +void scm_with_blocked_asyncs (void); +void scm_with_unblocked_asyncs (void); SCM_API void scm_init_async (void); #if (SCM_ENABLE_DEPRECATED == 1) From 185e369a7f8fa3f79b646803fd2b0e2edecc186d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 4 Jan 2004 23:40:14 +0000 Subject: [PATCH 214/239] (scm_with_current_input_port, scm_with_current_output_port, scm_with_current_error_port): New. --- libguile/ports.c | 57 +++++++++++++++++++++++++++++++++++++++++++++++- libguile/ports.h | 5 ++++- 2 files changed, 60 insertions(+), 2 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index e3419dc33..2a7305d3f 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -31,6 +31,7 @@ #include "libguile/objects.h" #include "libguile/smob.h" #include "libguile/chars.h" +#include "libguile/dynwind.h" #include "libguile/keywords.h" #include "libguile/root.h" @@ -425,6 +426,60 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0, } #undef FUNC_NAME +typedef struct { + SCM value; + SCM (*getter) (void); + SCM (*setter) (SCM); +} swap_data; + +static void +swap_port (void *data) +{ + swap_data *d = (swap_data *)data; + SCM t; + + t = d->getter (); + d->setter (d->value); + d->value = t; +} + +static void +scm_with_current_foo_port (SCM port, + SCM (*getter) (void), SCM (*setter) (SCM)) +{ + swap_data data; + data.value = port; + data.getter = getter; + data.setter = setter; + + scm_on_rewind (swap_port, &data, SCM_F_WIND_EXPLICITELY); + scm_on_unwind (swap_port, &data, SCM_F_WIND_EXPLICITELY); +} + +void +scm_with_current_input_port (SCM port) +{ + scm_with_current_foo_port (port, + scm_current_input_port, + scm_set_current_input_port); +} + +void +scm_with_current_output_port (SCM port) +{ + scm_with_current_foo_port (port, + scm_current_output_port, + scm_set_current_output_port); +} + +void +scm_with_current_error_port (SCM port) +{ + scm_with_current_foo_port (port, + scm_current_error_port, + scm_set_current_error_port); +} + /* The port table --- an array of pointers to ports. */ diff --git a/libguile/ports.h b/libguile/ports.h index 164a2bed3..796ccf87e 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -3,7 +3,7 @@ #ifndef SCM_PORTS_H #define SCM_PORTS_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -235,6 +235,9 @@ SCM_API SCM scm_current_load_port (void); SCM_API SCM scm_set_current_input_port (SCM port); SCM_API SCM scm_set_current_output_port (SCM port); SCM_API SCM scm_set_current_error_port (SCM port); +SCM_API void scm_with_current_input_port (SCM port); +SCM_API void scm_with_current_output_port (SCM port); +SCM_API void scm_with_current_error_port (SCM port); SCM_API SCM scm_new_port_table_entry (scm_t_bits tag); SCM_API void scm_remove_from_port_table (SCM port); SCM_API void scm_grow_port_cbuf (SCM port, size_t requested); From e911f3ff4ba85420e399258faa8274c73446dfd3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 4 Jan 2004 23:43:20 +0000 Subject: [PATCH 215/239] Minor markup fixes. --- doc/ref/scheme-control.texi | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/ref/scheme-control.texi b/doc/ref/scheme-control.texi index 49632ea7e..af574e90a 100644 --- a/doc/ref/scheme-control.texi +++ b/doc/ref/scheme-control.texi @@ -24,7 +24,7 @@ function that has already exited. This might cause some functions to return more than once. In general, these non-local jumps are done by invoking -@emph{continuations} that have previously been captured using +@dfn{continuations} that have previously been captured using @code{call-with-current-continuation}. Guile also offers a slightly restricted set of functions, @code{catch} and @code{throw}, that can only be used for non-local exits. This restriction makes them more @@ -57,7 +57,7 @@ when control enters non-locally. Scheme code can use the @code{dynamic-wind} function to arrange the setting and resetting of the global state. C code could use the corresponding @code{scm_internal_dynamic_wind} function, but it might -prefer to use the @emph{frames} concept that is more natural for C code. +prefer to use the @dfn{frames} concept that is more natural for C code. @menu * begin:: Evaluating a sequence of expressions. @@ -444,8 +444,8 @@ flow going on as normal. The functions @code{dynamic-wind} (@pxref{Dynamic Wind}) can be used to ensure setup and cleanup code is run when a program locus is resumed or -abandoned through the continuation mechanism. C code can use the -functions explained in @pxref{Frames}. +abandoned through the continuation mechanism. C code can use +@dfn{frames} (@pxref{Frames}). @sp 1 Continuations are a powerful mechanism, and can be used to implement From c76ff57bff40984e0bb76fe34b3e32488c6f428a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 4 Jan 2004 23:44:19 +0000 Subject: [PATCH 216/239] Document scm_with_current__port. --- doc/ref/scheme-io.texi | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/doc/ref/scheme-io.texi b/doc/ref/scheme-io.texi index 54688c061..58deaf9aa 100644 --- a/doc/ref/scheme-io.texi +++ b/doc/ref/scheme-io.texi @@ -634,6 +634,18 @@ Change the ports returned by @code{current-input-port}, so that they use the supplied @var{port} for input or output. @end deffn +@deftypefn {C Function} void scm_with_current_input_port (SCM port) +@deftypefnx {C Function} void scm_with_current_output_port (SCM port) +@deftypefnx {C Function} void scm_with_current_error_port (SCM port) +These functions must be used inside a pair of calls to +@code{scm_begin_frame} and @code{scm_end_frame} (@pxref{Frames}). +During the dynamic extent of the frame, the indicated port is set to +@var{port}. + +More precisely, the the current port is saved when the dynamic extent is +entered and set to @var{port}. When the dynamic extent is left, the +current port is stored in @var{port} and reset to the saved value. +@end deftypefn @node Port Types @section Types of Port From fb89fef7fb8d28be9100c87c8c0408a7eec28993 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 4 Jan 2004 23:45:11 +0000 Subject: [PATCH 217/239] Document scm_with_[un]blocked_asyncs. --- doc/ref/scheme-scheduling.texi | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/doc/ref/scheme-scheduling.texi b/doc/ref/scheme-scheduling.texi index b25dabd57..c9b4a029a 100644 --- a/doc/ref/scheme-scheduling.texi +++ b/doc/ref/scheme-scheduling.texi @@ -101,6 +101,12 @@ temporarily decrease the blocking level of the current thread. You can use it when you want to disable asyncs by default and only allow them temporarily. +In addition to the C versions of @code{call-with-blocked-asyncs} and +@code{call-with-unblocked-asyncs}, C code can use +@code{scm_with_blocked_asyncs} and @code{scm_with_unblocked_asyncs} +inside a @dfn{frame} (@pxref{Frames}) to block or unblock system asyncs +temporarily. + @deffn {Scheme Procedure} system-async-mark proc [thread] @deffnx {C Function} scm_system_async_mark (proc) @deffnx {C Function} scm_system_async_mark_for_thread (proc, thread) @@ -141,6 +147,19 @@ returned by @var{proc}. For the first two variants, call @var{proc} with no arguments; for the third, call it with @var{data}. @end deffn +@deftypefn {C Function} void scm_with_blocked_asyncs () +This function must be used inside a pair of calls to +@code{scm_begin_frame} and @code{scm_end_frame} (@pxref{Frames}). +During the dynamic extent of the frame, asyncs are blocked by one level. +@end deftypefn + +@deftypefn {C Function} void scm_with_unblocked_asyncs () +This function must be used inside a pair of calls to +@code{scm_begin_frame} and @code{scm_end_frame} (@pxref{Frames}). +During the dynamic extent of the frame, asyncs are unblocked by one +level. +@end deftypefn + @node User asyncs @subsection User asyncs From 49c00ecc7b373b80bc8b3c604c864e7e90e6fc07 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 4 Jan 2004 23:45:38 +0000 Subject: [PATCH 218/239] *** empty log message *** --- NEWS | 11 +++++++++++ doc/ref/ChangeLog | 6 ++++++ libguile/ChangeLog | 8 ++++++++ 3 files changed, 25 insertions(+) diff --git a/NEWS b/NEWS index c8aff5b97..b77391f38 100644 --- a/NEWS +++ b/NEWS @@ -608,6 +608,17 @@ a quick example of how to prevent a potential memory leak: For full documentation, see the node "Frames" in the manual. +** New way to block and unblock asyncs + +In addition to scm_c_call_with_blocked_asyncs you can now also use +scm_with_blocked_asyncs in a 'frame' (see above). Likewise for +scm_c_call_with_unblocked_asyncs and scm_with_unblocked_asyncs. + +** New way to temporarily set the current input, output or error ports + +C code can now use scm_with_current__port in a 'frame' (see +above). is one of "input", "output" or "error". + ** New types scm_t_intmax and scm_t_uintmax. On platforms that have them, these types are identical to intmax_t and diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index a4dd88e34..fdec1467f 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,9 @@ +2004-01-05 Marius Vollmer + + * scheme-scheduling.texi: Document scm_with_[un]blocked_asyncs. + + * scheme-io.texi: Document scm_with_current__port. + 2004-01-03 Marius Vollmer * scheme-control.texi: Document the frames stuff and other random diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 03db8277b..5c4db53ef 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2004-01-05 Marius Vollmer + + * ports.h, ports.c (scm_with_current_input_port, + scm_with_current_output_port, scm_with_current_error_port): New. + + * async.h, async.c (scm_with_blocked_asyncs, + scm_with_unblocked_asyncs): New. + 2004-01-03 Marius Vollmer * dynwind.h, scm_dynwind.c (scm_t_frame_flags, scm_t_wind_flags, From 08feeec84a26d379985b2baf640f88f73847383e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 6 Jan 2004 16:19:21 +0000 Subject: [PATCH 219/239] (print-result, print-user-result): Handle exact fractions. --- benchmark-suite/lib.scm | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/benchmark-suite/lib.scm b/benchmark-suite/lib.scm index 49e37be0c..840784e85 100644 --- a/benchmark-suite/lib.scm +++ b/benchmark-suite/lib.scm @@ -450,16 +450,17 @@ (user-time\interpreter (benchmark-user-time\interpreter before after gc-time)) (benchmark-core-time\interpreter - (benchmark-core-time\interpreter iterations before after gc-time))) + (benchmark-core-time\interpreter iterations before after gc-time)) + (i/ (lambda (a b) (exact->inexact (/ a b))))) (write (list name iterations - 'total (/ total-time time-base) - 'user (/ user-time time-base) - 'system (/ system-time time-base) - 'frame (/ frame-time time-base) - 'benchmark (/ benchmark-time time-base) - 'user/interp (/ user-time\interpreter time-base) - 'bench/interp (/ benchmark-core-time\interpreter time-base) - 'gc (/ gc-time time-base)) + 'total (i/ total-time time-base) + 'user (i/ user-time time-base) + 'system (i/ system-time time-base) + 'frame (i/ frame-time time-base) + 'benchmark (i/ benchmark-time time-base) + 'user/interp (i/ user-time\interpreter time-base) + 'bench/interp (i/ benchmark-core-time\interpreter time-base) + 'gc (i/ gc-time time-base)) port) (newline port))) @@ -482,12 +483,13 @@ (user-time (benchmark-user-time before after)) (benchmark-time (benchmark-core-time iterations before after)) (benchmark-core-time\interpreter - (benchmark-core-time\interpreter iterations before after gc-time))) + (benchmark-core-time\interpreter iterations before after gc-time)) + (i/ (lambda (a b) (exact->inexact (/ a b))))) (write (list name iterations - 'user (/ user-time time-base) - 'benchmark (/ benchmark-time time-base) - 'bench/interp (/ benchmark-core-time\interpreter time-base) - 'gc (/ gc-time time-base)) + 'user (i/ user-time time-base) + 'benchmark (i/ benchmark-time time-base) + 'bench/interp (i/ benchmark-core-time\interpreter time-base) + 'gc (i/ gc-time time-base)) port) (newline port))) From 476e56aa6445c3e625da9662529a22eb327fd87d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 6 Jan 2004 16:20:03 +0000 Subject: [PATCH 220/239] *** empty log message *** --- benchmark-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/benchmark-suite/ChangeLog b/benchmark-suite/ChangeLog index 296026af1..09e00a3e2 100644 --- a/benchmark-suite/ChangeLog +++ b/benchmark-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-01-06 Marius Vollmer + + * lib.scm (print-result, print-user-result): Handle exact + fractions. + 2003-05-27 Dirk Herrmann * lib.scm: Fix some typos in the documentation. From 62f3c0957e3e5aac821e304ff5fcb613400d3ba0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 6 Jan 2004 17:57:41 +0000 Subject: [PATCH 221/239] (SCM_F_WIND_EXPLICITELY, SCM_F_WIND_EXPLICITLY): It's "explicitly" not "explicitely", damn. Changed all uses. --- libguile/dynwind.h | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/dynwind.h b/libguile/dynwind.h index b207d83b8..920e9a83c 100644 --- a/libguile/dynwind.h +++ b/libguile/dynwind.h @@ -47,7 +47,7 @@ typedef enum { } scm_t_frame_flags; typedef enum { - SCM_F_WIND_EXPLICITELY = (1 << 0) + SCM_F_WIND_EXPLICITLY = (1 << 0) } scm_t_wind_flags; SCM_API void scm_begin_frame (scm_t_frame_flags); @@ -58,6 +58,11 @@ SCM_API void scm_on_unwind (void (*func) (void *), void *data, SCM_API void scm_on_rewind (void (*func) (void *), void *data, scm_t_wind_flags); +SCM_API void scm_on_unwind_with_scm (void (*func) (SCM), SCM data, + scm_t_wind_flags); +SCM_API void scm_on_rewind_with_scm (void (*func) (SCM), SCM data, + scm_t_wind_flags); + #ifdef GUILE_DEBUG SCM_API SCM scm_wind_chain (void); #endif /*GUILE_DEBUG*/ From a520e4f0d0268236bea18a890b5320f358d5f487 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 6 Jan 2004 18:04:47 +0000 Subject: [PATCH 222/239] (frame_print): Removed, use the default printer. (WINDER_F_MARK, WINDER_MARK_P, winder_mark): New. (scm_on_unwind_with_scm, scm_on_rewind_with_scm): New. Use above to protect SCM values. --- libguile/dynwind.c | 55 ++++++++++++++++++++++++++++++++++------------ 1 file changed, 41 insertions(+), 14 deletions(-) diff --git a/libguile/dynwind.c b/libguile/dynwind.c index ca934c912..1a02dd1c0 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -122,8 +122,8 @@ scm_internal_dynamic_wind (scm_t_guard before, SCM ans; scm_begin_frame (SCM_F_FRAME_REWINDABLE); - scm_on_rewind (before, guard_data, SCM_F_WIND_EXPLICITELY); - scm_on_unwind (after, guard_data, SCM_F_WIND_EXPLICITELY); + scm_on_rewind (before, guard_data, SCM_F_WIND_EXPLICITLY); + scm_on_unwind (after, guard_data, SCM_F_WIND_EXPLICITLY); ans = inner (inner_data); scm_end_frame (); return ans; @@ -144,15 +144,10 @@ static scm_t_bits tc16_winder; #define WINDER_F_EXPLICIT (1 << 16) #define WINDER_F_REWIND (1 << 17) +#define WINDER_F_MARK (1 << 18) #define WINDER_EXPLICIT_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_EXPLICIT) #define WINDER_REWIND_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_REWIND) - -static int -frame_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED) -{ - scm_puts ("#", port); - return 1; -} +#define WINDER_MARK_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_MARK) void scm_begin_frame (scm_t_frame_flags flags) @@ -186,12 +181,20 @@ scm_end_frame (void) assert (0); } +static SCM +winder_mark (SCM w) +{ + if (WINDER_MARK_P (w)) + return WINDER_DATA (w); + return SCM_BOOL_F; +} + void scm_on_unwind (void (*proc) (void *), void *data, scm_t_wind_flags flags) { SCM w; - scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITELY)? WINDER_F_EXPLICIT : 0); + scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0); SCM_NEWSMOB2 (w, tc16_winder | fl, (scm_t_bits) proc, (scm_t_bits) data); scm_dynwinds = scm_cons (w, scm_dynwinds); @@ -205,7 +208,30 @@ scm_on_rewind (void (*proc) (void *), void *data, SCM_NEWSMOB2 (w, tc16_winder | WINDER_F_REWIND, (scm_t_bits) proc, (scm_t_bits) data); scm_dynwinds = scm_cons (w, scm_dynwinds); - if (flags & SCM_F_WIND_EXPLICITELY) + if (flags & SCM_F_WIND_EXPLICITLY) + proc (data); +} + +void +scm_on_unwind_with_scm (void (*proc) (SCM), SCM data, + scm_t_wind_flags flags) +{ + SCM w; + scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0); + SCM_NEWSMOB2 (w, tc16_winder | fl | WINDER_F_MARK, + (scm_t_bits) proc, SCM_UNPACK (data)); + scm_dynwinds = scm_cons (w, scm_dynwinds); +} + +void +scm_on_rewind_with_scm (void (*proc) (SCM), SCM data, + scm_t_wind_flags flags) +{ + SCM w; + SCM_NEWSMOB2 (w, tc16_winder | WINDER_F_REWIND | WINDER_F_MARK, + (scm_t_bits) proc, SCM_UNPACK (data)); + scm_dynwinds = scm_cons (w, scm_dynwinds); + if (flags & SCM_F_WIND_EXPLICITLY) proc (data); } @@ -296,7 +322,7 @@ scm_i_dowinds (SCM to, long delta, int explicit, if (SCM_VARIABLEP (SCM_CAR (wind_key))) scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); else if (SCM_FLUIDP (SCM_CAR (wind_key))) - scm_swap_fluids (wind_key, SCM_CDR (wind_elt)); + scm_i_swap_fluids (wind_key, SCM_CDR (wind_elt)); } else if (SCM_TYP3 (wind_key) == scm_tc3_closure) scm_call_0 (wind_key); @@ -345,7 +371,8 @@ scm_i_dowinds (SCM to, long delta, int explicit, if (SCM_VARIABLEP (SCM_CAR (wind_key))) scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); else if (SCM_FLUIDP (SCM_CAR (wind_key))) - scm_swap_fluids_reverse (wind_key, SCM_CDR (wind_elt)); + scm_i_swap_fluids_reverse (wind_key, + SCM_CDR (wind_elt)); } else if (SCM_TYP3 (wind_key) == scm_tc3_closure) scm_call_0 (SCM_CDR (wind_elt)); @@ -361,9 +388,9 @@ void scm_init_dynwind () { tc16_frame = scm_make_smob_type ("frame", 0); - scm_set_smob_print (tc16_frame, frame_print); tc16_winder = scm_make_smob_type ("winder", 0); + scm_set_smob_mark (tc16_winder, winder_mark); #include "libguile/dynwind.x" } From a52dbe0177291dc914cbfff2cb2a7652d3b9713f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 6 Jan 2004 18:08:31 +0000 Subject: [PATCH 223/239] (scm_make_initial_fluids, scm_copy_fluids, scm_swap_fluids, scm_swap_fluids_reverse): Renamed to scm_i_... since they are internal. Changed all uses. --- libguile/fluids.c | 14 +++++++------- libguile/fluids.h | 8 ++++---- libguile/init.c | 2 +- libguile/root.c | 2 +- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/libguile/fluids.c b/libguile/fluids.c index 826883e4e..32a5ffd37 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -35,7 +35,7 @@ static volatile long n_fluids; scm_t_bits scm_tc16_fluid; SCM -scm_make_initial_fluids () +scm_i_make_initial_fluids () { return scm_c_make_vector (INITIAL_FLUIDS, SCM_BOOL_F); } @@ -65,7 +65,7 @@ grow_fluids (scm_root_state *root_state, int new_length) } void -scm_copy_fluids (scm_root_state *root_state) +scm_i_copy_fluids (scm_root_state *root_state) { grow_fluids (root_state, SCM_VECTOR_LENGTH (root_state->fluids)); } @@ -153,7 +153,7 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, #undef FUNC_NAME void -scm_swap_fluids (SCM fluids, SCM vals) +scm_i_swap_fluids (SCM fluids, SCM vals) { while (!SCM_NULL_OR_NIL_P (fluids)) { @@ -170,13 +170,13 @@ scm_swap_fluids (SCM fluids, SCM vals) same fluid appears multiple times in the fluids list. */ void -scm_swap_fluids_reverse (SCM fluids, SCM vals) +scm_i_swap_fluids_reverse (SCM fluids, SCM vals) { if (!SCM_NULL_OR_NIL_P (fluids)) { SCM fl, old_val; - scm_swap_fluids_reverse (SCM_CDR (fluids), SCM_CDR (vals)); + scm_i_swap_fluids_reverse (SCM_CDR (fluids), SCM_CDR (vals)); fl = SCM_CAR (fluids); old_val = scm_fluid_ref (fl); scm_fluid_set_x (fl, SCM_CAR (vals)); @@ -215,11 +215,11 @@ scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata) if (flen != vlen) scm_out_of_range (s_scm_with_fluids, values); - scm_swap_fluids (fluids, values); + scm_i_swap_fluids (fluids, values); scm_dynwinds = scm_acons (fluids, values, scm_dynwinds); ans = cproc (cdata); scm_dynwinds = SCM_CDR (scm_dynwinds); - scm_swap_fluids_reverse (fluids, values); + scm_i_swap_fluids_reverse (fluids, values); return ans; } #undef FUNC_NAME diff --git a/libguile/fluids.h b/libguile/fluids.h index 4cf26ecdd..07dce8523 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -76,10 +76,10 @@ SCM_API SCM scm_c_with_fluid (SCM fluid, SCM val, SCM (*cproc)(void *), void *cdata); SCM_API SCM scm_with_fluids (SCM fluids, SCM vals, SCM thunk); -SCM_API SCM scm_make_initial_fluids (void); -SCM_API void scm_copy_fluids (scm_root_state *); -SCM_API void scm_swap_fluids (SCM fluids, SCM vals); -SCM_API void scm_swap_fluids_reverse (SCM fluids, SCM vals); +SCM_API SCM scm_i_make_initial_fluids (void); +SCM_API void scm_i_copy_fluids (scm_root_state *); +SCM_API void scm_i_swap_fluids (SCM fluids, SCM vals); +SCM_API void scm_i_swap_fluids_reverse (SCM fluids, SCM vals); SCM_API void scm_init_fluids (void); diff --git a/libguile/init.c b/libguile/init.c index b3bf57504..3e96942d1 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -152,7 +152,7 @@ start_stack (void *base) scm_exitval = SCM_BOOL_F; /* vestigial */ - scm_root->fluids = scm_make_initial_fluids (); + scm_root->fluids = scm_i_make_initial_fluids (); /* Create an object to hold the root continuation. */ diff --git a/libguile/root.c b/libguile/root.c index c98b29176..dc80f7469 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -112,7 +112,7 @@ scm_make_root (SCM parent) if (SCM_ROOTP (parent)) /* Must be done here so that fluids are GC protected */ - scm_copy_fluids (root_state); + scm_i_copy_fluids (root_state); return root; } From b42170a484f0f77bbfa481f37accde19d0a27654 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 6 Jan 2004 18:09:42 +0000 Subject: [PATCH 224/239] (swap_ports, scm_with_current_foo_port): Do not allocate swap_data on stack, use a 'malloc obj'. --- libguile/ports.c | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 2a7305d3f..70fdcc0f2 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -36,7 +36,7 @@ #include "libguile/keywords.h" #include "libguile/root.h" #include "libguile/strings.h" - +#include "libguile/mallocs.h" #include "libguile/validate.h" #include "libguile/ports.h" @@ -433,9 +433,9 @@ typedef struct { } swap_data; static void -swap_port (void *data) +swap_port (SCM scm_data) { - swap_data *d = (swap_data *)data; + swap_data *d = (swap_data *)SCM_MALLOCDATA (scm_data); SCM t; t = d->getter (); @@ -447,13 +447,14 @@ static void scm_with_current_foo_port (SCM port, SCM (*getter) (void), SCM (*setter) (SCM)) { - swap_data data; - data.value = port; - data.getter = getter; - data.setter = setter; + SCM scm_data = scm_malloc_obj (sizeof (swap_data)); + swap_data *data = (swap_data *)SCM_MALLOCDATA (scm_data); + data->value = port; + data->getter = getter; + data->setter = setter; - scm_on_rewind (swap_port, &data, SCM_F_WIND_EXPLICITELY); - scm_on_unwind (swap_port, &data, SCM_F_WIND_EXPLICITELY); + scm_on_rewind_with_scm (swap_port, scm_data, SCM_F_WIND_EXPLICITLY); + scm_on_unwind_with_scm (swap_port, scm_data, SCM_F_WIND_EXPLICITLY); } void From 9320d21970a832a52be72108a6ef5489265618fb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 6 Jan 2004 18:11:55 +0000 Subject: [PATCH 225/239] dynwind.h (SCM_F_WIND_EXPLICITELY, SCM_F_WIND_EXPLICITLY): It's "explicitly" not "explicitely", damn. Changed all uses. --- libguile/async.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index ff4c9fc5a..276292ac1 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -367,8 +367,8 @@ scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data) void scm_with_blocked_asyncs () { - scm_on_rewind (increase_block, NULL, SCM_F_WIND_EXPLICITELY); - scm_on_unwind (decrease_block, NULL, SCM_F_WIND_EXPLICITELY); + scm_on_rewind (increase_block, NULL, SCM_F_WIND_EXPLICITLY); + scm_on_unwind (decrease_block, NULL, SCM_F_WIND_EXPLICITLY); } void @@ -377,8 +377,8 @@ scm_with_unblocked_asyncs () if (scm_root->block_asyncs == 0) scm_misc_error ("scm_with_unblocked_asyncs", "asyncs already unblocked", SCM_EOL); - scm_on_rewind (decrease_block, NULL, SCM_F_WIND_EXPLICITELY); - scm_on_unwind (increase_block, NULL, SCM_F_WIND_EXPLICITELY); + scm_on_rewind (decrease_block, NULL, SCM_F_WIND_EXPLICITLY); + scm_on_unwind (increase_block, NULL, SCM_F_WIND_EXPLICITLY); } From c05d0e8f1e2a20b021669125953209922d900c56 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 6 Jan 2004 18:13:51 +0000 Subject: [PATCH 226/239] (close_port, delete_file, check_ports): New. --- test-suite/standalone/test-unwind.c | 60 ++++++++++++++++++++++++++++- 1 file changed, 58 insertions(+), 2 deletions(-) diff --git a/test-suite/standalone/test-unwind.c b/test-suite/standalone/test-unwind.c index 7ccfef55a..e64c6e4c3 100644 --- a/test-suite/standalone/test-unwind.c +++ b/test-suite/standalone/test-unwind.c @@ -1,6 +1,7 @@ #include #include #include +#include void set_flag (void *data); void func1 (void); @@ -12,6 +13,9 @@ SCM check_flag1_body (void *data); SCM return_tag (void *data, SCM tag, SCM args); void check_cont (int rewindable); SCM check_cont_body (void *data); +void close_port (SCM port); +void delete_file (void *data); +void check_ports (void); int flag1, flag2, flag3; @@ -42,7 +46,7 @@ func2 () { scm_begin_frame (0); flag1 = 0; - scm_on_unwind (set_flag, &flag1, SCM_F_WIND_EXPLICITELY); + scm_on_unwind (set_flag, &flag1, SCM_F_WIND_EXPLICITLY); scm_end_frame (); } @@ -67,7 +71,7 @@ func4 () { scm_begin_frame (0); flag1 = 0; - scm_on_unwind (set_flag, &flag1, SCM_F_WIND_EXPLICITELY); + scm_on_unwind (set_flag, &flag1, SCM_F_WIND_EXPLICITLY); scm_misc_error ("func4", "gratuitous error", SCM_EOL); scm_end_frame (); } @@ -149,6 +153,56 @@ check_cont (int rewindable) exit (1); } } + +void +close_port (SCM port) +{ + scm_close_port (port); +} + +void +delete_file (void *data) +{ + unlink ((char *)data); +} + +void +check_ports () +{ + char filename[] = "/tmp/check-ports.XXXXXX"; + + if (mktemp (filename) == NULL) + exit (1); + + scm_begin_frame (0); + { + SCM port = scm_open_file (scm_str2string (filename), + scm_str2string ("w")); + scm_on_unwind_with_scm (close_port, port, SCM_F_WIND_EXPLICITLY); + + scm_with_current_output_port (port); + scm_write (scm_version (), SCM_UNDEFINED); + } + scm_end_frame (); + + scm_begin_frame (0); + { + SCM port = scm_open_file (scm_str2string (filename), + scm_str2string ("r")); + SCM res; + scm_on_unwind_with_scm (close_port, port, SCM_F_WIND_EXPLICITLY); + scm_on_unwind (delete_file, filename, SCM_F_WIND_EXPLICITLY); + + scm_with_current_input_port (port); + res = scm_read (SCM_UNDEFINED); + if (SCM_FALSEP (scm_equal_p (res, scm_version ()))) + { + printf ("ports didn't work\n"); + exit (1); + } + } + scm_end_frame (); +} static void inner_main (void *data, int argc, char **argv) @@ -161,6 +215,8 @@ inner_main (void *data, int argc, char **argv) check_cont (0); check_cont (1); + check_ports (); + exit (0); } From becc4b2716b6d7a108ae8170eb20f730302f0585 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 6 Jan 2004 18:17:17 +0000 Subject: [PATCH 227/239] Document scm_on_unwind_with_scm and scm_on_rewind_with_scm. --- doc/ref/scheme-control.texi | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/doc/ref/scheme-control.texi b/doc/ref/scheme-control.texi index af574e90a..023fdb9b7 100644 --- a/doc/ref/scheme-control.texi +++ b/doc/ref/scheme-control.texi @@ -1156,24 +1156,32 @@ This is an enumeration of several flags that modify the behavior of the following table. @table @code -@item SCM_F_WIND_EXPLICITELY +@item SCM_F_WIND_EXPLICITLY The registered action is also carried out when the frame is entered or left locally. @end table @end deftp @deftypefn {C Function} void scm_on_unwind (void (*func)(void *), void *data, scm_t_wind_flags flags) +@deftypefnx {C Function} void scm_on_unwind_with_scm (void (*func)(SCM), SCM data, scm_t_wind_flags flags) Arranges for @var{func} to be called with @var{data} as its arguments when the current frame ends implicitly. If @var{flags} contains -@code{SCM_F_WIND_EXPLICITELY}, @var{func} is also called when the frame +@code{SCM_F_WIND_EXPLICITLY}, @var{func} is also called when the frame ends explicitly with @code{scm_end_frame}. + +The function @code{scm_on_unwind_with_scm} takes care that @var{data} +is protected from garbage collected. @end deftypefn @deftypefn {C Function} void scm_on_rewind (void (*func)(void *), void *data, scm_t_wind_flags flags) +@deftypefnx {C Function} void scm_on_rewind_with_scm (void (*func)(SCM), SCM data, scm_t_wind_flags flags) Arrange for @var{func} to be called with @var{data} as its argument when the current frame is restarted by rewinding the stack. When @var{flags} -contains @code{SCM_F_WIND_EXPLICITELY}, @var{func} is called immediately +contains @code{SCM_F_WIND_EXPLICITLY}, @var{func} is called immediately as well. + +The function @code{scm_on_rewind_with_scm} takes care that @var{data} +is protected from garbage collected. @end deftypefn From aacff585bc02ee0a660c5d70b6c798da25e41e12 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 6 Jan 2004 18:17:30 +0000 Subject: [PATCH 228/239] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ libguile/ChangeLog | 19 +++++++++++++++++++ test-suite/ChangeLog | 5 +++++ 3 files changed, 29 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index fdec1467f..ecebd2a76 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2004-01-06 Marius Vollmer + + * scheme-control.texi: Document scm_on_unwind_with_scm and + scm_on_rewind_with_scm. + 2004-01-05 Marius Vollmer * scheme-scheduling.texi: Document scm_with_[un]blocked_asyncs. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5c4db53ef..a7c3a1f86 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,22 @@ +2004-01-06 Marius Vollmer + + * ports.c (swap_ports, scm_with_current_foo_port): Do not allocate + swap_data on stack, use a 'malloc obj'. + + * fluids.h, fluids.c (scm_make_initial_fluids, scm_copy_fluids, + scm_swap_fluids, scm_swap_fluids_reverse): Renamed to + scm_i_... since they are internal. Changed all uses. + + * dynwind.c (frame_print): Removed, use the default printer. + (WINDER_F_MARK, WINDER_MARK_P, winder_mark): New. + (scm_on_unwind_with_scm, scm_on_rewind_with_scm): New. Use above + to protect SCM values. + + * dynwind.h (SCM_F_WIND_EXPLICITELY, + SCM_F_WIND_EXPLICITLY): It's "explicitly" not "explicitely", damn. + Changed all uses. + (scm_on_unwind_with_scm, scm_on_rewind_with_scm): New. + 2004-01-05 Marius Vollmer * ports.h, ports.c (scm_with_current_input_port, diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 5f726969b..6eaa04c30 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-01-06 Marius Vollmer + + * standalone/test-unwind.c (close_port, delete_file, check_ports): + New. + 2004-01-03 Marius Vollmer * standalone/test-unwind.c: New test, for the frames stuff. From b41478a13d5e51a53d834809d9b32e5acaf0b891 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 6 Jan 2004 21:38:34 +0000 Subject: [PATCH 229/239] (q-pop!): Should be "null?" not "not" for end-of-list. Reported by Richard Todd. --- ice-9/q.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ice-9/q.scm b/ice-9/q.scm index b73a8ca6d..edc653930 100644 --- a/ice-9/q.scm +++ b/ice-9/q.scm @@ -1,6 +1,6 @@ ;;;; q.scm --- Queues ;;;; -;;;; Copyright (C) 1995, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1995, 2001, 2004 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -136,7 +136,7 @@ (q-empty-check q) (let ((it (caar q)) (next (cdar q))) - (if (not next) + (if (null? next) (set-cdr! q #f)) (set-car! q next) it)) From 8f85f93d88c24647dce830ea96b9293ae1256e06 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 6 Jan 2004 21:43:55 +0000 Subject: [PATCH 230/239] New file. (q-pop!): Exercise this, in particular the "not/null?" bug reported by Richard Todd. --- test-suite/tests/q.test | 93 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 test-suite/tests/q.test diff --git a/test-suite/tests/q.test b/test-suite/tests/q.test new file mode 100644 index 000000000..a4960619c --- /dev/null +++ b/test-suite/tests/q.test @@ -0,0 +1,93 @@ +;;;; q.test --- test (ice-9 q) module -*- scheme -*- +;;;; +;;;; Copyright 2004 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (test-suite test-ice-9-q) + #:use-module (test-suite lib) + #:use-module (ice-9 q)) + + +;; Call (THUNK) and return #t if it throws 'q-empty, or #f it not. +(define (true-if-catch-q-empty thunk) + (catch 'q-empty + (lambda () + (thunk) + #f) + (lambda args + #t))) + + +;;; +;;; q-pop! +;;; + +(with-test-prefix "q-pop!" + + (with-test-prefix "no elems" + (let ((q (make-q))) + (pass-if "empty" (true-if-catch-q-empty + (lambda () + (q-pop! q)))) + (pass-if "valid at end" (q? q)))) + + (with-test-prefix "one elem" + (let ((x (cons 1 2)) + (q (make-q))) + (q-push! q x) + + (pass-if "x" (eq? x (q-pop! q))) + (pass-if "valid after x" (q? q)) + (pass-if "empty" (true-if-catch-q-empty + (lambda () + (q-pop! q)))) + (pass-if "valid at end" (q? q)))) + + (with-test-prefix "two elems" + (let ((x (cons 1 2)) + (y (cons 3 4)) + (q (make-q))) + (q-push! q x) + (q-push! q y) + + (pass-if "y" (eq? y (q-pop! q))) + (pass-if "valid after y" (q? q)) + (pass-if "x" (eq? x (q-pop! q))) + (pass-if "valid after x" (q? q)) + (pass-if "empty" (true-if-catch-q-empty + (lambda () + (q-pop! q)))) + (pass-if "valid at end" (q? q)))) + + (with-test-prefix "three elems" + (let ((x (cons 1 2)) + (y (cons 3 4)) + (z (cons 5 6)) + (q (make-q))) + (q-push! q x) + (q-push! q y) + (q-push! q z) + + (pass-if "z" (eq? z (q-pop! q))) + (pass-if "valid after z" (q? q)) + (pass-if "y" (eq? y (q-pop! q))) + (pass-if "valid after y" (q? q)) + (pass-if "x" (eq? x (q-pop! q))) + (pass-if "valid after x" (q? q)) + (pass-if "empty" (true-if-catch-q-empty + (lambda () + (q-pop! q)))) + (pass-if "valid at end" (q? q))))) From e130b09ffa60b83552596d4403bf98456e53bb38 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 6 Jan 2004 21:45:48 +0000 Subject: [PATCH 231/239] (SCM_TESTS): Add q.test. --- test-suite/Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index d35a97fe4..69c5deb26 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -27,6 +27,7 @@ SCM_TESTS = tests/alist.test \ tests/popen.test \ tests/ports.test \ tests/posix.test \ + tests/q.test \ tests/r4rs.test \ tests/reader.test \ tests/regexp.test \ From f14d16ed3a7a772e56451db36a3a3ff18fd4ee70 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 6 Jan 2004 21:47:09 +0000 Subject: [PATCH 232/239] Add copyright and license notice. --- test-suite/Makefile.am | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 69c5deb26..2e9ce72a2 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -1,3 +1,24 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright 2001, 2002, 2003, 2004 Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as +## published by the Free Software Foundation; either version 2, or +## (at your option) any later version. +## +## GUILE is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public +## License along with GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + SUBDIRS = standalone SCM_TESTS = tests/alist.test \ From fe89421e30ac04ab02ba6e3a5bccc52f6d2057d0 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 6 Jan 2004 21:48:33 +0000 Subject: [PATCH 233/239] (<): Add tests inum/bignum/flonum/frac with frac. --- test-suite/tests/numbers.test | 90 ++++++++++++++++++++++++++++++++++- 1 file changed, 89 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 323ad8675..28364f96f 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1684,7 +1684,95 @@ (pass-if (not (< (1- (ash 3 1023)) +nan.0))) (pass-if (not (< +nan.0 (ash 3 1023)))) (pass-if (not (< +nan.0 (1+ (ash 3 1023))))) - (pass-if (not (< +nan.0 (1- (ash 3 1023)))))) + (pass-if (not (< +nan.0 (1- (ash 3 1023))))) + + (with-test-prefix "inum/frac" + (pass-if (< 2 9/4)) + (pass-if (< -2 9/4)) + (pass-if (< -2 7/4)) + (pass-if (< -2 -7/4)) + (pass-if (eq? #f (< 2 7/4))) + (pass-if (eq? #f (< 2 -7/4))) + (pass-if (eq? #f (< 2 -9/4))) + (pass-if (eq? #f (< -2 -9/4)))) + + (with-test-prefix "bignum/frac" + (let ((x (ash 1 2048))) + (pass-if (< x (* 4/3 x))) + (pass-if (< (- x) (* 4/3 x))) + (pass-if (< (- x) (* 2/3 x))) + (pass-if (< (- x) (* -2/3 x))) + (pass-if (eq? #f (< x (* 2/3 x)))) + (pass-if (eq? #f (< x (* -2/3 x)))) + (pass-if (eq? #f (< x (* -4/3 x)))) + (pass-if (eq? #f (< (- x) (* -4/3 x)))))) + + (with-test-prefix "flonum/frac" + (pass-if (< 0.75 4/3)) + (pass-if (< -0.75 4/3)) + (pass-if (< -0.75 2/3)) + (pass-if (< -0.75 -2/3)) + (pass-if (eq? #f (< 0.75 2/3))) + (pass-if (eq? #f (< 0.75 -2/3))) + (pass-if (eq? #f (< 0.75 -4/3))) + (pass-if (eq? #f (< -0.75 -4/3))) + + (pass-if (< -inf.0 4/3)) + (pass-if (< -inf.0 -4/3)) + (pass-if (eq? #f (< +inf.0 4/3))) + (pass-if (eq? #f (< +inf.0 -4/3))) + + (pass-if (eq? #f (< +nan.0 4/3))) + (pass-if (eq? #f (< +nan.0 -4/3)))) + + (with-test-prefix "frac/inum" + (pass-if (< 7/4 2)) + (pass-if (< -7/4 2)) + (pass-if (< -9/4 2)) + (pass-if (< -9/4 -2)) + (pass-if (eq? #f (< 9/4 2))) + (pass-if (eq? #f (< 9/4 -2))) + (pass-if (eq? #f (< 7/4 -2))) + (pass-if (eq? #f (< -7/4 -2)))) + + (with-test-prefix "frac/bignum" + (let ((x (ash 1 2048))) + (pass-if (< (* 2/3 x) x)) + (pass-if (< (* -2/3 x) x)) + (pass-if (< (* -4/3 x) x)) + (pass-if (< (* -4/3 x) (- x))) + (pass-if (eq? #f (< (* 4/3 x) x))) + (pass-if (eq? #f (< (* 4/3 x) (- x)))) + (pass-if (eq? #f (< (* 2/3 x) (- x)))) + (pass-if (eq? #f (< (* -2/3 x) (- x)))))) + + (with-test-prefix "frac/flonum" + (pass-if (< 2/3 0.75)) + (pass-if (< -2/3 0.75)) + (pass-if (< -4/3 0.75)) + (pass-if (< -4/3 -0.75)) + (pass-if (eq? #f (< 4/3 0.75))) + (pass-if (eq? #f (< 4/3 -0.75))) + (pass-if (eq? #f (< 2/3 -0.75))) + (pass-if (eq? #f (< -2/3 -0.75))) + + (pass-if (< 4/3 +inf.0)) + (pass-if (< -4/3 +inf.0)) + (pass-if (eq? #f (< 4/3 -inf.0))) + (pass-if (eq? #f (< -4/3 -inf.0))) + + (pass-if (eq? #f (< 4/3 +nan.0))) + (pass-if (eq? #f (< -4/3 +nan.0)))) + + (with-test-prefix "frac/frac" + (pass-if (< 2/3 6/7)) + (pass-if (< -2/3 6/7)) + (pass-if (< -4/3 6/7)) + (pass-if (< -4/3 -6/7)) + (pass-if (eq? #f (< 4/3 6/7))) + (pass-if (eq? #f (< 4/3 -6/7))) + (pass-if (eq? #f (< 2/3 -6/7))) + (pass-if (eq? #f (< -2/3 -6/7))))) ;;; ;;; > From 238ebcef24ee77be94b9b5ff6ce3a1d575cfe0d0 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 6 Jan 2004 21:55:29 +0000 Subject: [PATCH 234/239] (s_bignum): Remove, not used since gmp bignums. Reported by Richard Todd. --- libguile/numbers.c | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index f7faf7004..b34528deb 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -153,8 +153,6 @@ static mpz_t z_negative_one; -static const char s_bignum[] = "bignum"; - SCM_C_INLINE_KEYWORD SCM scm_i_mkbig () { From 524cbf64495687964422b77061373e501d211456 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 6 Jan 2004 22:05:12 +0000 Subject: [PATCH 235/239] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 5d50d06bd..14bac5f4c 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2004-01-07 Kevin Ryde + + * q.scm (q-pop!): Should be "null?" not "not" for end-of-list. + Reported by Richard Todd. + 2004-01-04 Kevin Ryde * boot-9.scm (false-if-exception): Unquote catch and lambda, so as not From 1382414987e0edb65b9eb2093db5194bc375ca25 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 6 Jan 2004 22:13:08 +0000 Subject: [PATCH 236/239] (scm_aind): Test SCM_CONSP rather than !SCM_NULLP while traversing the args list, fixes segv if an improper list is given. Reported by Rouben Rostamian. --- libguile/unif.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/unif.c b/libguile/unif.c index 7fc950f20..6c9b8506b 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -473,7 +473,7 @@ scm_aind (SCM ra, SCM args, const char *what) scm_error_num_args_subr (what); return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); } - while (k && !SCM_NULLP (args)) + while (k && SCM_CONSP (args)) { ind = SCM_CAR (args); args = SCM_CDR (args); From 18e2aba379acfa3a659826d1ad351778b9c3dd34 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 6 Jan 2004 22:14:44 +0000 Subject: [PATCH 237/239] Add copyright years. --- libguile/unif.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/unif.c b/libguile/unif.c index 6c9b8506b..fd33048fd 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2004 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public From 298ab9963373e2725b356bad1391d9a86bd3947e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 6 Jan 2004 22:15:55 +0000 Subject: [PATCH 238/239] *** empty log message *** --- libguile/ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a7c3a1f86..7a309f949 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2004-01-07 Kevin Ryde + + * numbers.c (s_bignum): Remove, not used since gmp bignums. + Reported by Richard Todd. + + * unif.c (scm_aind): Test SCM_CONSP rather than !SCM_NULLP while + traversing the args list, fixes segv if an improper list is given. + Reported by Rouben Rostamian. + 2004-01-06 Marius Vollmer * ports.c (swap_ports, scm_with_current_foo_port): Do not allocate From f410f8e7bab96b71b0f5bdb7486b7c7cdced2bd8 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 6 Jan 2004 22:19:23 +0000 Subject: [PATCH 239/239] New file. (uniform-array-set1!): Exercise this, in particular previous segv on improper arg list. --- test-suite/tests/unif.test | 67 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 67 insertions(+) create mode 100644 test-suite/tests/unif.test diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test new file mode 100644 index 000000000..95bbe3e31 --- /dev/null +++ b/test-suite/tests/unif.test @@ -0,0 +1,67 @@ +;;;; unif.test --- tests guile's uniform arrays -*- scheme -*- +;;;; +;;;; Copyright 2004 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (test-suite test-unif) + #:use-module (test-suite lib)) + + +;;; +;;; uniform-array-set1! +;;; + +(with-test-prefix "uniform-array-set1!" + + (with-test-prefix "one dim" + (let ((a (make-uniform-array '() '(3 5)))) + (pass-if "start" + (uniform-array-set1! a 'y '(3)) + #t) + (pass-if "end" + (uniform-array-set1! a 'y '(5)) + #t) + (pass-if-exception "start-1" exception:out-of-range + (uniform-array-set1! a 'y '(2))) + (pass-if-exception "end+1" exception:out-of-range + (uniform-array-set1! a 'y '(6))) + (pass-if-exception "two indexes" exception:out-of-range + (uniform-array-set1! a 'y '(6 7))) + (pass-if-exception "two improper indexes" exception:out-of-range + (uniform-array-set1! a 'y '(6 . 7))) + (pass-if-exception "three improper indexes" exception:out-of-range + (uniform-array-set1! a 'y '(6 7 . 8))))) + + (with-test-prefix "two dim" + (let ((a (make-uniform-array '() '(3 5) '(7 9)))) + (pass-if "start" + (uniform-array-set1! a 'y '(3 7)) + #t) + (pass-if "end" + (uniform-array-set1! a 'y '(5 9)) + #t) + (pass-if-exception "start i-1" exception:out-of-range + (uniform-array-set1! a 'y '(2 7))) + (pass-if-exception "end i+1" exception:out-of-range + (uniform-array-set1! a 'y '(6 9))) + (pass-if-exception "one index" exception:wrong-num-args + (uniform-array-set1! a 'y '(4))) + (pass-if-exception "three indexes" exception:wrong-num-args + (uniform-array-set1! a 'y '(4 8 0))) + (pass-if-exception "two improper indexes" exception:wrong-num-args + (uniform-array-set1! a 'y '(4 . 8))) + (pass-if-exception "three improper indexes" exception:wrong-num-args + (uniform-array-set1! a 'y '(4 8 . 0))))))