From 04bb321a9dff25723f18bdd235d0311338d3c993 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 22 Jan 2002 23:47:46 +0000 Subject: [PATCH 01/39] * New tests file for Elisp support. --- test-suite/ChangeLog | 6 ++ test-suite/tests/elisp.test | 136 ++++++++++++++++++++++++++++++++++++ 2 files changed, 142 insertions(+) create mode 100644 test-suite/tests/elisp.test diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 7a835df5e..d7e2367b4 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2002-01-22 Neil Jerram + + * Makefile.am (SCM_TESTS): Added elisp.test. + + * tests/elisp.test: New file. + 2001-11-22 Dirk Herrmann * tests/numbers.test: Added more division by zero tests. diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test new file mode 100644 index 000000000..516f4ced2 --- /dev/null +++ b/test-suite/tests/elisp.test @@ -0,0 +1,136 @@ +;;;; elisp.test --- tests guile's elisp support -*- scheme -*- +;;;; Copyright (C) 2002 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 +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +;;; +;;; elisp +;;; + +(if (defined? '%nil) + + (with-test-prefix "scheme" + + (with-test-prefix "nil value is a boolean" + + (pass-if "boolean?" + (boolean? %nil)) + + ) + + (with-test-prefix "nil value is false" + + (pass-if "not" + (eq? (not %nil) #t)) + + (pass-if "if" + (if %nil #f #t)) + + (pass-if "and" + (eq? (and %nil #t) #f)) + + (pass-if "or" + (eq? (or %nil #f) #f)) + + (pass-if "cond" + (cond (%nil #f) (else #t))) + + (pass-if "do" + (call-with-current-continuation + (lambda (exit) + (do ((i 0 (+ i 1))) + (%nil (exit #f)) + (if (> i 10) + (exit #t)))))) + + ) + + (with-test-prefix "nil value as an empty list" + + (pass-if "list?" + (list? %nil)) + + (pass-if "null?" + (null? %nil)) + + (pass-if "sort" + (eq? (sort %nil <) %nil)) + + ) + + (with-test-prefix "lists formed using nil value" + + (pass-if "list?" + (list? (cons 'a %nil))) + + (pass-if "length" + (= (length (cons 'a (cons 'b (cons 'c %nil)))) 3)) + + (pass-if "length (with backquoted list)" + (= (length `(a b c . ,%nil)) 3)) + + (pass-if "write" + (string=? (with-output-to-string + (lambda () (write (cons 'a %nil)))) + "(a)")) + + (pass-if "display" + (string=? (with-output-to-string + (lambda () (display (cons 'a %nil)))) + "(a)")) + + ) + + (with-test-prefix "value preservation" + + (pass-if "car" + (eq? (car (cons %nil 'a)) %nil)) + + (pass-if "cdr" + (eq? (cdr (cons 'a %nil)) %nil)) + + (pass-if "vector-ref" + (eq? (vector-ref (vector %nil) 0) %nil)) + + ) + + )) + +;;; elisp.test ends here From 962b1f0bacacb920e43a2e8d156e51b46b8f5197 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 24 Jan 2002 22:42:02 +0000 Subject: [PATCH 02/39] * More tests for the Elisp nil value. --- test-suite/ChangeLog | 4 +++ test-suite/tests/elisp.test | 70 +++++++++++++++++++++++++++++++++++++ 2 files changed, 74 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d7e2367b4..b407c1a81 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2002-01-24 Neil Jerram + + * tests/elisp.test: More new tests for the Elisp nil value. + 2002-01-22 Neil Jerram * Makefile.am (SCM_TESTS): Added elisp.test. diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test index 516f4ced2..3d7f3a303 100644 --- a/test-suite/tests/elisp.test +++ b/test-suite/tests/elisp.test @@ -100,6 +100,9 @@ (pass-if "list?" (list? (cons 'a %nil))) + (pass-if "length of %nil" + (= (length %nil) 0)) + (pass-if "length" (= (length (cons 'a (cons 'b (cons 'c %nil)))) 3)) @@ -116,6 +119,73 @@ (lambda () (display (cons 'a %nil)))) "(a)")) + (pass-if "assq" + (and (equal? (assq 1 `((1 one) (2 two) . ,%nil)) + '(1 one)) + (equal? (assq 3 `((1 one) (2 two) . ,%nil)) + #f))) + + (pass-if "assv" + (and (equal? (assv 1 `((1 one) (2 two) . ,%nil)) + '(1 one)) + (equal? (assv 3 `((1 one) (2 two) . ,%nil)) + #f))) + + (pass-if "assoc" + (and (equal? (assoc 1 `((1 one) (2 two) . ,%nil)) + '(1 one)) + (equal? (assoc 3 `((1 one) (2 two) . ,%nil)) + #f))) + + (pass-if "with-fluids*" + (let ((f (make-fluid)) + (g (make-fluid))) + (with-fluids* (cons f (cons g %nil)) + '(3 4) + (lambda () + (and (eq? (fluid-ref f) 3) + (eq? (fluid-ref g) 4)))))) + + (pass-if "append!" + (let ((a (copy-tree '(1 2 3))) + (b (copy-tree `(4 5 6 . ,%nil))) + (c (copy-tree '(7 8 9))) + (d (copy-tree `(a b c . ,%nil)))) + (equal? (append! a b c d) + `(1 2 3 4 5 6 7 8 9 a b c . ,%nil)))) + + (pass-if "last-pair" + (equal? (last-pair `(1 2 3 4 5 . ,%nil)) + (cons 5 %nil))) + + (pass-if "reverse" + (equal? (reverse `(1 2 3 4 5 . ,%nil)) + '(5 4 3 2 1))) ; Hmmm... is this OK, or + ; should it be + ; `(5 4 3 2 1 . ,%nil) ? + + (pass-if "reverse!" + (equal? (reverse! (copy-tree `(1 2 3 4 5 . ,%nil))) + '(5 4 3 2 1))) ; Ditto. + + (pass-if "list-ref" + (eq? (list-ref `(0 1 2 3 4 . ,%nil) 4) 4)) + + (pass-if-exception "list-ref" + exception:out-of-range + (eq? (list-ref `(0 1 2 3 4 . ,%nil) 6) 6)) + + (pass-if "list-set!" + (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) + (list-set! l 4 44) + (= (list-ref l 4) 44))) + + (pass-if-exception "list-set!" + exception:out-of-range + (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) + (list-set! l 6 44) + (= (list-ref l 6) 44))) + ) (with-test-prefix "value preservation" From af68e5e5a6d30dde274191530556b565dead45aa Mon Sep 17 00:00:00 2001 From: Stefan Jahn Date: Mon, 28 Jan 2002 21:15:55 +0000 Subject: [PATCH 03/39] 2002-01-28 Stefan Jahn * configure.in (guile_cv_have_uint32_t): Look also in `stdint.h' for uint32_t. 2002-01-28 Stefan Jahn * symbols.c (scm_c_symbol2str): New function, replacement for `gh_scm2newsymbol()'. * strings.c (scm_c_substring2str): New function. Proper replacement for `gh_get_substr()'. * socket.c: Include `stdint.h' if available for the `uint32_t' declaration. * scmsigs.c (s_scm_sigaction): Initialize `chandler' (inhibits compiler warning). * backtrace.c: Include `lang.h' for GUILE_DEBUG conditional. --- ChangeLog | 5 +++++ configure.in | 7 ++++++- libguile/ChangeLog | 16 ++++++++++++++++ libguile/Makefile.am | 2 +- libguile/backtrace.c | 1 + libguile/scmsigs.c | 2 +- libguile/socket.c | 3 +++ libguile/strings.c | 27 ++++++++++++++++++++++++++- libguile/strings.h | 1 + libguile/symbols.c | 44 ++++++++++++++++++++++++++++++++++++++++++++ libguile/symbols.h | 1 + 11 files changed, 105 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4fc82d682..88b3a520e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2002-01-28 Stefan Jahn + + * configure.in (guile_cv_have_uint32_t): Look also in + `stdint.h' for uint32_t. + 2002-01-13 Neil Jerram * Makefile.am (SUBDIRS): Added lang. diff --git a/configure.in b/configure.in index 9618a9734..4607b4d76 100644 --- a/configure.in +++ b/configure.in @@ -348,7 +348,12 @@ fi AC_MSG_CHECKING(whether uint32_t is defined) AC_CACHE_VAL(guile_cv_have_uint32_t, [AC_TRY_COMPILE([#include - #include ], + #if HAVE_STDINT_H + #include + #endif + #ifndef __MINGW32__ + #include + #endif], [uint32_t a;], guile_cv_have_uint32_t=yes, guile_cv_have_uint32_t=no)]) AC_MSG_RESULT($guile_cv_have_uint32_t) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f28ecbbb0..767002040 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2002-01-28 Stefan Jahn + + * symbols.c (scm_c_symbol2str): New function, replacement for + `gh_scm2newsymbol()'. + + * strings.c (scm_c_substring2str): New function. Proper + replacement for `gh_get_substr()'. + + * socket.c: Include `stdint.h' if available for the `uint32_t' + declaration. + + * scmsigs.c (s_scm_sigaction): Initialize `chandler' (inhibits + compiler warning). + + * backtrace.c: Include `lang.h' for GUILE_DEBUG conditional. + 2002-01-22 Neil Jerram Other changes unrelated to Elisp... diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 14aae5521..e3bb3b3ea 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -203,7 +203,7 @@ SUFFIXES = .x .doc .c.doc: -(test -n "${AWK+set}" || AWK="@AWK@"; ${AWK} -f ./guile-func-name-check $<) (./guile-snarf-docs $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< | \ - ./guile_filter_doc_snarfage --filter-snarfage) > $@ || { rm $@; false; } + ./guile_filter_doc_snarfage$(EXEEXT) --filter-snarfage) > $@ || { rm $@; false; } $(DOT_X_FILES) $(EXTRA_DOT_DOC_FILES): snarf.h guile-snarf.in diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 290627fbb..baa0e6e1a 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -67,6 +67,7 @@ #include "libguile/strings.h" #include "libguile/validate.h" +#include "libguile/lang.h" #include "libguile/backtrace.h" #include "libguile/filesys.h" diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 97375e8af..da1f93bfe 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -187,7 +187,7 @@ SCM_DEFINE (scm_sigaction, "sigaction", 1, 2, 0, struct sigaction action; struct sigaction old_action; #else - SIGRETTYPE (* chandler) (int); + SIGRETTYPE (* chandler) (int) = SIG_DFL; SIGRETTYPE (* old_chandler) (int); #endif int query_only = 0; diff --git a/libguile/socket.c b/libguile/socket.c index 7dc729ca1..10c064242 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -58,6 +58,9 @@ #include "win32-socket.h" #endif +#ifdef HAVE_STDINT_H +#include +#endif #ifdef HAVE_STRING_H #include #endif diff --git a/libguile/strings.c b/libguile/strings.c index 3aa24958d..6744a58c6 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -350,12 +350,13 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, determine the length of the returned value. However, the function always copies the complete contents of OBJ, and sets *LENP to the length of the scheme string (if LENP is non-null). */ +#define FUNC_NAME "scm_c_string2str" char * scm_c_string2str (SCM obj, char *str, size_t *lenp) { size_t len; - SCM_ASSERT (SCM_STRINGP (obj), obj, SCM_ARG1, "scm_c_string2str"); + SCM_ASSERT (SCM_STRINGP (obj), obj, SCM_ARG1, FUNC_NAME); len = SCM_STRING_LENGTH (obj); if (str == NULL) @@ -376,6 +377,30 @@ scm_c_string2str (SCM obj, char *str, size_t *lenp) return str; } +#undef FUNC_NAME + + +/* Copy LEN characters at START from the Scheme string OBJ to memory + at STR. START is an index into OBJ; zero means the beginning of + the string. STR has already been allocated by the caller. + + If START + LEN is off the end of OBJ, silently truncate the source + region to fit the string. If truncation occurs, the corresponding + area of STR is left unchanged. */ +#define FUNC_NAME "scm_c_substring2str" +char * +scm_c_substring2str (SCM obj, char *str, size_t start, size_t len) +{ + size_t src_length, effective_length; + + SCM_ASSERT (SCM_STRINGP (obj), obj, SCM_ARG2, FUNC_NAME); + src_length = SCM_STRING_LENGTH (obj); + effective_length = (len + start <= src_length) ? len : src_length - start; + memcpy (str, SCM_STRING_CHARS (obj) + start, effective_length); + scm_remember_upto_here_1 (obj); + return str; +} +#undef FUNC_NAME void diff --git a/libguile/strings.h b/libguile/strings.h index ea1bf7132..aea044dd9 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -79,6 +79,7 @@ SCM_API SCM scm_substring (SCM str, SCM start, SCM end); SCM_API SCM scm_string_append (SCM args); SCM_API void scm_init_strings (void); SCM_API char *scm_c_string2str (SCM obj, char *str, size_t *lenp); +SCM_API char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len); diff --git a/libguile/symbols.c b/libguile/symbols.c index 0a408234b..c3e22c865 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -318,6 +318,50 @@ SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, } #undef FUNC_NAME + +/* Converts the given Scheme symbol OBJ into a C string, containing a copy + of OBJ's content with a trailing null byte. If LENP is non-NULL, set + *LENP to the string's length. + + When STR is non-NULL it receives the copy and is returned by the function, + otherwise new memory is allocated and the caller is responsible for + freeing it via free(). If out of memory, NULL is returned. + + Note that Scheme symbols may contain arbitrary data, including null + characters. This means that null termination is not a reliable way to + determine the length of the returned value. However, the function always + copies the complete contents of OBJ, and sets *LENP to the length of the + scheme symbol (if LENP is non-null). */ +#define FUNC_NAME "scm_c_symbol2str" +char * +scm_c_symbol2str (SCM obj, char *str, size_t *lenp) +{ + size_t len; + + SCM_ASSERT (SCM_SYMBOLP (obj), obj, SCM_ARG1, FUNC_NAME); + len = SCM_SYMBOL_LENGTH (obj); + + if (str == NULL) + { + /* FIXME: Should we use exported wrappers for malloc (and free), which + * allow windows DLLs to call the correct freeing function? */ + str = (char *) malloc ((len + 1) * sizeof (char)); + if (str == NULL) + return NULL; + } + + memcpy (str, SCM_SYMBOL_CHARS (obj), len); + scm_remember_upto_here_1 (obj); + str[len] = '\0'; + + if (lenp != NULL) + *lenp = len; + + return str; +} +#undef FUNC_NAME + + void scm_symbols_prehistory () { diff --git a/libguile/symbols.h b/libguile/symbols.h index 9de355540..e4c624801 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -89,6 +89,7 @@ SCM_API SCM scm_symbol_pset_x (SCM s, SCM val); SCM_API SCM scm_symbol_hash (SCM s); SCM_API SCM scm_gensym (SCM prefix); +SCM_API char *scm_c_symbol2str (SCM obj, char *str, size_t *lenp); SCM_API void scm_symbols_prehistory (void); SCM_API void scm_init_symbols (void); From f74fa0a0fde2a484cbf751b90798c75a15852150 Mon Sep 17 00:00:00 2001 From: Stefan Jahn Date: Tue, 29 Jan 2002 10:46:13 +0000 Subject: [PATCH 04/39] 2002-01-29 Stefan Jahn * gh.texi (scm transition summary): Documented gh equivalents `scm_c_string2str', `scm_c_substring2str' and `scm_c_symbol2str' and removed the appropriate FIXME's. --- doc/ref/ChangeLog | 6 ++++++ doc/ref/gh.texi | 12 +++++++++--- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 176e0ff04..b0f5e2c67 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,9 @@ +2002-01-29 Stefan Jahn + + * gh.texi (scm transition summary): Documented gh equivalents + `scm_c_string2str', `scm_c_substring2str' and `scm_c_symbol2str' + and removed the appropriate FIXME's. + 2002-01-14 Marius Vollmer * Makefile.am (autoconf-macros.texi): Also set GUILE_LOAD_PATH diff --git a/doc/ref/gh.texi b/doc/ref/gh.texi index 7362232fb..9b2e9850e 100644 --- a/doc/ref/gh.texi +++ b/doc/ref/gh.texi @@ -978,13 +978,19 @@ a @code{SCM} value is a character before using @code{SCM_CHAR} to extract the character value, use the @code{SCM_VALIDATE_CHAR} macro. @item @code{gh_scm2newstr} -No direct scm equivalent. [FIXME] +Instead of @code{gh_scm2newstr (@var{obj}, @var{lenp})} use +@code{scm_c_string2str (@var{obj}, @var{str}, @var{lenp})}. With the +additional @var{str} argument the user can pass a pre-allocated memory +chunk or leave it passing NULL. @item @code{gh_get_substr} -No direct scm equivalent. [FIXME] +Use the @code{scm_c_substring2str (@var{obj}, @var{str}, @var{start}, +@var{len})} function instead. @item @code{gh_symbol2newstr} -No direct scm equivalent. [FIXME] +Use the @code{scm_c_symbol2str (@var{obj}, @var{str}, @var{lenp})} function +instead. With the additional @var{str} argument the user can pass a +pre-allocated memory chunk or leave it passing NULL. @item @code{gh_scm2chars} No direct scm equivalent. [FIXME] From bbd26b5ae5a9a595f8a39abe906c46fe3f139da7 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 30 Jan 2002 00:03:40 +0000 Subject: [PATCH 05/39] * Rename `call-with-readline-completion-function' to `with-readline-completion-function'. * More tests for Elisp nil value. * Development work on Elisp translator. --- guile-readline/ChangeLog | 5 + guile-readline/readline.scm | 2 +- lang/elisp/ChangeLog | 41 ++++ lang/elisp/base.scm | 62 ++--- lang/elisp/internals/null.scm | 3 +- lang/elisp/internals/set.scm | 11 +- lang/elisp/primitives/Makefile.am | 1 + lang/elisp/primitives/fns.scm | 24 +- lang/elisp/primitives/lists.scm | 10 +- lang/elisp/primitives/strings.scm | 2 + lang/elisp/primitives/symprop.scm | 4 +- lang/elisp/primitives/syntax.scm | 359 +++++++++++++++++++++++++++ lang/elisp/transform.scm | 387 +++--------------------------- libguile/ChangeLog | 10 +- test-suite/ChangeLog | 8 + test-suite/tests/elisp.test | 80 +++++- test-suite/tests/load.test | 9 + 17 files changed, 606 insertions(+), 412 deletions(-) create mode 100644 lang/elisp/primitives/syntax.scm diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 374e655e7..e56498535 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,8 @@ +2002-01-29 Neil Jerram + + * readline.scm (with-readline-completion-function): Renamed from + `call-with-readline-completion-function'. + 2001-11-30 Neil Jerram * Makefile.am (EXTRA_DIST): Refer to $(ice9_DATA) rather than diff --git a/guile-readline/readline.scm b/guile-readline/readline.scm index 2afb03513..cae45e30b 100644 --- a/guile-readline/readline.scm +++ b/guile-readline/readline.scm @@ -187,7 +187,7 @@ (set! *readline-completion-function* apropos-completion-function) )) -(define-public (call-with-readline-completion-function completer thunk) +(define-public (with-readline-completion-function completer thunk) "With @var{completer} as readline completion function, call @var{thunk}." (let ((old-completer *readline-completion-function*)) (dynamic-wind diff --git a/lang/elisp/ChangeLog b/lang/elisp/ChangeLog index 8338ab0e8..f1ed71dbb 100644 --- a/lang/elisp/ChangeLog +++ b/lang/elisp/ChangeLog @@ -1,3 +1,44 @@ +2002-01-29 Neil Jerram + + * transform.scm (transform-1, transform-2, transform-3, + transform-list): Removed (unused). + + * transform.scm, primitives/syntax.scm: Add commas everywhere + before use of (guile) primitives in generated code, so that (lang + elisp base) doesn't have to import bindings from (guile). + + * base.scm: Move use-modules expressions inside the define-module, + and add #:pure so that we don't import bindings from (guile). + +2002-01-25 Neil Jerram + + * transform.scm (transform-application): Preserve source + properties of original elisp expression by using cons-source. + + * transform.scm: Don't handle special forms specially in the + translator. Instead, define them as macros in ... + + * primitives/syntax.scm: New file; special form definitions. + + * primitives/fns.scm (run-hooks): Rewritten correctly. + + * primitives/symprop.scm (symbol-value): Use `value'. + + * internals/set.scm (value): New function. + + * primitives/fns.scm: Use (lang elisp internals null), as null is + no longer a primitive. Change generated #f values to %nil. + + * internals/null.scm (null): Handle nil symbol. + + * primitives/lists.scm (memq, member, assq, assoc): Handle all + possible nil values. + + * transform.scm (transformer): Translate `nil' and `t' to #nil and + #t. + + * base.scm: Remove setting of 'language read-option. + 2001-11-03 Neil Jerram * README (Resources): Fill in missing URLs. diff --git a/lang/elisp/base.scm b/lang/elisp/base.scm index 070be333b..c4d2b8d9a 100644 --- a/lang/elisp/base.scm +++ b/lang/elisp/base.scm @@ -1,34 +1,42 @@ -(define-module (lang elisp base)) +(define-module (lang elisp base) -;;; {Elisp Primitives} -;;; -;;; In other words, Scheme definitions of elisp primitives. This -;;; should (ultimately) include everything that Emacs defines in C. + ;; Be pure. Nothing in this module requires most of the standard + ;; Guile builtins, and it creates a problem if this module has + ;; access to them, as @bind can dynamically change their values. + #:pure -(use-modules (lang elisp primitives buffers) - (lang elisp primitives features) - (lang elisp primitives format) - (lang elisp primitives fns) - (lang elisp primitives guile) - (lang elisp primitives keymaps) - (lang elisp primitives lists) - (lang elisp primitives load) - (lang elisp primitives match) - (lang elisp primitives numbers) - (lang elisp primitives pure) - (lang elisp primitives read) - (lang elisp primitives signal) - (lang elisp primitives strings) - (lang elisp primitives symprop) - (lang elisp primitives system) - (lang elisp primitives time)) + ;; But we do need a few builtins - import them here. + #:use-module ((guile) #:select (@fop @bind nil-cond)) -;;; Now switch into Emacs Lisp syntax. + ;; {Elisp Primitives} + ;; + ;; In other words, Scheme definitions of elisp primitives. This + ;; should (ultimately) include everything that Emacs defines in C. + #:use-module (lang elisp primitives buffers) + #:use-module (lang elisp primitives features) + #:use-module (lang elisp primitives format) + #:use-module (lang elisp primitives fns) + #:use-module (lang elisp primitives guile) + #:use-module (lang elisp primitives keymaps) + #:use-module (lang elisp primitives lists) + #:use-module (lang elisp primitives load) + #:use-module (lang elisp primitives match) + #:use-module (lang elisp primitives numbers) + #:use-module (lang elisp primitives pure) + #:use-module (lang elisp primitives read) + #:use-module (lang elisp primitives signal) + #:use-module (lang elisp primitives strings) + #:use-module (lang elisp primitives symprop) + #:use-module (lang elisp primitives syntax) + #:use-module (lang elisp primitives system) + #:use-module (lang elisp primitives time) -(use-modules (lang elisp transform)) -(read-set! keywords 'prefix) -(read-set! language 'elisp) -(set-module-transformer! (current-module) transformer) + ;; Now switch into Emacs Lisp syntax. + #:use-syntax (lang elisp transform)) + +;(use-modules (lang elisp transform)) +;(read-set! keywords 'prefix) +;(set-module-transformer! (current-module) transformer) ;;; Everything below here is written in Elisp. diff --git a/lang/elisp/internals/null.scm b/lang/elisp/internals/null.scm index d574e3424..420278e0c 100644 --- a/lang/elisp/internals/null.scm +++ b/lang/elisp/internals/null.scm @@ -3,4 +3,5 @@ (define (null obj) (or (not obj) - (null? obj))) + (null? obj) + (eq? obj 'nil))) ; Should be removed. diff --git a/lang/elisp/internals/set.scm b/lang/elisp/internals/set.scm index cee332101..8137a6221 100644 --- a/lang/elisp/internals/set.scm +++ b/lang/elisp/internals/set.scm @@ -1,9 +1,18 @@ (define-module (lang elisp internals set) #:use-module (lang elisp internals evaluation) #:use-module (lang elisp internals signal) - #:export (set)) + #:export (set value)) ;; Set SYM's variable value to VAL, and return VAL. (define (set sym val) (module-define! the-elisp-module sym val) val) + +;; Return SYM's variable value. If it has none, signal an error if +;; MUST-EXIST is true, just return #nil otherwise. +(define (value sym must-exist) + (if (module-defined? the-elisp-module sym) + (module-ref the-elisp-module sym) + (if must-exist + (error "Symbol's value as variable is void:" sym) + %nil))) diff --git a/lang/elisp/primitives/Makefile.am b/lang/elisp/primitives/Makefile.am index f2bd3e919..283467a41 100644 --- a/lang/elisp/primitives/Makefile.am +++ b/lang/elisp/primitives/Makefile.am @@ -39,6 +39,7 @@ elisp_sources = \ signal.scm \ strings.scm \ symprop.scm \ + syntax.scm \ system.scm \ time.scm diff --git a/lang/elisp/primitives/fns.scm b/lang/elisp/primitives/fns.scm index 87b05c7e0..ba2b53a79 100644 --- a/lang/elisp/primitives/fns.scm +++ b/lang/elisp/primitives/fns.scm @@ -1,5 +1,7 @@ (define-module (lang elisp primitives fns) - #:use-module (lang elisp internals fset)) + #:use-module (lang elisp internals set) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals null)) (fset 'fset fset) (fset 'defalias fset) @@ -12,11 +14,11 @@ (fset 'interactive-p (lambda () - #f)) + %nil)) (fset 'commandp (lambda (sym) - (if (interactive-spec (fref sym)) #t #f))) + (if (interactive-spec (fref sym)) #t %nil))) (fset 'fboundp (lambda (sym) @@ -32,14 +34,12 @@ (fset 'byte-code-function-p (lambda (object) - #f)) + %nil)) (fset 'run-hooks - (lambda (hooks) - (cond ((null hooks)) - ((list? hooks) - (for-each (lambda (hook) - (elisp-apply hook '())) - hooks)) - (else - (elisp-apply hooks '()))))) + (lambda hooks + (for-each (lambda (hooksym) + (for-each (lambda (fn) + (elisp-apply fn '())) + (value hooksym #f))) + hooks))) diff --git a/lang/elisp/primitives/lists.scm b/lang/elisp/primitives/lists.scm index be603e2c8..43843f811 100644 --- a/lang/elisp/primitives/lists.scm +++ b/lang/elisp/primitives/lists.scm @@ -46,10 +46,16 @@ (fset sym (lambda (elt list) (if (null list) - #f + %nil (if (null elt) (or (proc #f list) - (proc '() list)) + (proc '() list) + (proc %nil list) + (proc 'nil list)) ; 'nil shouldn't be + ; here, as it should + ; have been + ; translated by the + ; transformer. (proc elt list)))))) '( memq member assq assoc) `(,memq ,member ,assq ,assoc)) diff --git a/lang/elisp/primitives/strings.scm b/lang/elisp/primitives/strings.scm index 4326aeb93..08bd8f8de 100644 --- a/lang/elisp/primitives/strings.scm +++ b/lang/elisp/primitives/strings.scm @@ -29,3 +29,5 @@ (else (wta 'arrayp array 1))))) (fset 'stringp string?) + +(fset 'vector vector) diff --git a/lang/elisp/primitives/symprop.scm b/lang/elisp/primitives/symprop.scm index ffdc7e6ae..4ca169226 100644 --- a/lang/elisp/primitives/symprop.scm +++ b/lang/elisp/primitives/symprop.scm @@ -22,9 +22,7 @@ (fset 'symbol-value (lambda (sym) - (if (module-defined? the-elisp-module sym) - (module-ref the-elisp-module sym) - (error "Symbol's value as variable is void:" sym)))) + (value sym #t))) (fset 'default-value 'symbol-value) diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm new file mode 100644 index 000000000..ac0951439 --- /dev/null +++ b/lang/elisp/primitives/syntax.scm @@ -0,0 +1,359 @@ +(define-module (lang elisp primitives syntax) + #:use-module (lang elisp internals evaluation) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals trace) + #:use-module (lang elisp transform)) + +;;; Define Emacs Lisp special forms as macros. This is much more +;;; flexible than handling them specially in the translator: allows +;;; them to be redefined, and hopefully allows better source location +;;; tracking. + +;;; {Variables} + +(define (setq exp env) + (cons begin + (let loop ((sets (cdr exp)) (last-sym #f)) + (if (null? sets) + (list last-sym) + (cons `(,module-define! ,the-elisp-module + (,quote ,(car sets)) + ,(transformer (cadr sets))) + (loop (cddr sets) (car sets))))))) + +(fset 'setq + (procedure->memoizing-macro setq)) + +(fset 'defvar + (procedure->memoizing-macro + (lambda (exp env) + (trc 'defvar (cadr exp)) + (if (null? (cddr exp)) + `(,quote ,(cadr exp)) + `(,begin (,if (,not (,defined? (,quote ,(cadr exp)))) + ,(setq (list (car exp) (cadr exp) (caddr exp)) env)) + ;; (,macro-setq ,(cadr exp) ,(caddr exp))) + (,quote ,(cadr exp))))))) + +(fset 'defconst + (procedure->memoizing-macro + (lambda (exp env) + (trc 'defconst (cadr exp)) + `(,begin ,(setq (list (car exp) (cadr exp) (caddr exp)) env) + (,quote ,(cadr exp)))))) + +;;; {lambda, function and macro definitions} + +;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and +;;; returns three values: (i) list of symbols for required arguments, +;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or +;;; #f if there is no rest argument. +(define (parse-formals formals) + (letrec ((do-required + (lambda (required formals) + (if (null? formals) + (values (reverse required) '() #f) + (let ((next-sym (car formals))) + (cond ((not (symbol? next-sym)) + (error "Bad formals (non-symbol in required list)")) + ((eq? next-sym '&optional) + (do-optional required '() (cdr formals))) + ((eq? next-sym '&rest) + (do-rest required '() (cdr formals))) + (else + (do-required (cons next-sym required) + (cdr formals)))))))) + (do-optional + (lambda (required optional formals) + (if (null? formals) + (values (reverse required) (reverse optional) #f) + (let ((next-sym (car formals))) + (cond ((not (symbol? next-sym)) + (error "Bad formals (non-symbol in optional list)")) + ((eq? next-sym '&rest) + (do-rest required optional (cdr formals))) + (else + (do-optional required + (cons next-sym optional) + (cdr formals)))))))) + (do-rest + (lambda (required optional formals) + (if (= (length formals) 1) + (let ((next-sym (car formals))) + (if (symbol? next-sym) + (values (reverse required) (reverse optional) next-sym) + (error "Bad formals (non-symbol rest formal)"))) + (error "Bad formals (more than one rest formal)"))))) + + (do-required '() (cond ((list? formals) + formals) + ((symbol? formals) + (list '&rest formals)) + (else + (error "Bad formals (not a list or a single symbol)")))))) + +(define (transform-lambda exp) + (call-with-values (lambda () (parse-formals (cadr exp))) + (lambda (required optional rest) + (let ((num-required (length required)) + (num-optional (length optional))) + `(,lambda %--args + (,let ((%--num-args (,length %--args))) + (,cond ((,< %--num-args ,num-required) + (,error "Wrong number of args (not enough required args)")) + ,@(if rest + '() + `(((,> %--num-args ,(+ num-required num-optional)) + (,error "Wrong number of args (too many args)")))) + (else + (@bind ,(append (map (lambda (i) + (list (list-ref required i) + `(,list-ref %--args ,i))) + (iota num-required)) + (map (lambda (i) + (let ((i+nr (+ i num-required))) + (list (list-ref optional i) + `(,if (,> %--num-args ,i+nr) + (,list-ref %--args ,i+nr) + #f)))) + (iota num-optional)) + (if rest + (list (list rest + `(,if (,> %--num-args + ,(+ num-required + num-optional)) + (,list-tail %--args + ,(+ num-required + num-optional)) + '()))) + '())) + ,@(map transformer (cddr exp))))))))))) + +(define interactive-spec (make-fluid)) + +(define (set-not-subr! proc boolean) + (set! (not-subr? proc) boolean)) + +(define (transform-lambda/interactive exp name) + (fluid-set! interactive-spec #f) + (let* ((x (transform-lambda exp)) + (is (fluid-ref interactive-spec))) + `(,let ((%--lambda ,x)) + (,set-procedure-property! %--lambda (,quote name) (,quote ,name)) + (,set-not-subr! %--lambda #t) + ,@(if is + `((,set! (,interactive-spec %--lambda) (,quote ,is))) + '()) + %--lambda))) + +(fset 'lambda + (procedure->memoizing-macro + (lambda (exp env) + (transform-lambda/interactive exp ')))) + +(fset 'defun + (procedure->memoizing-macro + (lambda (exp env) + (trc 'defun (cadr exp)) + `(,begin (,fset (,quote ,(cadr exp)) + ,(transform-lambda/interactive (cdr exp) + (symbol-append '))) + (,quote ,(cadr exp)))))) + +(fset 'interactive + (procedure->memoizing-macro + (lambda (exp env) + (fluid-set! interactive-spec exp) + #f))) + +(fset 'defmacro + (procedure->memoizing-macro + (lambda (exp env) + (trc 'defmacro (cadr exp)) + (call-with-values (lambda () (parse-formals (caddr exp))) + (lambda (required optional rest) + (let ((num-required (length required)) + (num-optional (length optional))) + `(,begin (,fset (,quote ,(cadr exp)) + (,procedure->memoizing-macro + (,lambda (exp1 env1) + (,trc (,quote using) (,quote ,(cadr exp))) + (,let* ((%--args (,cdr exp1)) + (%--num-args (,length %--args))) + (,cond ((,< %--num-args ,num-required) + (,error "Wrong number of args (not enough required args)")) + ,@(if rest + '() + `(((,> %--num-args ,(+ num-required num-optional)) + (,error "Wrong number of args (too many args)")))) + (else (,transformer + (@bind ,(append (map (lambda (i) + (list (list-ref required i) + `(,list-ref %--args ,i))) + (iota num-required)) + (map (lambda (i) + (let ((i+nr (+ i num-required))) + (list (list-ref optional i) + `(,if (,> %--num-args ,i+nr) + (,list-ref %--args ,i+nr) + #f)))) + (iota num-optional)) + (if rest + (list (list rest + `(,if (,> %--num-args + ,(+ num-required + num-optional)) + (,list-tail %--args + ,(+ num-required + num-optional)) + '()))) + '())) + ,@(map transformer (cdddr exp))))))))))))))))) + +;;; {Sequencing} + +(fset 'progn + (procedure->memoizing-macro + (lambda (exp env) + `(,begin ,@(map transformer (cdr exp)))))) + +(fset 'prog1 + (procedure->memoizing-macro + (lambda (exp env) + `(,let ((%res1 ,(transformer (cadr exp)))) + ,@(map transformer (cddr exp)) + %res1)))) + +(fset 'prog2 + (procedure->memoizing-macro + (lambda (exp env) + `(,begin ,(transformer (cadr exp)) + (,let ((%res2 ,(transformer (caddr exp)))) + ,@(map transformer (cdddr exp)) + %res2))))) + +;;; {Conditionals} + +(define <-- *unspecified*) + +(fset 'if + (procedure->memoizing-macro + (lambda (exp env) + (let ((else-case (cdddr exp))) + (cond ((null? else-case) + `(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f)) + ((null? (cdr else-case)) + `(nil-cond ,(transformer (cadr exp)) + ,(transformer (caddr exp)) + ,(transformer (car else-case)))) + (else + `(nil-cond ,(transformer (cadr exp)) + ,(transformer (caddr exp)) + (,begin ,@(map transformer else-case))))))))) + +(fset 'and + (procedure->memoizing-macro + (lambda (exp env) + (cond ((null? (cdr exp)) #t) + ((null? (cddr exp)) (transformer (cadr exp))) + (else + (cons nil-cond + (let loop ((args (cdr exp))) + (if (null? (cdr args)) + (list (transformer (car args))) + (cons (list not (transformer (car args))) + (cons #f + (loop (cdr args)))))))))))) + +(fset 'or + (procedure->memoizing-macro + (lambda (exp env) + (cond ((null? (cdr exp)) #f) + ((null? (cddr exp)) (transformer (cadr exp))) + (else + (cons nil-cond + (let loop ((args (cdr exp))) + (if (null? (cdr args)) + (list (transformer (car args))) + (cons (transformer (car args)) + (cons <-- + (loop (cdr args)))))))))))) + +(fset 'cond + (procedure->memoizing-macro + (lambda (exp env) + (if (null? (cdr exp)) + #f + (cons + nil-cond + (let loop ((clauses (cdr exp))) + (if (null? clauses) + '(#f) + (let ((clause (car clauses))) + (if (eq? (car clause) #t) + (cond ((null? (cdr clause)) '(t)) + ((null? (cddr clause)) + (list (transformer (cadr clause)))) + (else `((,begin ,@(map transformer (cdr clause)))))) + (cons (transformer (car clause)) + (cons (cond ((null? (cdr clause)) <--) + ((null? (cddr clause)) + (transformer (cadr clause))) + (else + `(,begin ,@(map transformer (cdr clause))))) + (loop (cdr clauses))))))))))))) + +(fset 'while + (procedure->memoizing-macro + (lambda (exp env) + `((,letrec ((%--while (,lambda () + (,nil-cond ,(transformer (cadr exp)) + (,begin ,@(map transformer (cddr exp)) + (%--while)) + #f)))) + %--while))))) + +;;; {Local binding} + +(fset 'let + (procedure->memoizing-macro + (lambda (exp env) + `(@bind ,(map (lambda (binding) + (trc 'let binding) + (if (pair? binding) + `(,(car binding) ,(transformer (cadr binding))) + `(,binding #f))) + (cadr exp)) + ,@(map transformer (cddr exp)))))) + +(fset 'let* + (procedure->memoizing-macro + (lambda (exp env) + (if (null? (cadr exp)) + `(begin ,@(map transformer (cddr exp))) + (car (let loop ((bindings (cadr exp))) + (if (null? bindings) + (map transformer (cddr exp)) + `((@bind (,(let ((binding (car bindings))) + (if (pair? binding) + `(,(car binding) ,(transformer (cadr binding))) + `(,binding #f)))) + ,@(loop (cdr bindings))))))))))) + +;;; {Exception handling} + +(fset 'unwind-protect + (procedure->memoizing-macro + (lambda (exp env) + (trc 'unwind-protect (cadr exp)) + `(,let ((%--throw-args #f)) + (,catch #t + (,lambda () + ,(transformer (cadr exp))) + (,lambda args + (,set! %--throw-args args))) + ,@(map transformer (cddr exp)) + (,if %--throw-args + (,apply ,throw %--throw-args)))))) diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm index 2f6ed8db5..ec1639d6e 100644 --- a/lang/elisp/transform.scm +++ b/lang/elisp/transform.scm @@ -3,9 +3,7 @@ #:use-module (lang elisp internals fset) #:use-module (lang elisp internals evaluation) #:use-module (ice-9 session) - #:export (transformer)) - -(define interactive-spec (make-fluid)) + #:export (transformer transform)) ;;; {S-expressions} ;;; @@ -16,7 +14,9 @@ ;; Should be made mutating instead of constructing ;; (define (transformer x) - (cond ((null? x) '()) + (cond ((eq? x 'nil) %nil) + ((eq? x 't) #t) + ((null? x) '()) ((not (pair? x)) x) ((and (pair? (car x)) (eq? (caar x) 'quasiquote)) @@ -27,43 +27,29 @@ ; Escape to Scheme syntax ((scheme) (cons 'begin (cdr x))) ; Should be handled in reader - ((quote function) (cons 'quote (cars->nil (cdr x)))) + ((quote function) `(,quote ,@(cars->nil (cdr x)))) ((quasiquote) (m-quasiquote x '())) - ((nil-cond) (transform-1 x)) - ((let) (m-let x '())) - ((let*) (m-let* x '())) - ((if) (m-if x '())) - ((and) (m-and x '())) - ((or) (m-or x '())) - ((while) (m-while x '())) + ;((nil-cond) (transform-1 x)) + ;((let) (m-let x '())) + ;((let*) (m-let* x '())) + ;((if) (m-if x '())) + ;((and) (m-and x '())) + ;((or) (m-or x '())) + ;((while) (m-while x '())) ;((while) (cons macro-while (cdr x))) - ((prog1) (m-prog1 x '())) - ((prog2) (m-prog2 x '())) - ((progn begin) (cons 'begin (map transformer (cdr x)))) - ((cond) (m-cond x '())) - ((lambda) (transform-lambda/interactive x ')) - ((defun) (m-defun x '())) - ((defmacro) (m-defmacro x '())) - ((setq) (m-setq x '())) - ((defvar) (m-defvar x '())) - ((defconst) (m-defconst x '())) - ((interactive) (fluid-set! interactive-spec x) #f) - ((unwind-protect) (m-unwind-protect x '())) + ;((prog1) (m-prog1 x '())) + ;((prog2) (m-prog2 x '())) + ;((progn) (cons 'begin (map transformer (cdr x)))) + ;((cond) (m-cond x '())) + ;((lambda) (transform-lambda/interactive x ')) + ;((defun) (m-defun x '())) + ;((defmacro) (m-defmacro x '())) + ;((setq) (m-setq x '())) + ;((interactive) (fluid-set! interactive-spec x) #f) + ;((unwind-protect) (m-unwind-protect x '())) (else (transform-application x)))) (else (syntax-error x)))) -(define (m-unwind-protect exp env) - (trc 'unwind-protect (cadr exp)) - `(let ((%--throw-args #f)) - (catch #t - (lambda () - ,(transformer (cadr exp))) - (lambda args - (set! %--throw-args args))) - ,@(transform-list (cddr exp)) - (if %--throw-args - (apply throw %--throw-args)))) - (define (m-quasiquote exp env) (cons 'quasiquote (map transform-inside-qq (cdr exp)))) @@ -78,185 +64,17 @@ (else (cons (car x) (map transform-inside-qq (cdr x)))))) (else (cons (transform-inside-qq (car x)) (transform-inside-qq (cdr x)))))) - -(define (transform-1 x) - (cons (car x) (map transformer (cdr x)))) - -(define (transform-2 x) - (cons (car x) - (cons (cadr x) - (map transformer (cddr x))))) - -(define (transform-3 x) - (cons (car x) - (cons (cadr x) - (cons (caddr x) - (map transformer (cdddr x)))))) - -(define (transform-list x) - (map transformer x)) - -;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and -;;; returns three values: (i) list of symbols for required arguments, -;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or -;;; #f if there is no rest argument. -(define (parse-formals formals) - (letrec ((do-required - (lambda (required formals) - (if (null? formals) - (values (reverse required) '() #f) - (let ((next-sym (car formals))) - (cond ((not (symbol? next-sym)) - (error "Bad formals (non-symbol in required list)")) - ((eq? next-sym '&optional) - (do-optional required '() (cdr formals))) - ((eq? next-sym '&rest) - (do-rest required '() (cdr formals))) - (else - (do-required (cons next-sym required) - (cdr formals)))))))) - (do-optional - (lambda (required optional formals) - (if (null? formals) - (values (reverse required) (reverse optional) #f) - (let ((next-sym (car formals))) - (cond ((not (symbol? next-sym)) - (error "Bad formals (non-symbol in optional list)")) - ((eq? next-sym '&rest) - (do-rest required optional (cdr formals))) - (else - (do-optional required - (cons next-sym optional) - (cdr formals)))))))) - (do-rest - (lambda (required optional formals) - (if (= (length formals) 1) - (let ((next-sym (car formals))) - (if (symbol? next-sym) - (values (reverse required) (reverse optional) next-sym) - (error "Bad formals (non-symbol rest formal)"))) - (error "Bad formals (more than one rest formal)"))))) - - (do-required '() (cond ((list? formals) - formals) - ((symbol? formals) - (list '&rest formals)) - (else - (error "Bad formals (not a list or a single symbol)")))))) - -(define (transform-lambda/interactive exp name) - (fluid-set! interactive-spec #f) - (let* ((x (transform-lambda exp)) - (is (fluid-ref interactive-spec))) - `(let ((%--lambda ,x)) - (set-procedure-property! %--lambda 'name ',name) - (set! (,not-subr? %--lambda) #t) - ,@(if is - `((set! (,interactive-specification %--lambda) ',is)) - '()) - %--lambda))) - -(define (transform-lambda exp) - (call-with-values (lambda () (parse-formals (cadr exp))) - (lambda (required optional rest) - (let ((num-required (length required)) - (num-optional (length optional))) - `(lambda %--args - (let ((%--num-args (length %--args))) - (cond ((< %--num-args ,num-required) - (error "Wrong number of args (not enough required args)")) - ,@(if rest - '() - `(((> %--num-args ,(+ num-required num-optional)) - (error "Wrong number of args (too many args)")))) - (else - (@bind ,(append (map (lambda (i) - (list (list-ref required i) - `(list-ref %--args ,i))) - (iota num-required)) - (map (lambda (i) - (let ((i+nr (+ i num-required))) - (list (list-ref optional i) - `(if (> %--num-args ,i+nr) - (list-ref %--args ,i+nr) - #f)))) - (iota num-optional)) - (if rest - (list (list rest - `(if (> %--num-args - ,(+ num-required - num-optional)) - (list-tail %--args - ,(+ num-required - num-optional)) - '()))) - '())) - ,@(transform-list (cddr exp))))))) - )))) - -(define (m-defun exp env) - (trc 'defun (cadr exp)) - `(begin (,fset ',(cadr exp) - ,(transform-lambda/interactive (cdr exp) - (symbol-append '))) - ',(cadr exp))) - -(define (m-defmacro exp env) - (trc 'defmacro (cadr exp)) - (call-with-values (lambda () (parse-formals (caddr exp))) - (lambda (required optional rest) - (let ((num-required (length required)) - (num-optional (length optional))) - `(begin (,fset ',(cadr exp) - (procedure->memoizing-macro - (lambda (exp1 env1) - (,trc 'using ',(cadr exp)) - (let* ((%--args (cdr exp1)) - (%--num-args (length %--args))) - (cond ((< %--num-args ,num-required) - (error "Wrong number of args (not enough required args)")) - ,@(if rest - '() - `(((> %--num-args ,(+ num-required num-optional)) - (error "Wrong number of args (too many args)")))) - (else (,transformer - (@bind ,(append (map (lambda (i) - (list (list-ref required i) - `(list-ref %--args ,i))) - (iota num-required)) - (map (lambda (i) - (let ((i+nr (+ i num-required))) - (list (list-ref optional i) - `(if (> %--num-args ,i+nr) - (list-ref %--args ,i+nr) - #f)))) - (iota num-optional)) - (if rest - (list (list rest - `(if (> %--num-args - ,(+ num-required - num-optional)) - (list-tail %--args - ,(+ num-required - num-optional)) - '()))) - '())) - ,@(transform-list (cdddr exp))))))))))))))) (define (transform-application x) - `(@fop ,(car x) - (,transformer-macro ,@(cdr x)))) + (cons-source x + '@fop + `(,(car x) (,transformer-macro ,@(cdr x))))) (define transformer-macro (procedure->memoizing-macro - (lambda (exp env) - (cons 'list (map transformer (cdr exp)))))) - -; (cons '@fop -; (cons (car x) -; (map transformer (cdr x))))) + (let ((cdr cdr)) + (lambda (exp env) + (cons 'list (map transformer (cdr exp))))))) (define (cars->nil ls) (cond ((not (pair? ls)) ls) @@ -264,151 +82,4 @@ (else (cons (cars->nil (car ls)) (cars->nil (cdr ls)))))) -;;; {Special forms} -;;; - -(define (m-setq exp env) - (cons 'begin - (let loop ((sets (cdr exp)) (last-sym #f)) - (if (null? sets) - (list last-sym) - (cons `(module-define! ,the-elisp-module - ',(car sets) - ,(transformer (cadr sets))) - (loop (cddr sets) (car sets))))))) - -;(define (m-setq exp env) -; (let* ((binder (car (last-pair env))) -; (varvals (let loop ((ls (cdr exp))) -; (if (null? ls) -; '() -; ;; Ensure existence only at macro expansion time -; (let ((var (or (binder (car ls) #f) -; (binder (car ls) #t)))) -; (if (not (variable-bound? var)) -; (variable-set! var #f)) -; (cons (list 'set! (car ls) (transformer (cadr ls))) -; (loop (cddr ls)))))))) -; (cond ((null? varvals) '()) -; ((null? (cdr varvals)) (car varvals)) -; (else (cons 'begin varvals))))) - -(define (m-let exp env) - `(@bind ,(map (lambda (binding) - (trc 'let binding) - (if (pair? binding) - `(,(car binding) ,(transformer (cadr binding))) - `(,binding #f))) - (cadr exp)) - ,@(transform-list (cddr exp)))) - -(define (m-let* exp env) - (if (null? (cadr exp)) - `(begin ,@(transform-list (cddr exp))) - (car (let loop ((bindings (cadr exp))) - (if (null? bindings) - (transform-list (cddr exp)) - `((@bind (,(let ((binding (car bindings))) - (if (pair? binding) - `(,(car binding) ,(transformer (cadr binding))) - `(,binding #f)))) - ,@(loop (cdr bindings))))))))) - -(define (m-prog1 exp env) - `(,let ((%res1 ,(transformer (cadr exp)))) - ,@(transform-list (cddr exp)) - %res1)) - -(define (m-prog2 exp env) - `(begin ,(transformer (cadr exp)) - (,let ((%res2 ,(transformer (caddr exp)))) - ,@(transform-list (cdddr exp)) - %res2))) - -(define <-- *unspecified*) - -(define (m-if exp env) - (let ((else-case (cdddr exp))) - (cond ((null? else-case) - `(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f)) - ((null? (cdr else-case)) - `(nil-cond ,(transformer (cadr exp)) - ,(transformer (caddr exp)) - ,(transformer (car else-case)))) - (else - `(nil-cond ,(transformer (cadr exp)) - ,(transformer (caddr exp)) - (begin ,@(transform-list else-case))))))) - -(define (m-and exp env) - (cond ((null? (cdr exp)) #t) - ((null? (cddr exp)) (transformer (cadr exp))) - (else - (cons 'nil-cond - (let loop ((args (cdr exp))) - (if (null? (cdr args)) - (list (transformer (car args))) - (cons (list 'not (transformer (car args))) - (cons #f - (loop (cdr args)))))))))) - -(define (m-or exp env) - (cond ((null? (cdr exp)) #f) - ((null? (cddr exp)) (transformer (cadr exp))) - (else - (cons 'nil-cond - (let loop ((args (cdr exp))) - (if (null? (cdr args)) - (list (transformer (car args))) - (cons (transformer (car args)) - (cons <-- - (loop (cdr args)))))))))) - -(define m-cond - (lambda (exp env) - (if (null? (cdr exp)) - #f - (cons - 'nil-cond - (let loop ((clauses (cdr exp))) - (if (null? clauses) - '(#f) - (let ((clause (car clauses))) - (if (eq? (car clause) #t) - (cond ((null? (cdr clause)) '(t)) - ((null? (cddr clause)) - (list (transformer (cadr clause)))) - (else `((begin ,@(transform-list (cdr clause)))))) - (cons (transformer (car clause)) - (cons (cond ((null? (cdr clause)) <--) - ((null? (cddr clause)) - (transformer (cadr clause))) - (else - `(begin ,@(transform-list (cdr clause))))) - (loop (cdr clauses)))))))))))) - -(define (m-while exp env) - `(,let %while () - (nil-cond ,(transformer (cadr exp)) - (begin ,@(transform-list (cddr exp)) (%while)) - #f))) - -(define (m-defvar exp env) - (trc 'defvar (cadr exp)) - (if (null? (cddr exp)) - `',(cadr exp) - `(begin (if (not (defined? ',(cadr exp))) - (,macro-setq ,(cadr exp) ,(caddr exp))) - ',(cadr exp)))) - -(define (m-defconst exp env) - (trc 'defconst (cadr exp)) - `(begin ,(m-setq (list (car exp) (cadr exp) (caddr exp)) env) - ',(cadr exp))) - -;(export-mmacros -; '(setq defun let let* if and or cond while prog1 prog2 progn) -; (list m-setq m-defun m-let m-let* m-if m-and m-or m-cond m-while m-prog1 m-prog2 begin)) - -(define macro-setq (procedure->memoizing-macro m-setq)) -(define macro-while (procedure->memoizing-macro m-while)) +(define transform transformer) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 767002040..bd6395e74 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -53,11 +53,11 @@ (scm_swap_fluids, scm_swap_fluids_reverse), list.c (scm_null_p, scm_ilength, scm_append_x, scm_last_pair, scm_reverse, scm_reverse_x, scm_list_ref, scm_list_set_x, scm_list_cdr_set_x, - scm_c_memq, scm_memv), load.c (scm_search_path), options.c - (change_option_setting, scm_options), posix.c (environ_list_to_c), - print.c (scm_iprlist), throw.c (scm_exit_status), vectors.c - (scm_vector), weaks.c (scm_weak_vector): Use SCM_NULL_OR_NIL_P - instead of SCM_NULLP. + scm_c_memq, scm_memv, scm_member), load.c (scm_search_path), + options.c (change_option_setting, scm_options), posix.c + (environ_list_to_c), print.c (scm_iprlist), throw.c + (scm_exit_status), vectors.c (scm_vector), weaks.c + (scm_weak_vector): Use SCM_NULL_OR_NIL_P instead of SCM_NULLP. * boolean.c (scm_not): Use `SCM_FALSEP || SCM_NILP' instead of just SCM_FALSEP. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index b407c1a81..c18b87194 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,11 @@ +2002-01-25 Neil Jerram + + * tests/load.test: New test; for search-path with Elisp + nil-terminated lists for PATH and EXTENSIONS. + + * tests/elisp.test: More tests for Scheme primitives that should + accept Elisp nil-terminated lists. + 2002-01-24 Neil Jerram * tests/elisp.test: More new tests for the Elisp nil value. diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test index 3d7f3a303..a7a4c4a51 100644 --- a/test-suite/tests/elisp.test +++ b/test-suite/tests/elisp.test @@ -109,12 +109,22 @@ (pass-if "length (with backquoted list)" (= (length `(a b c . ,%nil)) 3)) - (pass-if "write" + (pass-if "write (%nil)" + (string=? (with-output-to-string + (lambda () (write %nil))) + "#nil")) ; Hmmm... should be "()" ? + + (pass-if "display (%nil)" + (string=? (with-output-to-string + (lambda () (display %nil))) + "#nil")) ; Ditto. + + (pass-if "write (list)" (string=? (with-output-to-string (lambda () (write (cons 'a %nil)))) "(a)")) - (pass-if "display" + (pass-if "display (list)" (string=? (with-output-to-string (lambda () (display (cons 'a %nil)))) "(a)")) @@ -186,6 +196,72 @@ (list-set! l 6 44) (= (list-ref l 6) 44))) + (pass-if "list-cdr-set!" + (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) + (and (begin + (list-cdr-set! l 4 44) + (equal? l '(0 1 2 3 4 . 44))) + (begin + (list-cdr-set! l 3 `(new . ,%nil)) + (equal? l `(0 1 2 3 new . ,%nil)))))) + + (pass-if-exception "list-cdr-set!" + exception:out-of-range + (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) + (list-cdr-set! l 6 44))) + + (pass-if "memq" + (equal? (memq 'c `(a b c d . ,%nil)) `(c d . ,%nil))) + + (pass-if "memv" + (equal? (memv 'c `(a b c d . ,%nil)) `(c d . ,%nil))) + + (pass-if "member" + (equal? (member "c" `("a" "b" "c" "d" . ,%nil)) `("c" "d" . ,%nil))) + + (pass-if "list->vector" + (equal? #(1 2 3) (list->vector `(1 2 3 . ,%nil)))) + + (pass-if "list->vector" + (equal? #(1 2 3) (list->vector `(1 2 3 . ,%nil)))) + + (pass-if "list->weak-vector" + (equal? (weak-vector 1 2 3) (list->weak-vector `(1 2 3 . ,%nil)))) + + (pass-if "sorted?" + (and (sorted? `(1 2 3 . ,%nil) <) + (not (sorted? `(1 6 3 . ,%nil) <)))) + + (pass-if "merge" + (equal? (merge '(1 4 7 10) + (merge `(2 5 8 11 . ,%nil) + `(3 6 9 12 . ,%nil) + <) + <) + `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil))) + + (pass-if "merge!" + (equal? (merge! (copy-tree '(1 4 7 10)) + (merge! (copy-tree `(2 5 8 11 . ,%nil)) + (copy-tree `(3 6 9 12 . ,%nil)) + <) + <) + `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil))) + + (pass-if "sort" + (equal? (sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8))) + + (pass-if "stable-sort" + (equal? (stable-sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8))) + + (pass-if "sort!" + (equal? (sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <) + '(1 3 4 5 8))) + + (pass-if "stable-sort!" + (equal? (stable-sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <) + '(1 3 4 5 8))) + ) (with-test-prefix "value preservation" diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test index 294bd252a..6b0de7612 100644 --- a/test-suite/tests/load.test +++ b/test-suite/tests/load.test @@ -114,4 +114,13 @@ (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm") (try-search-with-extensions path "ugly.ss" extensions #f) +(if (defined? '%nil) + ;; Check that search-path accepts Elisp nil-terminated lists for + ;; PATH and EXTENSIONS. + (with-test-prefix "elisp-nil" + (set-cdr! (last-pair path) %nil) + (set-cdr! (last-pair extensions) %nil) + (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm") + (try-search-with-extensions path "ugly.ss" extensions #f))) + (delete-tree temp-dir) From 1fa86ca526d94b9149bdd805989f694be8c120d5 Mon Sep 17 00:00:00 2001 From: Stefan Jahn Date: Thu, 31 Jan 2002 10:38:50 +0000 Subject: [PATCH 06/39] 2002-01-31 Stefan Jahn * convert.c, convert.h, convert.i.c: New files containing C array to Scheme conversion helpers meant to be replacement functions for the deprecated gh interface. * Makefile.am: Setup rules for new `convert.*' files. 2002-01-31 Stefan Jahn * configure.in: Add -DLIBLTDL_DLL_IMPORT to INCLTDL when using `libltdl.dll'. --- ChangeLog | 5 + configure.in | 4 + libguile/ChangeLog | 8 ++ libguile/Makefile.am | 12 +-- libguile/convert.c | 146 +++++++++++++++++++++++++ libguile/convert.h | 76 +++++++++++++ libguile/convert.i.c | 247 +++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 492 insertions(+), 6 deletions(-) create mode 100644 libguile/convert.c create mode 100644 libguile/convert.h create mode 100644 libguile/convert.i.c diff --git a/ChangeLog b/ChangeLog index 88b3a520e..dfac20bd8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2002-01-31 Stefan Jahn + + * configure.in: Add -DLIBLTDL_DLL_IMPORT to INCLTDL when using + `libltdl.dll'. + 2002-01-28 Stefan Jahn * configure.in (guile_cv_have_uint32_t): Look also in diff --git a/configure.in b/configure.in index 4607b4d76..2e0e2c0e5 100644 --- a/configure.in +++ b/configure.in @@ -251,6 +251,9 @@ if test "$MINGW32" = "yes" ; then AC_DEFINE(USE_DLL_IMPORT, 1, [Define if you need additional CPP macros on Win32 platforms.]) fi + if test x"$enable_ltdl_install" = x"yes" ; then + INCLTDL="-DLIBLTDL_DLL_IMPORT $INCLTDL" + fi fi AC_SUBST(EXTRA_DEFS) @@ -273,6 +276,7 @@ if test "$use_modules" != no; then done fi fi + AC_SUBST(INCLTDL) AC_SUBST(LIBLTDL) AC_SUBST(DLPREOPEN) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index bd6395e74..e4bab308a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2002-01-31 Stefan Jahn + + * convert.c, convert.h, convert.i.c: New files containing C + array to Scheme conversion helpers meant to be replacement + functions for the deprecated gh interface. + + * Makefile.am: Setup rules for new `convert.*' files. + 2002-01-28 Stefan Jahn * symbols.c (scm_c_symbol2str): New function, replacement for diff --git a/libguile/Makefile.am b/libguile/Makefile.am index e3bb3b3ea..c11ef267e 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -41,8 +41,8 @@ guile_LDFLAGS = @DLPREOPEN@ guile_filter_doc_snarfage_SOURCES = c-tokenize.c libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ - chars.c continuations.c debug.c deprecation.c dynl.c dynwind.c \ - environments.c eq.c error.c eval.c evalext.c extensions.c \ + chars.c continuations.c convert.c debug.c deprecation.c dynl.c \ + dynwind.c environments.c eq.c error.c eval.c evalext.c extensions.c \ feature.c fluids.c fports.c \ gc.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c \ gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c guardians.c hash.c \ @@ -117,7 +117,7 @@ install-exec-hook: ## Perhaps we can deal with them normally once the merge seems to be ## working. noinst_HEADERS = coop-threads.c coop-threads.h coop.c \ - num2integral.i.c num2float.i.c \ + num2integral.i.c num2float.i.c convert.i.c \ win32-uname.h win32-dirent.h win32-socket.h libguile_la_DEPENDENCIES = @LIBLOBJS@ @@ -130,9 +130,9 @@ pkginclude_HEADERS = gh.h # These are headers visible as . modincludedir = $(includedir)/libguile modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ - chars.h continuations.h coop-defs.h debug.h debug-malloc.h deprecation.h \ - dynl.h dynwind.h environments.h eq.h error.h eval.h evalext.h \ - extensions.h feature.h filesys.h fluids.h fports.h gc.h \ + chars.h continuations.h convert.h coop-defs.h debug.h debug-malloc.h \ + deprecation.h dynl.h dynwind.h environments.h eq.h error.h eval.h \ + evalext.h extensions.h feature.h filesys.h fluids.h fports.h gc.h \ gdb_interface.h gdbint.h \ goops.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h \ inline.h ioext.h \ diff --git a/libguile/convert.c b/libguile/convert.c new file mode 100644 index 000000000..43d5d7107 --- /dev/null +++ b/libguile/convert.c @@ -0,0 +1,146 @@ +/* Copyright (C) 2002 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 + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + + +#include "libguile/_scm.h" +#include "libguile/validate.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/pairs.h" +#if HAVE_ARRAYS +# include "libguile/unif.h" +#endif + +#include "libguile/convert.h" + +#define CTYPE char +#define SCM2CTYPES_FN "scm_c_scm2chars" +#define SCM2CTYPES scm_c_scm2chars +#define CTYPES2SCM_FN "scm_c_chars2scm" +#define CTYPES2SCM scm_c_chars2scm +#define CTYPEFIXABLE +#define CTYPES2UVECT_FN "scm_c_chars2byvect" +#define CTYPES2UVECT scm_c_chars2byvect +#define UVECTTYPE scm_tc7_byvect +#define CTYPEMIN -128 +#define CTYPEMAX +255 +#define ARRAYTYPE1 scm_tc7_byvect +#define STRINGTYPE +#include "convert.i.c" + +#define CTYPE short +#define SCM2CTYPES_FN "scm_c_scm2shorts" +#define SCM2CTYPES scm_c_scm2shorts +#define CTYPES2SCM_FN "scm_c_shorts2scm" +#define CTYPES2SCM scm_c_shorts2scm +#define CTYPEFIXABLE +#define CTYPES2UVECT_FN "scm_c_shorts2svect" +#define CTYPES2UVECT scm_c_shorts2svect +#define UVECTTYPE scm_tc7_svect +#define CTYPEMIN -32768 +#define CTYPEMAX +65535 +#define ARRAYTYPE1 scm_tc7_svect +#include "convert.i.c" + +#define CTYPE int +#define SCM2CTYPES_FN "scm_c_scm2ints" +#define SCM2CTYPES scm_c_scm2ints +#define CTYPES2SCM_FN "scm_c_ints2scm" +#define CTYPES2SCM scm_c_ints2scm +#define CTYPES2UVECT_FN "scm_c_ints2ivect" +#define CTYPES2UVECT scm_c_ints2ivect +#define UVECTTYPE scm_tc7_ivect +#define CTYPES2UVECT_FN2 "scm_c_uints2uvect" +#define CTYPES2UVECT2 scm_c_uints2uvect +#define UVECTTYPE2 scm_tc7_uvect +#define ARRAYTYPE1 scm_tc7_ivect +#define ARRAYTYPE2 scm_tc7_uvect +#include "convert.i.c" + +#define CTYPE long +#define SCM2CTYPES_FN "scm_c_scm2longs" +#define SCM2CTYPES scm_c_scm2longs +#define CTYPES2SCM_FN "scm_c_longs2scm" +#define CTYPES2SCM scm_c_longs2scm +#define CTYPES2UVECT_FN "scm_c_longs2ivect" +#define CTYPES2UVECT scm_c_longs2ivect +#define UVECTTYPE scm_tc7_ivect +#define CTYPES2UVECT_FN2 "scm_c_ulongs2uvect" +#define CTYPES2UVECT2 scm_c_ulongs2uvect +#define UVECTTYPE2 scm_tc7_uvect +#define ARRAYTYPE1 scm_tc7_ivect +#define ARRAYTYPE2 scm_tc7_uvect +#include "convert.i.c" + +#define CTYPE float +#define SCM2CTYPES_FN "scm_c_scm2floats" +#define SCM2CTYPES scm_c_scm2floats +#define CTYPES2SCM_FN "scm_c_floats2scm" +#define CTYPES2SCM scm_c_floats2scm +#define CTYPES2UVECT_FN "scm_c_floats2fvect" +#define CTYPES2UVECT scm_c_floats2fvect +#define UVECTTYPE scm_tc7_fvect +#define ARRAYTYPE1 scm_tc7_fvect +#define ARRAYTYPE2 scm_tc7_dvect +#define FLOATTYPE1 float +#define FLOATTYPE2 double +#include "convert.i.c" + +#define CTYPE double +#define SCM2CTYPES_FN "scm_c_scm2doubles" +#define SCM2CTYPES scm_c_scm2doubles +#define CTYPES2SCM_FN "scm_c_doubles2scm" +#define CTYPES2SCM scm_c_doubles2scm +#define CTYPES2UVECT_FN "scm_c_doubles2dvect" +#define CTYPES2UVECT scm_c_doubles2dvect +#define UVECTTYPE scm_tc7_dvect +#define ARRAYTYPE1 scm_tc7_dvect +#define ARRAYTYPE2 scm_tc7_fvect +#define FLOATTYPE1 double +#define FLOATTYPE2 float +#include "convert.i.c" + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/convert.h b/libguile/convert.h new file mode 100644 index 000000000..ec350fef4 --- /dev/null +++ b/libguile/convert.h @@ -0,0 +1,76 @@ +/* classes: h_files */ + +#ifndef SCM_CONVERT_H +#define SCM_CONVERT_H + +/* Copyright (C) 2002 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 + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + + +#include "libguile/__scm.h" + +SCM_API char *scm_c_scm2chars (SCM obj, char *dst); +SCM_API short *scm_c_scm2shorts (SCM obj, short *dst); +SCM_API int *scm_c_scm2ints (SCM obj, int *dst); +SCM_API long *scm_c_scm2longs (SCM obj, long *dst); +SCM_API float *scm_c_scm2floats (SCM obj, float *dst); +SCM_API double *scm_c_scm2doubles (SCM obj, double *dst); + +SCM_API SCM scm_c_chars2scm (const char *src, long n); +SCM_API SCM scm_c_shorts2scm (const short *src, long n); +SCM_API SCM scm_c_ints2scm (const int *src, long n); +SCM_API SCM scm_c_longs2scm (const long *src, long n); +SCM_API SCM scm_c_floats2scm (const float *src, long n); +SCM_API SCM scm_c_doubles2scm (const double *src, long n); + +#if HAVE_ARRAYS +SCM_API SCM scm_c_chars2byvect (const char *src, long n); +SCM_API SCM scm_c_shorts2svect (const short *src, long n); +SCM_API SCM scm_c_ints2ivect (const int *src, long n); +SCM_API SCM scm_c_uints2uvect (const unsigned int *src, long n); +SCM_API SCM scm_c_longs2ivect (const long *src, long n); +SCM_API SCM scm_c_ulongs2uvect (const unsigned long *src, long n); +SCM_API SCM scm_c_floats2fvect (const float *src, long n); +SCM_API SCM scm_c_doubles2dvect (const double *src, long n); +#endif + +#endif /* SCM_CONVERT_H */ diff --git a/libguile/convert.i.c b/libguile/convert.i.c new file mode 100644 index 000000000..118182943 --- /dev/null +++ b/libguile/convert.i.c @@ -0,0 +1,247 @@ +/* this file is #include'd (x times) by convert.c */ + +/* FIXME: Should we use exported wrappers for malloc (and free), which + * allow windows DLLs to call the correct freeing function? */ + + +/* Convert a vector, weak vector, (if possible string, substring), list + or uniform vector into an C array. If result array in argument 2 is + NULL, malloc() a new one. If out of memory, return NULL. */ +#define FUNC_NAME SCM2CTYPES_FN +CTYPE * +SCM2CTYPES (SCM obj, CTYPE *data) +{ + long i, n; + SCM val; + + SCM_ASSERT (SCM_NIMP (obj) || SCM_NFALSEP (scm_list_p (obj)), + obj, SCM_ARG1, FUNC_NAME); + + if (SCM_NFALSEP (scm_list_p (obj))) + { + SCM list = obj; + for (n = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), n++) + { + val = SCM_CAR (list); +#if defined (CTYPEMIN) && defined (CTYPEMAX) + if (SCM_INUMP (val)) + { + long v = SCM_INUM (val); + SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX); + } + else +#elif defined (FLOATTYPE1) + if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val))) +#else + if (!SCM_INUMP (val) && !SCM_BIGP (val)) +#endif + SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); + } + if (data == NULL) + data = (CTYPE *) malloc (n * sizeof (CTYPE)); + if (data == NULL) + return NULL; + + list = obj; + for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++) + { + val = SCM_CAR (list); + if (SCM_INUMP (val)) + data[i] = SCM_INUM (val); + else if (SCM_BIGP (val)) + data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME); +#ifdef FLOATTYPE1 + else + data[i] = (CTYPE) SCM_REAL_VALUE (val); +#endif + } + return data; + } + + switch (SCM_TYP7 (obj)) + { + case scm_tc7_vector: + case scm_tc7_wvect: + n = SCM_VECTOR_LENGTH (obj); + for (i = 0; i < n; i++) + { + val = SCM_VELTS (obj)[i]; + +#if defined (CTYPEMIN) && defined (CTYPEMAX) + if (SCM_INUMP (val)) + { + long v = SCM_INUM (val); + SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX); + } + else +#elif defined (FLOATTYPE1) + if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val))) +#else + if (!SCM_INUMP (val) && !SCM_BIGP (val)) +#endif + SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); + } + if (data == NULL) + data = (CTYPE *) malloc (n * sizeof (CTYPE)); + if (data == NULL) + return NULL; + for (i = 0; i < n; i++) + { + val = SCM_VELTS (obj)[i]; + if (SCM_INUMP (val)) + data[i] = (CTYPE) SCM_INUM (val); + else if (SCM_BIGP (val)) + data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME); +#ifdef FLOATTYPE1 + else + data[i] = (CTYPE) SCM_REAL_VALUE (val); +#endif + } + break; + +#ifdef HAVE_ARRAYS + case ARRAYTYPE1: +#ifdef ARRAYTYPE2 + case ARRAYTYPE2: +#endif + n = SCM_UVECTOR_LENGTH (obj); + if (data == NULL) + data = (CTYPE *) malloc (n * sizeof (CTYPE)); + if (data == NULL) + return NULL; +#ifdef FLOATTYPE2 + if (SCM_TYP7 (obj) == ARRAYTYPE2) + { + for (i = 0; i < n; i++) + data[i] = ((FLOATTYPE2 *) SCM_UVECTOR_BASE (obj))[i]; + } + else +#endif + memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE)); + break; +#endif /* HAVE_ARRAYS */ + +#ifdef STRINGTYPE + case scm_tc7_string: + n = SCM_STRING_LENGTH (obj); + if (data == NULL) + data = (CTYPE *) malloc (n * sizeof (CTYPE)); + if (data == NULL) + return NULL; + memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE)); + break; +#endif /* STRINGTYPE */ + + default: + SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); + } + return data; +} +#undef FUNC_NAME + + +#if HAVE_ARRAYS + +/* Converts a C array into a uniform vector, returns SCM_UNDEFINED if out + of memory. */ +#define FUNC_NAME CTYPES2UVECT_FN +SCM +CTYPES2UVECT (const CTYPE *data, long n) +{ + char *v; + + SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), + n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); + if ((v = (char *) SCM_MUST_MALLOC_TYPE_NUM (CTYPE, n)) == NULL) + return SCM_UNDEFINED; + memcpy (v, data, n * sizeof (CTYPE)); + return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v); +} +#undef FUNC_NAME + +#ifdef UVECTTYPE2 +#define FUNC_NAME CTYPES2UVECT_FN2 +SCM +CTYPES2UVECT2 (const unsigned CTYPE *data, long n) +{ + char *v; + + SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), + n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); + if ((v = (char *) SCM_MUST_MALLOC_TYPE_NUM (unsigned CTYPE, n)) == NULL) + return SCM_UNDEFINED; + memcpy (v, data, n * sizeof (unsigned CTYPE)); + return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE2), (scm_t_bits) v); +} +#undef FUNC_NAME +#endif /* UVECTTYPE2 */ + +#endif /* HAVE_ARRAYS */ + +/* Converts a C array into a vector. */ +#define FUNC_NAME CTYPES2SCM_FN +SCM +CTYPES2SCM (const CTYPE *data, long n) +{ + long i; + SCM v, *velts; + + SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), + n > 0 && n <= SCM_VECTOR_MAX_LENGTH); + v = scm_c_make_vector (n, SCM_UNSPECIFIED); + velts = SCM_VELTS (v); + for (i = 0; i < n; i++) +#ifdef FLOATTYPE1 + velts[i] = scm_make_real ((double) data[i]); +#elif defined (CTYPEFIXABLE) + velts[i] = SCM_MAKINUM (data[i]); +#else + velts[i] = (SCM_FIXABLE (data[i]) ? SCM_MAKINUM (data[i]) : + scm_i_long2big (data[i])); +#endif + return v; +} +#undef FUNC_NAME + +/* cleanup of conditionals */ +#undef SCM2CTYPES +#undef SCM2CTYPES_FN +#undef CTYPES2SCM +#undef CTYPES2SCM_FN +#undef CTYPE +#undef CTYPES2UVECT +#undef CTYPES2UVECT_FN +#ifdef CTYPEFIXABLE +#undef CTYPEFIXABLE +#endif +#undef UVECTTYPE +#ifdef UVECTTYPE2 +#undef CTYPES2UVECT2 +#undef CTYPES2UVECT_FN2 +#undef UVECTTYPE2 +#endif +#ifdef CTYPEMIN +#undef CTYPEMIN +#endif +#ifdef CTYPEMAX +#undef CTYPEMAX +#endif +#undef ARRAYTYPE1 +#ifdef ARRAYTYPE2 +#undef ARRAYTYPE2 +#endif +#ifdef FLOATTYPE1 +#undef FLOATTYPE1 +#endif +#ifdef FLOATTYPE2 +#undef FLOATTYPE2 +#endif +#ifdef STRINGTYPE +#undef STRINGTYPE +#endif + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ From 68dc153d7f7a86c6e7843dc1a776d73014c89ed2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 31 Jan 2002 19:59:26 +0000 Subject: [PATCH 07/39] (scm_gensym): Use " g" as default prefix, not "g". This might help to make unintented clashes less likely. (scm_string_to_symbol): Protect the string until the symbols is created. --- libguile/symbols.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index c3e22c865..3661106ea 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -139,7 +139,6 @@ scm_mem2symbol (const char *name, size_t len) } } - SCM scm_str2symbol (const char *str) { @@ -216,9 +215,12 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_string_to_symbol { + SCM sym; SCM_VALIDATE_STRING (1, string); - return scm_mem2symbol (SCM_STRING_CHARS (string), - SCM_STRING_LENGTH (string)); + sym = scm_mem2symbol (SCM_STRING_CHARS (string), + SCM_STRING_LENGTH (string)); + scm_remember_upto_here_1 (string); + return sym; } #undef FUNC_NAME @@ -230,7 +232,7 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, (SCM prefix), "Create a new symbol with a name constructed from a prefix and\n" "a counter value. The string @var{prefix} can be specified as\n" - "an optional argument. Default prefix is @code{g}. The counter\n" + "an optional argument. Default prefix is @code{ g}. The counter\n" "is increased by 1 at each call. There is no provision for\n" "resetting the counter.") #define FUNC_NAME s_scm_gensym @@ -240,8 +242,9 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, size_t len; if (SCM_UNBNDP (prefix)) { - name[0] = 'g'; - len = 1; + name[0] = ' '; + name[1] = 'g'; + len = 2; } else { From 1b39c2e37f9a4def1f834ecb86d705d7e4bf2682 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 31 Jan 2002 19:59:39 +0000 Subject: [PATCH 08/39] *** empty log message *** --- libguile/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e4bab308a..d07a00f85 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2002-01-31 Marius Vollmer + + * symbols.c (scm_gensym): Use " g" as default prefix, not "g". + This might help to make unintented clashes less likely. + (scm_string_to_symbol): Protect the string until the symbols is + created. + 2002-01-31 Stefan Jahn * convert.c, convert.h, convert.i.c: New files containing C From 329e4968208252819b2c854367ca0dbcd6bc7600 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 1 Feb 2002 16:47:00 +0000 Subject: [PATCH 09/39] * Unquote uses of `begin' in transformed Elisp code. --- lang/elisp/ChangeLog | 5 +++++ lang/elisp/primitives/syntax.scm | 2 +- lang/elisp/transform.scm | 2 +- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/lang/elisp/ChangeLog b/lang/elisp/ChangeLog index f1ed71dbb..461436daf 100644 --- a/lang/elisp/ChangeLog +++ b/lang/elisp/ChangeLog @@ -1,3 +1,8 @@ +2002-02-01 Neil Jerram + + * transform.scm (transformer), primitives/syntax.scm (let*): + Unquote uses of `begin' in transformed code. + 2002-01-29 Neil Jerram * transform.scm (transform-1, transform-2, transform-3, diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm index ac0951439..3bf5a903a 100644 --- a/lang/elisp/primitives/syntax.scm +++ b/lang/elisp/primitives/syntax.scm @@ -332,7 +332,7 @@ (procedure->memoizing-macro (lambda (exp env) (if (null? (cadr exp)) - `(begin ,@(map transformer (cddr exp))) + `(,begin ,@(map transformer (cddr exp))) (car (let loop ((bindings (cadr exp))) (if (null? bindings) (map transformer (cddr exp)) diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm index ec1639d6e..0bb28ea37 100644 --- a/lang/elisp/transform.scm +++ b/lang/elisp/transform.scm @@ -25,7 +25,7 @@ (case (car x) ((@fop @bind define-module use-modules use-syntax) x) ; Escape to Scheme syntax - ((scheme) (cons 'begin (cdr x))) + ((scheme) (cons begin (cdr x))) ; Should be handled in reader ((quote function) `(,quote ,@(cars->nil (cdr x)))) ((quasiquote) (m-quasiquote x '())) From 3dd84ef10c2161b8ad320726940d3ee428301ffb Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 3 Feb 2002 05:19:05 +0000 Subject: [PATCH 10/39] (HAVE_UINTPTR_T): Only define if UINTPTR_T attributes are defined: UINTPTR_MAX, INTPTR_MAX, INTPTR_MIN. --- libguile/__scm.h | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/libguile/__scm.h b/libguile/__scm.h index d9e26cada..986797c57 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -293,7 +293,11 @@ * - ... add more */ -#if SIZEOF_UINTPTR_T != 0 +#if SIZEOF_UINTPTR_T != 0 && defined(UINTPTR_MAX) \ + && defined(INTPTR_MAX) \ + && defined(INTPTR_MIN) +/* Used as SCM if available, so we bundle related attributes to avoid possible + type incon[st][oi]n[ae]nce later. Word in tags.h. */ #define HAVE_UINTPTR_T 1 #endif @@ -384,7 +388,7 @@ typedef long ptrdiff_t; /* James Clark came up with this neat one instruction fix for * continuations on the SPARC. It flushes the register windows so - * that all the state of the process is contained in the stack. + * that all the state of the process is contained in the stack. */ #ifdef sparc @@ -393,7 +397,7 @@ typedef long ptrdiff_t; # define SCM_FLUSH_REGISTER_WINDOWS /* empty */ #endif -/* If stack is not longword aligned then +/* If stack is not longword aligned then */ /* #define SHORT_ALIGN */ @@ -415,8 +419,8 @@ typedef long SCM_STACKITEM; #ifndef USE_THREADS -#define SCM_CRITICAL_SECTION_START -#define SCM_CRITICAL_SECTION_END +#define SCM_CRITICAL_SECTION_START +#define SCM_CRITICAL_SECTION_END #define SCM_THREAD_SWITCHING_CODE #endif @@ -573,7 +577,7 @@ do { \ /** SCM_ASSERT - ** + ** **/ @@ -659,7 +663,7 @@ SCM_API SCM scm_apply_generic (SCM gf, SCM args); #define SCM_ARG4 4 #define SCM_ARG5 5 #define SCM_ARG6 6 -#define SCM_ARG7 7 +#define SCM_ARG7 7 #endif /* SCM_MAGIC_SNARFER */ From 34472dfe987302b9835d7e2f28d7bb2a6a9e421b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 3 Feb 2002 05:20:21 +0000 Subject: [PATCH 11/39] *** empty log message *** --- libguile/ChangeLog | 45 +++++++++++++++++++++++++-------------------- 1 file changed, 25 insertions(+), 20 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d07a00f85..20c4e48da 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2002-02-02 Thien-Thi Nguyen + + * __scm.h (HAVE_UINTPTR_T): Only define if UINTPTR_T attributes + are defined: UINTPTR_MAX, INTPTR_MAX, INTPTR_MIN. + 2002-01-31 Marius Vollmer * symbols.c (scm_gensym): Use " g" as default prefix, not "g". @@ -8,7 +13,7 @@ 2002-01-31 Stefan Jahn * convert.c, convert.h, convert.i.c: New files containing C - array to Scheme conversion helpers meant to be replacement + array to Scheme conversion helpers meant to be replacement functions for the deprecated gh interface. * Makefile.am: Setup rules for new `convert.*' files. @@ -18,21 +23,21 @@ * symbols.c (scm_c_symbol2str): New function, replacement for `gh_scm2newsymbol()'. - * strings.c (scm_c_substring2str): New function. Proper + * strings.c (scm_c_substring2str): New function. Proper replacement for `gh_get_substr()'. * socket.c: Include `stdint.h' if available for the `uint32_t' declaration. - * scmsigs.c (s_scm_sigaction): Initialize `chandler' (inhibits + * scmsigs.c (s_scm_sigaction): Initialize `chandler' (inhibits compiler warning). * backtrace.c: Include `lang.h' for GUILE_DEBUG conditional. 2002-01-22 Neil Jerram - + Other changes unrelated to Elisp... - + * eval.c (scm_m_if): Use s_if rather than repeating string literal "if". (comments): Fix a few typos. @@ -60,7 +65,7 @@ * eval.c, eval.h, init.c, lang.c, lang.h: Use SCM_ENABLE_ELISP to conditionalize compilation and initialization of Elisp support function. - + * alist.c (scm_assq, scm_assv, scm_assoc), async.c (scm_asyncs_pending, scm_run_asyncs, noop), backtrace.c (scm_set_print_params_x), dynl.c (scm_make_argv_from_stringlist), @@ -76,7 +81,7 @@ * boolean.c (scm_not): Use `SCM_FALSEP || SCM_NILP' instead of just SCM_FALSEP. - + * boolean.c (scm_boolean_p): Use `SCM_BOOLP || SCM_NILP' instead of just SCM_BOOLP. @@ -123,7 +128,7 @@ (SCM_ELISP_NIL): New IFLAG. * validate.h (SCM_VALIDATE_NULL_OR_NIL): New. - + 2002-01-10 Dirk Herrmann * eval.c: Removed outdated references to "everr". Improved some @@ -179,7 +184,7 @@ 2001-12-08 Stefan Jahn * strings.c (scm_c_string2str): New function. Converts a - given Scheme string into a C string. Also put in two + given Scheme string into a C string. Also put in two THINKME's regarding the malloc policy for the missing converter routines. @@ -206,7 +211,7 @@ 2001-11-25 Marius Vollmer * vectors.h (SCM_MAKE_VECTOR_TAG): New. - * unif.h (SCM_MAKE_BITVECTOR_TAG, SCM_MAKE_UVECTOR_TAG): New. + * unif.h (SCM_MAKE_BITVECTOR_TAG, SCM_MAKE_UVECTOR_TAG): New. * symbols.h (SCM_MAKE_SYMBOL_TAG): New. * strings.h (SCM_MAKE_STRING_TAG): New. * procs.h (SCM_MAKE_CCLO_TAG): New. @@ -226,7 +231,7 @@ Deprecated SCM_NEWCELL and SCM_NEWCELL2. Added scm_alloc_cell and scm_alloc_double_cell in their place. - + * gc.h (SCM_GC_SET_ALLOCATED, scm_debug_newcell, scm_debug_newcell2, scm_tc16_allocated): Removed from header. (scm_deprecated_newcell, scm_deprecated_newcell2): New. @@ -240,11 +245,11 @@ (scm_init_gc): Do it here. (allocated_mark): New, from old code. (scm_deprecated_newcell, scm_deprecated_newcell2): New. - - * inline.c, inline.h: New files. - * Makefile.am: Added them in all the right places. - * _scm.h: Include "libguile/inline.h". + * inline.c, inline.h: New files. + * Makefile.am: Added them in all the right places. + + * _scm.h: Include "libguile/inline.h". * alist.c, coop-threads.c, debug.c, environments.c, eval.c, fports.c, gh_data.c, goops.c, guardians.c, lang.c, list.c, @@ -278,19 +283,19 @@ * Makefile.am (install-exec-hook): Prepend $(DESTDIR) to filename. Thanks to Eric Gillespie, Jr! - + 2001-11-21 Stefan Jahn - * win32-socket.c (getservent, setservent, endservent, - getprotoent, setprotoent, endprotoent): New functions. + * win32-socket.c (getservent, setservent, endservent, + getprotoent, setprotoent, endprotoent): New functions. Appropriate replacements for M$-Windows. * numbers.c (SIZE_MAX, PTRDIFF_MAX, PTRDIFF_MIN): Reintroduced these definitions for GUILE_DEBUG. * net_db.c: Include "win32-socket.h" if compiling with a native - M$-Windows compiler. Include some pieces of code (protoent and - servent interface) protected by HAVE_* macros when using a + M$-Windows compiler. Include some pieces of code (protoent and + servent interface) protected by HAVE_* macros when using a native M$-Windows compiler. 2001-11-20 Marius Vollmer From b0c6d4040eaf900b3037ed9cb13b0aae51f6879a Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 3 Feb 2002 07:08:50 +0000 Subject: [PATCH 12/39] Initial revision --- devel/build/README | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 devel/build/README diff --git a/devel/build/README b/devel/build/README new file mode 100644 index 000000000..e69de29bb From e3f394f39164d1b8f84b4b3187cde04e968aea13 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 3 Feb 2002 07:12:58 +0000 Subject: [PATCH 13/39] Add instructions. Remove version control tag. --- devel/build/guile-projects-entry | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/devel/build/guile-projects-entry b/devel/build/guile-projects-entry index 7559b24d3..e69de29bb 100644 --- a/devel/build/guile-projects-entry +++ b/devel/build/guile-projects-entry @@ -1,15 +0,0 @@ -;;; $Date: 2001-11-15 21:11:25 $ -((name "guile") - (category "Core") - (keywords "Extension Language " "Scheme " "Interpreter") - (description "GNU Ubiquitous Intelligent Language for Extension") - (location (url "http://www.gnu.org/software/guile/guile.html" - "Guile Homepage")) - (mailing-list (url "http://www.gnu.org/software/guile/mail/mail.html" - "guile-user, guile-devel, etc.")) - (status "version 1.5.4 " - (url "ftp://alpha.gnu.org/gnu/guile/" - "(beta)") - " released 2001-09-28") - (license "GPL, with an exception to allow non-GPL'd programs to " - "link to the library without becoming derivitive works.")) From ac48757b5ed4efeb2b7018c8e08ea26cab8a5418 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Feb 2002 22:49:06 +0000 Subject: [PATCH 14/39] * symbols.h (SCM_SET_SYMBOL_HASH): Removed. (SCM_SYMBOL_INTERNED_P): New. * symbols.c (scm_symbol_hash): Use scm_ulong2num instead of SCM_MAKINUM since hash values can well be bignums. (scm_mem2symbol): Only use hash values below SCM_T_BITS_MAX/2. This signals a interned symbol. (scm_mem2uninterned_symbol, scm_symbol_interned_p, scm_make_symbol): New. --- libguile/symbols.c | 44 ++++++++++++++++++++++++++++++++++++++++++-- libguile/symbols.h | 6 +++++- 2 files changed, 47 insertions(+), 3 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index 3661106ea..b2f89b9e1 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -87,7 +87,7 @@ SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0, SCM scm_mem2symbol (const char *name, size_t len) { - size_t raw_hash = scm_string_hash ((const unsigned char *) name, len); + size_t raw_hash = scm_string_hash ((const unsigned char *) name, len)/2; size_t hash = raw_hash % SCM_VECTOR_LENGTH (symbols); { @@ -139,6 +139,19 @@ scm_mem2symbol (const char *name, size_t len) } } +SCM +scm_mem2uninterned_symbol (const char *name, size_t len) +{ + size_t raw_hash = (scm_string_hash ((const unsigned char *) name, len)/2 + + SCM_T_BITS_MAX/2 + 1); + + return scm_alloc_double_cell (SCM_MAKE_SYMBOL_TAG (len), + (scm_t_bits) scm_must_strndup (name, len), + raw_hash, + SCM_UNPACK (scm_cons (SCM_BOOL_F, + SCM_EOL))); +} + SCM scm_str2symbol (const char *str) { @@ -155,6 +168,33 @@ SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 1, 0, 0, + (SCM symbol), + "Return @code{#t} if @var{symbol} is interned, otherwise return\n" + "@code{#f}.") +#define FUNC_NAME s_scm_symbol_interned_p +{ + SCM_VALIDATE_SYMBOL (1, symbol); + return SCM_BOOL (SCM_SYMBOL_INTERNED_P (symbol)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0, + (SCM name), + "Return a new uninterned symbol with the name @var{name}. " + "The returned symbol is guaranteed to be unique and future " + "calls to @code{string->symnbol} will not return it.") +#define FUNC_NAME s_scm_make_symbol +{ + SCM sym; + SCM_VALIDATE_STRING (1, name); + sym = scm_mem2uninterned_symbol (SCM_STRING_CHARS (name), + SCM_STRING_LENGTH (name)); + scm_remember_upto_here_1 (name); + return sym; +} +#undef FUNC_NAME + SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, (SCM s), "Return the name of @var{symbol} as a string. If the symbol was\n" @@ -270,7 +310,7 @@ SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, #define FUNC_NAME s_scm_symbol_hash { SCM_VALIDATE_SYMBOL (1, symbol); - return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol)); + return scm_ulong2num (SCM_SYMBOL_HASH (symbol)); } #undef FUNC_NAME diff --git a/libguile/symbols.h b/libguile/symbols.h index e4c624801..771d9ecab 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -51,6 +51,10 @@ /* SCM_SYMBOL_LENGTH(SYM) is the length of SYM's name in characters, and * SCM_SYMBOL_CHARS(SYM) is the address of the first character of SYM's name. + * + * SCM_SYMBOL_HASH is a hash value for the symbol. It is also used to + * encode whether the symbol is interned or not. See + * SCM_SYMBOL_INTERNED_P. */ #define SCM_SYMBOLP(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_symbol)) @@ -60,7 +64,7 @@ #define SCM_SYMBOL_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_SYMBOL_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) #define SCM_SYMBOL_HASH(X) ((unsigned long) SCM_CELL_WORD_2 (X)) -#define SCM_SET_SYMBOL_HASH(X, v) (SCM_SET_CELL_WORD_2 ((X), (v))) +#define SCM_SYMBOL_INTERNED_P(X) (SCM_SYMBOL_HASH(X) <= (SCM_T_BITS_MAX/2)) #define SCM_PROP_SLOTS(X) (SCM_CELL_OBJECT_3 (X)) #define SCM_SET_PROP_SLOTS(X, v) (SCM_SET_CELL_OBJECT_3 ((X), (v))) From 9ff28a13e089fcd3706be7ba2edde98051e2df07 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Feb 2002 22:50:07 +0000 Subject: [PATCH 15/39] (scm_iprin1): Print uninterned symbols unreadably. --- libguile/print.c | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index e28284637..d972c3d4e 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -527,10 +527,23 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_lfwrite (SCM_STRING_CHARS (exp), SCM_STRING_LENGTH (exp), port); break; case scm_tc7_symbol: - scm_print_symbol_name (SCM_SYMBOL_CHARS (exp), - SCM_SYMBOL_LENGTH (exp), - port); - scm_remember_upto_here_1 (exp); + if (SCM_SYMBOL_INTERNED_P (exp)) + { + scm_print_symbol_name (SCM_SYMBOL_CHARS (exp), + SCM_SYMBOL_LENGTH (exp), + port); + scm_remember_upto_here_1 (exp); + } + else + { + scm_puts ("#', port); + } break; case scm_tc7_variable: scm_i_variable_print (exp, port, pstate); From 319b98ed9cd0b75d94775b9f0c0948a4fe6305c8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Feb 2002 22:50:18 +0000 Subject: [PATCH 16/39] *** empty log message *** --- libguile/ChangeLog | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 20c4e48da..74754eab9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2002-02-03 Marius Vollmer + + * symbols.h (SCM_SET_SYMBOL_HASH): Removed. + (SCM_SYMBOL_INTERNED_P): New. + * symbols.c (scm_symbol_hash): Use scm_ulong2num instead of + SCM_MAKINUM since hash values can well be bignums. + (scm_mem2symbol): Only use hash values below SCM_T_BITS_MAX/2. + This signals a interned symbol. + (scm_mem2uninterned_symbol, scm_symbol_interned_p, + scm_make_symbol): New. + + * print.c (scm_iprin1): Print uninterned symbols unreadably. + 2002-02-02 Thien-Thi Nguyen * __scm.h (HAVE_UINTPTR_T): Only define if UINTPTR_T attributes @@ -6,7 +19,7 @@ 2002-01-31 Marius Vollmer * symbols.c (scm_gensym): Use " g" as default prefix, not "g". - This might help to make unintented clashes less likely. + This might help to make unintended clashes less likely. (scm_string_to_symbol): Protect the string until the symbols is created. From a63cdd615010461c4d180149d5f9160a38c59c25 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Feb 2002 16:47:23 +0000 Subject: [PATCH 17/39] (scm_mem2uninterned_symbol, scm_symbol_interned_p, scm_make_symbol): New prototypes. --- libguile/symbols.h | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/symbols.h b/libguile/symbols.h index 771d9ecab..22dc5cc25 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -79,9 +79,12 @@ SCM_API SCM scm_sys_symbols (void); #endif SCM_API SCM scm_mem2symbol (const char*, size_t); +SCM_API SCM scm_mem2uninterned_symbol (const char *name, size_t len); SCM_API SCM scm_str2symbol (const char*); SCM_API SCM scm_symbol_p (SCM x); +SCM_API SCM scm_symbol_interned_p (SCM sym); +SCM_API SCM scm_make_symbol (SCM name); SCM_API SCM scm_symbol_to_string (SCM s); SCM_API SCM scm_string_to_symbol (SCM s); From d58d5bfc1cb55d2c21954369eb67e7c965ce49cd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Feb 2002 16:47:35 +0000 Subject: [PATCH 18/39] (scm_make_symbol): Fix typo in docstring. --- libguile/symbols.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index b2f89b9e1..106b18fce 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -183,7 +183,7 @@ SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0, (SCM name), "Return a new uninterned symbol with the name @var{name}. " "The returned symbol is guaranteed to be unique and future " - "calls to @code{string->symnbol} will not return it.") + "calls to @code{string->symbol} will not return it.") #define FUNC_NAME s_scm_make_symbol { SCM sym; From 3933a7860db8e375d35d769559e919e1e2b00a4d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Feb 2002 16:48:28 +0000 Subject: [PATCH 19/39] (Symbol Uninterned): Added node. --- doc/ref/scheme-data.texi | 87 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 87 insertions(+) diff --git a/doc/ref/scheme-data.texi b/doc/ref/scheme-data.texi index 9dbced157..0aeb7de6c 100755 --- a/doc/ref/scheme-data.texi +++ b/doc/ref/scheme-data.texi @@ -2211,6 +2211,7 @@ objects @i{per se}. * Symbol Primitives:: Operations related to symbols. * Symbol Discrete:: Using symbols as discrete values. * Symbol Props:: Function slots and property lists. +* Symbol Uninterned:: Uninterned symbols. @end menu @@ -2390,6 +2391,92 @@ Return the @dfn{property list} currently associated with @var{symbol}. Change the binding of @var{symbol}'s property slot. @end deffn +@node Symbol Uninterned +@subsection Uninterned Symbols + +What makes symbols useful is that they are automatically kept unique. +There are no two symbols that are distinct objects but have the same +name. But of course, there is no rule without exception. In addition +to the normal symbols that have been discussed upto now, you can also +create special @dfn{uninterned} symbols that behave slightly +differently. + +To understand what is different about them and why they might be useful, +we look at how normal symbols are actually kept unique. + +Whenever Guile wants to find the symbol with a specific name, for +example during @code{read} or when executing @code{string->symbol}, it +first looks into a table of all existing symbols to find out whether a +symbol with the given name already exists. When this is the case, Guile +just returns that symbol. When not, a new symbol with the name is +created and entered into the table so that it can be found later. + +Sometimes you might want to create a symbol that is guaranteed `fresh', +i.e., a symbol that did not exist previously. You might also want to +somehow guarantee that no one else will ever unintentionally stumble +across your symbol in the future. These properties of a symbol are +often needed when generating code during macro expansion. When +introducing new temporary variables, you want to guarantee that they +don't conflict with variables in other peoples code. + +The simplest way to arrange for this is to create a new symbol and to +not enter it into the global table of all symbols. That way, no one +will ever get access to your symbol by chance. Symbols that are not in +the table are called @dfn{uninterned}. Of course, symbols that +@emph{are} in the table are called @dfn{interned}. + +You create new uninterned symbols with the function @code{make-symbol}. +You can test whether a symbol is interned or not with +@code{symbol-interned?}. + +Uninterned symbols break the rule that the name of a symbol uniquely +identifies the symbol object. Because of this, they can not be written +out and read back in like interned symbols. Currently, Guile has no +support for reading uninterned symbols. Note that the function +@code{gensym} does not return uninterned symbols for this reason. + +@deffn {Scheme Procedure} make-symbol name +@deffnx {C Function} scm_make_symbol (name) +Return a new uninterned symbol with the name @var{name}. The returned +symbol is guaranteed to be unique and future calls to +@code{string->symbol} will not return it. +@end deffn + +@deffn {Scheme Procedure} symbol-interned? symbol +@deffnx {C Function} scm_symbol_interned_p (symbol) +Return @code{#t} if @var{symbol} is interned, otherwise return +@code{#f}. +@end deffn + +For example: + +@lisp +(define foo-1 (string->symbol "foo")) +(define foo-2 (string->symbol "foo")) +(define foo-3 (make-symbol "foo")) +(define foo-4 (make-symbol "foo")) + +(eq? foo-1 foo-2) +@result{#t} ; Two interned symbols with the same name are the same object, + +(eq? foo-1 foo-3) +@result{#f} ; but a call to make-symbol with the same name returns a + ; distinct object. + +(eq? foo-3 foo-4) +@result{#f} ; A call to make-symbol always returns a new object, even for + ; the same name. + +foo-3 +@result{#} + ; Uninterned symbols print different from interned symbols, +(symbol? foo-3) +@result{#t} ; but they are still symbols. + +(symbol-interned? foo-3) +@result{#f} ; Just not interned. + +@end lisp @node Keywords @section Keywords From 402e687cc9d1db7c2b9c277e9b3103258f06171c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Feb 2002 16:48:36 +0000 Subject: [PATCH 20/39] *** empty log message *** --- doc/ref/ChangeLog | 4 ++++ libguile/ChangeLog | 7 +++++++ 2 files changed, 11 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index b0f5e2c67..58737d89e 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,7 @@ +2002-02-04 Marius Vollmer + + * scheme-data.texi (Symbol Uninterned): Added node. + 2002-01-29 Stefan Jahn * gh.texi (scm transition summary): Documented gh equivalents diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 74754eab9..1fc2f2169 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2002-02-04 Marius Vollmer + + * symbols.c (scm_make_symbol): Fix typo in docstring. + + * symbols.h (scm_mem2uninterned_symbol, scm_symbol_interned_p, + scm_make_symbol): New prototypes. + 2002-02-03 Marius Vollmer * symbols.h (SCM_SET_SYMBOL_HASH): Removed. From a284e7081e9219f0a316e9bf9ec379a56401dbbb Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 4 Feb 2002 19:20:00 +0000 Subject: [PATCH 21/39] (Autofrisk, Using Autofrisk): New sections. (Autoconf Support): Add new sections to menu. --- doc/ref/autoconf.texi | 112 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 111 insertions(+), 1 deletion(-) diff --git a/doc/ref/autoconf.texi b/doc/ref/autoconf.texi index 37f1a24ab..301dc440f 100644 --- a/doc/ref/autoconf.texi +++ b/doc/ref/autoconf.texi @@ -4,12 +4,15 @@ When Guile is installed, a set of autoconf macros is also installed as PREFIX/share/aclocal/guile.m4. This chapter documents the macros provided in -that file. @xref{Top,The GNU Autoconf Manual,,autoconf}, for more info. +that file, as well as the high-level guile-tool Autofrisk. @xref{Top,The GNU +Autoconf Manual,,autoconf}, for more info. @menu * Autoconf Background:: Why use autoconf? * Autoconf Macros:: The GUILE_* macros. * Using Autoconf Macros:: How to use them, plus examples. +* Autofrisk:: AUTOFRISK_CHECKS and AUTOFRISK_SUMMARY. +* Using Autofrisk:: Example modules.af files. @end menu @@ -120,4 +123,111 @@ In Makefile.in: $(INSTALL) my/*.scm $(instdir) @end example + +@node Autofrisk +@section Autofrisk + +The @dfn{guile-tools autofrisk} command looks for the file @file{modules.af} +in the current directory and writes out @file{modules.af.m4} containing +autoconf definitions for @code{AUTOFRISK_CHECKS} and @code{AUTOFRISK_SUMMARY}. +@xref{Autoconf Background}, and @xref{Using Autoconf Macros}, for more info. + +The modules.af file consists of a series of configuration forms (Scheme +lists), which have one of the following formats: + +@example + (files-glob PATTERN ...) ;; required + (non-critical-external MODULE ...) ;; optional + (non-critical-internal MODULE ...) ;; optional + (programs (MODULE PROG ...) ...) ;; optional + (pww-varname VARNAME) ;; optional +@end example + +@var{pattern} is a string that may contain "*" and "?" characters to be +expanded into filenames. @var{module} is a list of symbols naming a module, +such as `(srfi srfi-1)'. @var{varname} is a shell-safe name to use instead of +@code{probably_wont_work}, the default. This var is passed to `AC_SUBST'. +@var{prog} is a string that names a program, such as "gpg". + +Autofrisk expands the @code{files-glob} pattern(s) into a list of files, scans +each file's module definition form(s), and constructs a module dependency +graph wherein modules defined by @code{define-module} are considered +@dfn{internal} and the remaining, @dfn{external}. For each external module +that has an internal dependency, Autofrisk emits a +@code{GUILE_MODULE_REQUIRED} check (@pxref{Autoconf Macros}), which altogether +form the body of @code{AUTOFRISK_CHECKS}. + +@code{GUILE_MODULE_REQUIRED} causes the @file{configure} script to exit with +an error message if the specified module is not available; it enforces a +strong dependency. You can temper dependency strength by using the +@code{non-critical-external} and @code{non-critical-internal} configuration +forms in modules.af. For graph edges that touch such non-critical modules, +Autofrisk uses @code{GUILE_MODULE_AVAILABLE}, and arranges for +@code{AUTOFRISK_SUMMARY} to display a warning if they are not found. + +The shell code resulting from the expansion of @code{AUTOFRISK_CHECKS} and +@code{AUTOFRISK_SUMMARY} uses the shell variable @code{probably_wont_work} to +collect the names of unfound non-critical modules. If this bothers you, use +configuration form @code{(pww-name foo)} in modules.af. + +Although Autofrisk does not detect when a module uses a program (for example, +in a @code{system} call), it can generate @code{AC_PATH_PROG} forms anyway if +you use the @code{programs} configuration form in modules.af. These are +collected into @code{AUTOCONF_CHECKS}. + +@xref{Using Autofrisk}, for some modules.af examples. + + +@node Using Autofrisk +@section Using Autofrisk + +Using Autofrisk (@pxref{Autofrisk}) involves writing @file{modules.af} and +adding two macro calls to @file{configure.in}. Here is an example of the +latter: + +@example +AUTOFRISK_CHECKS +AUTOFRISK_SUMMARY +@end example + +Here is an adaptation of the second "GUILE_*" example (@pxref{Using Autoconf +Macros}) that does basically the same thing. + +@example +(files-glob "my/*.scm") +(non-critical-external (database postgres)) +(programs ((my gpgutils) "gpg")) ;; (my gpgutils) uses "gpg" +@end example + +If the SRFI modules (@pxref{SRFI Support}) were a separate package, we could +use @code{guile-tools frisk} to find out its dependencies: + +@example +$ guile-tools frisk srfi/*.scm +13 files, 18 modules (13 internal, 5 external), 9 edges + +x (ice-9 and-let-star) + regular (srfi srfi-2) +x (ice-9 syncase) + regular (srfi srfi-11) +x (ice-9 rdelim) + regular (srfi srfi-10) +x (ice-9 receive) + regular (srfi srfi-8) + regular (srfi srfi-1) +x (ice-9 session) + regular (srfi srfi-1) +@end example + +Then, we could use the following modules.af to help configure it: + +@example +(files-glob "srfi/*.scm") +(non-critical-external ;; relatively recent + (ice-9 rdelim) + (ice-9 receive) + (ice-9 and-let-star)) +(pww-varname not_fully_supported) +@end example + @c autoconf.texi ends here From 7c5c279671e81bb99d3f8ac195a2426254853541 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 4 Feb 2002 19:21:37 +0000 Subject: [PATCH 22/39] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 58737d89e..0d50fade9 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2002-02-04 Thien-Thi Nguyen + + * autoconf.texi (Autofrisk, Using Autofrisk): New sections. + (Autoconf Support): Add new sections to menu. + 2002-02-04 Marius Vollmer * scheme-data.texi (Symbol Uninterned): Added node. From 877accb11a14f88d5bda60629aa40ae4283ce01a Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 4 Feb 2002 21:13:46 +0000 Subject: [PATCH 23/39] * Further Elisp translator work. --- lang/elisp/ChangeLog | 21 ++++++ lang/elisp/internals/Makefile.am | 1 + lang/elisp/internals/fset.scm | 6 +- lang/elisp/internals/lambda.scm | 108 ++++++++++++++++++++++++++++++ lang/elisp/primitives/syntax.scm | 110 ++----------------------------- lang/elisp/transform.scm | 4 +- 6 files changed, 140 insertions(+), 110 deletions(-) create mode 100644 lang/elisp/internals/lambda.scm diff --git a/lang/elisp/ChangeLog b/lang/elisp/ChangeLog index 461436daf..d20d6e355 100644 --- a/lang/elisp/ChangeLog +++ b/lang/elisp/ChangeLog @@ -1,3 +1,24 @@ +2002-02-04 Neil Jerram + + * primitives/syntax.scm (parse-formals, transform-lambda, + interactive-spec, set-not-subr!, transform-lambda/interactive): + Move into internals/lambda.scm so that these can also be used + by... + + * internals/fset.scm (elisp-apply): Use `eval' and + `transform-lambda/interactive' to turn a quoted lambda expression + into a Scheme procedure. + + * transform.scm (m-quasiquote): Don't quote `quasiquote' in + transformed code. + (transformer): Transform '() to #nil. + +2002-02-03 Neil Jerram + + * internals/Makefile.am (elisp_sources): Add lambda.scm. + + * internals/lambda.scm (lang): New file. + 2002-02-01 Neil Jerram * transform.scm (transformer), primitives/syntax.scm (let*): diff --git a/lang/elisp/internals/Makefile.am b/lang/elisp/internals/Makefile.am index 49226038b..c66edb491 100644 --- a/lang/elisp/internals/Makefile.am +++ b/lang/elisp/internals/Makefile.am @@ -27,6 +27,7 @@ elisp_sources = \ evaluation.scm \ format.scm \ fset.scm \ + lambda.scm \ load.scm \ null.scm \ set.scm \ diff --git a/lang/elisp/internals/fset.scm b/lang/elisp/internals/fset.scm index 885c9e897..249db7c91 100644 --- a/lang/elisp/internals/fset.scm +++ b/lang/elisp/internals/fset.scm @@ -1,6 +1,7 @@ (define-module (lang elisp internals fset) - #:use-module (lang elisp internals signal) #:use-module (lang elisp internals evaluation) + #:use-module (lang elisp internals lambda) + #:use-module (lang elisp internals signal) #:export (fset fref fref/error-if-void @@ -105,7 +106,8 @@ function) ((and (pair? function) (eq? (car function) 'lambda)) - (eval function the-elisp-module)) + (eval (transform-lambda/interactive function ') + the-root-module)) (else (signal 'invalid-function (list function)))) args)) diff --git a/lang/elisp/internals/lambda.scm b/lang/elisp/internals/lambda.scm new file mode 100644 index 000000000..96b21f650 --- /dev/null +++ b/lang/elisp/internals/lambda.scm @@ -0,0 +1,108 @@ +(define-module (lang elisp internals lambda) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp transform) + #:export (parse-formals + transform-lambda/interactive + interactive-spec)) + +;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and +;;; returns three values: (i) list of symbols for required arguments, +;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or +;;; #f if there is no rest argument. +(define (parse-formals formals) + (letrec ((do-required + (lambda (required formals) + (if (null? formals) + (values (reverse required) '() #f) + (let ((next-sym (car formals))) + (cond ((not (symbol? next-sym)) + (error "Bad formals (non-symbol in required list)")) + ((eq? next-sym '&optional) + (do-optional required '() (cdr formals))) + ((eq? next-sym '&rest) + (do-rest required '() (cdr formals))) + (else + (do-required (cons next-sym required) + (cdr formals)))))))) + (do-optional + (lambda (required optional formals) + (if (null? formals) + (values (reverse required) (reverse optional) #f) + (let ((next-sym (car formals))) + (cond ((not (symbol? next-sym)) + (error "Bad formals (non-symbol in optional list)")) + ((eq? next-sym '&rest) + (do-rest required optional (cdr formals))) + (else + (do-optional required + (cons next-sym optional) + (cdr formals)))))))) + (do-rest + (lambda (required optional formals) + (if (= (length formals) 1) + (let ((next-sym (car formals))) + (if (symbol? next-sym) + (values (reverse required) (reverse optional) next-sym) + (error "Bad formals (non-symbol rest formal)"))) + (error "Bad formals (more than one rest formal)"))))) + + (do-required '() (cond ((list? formals) + formals) + ((symbol? formals) + (list '&rest formals)) + (else + (error "Bad formals (not a list or a single symbol)")))))) + +(define (transform-lambda exp) + (call-with-values (lambda () (parse-formals (cadr exp))) + (lambda (required optional rest) + (let ((num-required (length required)) + (num-optional (length optional))) + `(,lambda %--args + (,let ((%--num-args (,length %--args))) + (,cond ((,< %--num-args ,num-required) + (,error "Wrong number of args (not enough required args)")) + ,@(if rest + '() + `(((,> %--num-args ,(+ num-required num-optional)) + (,error "Wrong number of args (too many args)")))) + (else + (@bind ,(append (map (lambda (i) + (list (list-ref required i) + `(,list-ref %--args ,i))) + (iota num-required)) + (map (lambda (i) + (let ((i+nr (+ i num-required))) + (list (list-ref optional i) + `(,if (,> %--num-args ,i+nr) + (,list-ref %--args ,i+nr) + #f)))) + (iota num-optional)) + (if rest + (list (list rest + `(,if (,> %--num-args + ,(+ num-required + num-optional)) + (,list-tail %--args + ,(+ num-required + num-optional)) + '()))) + '())) + ,@(map transformer (cddr exp))))))))))) + +(define (set-not-subr! proc boolean) + (set! (not-subr? proc) boolean)) + +(define (transform-lambda/interactive exp name) + (fluid-set! interactive-spec #f) + (let* ((x (transform-lambda exp)) + (is (fluid-ref interactive-spec))) + `(,let ((%--lambda ,x)) + (,set-procedure-property! %--lambda (,quote name) (,quote ,name)) + (,set-not-subr! %--lambda #t) + ,@(if is + `((,set! (,interactive-spec %--lambda) (,quote ,is))) + '()) + %--lambda))) + +(define interactive-spec (make-fluid)) diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm index 3bf5a903a..7f7e4af21 100644 --- a/lang/elisp/primitives/syntax.scm +++ b/lang/elisp/primitives/syntax.scm @@ -1,13 +1,13 @@ (define-module (lang elisp primitives syntax) #:use-module (lang elisp internals evaluation) #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals lambda) #:use-module (lang elisp internals trace) #:use-module (lang elisp transform)) -;;; Define Emacs Lisp special forms as macros. This is much more -;;; flexible than handling them specially in the translator: allows -;;; them to be redefined, and hopefully allows better source location -;;; tracking. +;;; Define Emacs Lisp special forms as macros. This is more flexible +;;; than handling them specially in the translator: allows them to be +;;; redefined, and hopefully allows better source location tracking. ;;; {Variables} @@ -44,108 +44,6 @@ ;;; {lambda, function and macro definitions} -;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and -;;; returns three values: (i) list of symbols for required arguments, -;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or -;;; #f if there is no rest argument. -(define (parse-formals formals) - (letrec ((do-required - (lambda (required formals) - (if (null? formals) - (values (reverse required) '() #f) - (let ((next-sym (car formals))) - (cond ((not (symbol? next-sym)) - (error "Bad formals (non-symbol in required list)")) - ((eq? next-sym '&optional) - (do-optional required '() (cdr formals))) - ((eq? next-sym '&rest) - (do-rest required '() (cdr formals))) - (else - (do-required (cons next-sym required) - (cdr formals)))))))) - (do-optional - (lambda (required optional formals) - (if (null? formals) - (values (reverse required) (reverse optional) #f) - (let ((next-sym (car formals))) - (cond ((not (symbol? next-sym)) - (error "Bad formals (non-symbol in optional list)")) - ((eq? next-sym '&rest) - (do-rest required optional (cdr formals))) - (else - (do-optional required - (cons next-sym optional) - (cdr formals)))))))) - (do-rest - (lambda (required optional formals) - (if (= (length formals) 1) - (let ((next-sym (car formals))) - (if (symbol? next-sym) - (values (reverse required) (reverse optional) next-sym) - (error "Bad formals (non-symbol rest formal)"))) - (error "Bad formals (more than one rest formal)"))))) - - (do-required '() (cond ((list? formals) - formals) - ((symbol? formals) - (list '&rest formals)) - (else - (error "Bad formals (not a list or a single symbol)")))))) - -(define (transform-lambda exp) - (call-with-values (lambda () (parse-formals (cadr exp))) - (lambda (required optional rest) - (let ((num-required (length required)) - (num-optional (length optional))) - `(,lambda %--args - (,let ((%--num-args (,length %--args))) - (,cond ((,< %--num-args ,num-required) - (,error "Wrong number of args (not enough required args)")) - ,@(if rest - '() - `(((,> %--num-args ,(+ num-required num-optional)) - (,error "Wrong number of args (too many args)")))) - (else - (@bind ,(append (map (lambda (i) - (list (list-ref required i) - `(,list-ref %--args ,i))) - (iota num-required)) - (map (lambda (i) - (let ((i+nr (+ i num-required))) - (list (list-ref optional i) - `(,if (,> %--num-args ,i+nr) - (,list-ref %--args ,i+nr) - #f)))) - (iota num-optional)) - (if rest - (list (list rest - `(,if (,> %--num-args - ,(+ num-required - num-optional)) - (,list-tail %--args - ,(+ num-required - num-optional)) - '()))) - '())) - ,@(map transformer (cddr exp))))))))))) - -(define interactive-spec (make-fluid)) - -(define (set-not-subr! proc boolean) - (set! (not-subr? proc) boolean)) - -(define (transform-lambda/interactive exp name) - (fluid-set! interactive-spec #f) - (let* ((x (transform-lambda exp)) - (is (fluid-ref interactive-spec))) - `(,let ((%--lambda ,x)) - (,set-procedure-property! %--lambda (,quote name) (,quote ,name)) - (,set-not-subr! %--lambda #t) - ,@(if is - `((,set! (,interactive-spec %--lambda) (,quote ,is))) - '()) - %--lambda))) - (fset 'lambda (procedure->memoizing-macro (lambda (exp env) diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm index 0bb28ea37..0221dcc8a 100644 --- a/lang/elisp/transform.scm +++ b/lang/elisp/transform.scm @@ -16,7 +16,7 @@ (define (transformer x) (cond ((eq? x 'nil) %nil) ((eq? x 't) #t) - ((null? x) '()) + ((null? x) %nil) ((not (pair? x)) x) ((and (pair? (car x)) (eq? (caar x) 'quasiquote)) @@ -51,7 +51,7 @@ (else (syntax-error x)))) (define (m-quasiquote exp env) - (cons 'quasiquote + (cons quasiquote (map transform-inside-qq (cdr exp)))) (define (transform-inside-qq x) From 610922b2e20b49ae282c7099d5e14557dc64c8fa Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Feb 2002 22:00:42 +0000 Subject: [PATCH 24/39] Added blurb about uninterned symbols. --- NEWS | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/NEWS b/NEWS index 69e639cb3..05904d621 100644 --- a/NEWS +++ b/NEWS @@ -20,6 +20,15 @@ debugging evaluator gives better error messages. * Changes to Scheme functions and syntax +** We now have uninterned symbols. + +The new function 'make-symbol' will return a uninterned symbol. This +is a symbol that is unique and is guaranteed to remain unique. +However, uninterned symbols can not yet be read back in. + +Use the new function 'symbol-interned?' to check whether a symbol is +interned or not. + ** pretty-print has more options. The function pretty-print from the (ice-9 pretty-print) module can now From 9c8d9ff91951626dd38c2e3c356610fafd172242 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:13:00 +0000 Subject: [PATCH 25/39] *** empty log message *** --- devel/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/devel/ChangeLog b/devel/ChangeLog index b60980387..70ffefe55 100644 --- a/devel/ChangeLog +++ b/devel/ChangeLog @@ -1,3 +1,7 @@ +2002-02-05 Thien-Thi Nguyen + + * build/pre-inst-guile.text: Initial revision. + 2001-12-04 Gary Houston * some discussion in extension/dynamic-root.text. From 3ac1e90a7c392d6c7c29b33d5fd45a635a969e90 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:14:26 +0000 Subject: [PATCH 26/39] Initial revision --- devel/build/pre-inst-guile.text | 47 ++++++++++++++++++ pre-inst-guile | 84 +++++++++++++++++++++++++++++++++ pre-inst-guile.am | 0 3 files changed, 131 insertions(+) create mode 100644 devel/build/pre-inst-guile.text create mode 100755 pre-inst-guile create mode 100644 pre-inst-guile.am diff --git a/devel/build/pre-inst-guile.text b/devel/build/pre-inst-guile.text new file mode 100644 index 000000000..5e9a24b37 --- /dev/null +++ b/devel/build/pre-inst-guile.text @@ -0,0 +1,47 @@ +THEORY + + The pre-installed guile interpreter can be used if has access to + the proper shared libraries and scheme modules, which can be + arranged by tweaking GUILE_LOAD_PATH and LTDL_LIBRARY_PATH env + vars, respectively. + + +GENERAL PRACTICE + + To invoke the guile interpreter before installing it (and its + support files), call ${top_srcdir}/pre-inst-guile w/ first arg + ${top_builddir}, where you would normally call guile. + + Similarly, for scripts/* (normally found by guile-tools), set + env var GUILE to the above combination. + + See commentary in ${top_srcdir}/pre-inst-guile for more info. + + +SPECIFIC PRACTICE + + Include the following line in any Makefile.am with rules that + need to call the pre-installed guile interpreter: + + include $(top_srcdir)/pre-inst-guile.am + + This causes Automake to include a makefile fragment that defines + two vars: `preinstguile' and `preinstguiletool'. The following + examples show how these vars are used: + + display-sum5: + $(preinstguile) -c '(display (+ 1 2 3 4 5))' + + display-deps-dotty: + $(preinstguiletool)/use2dot *.scm + + Note the particular syntax of `preinstguiletool' usage. + + +KNOWN USAGE + + check-guile.in + doc/ref/Makefile.am + libguile/Makefile.am + ice-9/Makefile.am + scripts/Makefile.am diff --git a/pre-inst-guile b/pre-inst-guile new file mode 100755 index 000000000..6f684e5bb --- /dev/null +++ b/pre-inst-guile @@ -0,0 +1,84 @@ +#!/bin/sh + +# Copyright (C) 2002 Free Software Foundation +# +# 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 + +# Commentary: + +# Usage: pre-inst-guile TOP-BUILDDIR [ARGS] +# +# This script arranges for the environment to support, and eventaully execs, +# the uninstalled binary guile executable located somewhere under libguile/, +# passing ARGS to it. In the process, env var GUILE is clobbered, and the +# following env vars are modified (but not clobbered): +# GUILE_LOAD_PATH +# LTDL_LOAD_PATH +# +# WARNING: This script is *NOT* a "drop in" replacement for $bindir/guile; +# it is intended only for use in building/testing. + +# Code: + +subdirs_with_ltlibs="srfi guile-readline" # maintain me + +# determine absolute top_srcdir +[ x"$top_srcdir" = x ] && case $0 in */*) top_srcdir=`dirname $0` ;; esac +if [ x"$top_srcdir" = x ] ; then + echo $0: could not determine top_srcdir + exit 1 +fi +top_srcdir=`(cd $top_srcdir ; pwd)` + +# determine absolute top_builddir +if [ x"$1" = x ] ; then + echo $0: could not determine top_builddir + exit 1 +fi +top_builddir=`(cd $1 ; pwd)` +shift + +# handle GUILE_LOAD_PATH (no clobber) +if [ x"$GUILE_LOAD_PATH" = x ] ; then + GUILE_LOAD_PATH="${top_srcdir}" +else + case "$GUILE_LOAD_PATH" in *${top_srcdir}*) ;; + *) GUILE_LOAD_PATH="${top_srcdir}:$GUILE_LOAD_PATH" ;; + esac +fi +export GUILE_LOAD_PATH + +# handle LTDL_LIBRARY_PATH (no clobber) +ltdl_prefix="" +for dir in $subdirs_with_ltlibs ; do + ltdl_prefix="${top_builddir}/${dir}:${ltdl_prefix}" +done +LTDL_LIBRARY_PATH="${ltdl_prefix}$LTDL_LIBRARY_PATH" +export LTDL_LIBRARY_PATH + +# set GUILE (clobber) +GUILE=${top_builddir}/libguile/guile +export GUILE + +# do it +exec $GUILE "$@" + +# never reached +exit 1 + +# pre-inst-guile ends here diff --git a/pre-inst-guile.am b/pre-inst-guile.am new file mode 100644 index 000000000..e69de29bb From ba833f4a2fdd81311b6a31398c59cf23b5f22e4d Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:21:54 +0000 Subject: [PATCH 27/39] (srcdir): Delete var. (top_builddir, top_srcdir, guile_opts): New vars. Use "set -e". No longer set LTDL_LIBRARY_PATH. Use ${top_srcdir}/pre-inst-guile instead of libguile/guile. --- check-guile.in | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/check-guile.in b/check-guile.in index ebfe89cb2..ed571becb 100644 --- a/check-guile.in +++ b/check-guile.in @@ -1,6 +1,6 @@ #! /bin/sh # Usage: check-guile [-i GUILE-INTERPRETER] [GUILE-TEST-ARGS] -# If `-i GUILE-INTERPRETER' is omitted, use libguile/guile. +# If `-i GUILE-INTERPRETER' is omitted, use ${top_srcdir}/pre-inst-guile. # See test-suite/guile-test for documentation on GUILE-TEST-ARGS. # # Example invocations: @@ -9,27 +9,31 @@ # ./check-guile -i /usr/local/bin/guile # ./check-guile -i /usr/local/bin/guile numbers.test +set -e + # this script runs in the top-level build-dir. -srcdir=@srcdir@ -TEST_SUITE_DIR=$srcdir/test-suite +top_builddir=@srcdir@ + +top_srcdir=@top_srcdir@ + +TEST_SUITE_DIR=$top_builddir/test-suite if [ x"$1" = x-i ] ; then guile=$2 + guile_opts= shift shift GUILE_LOAD_PATH=$TEST_SUITE_DIR else - guile=libguile/guile - GUILE_LOAD_PATH=$srcdir:$TEST_SUITE_DIR - LTDL_LIBRARY_PATH=`pwd`/srfi:${LTDL_LIBRARY_PATH} + guile=${top_srcdir}/pre-inst-guile + guile_opts="${top_builddir}" + GUILE_LOAD_PATH=${top_builddir}:$TEST_SUITE_DIR fi export GUILE_LOAD_PATH -export LTDL_LIBRARY_PATH if [ -f "$guile" -a -x "$guile" ] ; then echo Testing $guile ... "$@" echo with GUILE_LOAD_PATH=$GUILE_LOAD_PATH - echo with LTDL_LIBRARY_PATH=$LTDL_LIBRARY_PATH else echo ERROR: Cannot execute $guile exit 1 @@ -40,6 +44,9 @@ if [ ! -f guile-procedures.txt ] ; then @LN_S@ libguile/guile-procedures.txt . fi -exec "$guile" -e main -s "$TEST_SUITE_DIR/guile-test" --test-suite "$TEST_SUITE_DIR/tests" --log-file check-guile.log "$@" +exec $guile $guile_opts \ + -e main -s "$TEST_SUITE_DIR/guile-test" \ + --test-suite "$TEST_SUITE_DIR/tests" \ + --log-file check-guile.log "$@" # check-guile ends here From 9d32aac72a07754c296c0662033629b7fdffdfe0 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:25:56 +0000 Subject: [PATCH 28/39] Include $(top_srcdir)/pre-inst-guile.am. (GUILE): Delete var. (autoconf-macros.texi): Use $(preinstguiletool). --- doc/ref/Makefile.am | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 1f42fcc80..d9da61d85 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -37,14 +37,13 @@ guile_TEXINFOS = preface.texi intro.texi program.texi scheme-intro.texi \ ETAGS_ARGS = $(info_TEXINFOS) $(guile_TEXINFOS) -GUILE = $(top_builddir)/libguile/guile +include $(top_srcdir)/pre-inst-guile.am # Automated snarfing autoconf.texi: autoconf-macros.texi autoconf-macros.texi: $(top_srcdir)/guile-config/guile.m4 - GUILE=$(GUILE) GUILE_LOAD_PATH=$(top_srcdir) \ - $(top_srcdir)/scripts/snarf-guile-m4-docs $< > $(srcdir)/$@ + $(preinstguiletool)/snarf-guile-m4-docs $< > $(srcdir)/$@ # Optionally support building an HTML version of the reference manual. From 5e9d88a400263af2e6622957e58c8dad587aaece Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:27:12 +0000 Subject: [PATCH 29/39] *** empty log message *** --- doc/ref/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 0d50fade9..4c9a21bd9 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,10 @@ +2002-02-05 Thien-Thi Nguyen + + * Makefile.am: Include $(top_srcdir)/pre-inst-guile.am. + + (GUILE): Delete var. + (autoconf-macros.texi): Use $(preinstguiletool). + 2002-02-04 Thien-Thi Nguyen * autoconf.texi (Autofrisk, Using Autofrisk): New sections. From f8241358de5cac4ae582878ace0a2cc85299f88d Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:29:53 +0000 Subject: [PATCH 30/39] Include $(top_srcdir)/pre-inst-guile.am. (bin_SCRIPTS): Remove guile-snarf-docs-texi. (alldotdocfiles, snarf2checkedtexi, dotdoc2texi): New vars. (guile.texi, guile-procedures.texi): Use $(dotdoc2texi). --- libguile/Makefile.am | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index c11ef267e..e0d1dfbd4 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -149,7 +149,7 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ modinclude_DATA = scmconfig.h bin_SCRIPTS = guile-snarf guile-doc-snarf guile-snarf-docs \ - guile-snarf-docs-texi guile-func-name-check + guile-func-name-check EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \ ChangeLog-1996-1999 ChangeLog-2000 cpp_signal.c \ @@ -213,13 +213,17 @@ error.x: cpp_err_symbols.c posix.x: cpp_sig_symbols.c load.x: libpath.h -guile.texi: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) guile-snarf-docs-texi.in guile - cat $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) | ./guile-snarf-docs-texi --manual > $@ \ - || { rm $@; false; } +include $(top_srcdir)/pre-inst-guile.am -guile-procedures.texi: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) guile-snarf-docs-texi.in guile - cat $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) | ./guile-snarf-docs-texi > $@ \ - || { rm $@; false; } +alldotdocfiles = $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) +snarf2checkedtexi = $(preinstguiletool)/snarf-check-and-output-texi +dotdoc2texi = cat $(alldotdocfiles) | $(snarf2checkedtexi) + +guile.texi: $(alldotdocfiles) guile + $(dotdoc2texi) --manual > $@ || { rm $@; false; } + +guile-procedures.texi: $(alldotdocfiles) guile + $(dotdoc2texi) > $@ || { rm $@; false; } if HAVE_MAKEINFO From d6c33794d55de6c79df09c34e812eeabde7d7159 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:32:26 +0000 Subject: [PATCH 31/39] bye bye --- libguile/guile-snarf-docs-texi.in | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100755 libguile/guile-snarf-docs-texi.in diff --git a/libguile/guile-snarf-docs-texi.in b/libguile/guile-snarf-docs-texi.in deleted file mode 100755 index e69de29bb..000000000 From dce05f4a4b2e4394cdd2671ee4e9461901b2b244 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:35:42 +0000 Subject: [PATCH 32/39] (libguile/guile-snarf-docs-texi): Remove from `AC_CONFIG_FILES' and `AC_CONFIG_COMMANDS'. --- configure.in | 2 -- 1 file changed, 2 deletions(-) diff --git a/configure.in b/configure.in index 2e0e2c0e5..ca9971ffb 100644 --- a/configure.in +++ b/configure.in @@ -674,7 +674,6 @@ AC_CONFIG_FILES([ libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf-docs - libguile/guile-snarf-docs-texi libguile/version.h ice-9/Makefile lang/Makefile @@ -712,7 +711,6 @@ AC_CONFIG_COMMANDS(default, libguile/guile-doc-snarf \ libguile/guile-func-name-check \ libguile/guile-snarf-docs \ - libguile/guile-snarf-docs-texi \ check-guile \ guile-tools]) From 9f03ac3db23914c5e93c3b3f00bf765770823258 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:38:23 +0000 Subject: [PATCH 33/39] Include $(top_srcdir)/pre-inst-guile.am. (psyntax.pp): Use $(preinstguile). --- ice-9/Makefile.am | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 4034be602..2c36a76ac 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -3,17 +3,17 @@ ## Copyright (C) 1998, 1999, 2000, 2001 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 @@ -42,6 +42,13 @@ ETAGS_ARGS = $(subpkgdata_DATA) EXTRA_DIST = $(ice9_sources) test.scm compile-psyntax.scm if MAINTAINER_MODE +# We expect this to never be invoked when there is not already +# ice-9/psyntax.pp in %load-path, since compile-psyntax.scm depends +# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax.pp")'. +# In other words, to bootstrap this file, you need to do something like: +# GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax.pp +include $(top_srcdir)/pre-inst-guile.am psyntax.pp: psyntax.ss - GUILE_LOAD_PATH=$(srcdir)/..:.. ../libguile/guile -s $(srcdir)/compile-psyntax.scm $(srcdir)/psyntax.ss $(srcdir)/psyntax.pp + $(preinstguile) -s $(srcdir)/compile-psyntax.scm \ + $(srcdir)/psyntax.ss $(srcdir)/psyntax.pp endif From 0f73b20f51ab4e9e8e0b088ba29c68b1fce27ddf Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:40:56 +0000 Subject: [PATCH 34/39] Include $(top_srcdir)/pre-inst-guile.am. (overview): Use $(preinstguiletool). --- scripts/Makefile.am | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/scripts/Makefile.am b/scripts/Makefile.am index 3e21a0a7a..270120800 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -42,7 +42,9 @@ EXTRA_DIST = $(scripts_sources) list: @echo $(scripts_sources) -overview: +include $(top_srcdir)/pre-inst-guile.am + +overview: $(scripts_sources) @echo '----------------------------' @echo Overview @echo I. Commentaries @@ -50,10 +52,10 @@ overview: @echo '----------------------------' @echo I. Commentaries @echo '----------------------------' - @GUILE_LOAD_PATH=`(cd $(srcdir)/.. ; pwd)` \ - $(srcdir)/display-commentary $(scripts_sources) + $(preinstguiletool)/display-commentary $^ @echo '----------------------------' @echo II. Module Interfaces @echo '----------------------------' - @GUILE_LOAD_PATH=`(cd $(srcdir)/.. ; pwd)` \ - $(srcdir)/frisk $(scripts_sources) + $(preinstguiletool)/frisk $^ + +# Makefile.am ends here From 0187b4f4171ee98042278fc5734bedb20ed2d13e Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:42:16 +0000 Subject: [PATCH 35/39] *** empty log message *** --- ChangeLog | 18 ++++++++++++++++-- ice-9/ChangeLog | 8 +++++++- libguile/ChangeLog | 13 ++++++++++++- scripts/ChangeLog | 6 ++++++ 4 files changed, 41 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index dfac20bd8..0b1c124f8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,17 @@ +2002-02-05 Thien-Thi Nguyen + + * pre-inst-guile.am, pre-inst-guile: New files. + + * check-guile.in (srcdir): Delete var. + (top_builddir, top_srcdir, guile_opts): New vars. + + Use "set -e". + No longer set LTDL_LIBRARY_PATH. + Use ${top_srcdir}/pre-inst-guile instead of libguile/guile. + + * configure.in (libguile/guile-snarf-docs-texi): Remove + from `AC_CONFIG_FILES' and `AC_CONFIG_COMMANDS'. + 2002-01-31 Stefan Jahn * configure.in: Add -DLIBLTDL_DLL_IMPORT to INCLTDL when using @@ -5,7 +19,7 @@ 2002-01-28 Stefan Jahn - * configure.in (guile_cv_have_uint32_t): Look also in + * configure.in (guile_cv_have_uint32_t): Look also in `stdint.h' for uint32_t. 2002-01-13 Neil Jerram @@ -31,7 +45,7 @@ * configure.in (HAVE_MAKEINFO): Check for the makeinfo program and set this conditional accordingly. - + 2001-12-01 Thien-Thi Nguyen * README: Fix virulent typo. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 016ee6e56..542d0aa67 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2002-02-05 Thien-Thi Nguyen + + * Makefile.am: Include $(top_srcdir)/pre-inst-guile.am. + + (psyntax.pp): Use $(preinstguile). + 2002-01-14 Marius Vollmer * psyntax.ss (datum->syntax-object): Removed assertion in @@ -8,7 +14,7 @@ 2002-01-12 Marius Vollmer More options for pretty-print. Thanks to Matthias Köppe! - + * pretty-print.scm (generic-write): New per-line-prefix argument. (pretty-print): Check whether the new keyword argument style is used and dispatch to pretty-print-with-keys accordingly. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1fc2f2169..a0680ab60 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2002-02-05 Thien-Thi Nguyen + + * Makefile.am: Include $(top_srcdir)/pre-inst-guile.am. + + (bin_SCRIPTS): Remove guile-snarf-docs-texi. + (alldotdocfiles, snarf2checkedtexi, dotdoc2texi): New vars. + (guile.texi, guile-procedures.texi): Use $(dotdoc2texi). + + * guile-snarf-docs-texi.in: Bye bye. + 2002-02-04 Marius Vollmer * symbols.c (scm_make_symbol): Fix typo in docstring. @@ -15,13 +25,14 @@ This signals a interned symbol. (scm_mem2uninterned_symbol, scm_symbol_interned_p, scm_make_symbol): New. - + * print.c (scm_iprin1): Print uninterned symbols unreadably. 2002-02-02 Thien-Thi Nguyen * __scm.h (HAVE_UINTPTR_T): Only define if UINTPTR_T attributes are defined: UINTPTR_MAX, INTPTR_MAX, INTPTR_MIN. + Thanks to Dave Love. 2002-01-31 Marius Vollmer diff --git a/scripts/ChangeLog b/scripts/ChangeLog index c936eaefd..f11df41c2 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,9 @@ +2002-02-05 Thien-Thi Nguyen + + * Include $(top_srcdir)/pre-inst-guile.am. + + (overview): Use $(preinstguiletool). + 2002-01-11 Thien-Thi Nguyen * Makefile.am (scripts_sources): Add autofrisk. From e15fa93d74c659e8b0aacfe4151f51a2863dbfd7 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 10:09:39 +0000 Subject: [PATCH 36/39] (top_builddir): Fix bug: Use cwd. --- check-guile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/check-guile.in b/check-guile.in index ed571becb..8c350f258 100644 --- a/check-guile.in +++ b/check-guile.in @@ -12,7 +12,7 @@ set -e # this script runs in the top-level build-dir. -top_builddir=@srcdir@ +top_builddir=`pwd` top_srcdir=@top_srcdir@ From 77bf05e08bd9a3614277d109874c5567bbd3a162 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 10:10:49 +0000 Subject: [PATCH 37/39] *** empty log message *** --- ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog b/ChangeLog index 0b1c124f8..a3e00ee53 100644 --- a/ChangeLog +++ b/ChangeLog @@ -12,6 +12,8 @@ * configure.in (libguile/guile-snarf-docs-texi): Remove from `AC_CONFIG_FILES' and `AC_CONFIG_COMMANDS'. + * check-guile.in (top_builddir): Fix bug: Use cwd. + 2002-01-31 Stefan Jahn * configure.in: Add -DLIBLTDL_DLL_IMPORT to INCLTDL when using From ec5e172228605bdcc96b1edc48859be6135ea0ef Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 10:30:04 +0000 Subject: [PATCH 38/39] Fix bug: Use ":" in `case' pattern to prevent prefix aliasing. --- pre-inst-guile | 84 -------------------------------------------------- 1 file changed, 84 deletions(-) diff --git a/pre-inst-guile b/pre-inst-guile index 6f684e5bb..e69de29bb 100755 --- a/pre-inst-guile +++ b/pre-inst-guile @@ -1,84 +0,0 @@ -#!/bin/sh - -# Copyright (C) 2002 Free Software Foundation -# -# 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 - -# Commentary: - -# Usage: pre-inst-guile TOP-BUILDDIR [ARGS] -# -# This script arranges for the environment to support, and eventaully execs, -# the uninstalled binary guile executable located somewhere under libguile/, -# passing ARGS to it. In the process, env var GUILE is clobbered, and the -# following env vars are modified (but not clobbered): -# GUILE_LOAD_PATH -# LTDL_LOAD_PATH -# -# WARNING: This script is *NOT* a "drop in" replacement for $bindir/guile; -# it is intended only for use in building/testing. - -# Code: - -subdirs_with_ltlibs="srfi guile-readline" # maintain me - -# determine absolute top_srcdir -[ x"$top_srcdir" = x ] && case $0 in */*) top_srcdir=`dirname $0` ;; esac -if [ x"$top_srcdir" = x ] ; then - echo $0: could not determine top_srcdir - exit 1 -fi -top_srcdir=`(cd $top_srcdir ; pwd)` - -# determine absolute top_builddir -if [ x"$1" = x ] ; then - echo $0: could not determine top_builddir - exit 1 -fi -top_builddir=`(cd $1 ; pwd)` -shift - -# handle GUILE_LOAD_PATH (no clobber) -if [ x"$GUILE_LOAD_PATH" = x ] ; then - GUILE_LOAD_PATH="${top_srcdir}" -else - case "$GUILE_LOAD_PATH" in *${top_srcdir}*) ;; - *) GUILE_LOAD_PATH="${top_srcdir}:$GUILE_LOAD_PATH" ;; - esac -fi -export GUILE_LOAD_PATH - -# handle LTDL_LIBRARY_PATH (no clobber) -ltdl_prefix="" -for dir in $subdirs_with_ltlibs ; do - ltdl_prefix="${top_builddir}/${dir}:${ltdl_prefix}" -done -LTDL_LIBRARY_PATH="${ltdl_prefix}$LTDL_LIBRARY_PATH" -export LTDL_LIBRARY_PATH - -# set GUILE (clobber) -GUILE=${top_builddir}/libguile/guile -export GUILE - -# do it -exec $GUILE "$@" - -# never reached -exit 1 - -# pre-inst-guile ends here From ae84ee626edbe55f28a253bc39a4270361a64d92 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 10:32:35 +0000 Subject: [PATCH 39/39] (TEST_SUITE_DIR): Fix bug: Use `top_srcdir'. (GUILE_LOAD_PATH): No longer include $top_srcdir. --- check-guile.in | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/check-guile.in b/check-guile.in index 8c350f258..547a93753 100644 --- a/check-guile.in +++ b/check-guile.in @@ -13,22 +13,21 @@ set -e # this script runs in the top-level build-dir. top_builddir=`pwd` - top_srcdir=@top_srcdir@ -TEST_SUITE_DIR=$top_builddir/test-suite +TEST_SUITE_DIR=${top_srcdir}/test-suite if [ x"$1" = x-i ] ; then guile=$2 guile_opts= shift shift - GUILE_LOAD_PATH=$TEST_SUITE_DIR else guile=${top_srcdir}/pre-inst-guile guile_opts="${top_builddir}" - GUILE_LOAD_PATH=${top_builddir}:$TEST_SUITE_DIR fi + +GUILE_LOAD_PATH=$TEST_SUITE_DIR export GUILE_LOAD_PATH if [ -f "$guile" -a -x "$guile" ] ; then