summaryrefslogtreecommitdiff
path: root/srfi
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>2002-12-01 13:10:51 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>2002-12-01 13:10:51 +0000
commitee6aac97334d5eb24ccdfbcfd1a49f9e28492e73 (patch)
treefb5fea8db27cca04baca276f35e603f3d935b678 /srfi
parentcfc7c7c03fcf259a72db0489890a18297d9ca163 (diff)
downloadguile-ee6aac97334d5eb24ccdfbcfd1a49f9e28492e73.tar.gz
* srfi-1.scm: Load srfi-1 extension.
(map, map-in-order, for-each, member): Replaced by primitives in srfi-1.c. * Makefile.am: Added rules for srfi-1.c. * srfi-1.c, srfi-1.h: New files.
Diffstat (limited to 'srfi')
-rw-r--r--srfi/ChangeLog10
-rw-r--r--srfi/Makefile.am13
-rw-r--r--srfi/srfi-1.c324
-rw-r--r--srfi/srfi-1.h67
-rw-r--r--srfi/srfi-1.scm49
5 files changed, 416 insertions, 47 deletions
diff --git a/srfi/ChangeLog b/srfi/ChangeLog
index ae124be8d..ad303dc6b 100644
--- a/srfi/ChangeLog
+++ b/srfi/ChangeLog
@@ -1,3 +1,13 @@
+2002-12-01 Mikael Djurfeldt <mdj@linnaeus>
+
+ * srfi-1.scm: Load srfi-1 extension.
+ (map, map-in-order, for-each, member): Replaced by primitives in
+ srfi-1.c.
+
+ * Makefile.am: Added rules for srfi-1.c.
+
+ * srfi-1.c, srfi-1.h: New files.
+
2002-05-06 Marius Vollmer <mvo@zagadka.ping.de>
* srfi-13.c (scm_string_tokenize): Instead of using "isgraphic" as
diff --git a/srfi/Makefile.am b/srfi/Makefile.am
index 5ec635701..6758bb916 100644
--- a/srfi/Makefile.am
+++ b/srfi/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 2001 Free Software Foundation, Inc.
+## Copyright (C) 2001, 2002 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -33,9 +33,16 @@ srfiincludedir = $(pkgincludedir)/srfi
# These headers are visible as <guile/srfi/mumble.h>
srfiinclude_HEADERS = srfi-4.h srfi-13.h srfi-14.h
-lib_LTLIBRARIES = libguile-srfi-srfi-13-14.la libguile-srfi-srfi-4.la
+lib_LTLIBRARIES = libguile-srfi-srfi-1.la \
+ libguile-srfi-srfi-4.la \
+ libguile-srfi-srfi-13-14.la
-BUILT_SOURCES = srfi-13.x srfi-14.x srfi-4.x
+BUILT_SOURCES = srfi-1.x srfi-4.x srfi-13.x srfi-14.x
+
+libguile_srfi_srfi_1_la_SOURCES = srfi-1.x srfi-1.c
+libguile_srfi_srfi_1_la_LIBADD = ../libguile/libguile.la
+libguile_srfi_srfi_1_la_LDFLAGS = -export-dynamic \
+ -version-info @LIBGUILE_SRFI_SRFI_1_INTERFACE@
libguile_srfi_srfi_4_la_SOURCES = srfi-4.x srfi-4.c
libguile_srfi_srfi_4_la_LIBADD = ../libguile/libguile.la
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
new file mode 100644
index 000000000..8783e8384
--- /dev/null
+++ b/srfi/srfi-1.c
@@ -0,0 +1,324 @@
+/* srfi-1.c --- SRFI-1 procedures for Guile
+ *
+ * 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.h>
+#include <libguile/lang.h>
+
+#include "srfi-1.h"
+
+/* The intent of this file is to gradually replace those Scheme
+ * procedures in srfi-1.scm which extends core primitive procedures,
+ * so that using srfi-1 won't have performance penalties.
+ *
+ * Please feel free to contribute any new replacements!
+ */
+
+static long
+srfi1_ilength (SCM sx)
+{
+ long i = 0;
+ SCM tortoise = sx;
+ SCM hare = sx;
+
+ do {
+ if (SCM_NULL_OR_NIL_P(hare)) return i;
+ if (SCM_NCONSP(hare)) return -2;
+ hare = SCM_CDR(hare);
+ i++;
+ if (SCM_NULL_OR_NIL_P(hare)) return i;
+ if (SCM_NCONSP(hare)) return -2;
+ hare = SCM_CDR(hare);
+ i++;
+ /* For every two steps the hare takes, the tortoise takes one. */
+ tortoise = SCM_CDR(tortoise);
+ }
+ while (! SCM_EQ_P (hare, tortoise));
+
+ /* If the tortoise ever catches the hare, then the list must contain
+ a cycle. */
+ return -1;
+}
+
+/* Typechecking for multi-argument MAP and FOR-EACH.
+
+ Verify that each element of the vector ARGV, except for the first,
+ is a list and return minimum length. Attribute errors to WHO,
+ and claim that the i'th element of ARGV is WHO's i+2'th argument. */
+static inline int
+check_map_args (SCM argv,
+ long len,
+ SCM gf,
+ SCM proc,
+ SCM args,
+ const char *who)
+{
+ SCM const *ve = SCM_VELTS (argv);
+ long i;
+
+ for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
+ {
+ long elt_len;
+
+ if (!(SCM_NULLP (ve[i]) || SCM_CONSP (ve[i])))
+ {
+ check_map_error:
+ if (gf)
+ scm_apply_generic (gf, scm_cons (proc, args));
+ else
+ scm_wrong_type_arg (who, i + 2, ve[i]);
+ }
+
+ elt_len = srfi1_ilength (ve[i]);
+ if (elt_len < -1)
+ goto check_map_error;
+
+ if (len < 0 || (elt_len >= 0 && elt_len < len))
+ len = elt_len;
+ }
+ if (len < 0)
+ /* i == 0 */
+ goto check_map_error;
+
+ scm_remember_upto_here_1 (argv);
+ return len;
+}
+
+
+SCM_GPROC (s_srfi1_map, "map", 2, 0, 1, scm_srfi1_map, g_srfi1_map);
+
+/* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
+ sequentially, starting with the first element(s). This is used in
+ the Scheme procedure `map-in-order', which guarantees sequential
+ behaviour, is implemented using scm_map. If the behaviour changes,
+ we need to update `map-in-order'.
+*/
+
+SCM
+scm_srfi1_map (SCM proc, SCM arg1, SCM args)
+#define FUNC_NAME s_srfi1_map
+{
+ long i, len;
+ SCM res = SCM_EOL;
+ SCM *pres = &res;
+ SCM const *ve = &args; /* Keep args from being optimized away. */
+
+ len = srfi1_ilength (arg1);
+ SCM_GASSERTn ((SCM_NULLP (arg1) || SCM_CONSP (arg1)) && len >= -1,
+ g_srfi1_map,
+ scm_cons2 (proc, arg1, args), SCM_ARG2, s_srfi1_map);
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ if (SCM_NULLP (args))
+ {
+ scm_t_trampoline_1 call = scm_trampoline_1 (proc);
+ SCM_GASSERT2 (call, g_srfi1_map, proc, arg1, SCM_ARG1, s_srfi1_map);
+ SCM_GASSERT2 (len >= 0, g_srfi1_map, proc, arg1, SCM_ARG2, s_srfi1_map);
+ while (SCM_NIMP (arg1))
+ {
+ *pres = scm_list_1 (call (proc, SCM_CAR (arg1)));
+ pres = SCM_CDRLOC (*pres);
+ arg1 = SCM_CDR (arg1);
+ }
+ return res;
+ }
+ if (SCM_NULLP (SCM_CDR (args)))
+ {
+ SCM arg2 = SCM_CAR (args);
+ int len2 = srfi1_ilength (arg2);
+ scm_t_trampoline_2 call = scm_trampoline_2 (proc);
+ SCM_GASSERTn (call, g_srfi1_map,
+ scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_map);
+ if (len < 0 || (len2 >= 0 && len2 < len))
+ len = len2;
+ SCM_GASSERTn ((SCM_NULLP (arg2) || SCM_CONSP (arg2))
+ && len >= 0 && len2 >= -1,
+ g_srfi1_map,
+ scm_cons2 (proc, arg1, args),
+ len2 >= 0 ? SCM_ARG3 : SCM_ARG2,
+ s_srfi1_map);
+ while (len > 0)
+ {
+ *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
+ pres = SCM_CDRLOC (*pres);
+ arg1 = SCM_CDR (arg1);
+ arg2 = SCM_CDR (arg2);
+ --len;
+ }
+ return res;
+ }
+ args = scm_vector (arg1 = scm_cons (arg1, args));
+ ve = SCM_VELTS (args);
+ len = check_map_args (args, len, g_srfi1_map, proc, arg1, s_srfi1_map);
+ while (len > 0)
+ {
+ arg1 = SCM_EOL;
+ for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
+ {
+ arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
+ SCM_VECTOR_SET (args, i, SCM_CDR (ve[i]));
+ }
+ *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
+ pres = SCM_CDRLOC (*pres);
+ --len;
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+SCM_REGISTER_PROC (s_srfi1_map_in_order, "map-in-order", 2, 0, 1, scm_srfi1_map);
+
+SCM_GPROC (s_srfi1_for_each, "for-each", 2, 0, 1, scm_srfi1_for_each, g_srfi1_for_each);
+
+SCM
+scm_srfi1_for_each (SCM proc, SCM arg1, SCM args)
+#define FUNC_NAME s_srfi1_for_each
+{
+ SCM const *ve = &args; /* Keep args from being optimized away. */
+ long i, len;
+ len = srfi1_ilength (arg1);
+ SCM_GASSERTn ((SCM_NULLP (arg1) || SCM_CONSP (arg1)) && len >= -1,
+ g_srfi1_for_each, scm_cons2 (proc, arg1, args),
+ SCM_ARG2, s_srfi1_for_each);
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ if (SCM_NULLP (args))
+ {
+ scm_t_trampoline_1 call = scm_trampoline_1 (proc);
+ SCM_GASSERT2 (call, g_srfi1_for_each, proc, arg1,
+ SCM_ARG1, s_srfi1_for_each);
+ SCM_GASSERT2 (len >= 0, g_srfi1_for_each, proc, arg1,
+ SCM_ARG2, s_srfi1_map);
+ while (SCM_NIMP (arg1))
+ {
+ call (proc, SCM_CAR (arg1));
+ arg1 = SCM_CDR (arg1);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ if (SCM_NULLP (SCM_CDR (args)))
+ {
+ SCM arg2 = SCM_CAR (args);
+ int len2 = srfi1_ilength (arg2);
+ scm_t_trampoline_2 call = scm_trampoline_2 (proc);
+ SCM_GASSERTn (call, g_srfi1_for_each,
+ scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_for_each);
+ if (len < 0 || (len2 >= 0 && len2 < len))
+ len = len2;
+ SCM_GASSERTn ((SCM_NULLP (arg2) || SCM_CONSP (arg2))
+ && len >= 0 && len2 < len,
+ g_srfi1_for_each,
+ scm_cons2 (proc, arg1, args),
+ len2 >= 0 ? SCM_ARG3 : SCM_ARG2,
+ s_srfi1_for_each);
+ while (len > 0)
+ {
+ call (proc, SCM_CAR (arg1), SCM_CAR (arg2));
+ arg1 = SCM_CDR (arg1);
+ arg2 = SCM_CDR (arg2);
+ --len;
+ }
+ return SCM_UNSPECIFIED;
+ }
+ args = scm_vector (arg1 = scm_cons (arg1, args));
+ ve = SCM_VELTS (args);
+ len = check_map_args (args, len, g_srfi1_for_each, proc, arg1,
+ s_srfi1_for_each);
+ while (len > 0)
+ {
+ arg1 = SCM_EOL;
+ for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
+ {
+ arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
+ SCM_VECTOR_SET (args, i, SCM_CDR (ve[i]));
+ }
+ scm_apply (proc, arg1, SCM_EOL);
+ --len;
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+static SCM
+equal_trampoline (SCM proc, SCM arg1, SCM arg2)
+{
+ return scm_equal_p (arg1, arg2);
+}
+
+SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,
+ (SCM x, SCM lst, SCM pred),
+ "Return the first sublist of @var{lst} whose car is\n"
+ "@code{equal?} to @var{x} where the sublists of @var{lst} are\n"
+ "the non-empty lists returned by @code{(list-tail @var{lst}\n"
+ "@var{k})} for @var{k} less than the length of @var{lst}. If\n"
+ "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
+ "empty list) is returned.")
+#define FUNC_NAME s_scm_srfi1_member
+{
+ scm_t_trampoline_2 equal_p;
+ SCM_VALIDATE_LIST (2, lst);
+ if (SCM_UNBNDP (pred))
+ equal_p = equal_trampoline;
+ else
+ {
+ equal_p = scm_trampoline_2 (pred);
+ SCM_ASSERT (equal_p, pred, 3, FUNC_NAME);
+ }
+ for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
+ {
+ if (!SCM_FALSEP (equal_p (pred, SCM_CAR (lst), x)))
+ return lst;
+ }
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+void
+scm_init_srfi_1 (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "srfi/srfi-1.x"
+#endif
+}
+
+/* End of srfi-1.c. */
diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h
new file mode 100644
index 000000000..b42f4f97a
--- /dev/null
+++ b/srfi/srfi-1.h
@@ -0,0 +1,67 @@
+#ifndef SCM_SRFI_1_H
+#define SCM_SRFI_1_H
+/* srfi-1.h --- SRFI-1 procedures for Guile
+ *
+ * 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. */
+
+
+/* SCM_SRFI1_API is a macro prepended to all function and data definitions
+ which should be exported or imported in the resulting dynamic link
+ library in the Win32 port. */
+
+#if defined (SCM_SRFI1_IMPORT)
+# define SCM_SRFI1_API __declspec (dllimport) extern
+#elif defined (SCM_SRFI1_EXPORT) || defined (DLL_EXPORT)
+# define SCM_SRFI1_API __declspec (dllexport) extern
+#else
+# define SCM_SRFI1_API extern
+#endif
+
+SCM_API SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args);
+SCM_API SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args);
+SCM_SRFI1_API SCM scm_srfi1_member (SCM obj, SCM ls, SCM pred);
+
+SCM_SRFI1_API void scm_init_srfi_1 (void);
+
+#endif /* SCM_SRFI_1_H */
diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm
index a06e8462e..f1208e37e 100644
--- a/srfi/srfi-1.scm
+++ b/srfi/srfi-1.scm
@@ -236,6 +236,11 @@
(cond-expand-provide (current-module) '(srfi-1))
+;; Load the compiled primitives from the shared library.
+;;
+(load-extension "libguile-srfi-srfi-1" "scm_init_srfi_1")
+
+
;;; Constructors
(define (xcons d a)
@@ -615,41 +620,6 @@
(set-cdr! p (list (f (car ls))))
(lp (cdr ls) (cdr p))))))))
-;; This `map' is extended from the standard `map'. It allows argument
-;; lists of different length, so that the shortest list determines the
-;; number of elements processed.
-;;
-(define (map f list1 . rest)
- (if (null? rest)
- (map1 f list1)
- (let lp ((l (cons list1 rest)))
- (if (any1 null? l)
- '()
- (cons (apply f (map1 car l)) (lp (map1 cdr l)))))))
-
-;; extended to lists of unequal length.
-(define map-in-order map)
-
-;; This `for-each' is extended from the standard `for-each'. It
-;; allows argument lists of different length, so that the shortest
-;; list determines the number of elements processed.
-;;
-(define (for-each f list1 . rest)
- (if (null? rest)
- (let lp ((l list1))
- (if (null? l)
- (if #f #f) ; Return unspecified value.
- (begin
- (f (car l))
- (lp (cdr l)))))
- (let lp ((l (cons list1 rest)))
- (if (any1 null? l)
- (if #f #f)
- (begin
- (apply f (map1 car l))
- (lp (map1 cdr l)))))))
-
-
(define (append-map f clist1 . rest)
(if (null? rest)
(let lp ((l clist1))
@@ -872,15 +842,6 @@
(else
(lp (map1 cdr lists) (+ i 1)))))))
-(define (member x list . rest)
- (let ((l= (if (pair? rest) (car rest) equal?)))
- (let lp ((l list))
- (if (null? l)
- #f
- (if (l= x (car l))
- l
- (lp (cdr l)))))))
-
;;; Deletion
(define (delete x list . rest)