From 08ee6abd86a0b2905e0e842bbf7e7874ffe4d15a Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 9 Jul 2004 22:16:04 +0000 Subject: [PATCH 01/89] * tests/hash.test: New file. * Makefile.am (SCM_TESTS): Add it. --- test-suite/Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 3cdfa2ff6..ee8bf8b88 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -37,6 +37,7 @@ SCM_TESTS = tests/alist.test \ tests/getopt-long.test \ tests/goops.test \ tests/guardians.test \ + tests/hash.test \ tests/hooks.test \ tests/import.test \ tests/interp.test \ From 677104a65cc734f3fefdfc7b8658c8766688f709 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 9 Jul 2004 22:27:47 +0000 Subject: [PATCH 02/89] *** empty log message *** --- test-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 78fe924a6..f6038fea3 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-07-10 Kevin Ryde + + * tests/hash.test: New file. + * Makefile.am (SCM_TESTS): Add it. + 2004-07-08 Marius Vollmer * standalone/test-unwind.c: Use scm_from_int instead of From 48a06bd55ded5ab29e34926bb09b573985793c62 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 9 Jul 2004 23:08:53 +0000 Subject: [PATCH 03/89] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5aec17776..da43ba0e9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2004-07-10 Kevin Ryde + + * hash.c (scm_hashq, scm_hashv, scm_hash): Restrict to size>=1 rather + than size>=0, since 0<=hash * numbers.c (scm_is_signed_integer, scm_is_unsigned_integer): From f8fc973725fa6809820be1a8ccd0b713fd99917f Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 9 Jul 2004 23:15:28 +0000 Subject: [PATCH 04/89] (scm_make_regexp): Free rx on error, to avoid memory leak. --- libguile/regex-posix.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 8792baf50..9a128bf42 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -188,9 +188,11 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, cflags & ~REG_NOSUB); if (status != 0) { + char *errmsg = scm_regexp_error_msg (status, rx); + scm_gc_free (rx, sizeof(regex_t), "regex"); scm_error (scm_regexp_error_key, FUNC_NAME, - scm_regexp_error_msg (status, rx), + errmsg, SCM_BOOL_F, SCM_BOOL_F); /* never returns */ From 052fbfd928c0eca24334232129aa9975cb4fef3c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 9 Jul 2004 23:16:48 +0000 Subject: [PATCH 05/89] *** empty log message *** --- libguile/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index da43ba0e9..800d104f4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -4,6 +4,9 @@ than size>=0, since 0<=hash * numbers.c (scm_is_signed_integer, scm_is_unsigned_integer): From ac0a9fa32f1b44d2ee28c0777e98bfea418d0046 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 9 Jul 2004 23:40:07 +0000 Subject: [PATCH 06/89] (and-let*): Remove unused variable "val". --- ice-9/and-let-star.scm | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ice-9/and-let-star.scm b/ice-9/and-let-star.scm index 03903cdc5..4057fb498 100644 --- a/ice-9/and-let-star.scm +++ b/ice-9/and-let-star.scm @@ -1,7 +1,7 @@ ;;;; and-let-star.scm --- and-let* syntactic form (draft SRFI-2) for Guile ;;;; written by Michael Livshin ;;;; -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2004 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -34,8 +34,7 @@ ((null? (cdr exp)) `(and ,(car exp) ,(expand (cdr vars) body))) (else - (let ((var (car exp)) - (val (cadr exp))) + (let ((var (car exp))) `(let (,exp) (and ,var ,(expand (cdr vars) body))))))) (else From 5bc8bc69352b04e632528e0ac4ad43edbb2c9014 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 9 Jul 2004 23:41:20 +0000 Subject: [PATCH 07/89] (read-macro-prefix): Remove unused variable "tail". --- ice-9/pretty-print.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ice-9/pretty-print.scm b/ice-9/pretty-print.scm index d5c8aff4c..c478c1525 100644 --- a/ice-9/pretty-print.scm +++ b/ice-9/pretty-print.scm @@ -1,6 +1,6 @@ ;;;; -*-scheme-*- ;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2004 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -42,7 +42,7 @@ (cadr l)) (define (read-macro-prefix l) - (let ((head (car l)) (tail (cdr l))) + (let ((head (car l))) (case head ((quote) "'") ((quasiquote) "`") From 72b4bea4d3247ab9c7d49a310e970b20eff1272b Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 9 Jul 2004 23:42:53 +0000 Subject: [PATCH 08/89] (re-export): Uncomment numerator, denominator, rationalize, since they now exist. --- ice-9/safe-r5rs.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ice-9/safe-r5rs.scm b/ice-9/safe-r5rs.scm index 8d4d45d23..56036ca92 100644 --- a/ice-9/safe-r5rs.scm +++ b/ice-9/safe-r5rs.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2004 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -28,8 +28,8 @@ abs quotient remainder modulo gcd lcm - ;;numerator denominator XXX - ;;rationalize XXX + numerator denominator + rationalize floor ceiling truncate round exp log sin cos tan asin acos atan sqrt From 018733ff9e59a67b8f6776c7f60ce6443c8f2979 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 9 Jul 2004 23:44:48 +0000 Subject: [PATCH 09/89] (%cond-expand-features): Add srfi-6 which is in the core. --- ice-9/boot-9.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 7ec826e23..4df582807 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -3183,14 +3183,18 @@ ;;; ;;; Currently, the following feature identifiers are supported: ;;; -;;; guile r5rs srfi-0 +;;; guile r5rs srfi-0 srfi-6 ;;; ;;; Remember to update the features list when adding more SRFIs. ;;; (define %cond-expand-features ;; Adjust the above comment when changing this. - '(guile r5rs srfi-0)) + '(guile + r5rs + srfi-0 ;; cond-expand itself + srfi-6 ;; open-input-string etc, in the guile core + )) ;; This table maps module public interfaces to the list of features. ;; From 2755366c4ad332ca1a97bb63f36985793311cbc5 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 9 Jul 2004 23:45:41 +0000 Subject: [PATCH 10/89] *** empty log message *** --- ice-9/ChangeLog | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 581e367e4..c7524f3c9 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,13 @@ +2004-07-10 Kevin Ryde + + * and-let-star.scm (and-let*): Remove unused variable "val". + * pretty-print.scm (read-macro-prefix): Remove unused variable "tail". + + * boot-9.scm (%cond-expand-features): Add srfi-6 which is in the core. + + * safe-r5rs.scm (re-export): Uncomment numerator, denominator, + rationalize, since they now exist. + 2004-07-05 Kevin Ryde * slib.scm (system): Correction to redefinition, now guile is stricter From a3de8e7b0f90943e26e53e984b2ce8fd6dfa02e6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 00:16:34 +0000 Subject: [PATCH 11/89] Forgot to list just what numbers are no longer hard-coded in gen-scmconfig.c --- libguile/ChangeLog | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 800d104f4..3f8810034 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -20,7 +20,8 @@ SCM_I_MAKINUM and changed all uses. * deprecated.h, deprecated.c (SCM_MAKINUM): Newly deprecated. - * gen-scmconfig.c: Instead of hard-coding the numbers, compute + * gen-scmconfig.c (SCM_I_LLONG_MIN, SCM_I_LLONG_MAX, + SCM_I_ULLONG_MAX): Instead of hard-coding the numbers, compute them by assuming twos-complement. 2004-07-07 Marius Vollmer From 26a6ccfa9027bfb58902dfc69803c3c0c692525f Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 10 Jul 2004 00:22:12 +0000 Subject: [PATCH 12/89] (SRFI-0): Add srfi-6 to the identifiers provided by default. --- doc/ref/srfi-modules.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 15e3da79f..f67544946 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -137,8 +137,8 @@ implementation-dependent operations, such as @code{use-modules} in Guile. Thus, it is not necessary to use any module to get access to this form. -Currently, the feature identifiers @code{guile}, @code{r5rs} and -@code{srfi-0} are supported. The other SRFIs are not in that list by +Currently, the feature identifiers @code{guile}, @code{r5rs}, @code{srfi-0} and +@code{srfi-6} are supported. The other SRFIs are not in that list by default, because the SRFI modules must be explicitly used before their exported bindings can be used. From 7f6c5a88cc677c63a96a409dbc4347b5d6fd5ad4 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 10 Jul 2004 00:29:26 +0000 Subject: [PATCH 13/89] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 47aa4aea7..6fb52e813 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2004-07-10 Kevin Ryde + + * srfi-modules.texi (SRFI-0): Add srfi-6 to the identifiers provided + by default. + 2004-07-07 Marius Vollmer * scheme-data.texi (Integers): Added docs for the new scm_is_, From 0f94980db9a7395fb1284aa6c3ad451b49150f11 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 13:42:18 +0000 Subject: [PATCH 14/89] Use scm_from_int instead of SCM_MAKINUM. --- libguile/cpp_cnvt.awk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/cpp_cnvt.awk b/libguile/cpp_cnvt.awk index 128136fa2..1e6c09436 100644 --- a/libguile/cpp_cnvt.awk +++ b/libguile/cpp_cnvt.awk @@ -2,6 +2,6 @@ # in Guile. { print "#ifdef " $0; -print "scm_c_define (\""$0"\", SCM_MAKINUM ("$0"));"; +print "scm_c_define (\""$0"\", scm_from_int ("$0"));"; print "#endif" } From 8805b77dd07a333caba3da57df13f604baca8588 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 13:47:02 +0000 Subject: [PATCH 15/89] (SCM_VALIDATE_INUM, SCM_VALIDATE_INUM_COPY, SCM_VALIDATE_BIGINT, SCM_VALIDATE_INUM_MIN, SCM_VALIDATE_INUM_MIN_COPY, SCM_VALIDATE_INUM_MIN_DEF_COPY,SCM_VALIDATE_INUM_DEF, SCM_VALIDATE_INUM_DEF_COPY, SCM_VALIDATE_INUM_RANGE, SCM_VALIDATE_INUM_RANGE_COPY): Deprecated because they make the fixnum/bignum distinction visible. Changed all uses to scm_to_size_t or similar. --- libguile/deprecated.h | 72 +++++++++++++++++++++++++++++++++++++++++++ libguile/validate.h | 72 ++----------------------------------------- 2 files changed, 74 insertions(+), 70 deletions(-) diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 039ec540f..7f71bb4d7 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -325,6 +325,78 @@ SCM_API SCM scm_gentemp (SCM prefix, SCM obarray); SCM_API SCM SCM_MAKINUM (scm_t_signed_bits val); +/* Users shouldn't know about INUMs. + */ + +#define SCM_VALIDATE_INUM(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, INUMP, "exact integer") + +#define SCM_VALIDATE_INUM_COPY(pos, k, cvar) \ + do { \ + SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ + cvar = SCM_INUM (k); \ + } while (0) + +#define SCM_VALIDATE_BIGINT(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, BIGP, "bignum") + +#define SCM_VALIDATE_INUM_MIN(pos, k, min) \ + do { \ + SCM_ASSERT (SCM_INUMP(k), k, pos, FUNC_NAME); \ + SCM_ASSERT_RANGE (pos, k, (SCM_INUM (k) >= min)); \ + } while (0) + +#define SCM_VALIDATE_INUM_MIN_COPY(pos, k, min, cvar) \ + do { \ + SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ + SCM_ASSERT_RANGE (pos, k, (SCM_INUM (k) >= min)); \ + cvar = SCM_INUM (k); \ + } while (0) + +#define SCM_VALIDATE_INUM_MIN_DEF_COPY(pos, k, min, default, cvar) \ + do { \ + if (SCM_UNBNDP (k)) \ + k = SCM_I_MAKINUM (default); \ + SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ + SCM_ASSERT_RANGE (pos, k, (SCM_INUM (k) >= min)); \ + cvar = SCM_INUM (k); \ + } while (0) + +#define SCM_VALIDATE_INUM_DEF(pos, k, default) \ + do { \ + if (SCM_UNBNDP (k)) \ + k = SCM_I_MAKINUM (default); \ + else SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ + } while (0) + +#define SCM_VALIDATE_INUM_DEF_COPY(pos, k, default, cvar) \ + do { \ + if (SCM_UNBNDP (k)) \ + { \ + k = SCM_I_MAKINUM (default); \ + cvar = default; \ + } \ + else \ + { \ + SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ + cvar = SCM_INUM (k); \ + } \ + } while (0) + +/* [low, high) */ +#define SCM_VALIDATE_INUM_RANGE(pos, k, low, high) \ + do { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); \ + SCM_ASSERT_RANGE(pos, k, \ + (SCM_INUM (k) >= low && \ + SCM_INUM (k) < high)); \ + } while (0) + +#define SCM_VALIDATE_INUM_RANGE_COPY(pos, k, low, high, cvar) \ + do { \ + SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ + SCM_ASSERT_RANGE (pos, k, low <= SCM_INUM (k) && SCM_INUM (k) < high); \ + cvar = SCM_INUM (k); \ + } while (0) + + void scm_i_init_deprecated (void); #endif diff --git a/libguile/validate.h b/libguile/validate.h index 31c5d1e53..3da0d0500 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -170,8 +170,8 @@ pos_end, end, c_end) \ do {\ SCM_VALIDATE_STRING_COPY (pos_str, str, c_str);\ - SCM_VALIDATE_INUM_DEF_COPY (pos_start, start, 0, c_start);\ - SCM_VALIDATE_INUM_DEF_COPY (pos_end, end, SCM_STRING_LENGTH (str), c_end);\ + c_start = SCM_UNBNDP(start)? 0 : scm_to_size_t (start);\ + c_end = SCM_UNBNDP(end)? SCM_STRING_LENGTH(str) : scm_to_size_t (end);\ SCM_ASSERT_RANGE (pos_start, start,\ 0 <= c_start \ && (size_t) c_start <= SCM_STRING_LENGTH (str));\ @@ -184,14 +184,6 @@ #define SCM_VALIDATE_NUMBER(pos, z) SCM_MAKE_VALIDATE_MSG (pos, z, NUMBERP, "number") -#define SCM_VALIDATE_INUM(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, INUMP, "exact integer") - -#define SCM_VALIDATE_INUM_COPY(pos, k, cvar) \ - do { \ - SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ - cvar = SCM_INUM (k); \ - } while (0) - #define SCM_VALIDATE_USHORT_COPY(pos, k, cvar) \ do { \ cvar = SCM_NUM2USHORT (pos, k); \ @@ -232,51 +224,6 @@ cvar = SCM_NUM2DOUBLE (pos, k); \ } while (0) -#define SCM_VALIDATE_BIGINT(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, BIGP, "bignum") - -#define SCM_VALIDATE_INUM_MIN(pos, k, min) \ - do { \ - SCM_ASSERT (SCM_INUMP(k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE (pos, k, (SCM_INUM (k) >= min)); \ - } while (0) - -#define SCM_VALIDATE_INUM_MIN_COPY(pos, k, min, cvar) \ - do { \ - SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE (pos, k, (SCM_INUM (k) >= min)); \ - cvar = SCM_INUM (k); \ - } while (0) - -#define SCM_VALIDATE_INUM_MIN_DEF_COPY(pos, k, min, default, cvar) \ - do { \ - if (SCM_UNBNDP (k)) \ - k = SCM_I_MAKINUM (default); \ - SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE (pos, k, (SCM_INUM (k) >= min)); \ - cvar = SCM_INUM (k); \ - } while (0) - -#define SCM_VALIDATE_INUM_DEF(pos, k, default) \ - do { \ - if (SCM_UNBNDP (k)) \ - k = SCM_I_MAKINUM (default); \ - else SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ - } while (0) - -#define SCM_VALIDATE_INUM_DEF_COPY(pos, k, default, cvar) \ - do { \ - if (SCM_UNBNDP (k)) \ - { \ - k = SCM_I_MAKINUM (default); \ - cvar = default; \ - } \ - else \ - { \ - SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ - cvar = SCM_INUM (k); \ - } \ - } while (0) - #define SCM_VALIDATE_DOUBLE_DEF_COPY(pos, k, default, cvar) \ do { \ if (SCM_UNBNDP (k)) \ @@ -290,21 +237,6 @@ } \ } while (0) -/* [low, high) */ -#define SCM_VALIDATE_INUM_RANGE(pos, k, low, high) \ - do { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE(pos, k, \ - (SCM_INUM (k) >= low && \ - SCM_INUM (k) < high)); \ - } while (0) - -#define SCM_VALIDATE_INUM_RANGE_COPY(pos, k, low, high, cvar) \ - do { \ - SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE (pos, k, low <= SCM_INUM (k) && SCM_INUM (k) < high); \ - cvar = SCM_INUM (k); \ - } while (0) - #define SCM_VALIDATE_NULL(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, NULLP, "null") #define SCM_VALIDATE_NULL_OR_NIL(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, NULL_OR_NIL_P, "null") From 1a161b8ece1d8c1c75cc89658a116fbeacf8a00a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 13:50:33 +0000 Subject: [PATCH 16/89] Changed all uses of SCM_VALIDATE_INUM, SCM_VALIDATE_INUM_COPY, SCM_VALIDATE_BIGINT, SCM_VALIDATE_INUM_MIN, SCM_VALIDATE_INUM_MIN_COPY, SCM_VALIDATE_INUM_MIN_DEF_COPY,SCM_VALIDATE_INUM_DEF, SCM_VALIDATE_INUM_DEF_COPY, SCM_VALIDATE_INUM_RANGE, SCM_VALIDATE_INUM_RANGE_COPY to scm_to_size_t or similar. --- srfi/srfi-13.c | 87 ++++++++++++++++++++++++++------------------------ srfi/srfi-14.c | 38 +++++++++------------- srfi/srfi-4.c | 70 +++++++++++++++++----------------------- 3 files changed, 90 insertions(+), 105 deletions(-) diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index 945d6d5ef..0efd24abb 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -97,13 +97,13 @@ SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0, "@var{proc} is applied to the indices is not specified.") #define FUNC_NAME s_scm_string_tabulate { - int clen, i; + size_t clen, i; SCM res; SCM ch; char * p; SCM_VALIDATE_PROC (1, proc); - SCM_VALIDATE_INUM_COPY (2, len, clen); + clen = scm_to_size_t (len); SCM_ASSERT_RANGE (2, len, clen >= 0); res = scm_allocate_string (clen); @@ -111,7 +111,7 @@ SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0, i = 0; while (i < clen) { - ch = scm_call_1 (proc, SCM_I_MAKINUM (i)); + ch = scm_call_1 (proc, scm_from_int (i)); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); *p++ = SCM_CHAR (ch); @@ -365,16 +365,17 @@ SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0, "argument @var{str}.") #define FUNC_NAME s_scm_substring_shared { + size_t s, e; SCM_VALIDATE_STRING (1, str); - SCM_VALIDATE_INUM (2, start); + s = scm_to_size_t (start); if (SCM_UNBNDP (end)) - end = SCM_I_MAKINUM (SCM_STRING_LENGTH (str)); + e = SCM_STRING_LENGTH (str); else - SCM_VALIDATE_INUM (3, end); - if (SCM_INUM (start) == 0 && - SCM_INUM (end) == SCM_STRING_LENGTH (str)) + e = scm_to_size_t (end); + if (s == 0 && e == SCM_STRING_LENGTH (str)) return str; - return scm_substring (str, start, end); + else + return scm_substring (str, start, end); } #undef FUNC_NAME @@ -418,11 +419,10 @@ SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0, #define FUNC_NAME s_scm_string_take { char * cstr; - int cn; + size_t cn; SCM_VALIDATE_STRING_COPY (1, s, cstr); - SCM_VALIDATE_INUM_COPY (2, n, cn); - SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s)); + cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s)); return scm_mem2string (cstr, cn); } @@ -435,11 +435,10 @@ SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0, #define FUNC_NAME s_scm_string_drop { char * cstr; - int cn; + size_t cn; SCM_VALIDATE_STRING_COPY (1, s, cstr); - SCM_VALIDATE_INUM_COPY (2, n, cn); - SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s)); + cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s)); return scm_mem2string (cstr + cn, SCM_STRING_LENGTH (s) - cn); } @@ -452,11 +451,10 @@ SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0, #define FUNC_NAME s_scm_string_take_right { char * cstr; - int cn; + size_t cn; SCM_VALIDATE_STRING_COPY (1, s, cstr); - SCM_VALIDATE_INUM_COPY (2, n, cn); - SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s)); + cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s)); return scm_mem2string (cstr + SCM_STRING_LENGTH (s) - cn, cn); } @@ -469,11 +467,10 @@ SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0, #define FUNC_NAME s_scm_string_drop_right { char * cstr; - int cn; + size_t cn; SCM_VALIDATE_STRING_COPY (1, s, cstr); - SCM_VALIDATE_INUM_COPY (2, n, cn); - SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s)); + cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s)); return scm_mem2string (cstr, SCM_STRING_LENGTH (s) - cn); } @@ -490,13 +487,14 @@ SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0, { char cchr; char * cstr; - int cstart, cend, clen; + size_t cstart, cend, clen; SCM result; SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 4, start, cstart, 5, end, cend); - SCM_VALIDATE_INUM_COPY (2, len, clen); + clen = scm_to_size_t (len); + if (SCM_UNBNDP (chr)) cchr = ' '; else @@ -532,13 +530,14 @@ SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0, { char cchr; char * cstr; - int cstart, cend, clen; + size_t cstart, cend, clen; SCM result; SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 4, start, cstart, 5, end, cend); - SCM_VALIDATE_INUM_COPY (2, len, clen); + clen = scm_to_size_t (len); + if (SCM_UNBNDP (chr)) cchr = ' '; else @@ -584,7 +583,7 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, #define FUNC_NAME s_scm_string_trim { char * cstr; - int cstart, cend; + size_t cstart, cend; SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 3, start, cstart, @@ -2281,9 +2280,9 @@ SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, { long strings; SCM tmp, result; - int len = 0; + size_t len = 0; char * p; - int cend = 0; + size_t cend = 0; /* Check the optional arguments and calculate the additional length of the result string. */ @@ -2292,10 +2291,8 @@ SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, SCM_VALIDATE_STRING (2, final_string); if (!SCM_UNBNDP (end)) { - SCM_VALIDATE_INUM_COPY (3, end, cend); - SCM_ASSERT_RANGE (3, end, - (cend >= 0) && - (cend <= SCM_STRING_LENGTH (final_string))); + cend = scm_to_unsigned_integer (end, + 0, SCM_STRING_LENGTH (final_string)); } else { @@ -2674,14 +2671,17 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, #define FUNC_NAME s_scm_xsubstring { char * cs, * p; - int cstart, cend, cfrom, cto; + size_t cstart, cend, cfrom, cto; SCM result; SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cs, 4, start, cstart, 5, end, cend); - SCM_VALIDATE_INUM_COPY (2, from, cfrom); - SCM_VALIDATE_INUM_DEF_COPY (3, to, cfrom + (cend - cstart), cto); + cfrom = scm_to_size_t (from); + if (SCM_UNBNDP (to)) + cto = cfrom + (cend - cstart); + else + cto = scm_to_size_t (to); if (cstart == cend && cfrom != cto) SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); @@ -2713,7 +2713,7 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, #define FUNC_NAME s_scm_string_xcopy_x { char * ctarget, * cs, * p; - int ctstart, csfrom, csto, cstart, cend; + size_t ctstart, csfrom, csto, cstart, cend; SCM dummy = SCM_UNDEFINED; int cdummy; @@ -2723,8 +2723,11 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cs, 6, start, cstart, 7, end, cend); - SCM_VALIDATE_INUM_COPY (4, sfrom, csfrom); - SCM_VALIDATE_INUM_DEF_COPY (5, sto, csfrom + (cend - cstart), csto); + csfrom = scm_to_size_t (sfrom); + if (SCM_UNBNDP (sto)) + csto = csfrom + (cend - cstart); + else + csto = scm_to_size_t (sto); if (cstart == cend && csfrom != csto) SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); SCM_ASSERT_RANGE (1, tstart, @@ -2754,7 +2757,7 @@ SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0, #define FUNC_NAME s_scm_string_replace { char * cstr1, * cstr2, * p; - int cstart1, cend1, cstart2, cend2; + size_t cstart1, cend1, cstart2, cend2; SCM result; SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, @@ -2788,7 +2791,7 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, #define FUNC_NAME s_scm_string_tokenize { char * cstr; - int cstart, cend; + size_t cstart, cend; SCM result = SCM_EOL; static SCM charset_graphic = SCM_BOOL_F; @@ -2850,7 +2853,7 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, #define FUNC_NAME s_scm_string_filter { char * cstr; - int cstart, cend; + size_t cstart, cend; SCM result; int idx; @@ -2916,7 +2919,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, #define FUNC_NAME s_scm_string_delete { char * cstr; - int cstart, cend; + size_t cstart, cend; SCM result; int idx; diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 551514aba..f9e961c9c 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -163,8 +163,8 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, "returned value to the range 0 @dots{} @var{bound - 1}.") #define FUNC_NAME s_scm_char_set_hash { - const int default_bnd = 871; - int bnd; + const unsigned long default_bnd = 871; + unsigned long bnd; long * p; unsigned long val = 0; int k; @@ -175,7 +175,7 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, bnd = default_bnd; else { - SCM_VALIDATE_INUM_MIN_COPY (2, bound, 0, bnd); + bnd = scm_to_ulong (bound); if (bnd == 0) bnd = default_bnd; } @@ -186,7 +186,7 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, if (p[k] != 0) val = p[k] + (val << 1); } - return SCM_I_MAKINUM (val % bnd); + return scm_from_ulong (val % bnd); } #undef FUNC_NAME @@ -216,10 +216,8 @@ SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0, "pass a cursor for which @code{end-of-char-set?} returns true.") #define FUNC_NAME s_scm_char_set_ref { - int ccursor; - + size_t ccursor = scm_to_size_t (cursor); SCM_VALIDATE_SMOB (1, cs, charset); - SCM_VALIDATE_INUM_MIN_COPY (2, cursor, 0, ccursor); if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); @@ -235,10 +233,8 @@ SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0, "cursor given satisfies @code{end-of-char-set?}.") #define FUNC_NAME s_scm_char_set_cursor_next { - int ccursor; - + size_t ccursor = scm_to_size_t (cursor); SCM_VALIDATE_SMOB (1, cs, charset); - SCM_VALIDATE_INUM_MIN_COPY (2, cursor, 0, ccursor); if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); @@ -258,9 +254,7 @@ SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0, "character set, @code{#f} otherwise.") #define FUNC_NAME s_scm_end_of_char_set_p { - int ccursor; - - SCM_VALIDATE_INUM_MIN_COPY (1, cursor, 0, ccursor); + size_t ccursor = scm_to_size_t (cursor); return scm_from_bool (ccursor >= SCM_CHARSET_SIZE); } #undef FUNC_NAME @@ -661,13 +655,12 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, #define FUNC_NAME s_scm_ucs_range_to_char_set { SCM cs; - int clower, cupper; + size_t clower, cupper; long * p; - SCM_VALIDATE_INUM_COPY (1, lower, clower); - SCM_VALIDATE_INUM_COPY (2, upper, cupper); - SCM_ASSERT_RANGE (1, lower, clower >= 0); - SCM_ASSERT_RANGE (2, upper, cupper >= 0 && cupper >= clower); + clower = scm_to_size_t (lower); + cupper = scm_to_size_t (upper); + SCM_ASSERT_RANGE (2, upper, cupper >= clower); if (!SCM_UNBNDP (error)) { if (scm_is_true (error)) @@ -714,13 +707,12 @@ SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0, "returned.") #define FUNC_NAME s_scm_ucs_range_to_char_set_x { - int clower, cupper; + size_t clower, cupper; long * p; - SCM_VALIDATE_INUM_COPY (1, lower, clower); - SCM_VALIDATE_INUM_COPY (2, upper, cupper); - SCM_ASSERT_RANGE (1, lower, clower >= 0); - SCM_ASSERT_RANGE (2, upper, cupper >= 0 && cupper >= clower); + clower = scm_to_size_t (lower); + cupper = scm_to_size_t (upper); + SCM_ASSERT_RANGE (2, upper, cupper >= clower); if (scm_is_true (error)) { SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); diff --git a/srfi/srfi-4.c b/srfi/srfi-4.c index 45efe728f..a70d96850 100644 --- a/srfi/srfi-4.c +++ b/srfi/srfi-4.c @@ -286,7 +286,7 @@ SCM_DEFINE (scm_u8vector_p, "u8vector?", 1, 0, 0, SCM_DEFINE (scm_make_u8vector, "make-u8vector", 1, 1, 0, - (SCM n, SCM fill), + (SCM len, SCM fill), "Create a newly allocated homogeneous numeric vector which can\n" "hold @var{len} elements. If @var{fill} is given, it is used to\n" "initialize the elements, otherwise the contents of the vector\n" @@ -296,10 +296,9 @@ SCM_DEFINE (scm_make_u8vector, "make-u8vector", 1, 1, 0, SCM uvec; int_u8 * p; int_u8 f; - int count; + size_t count; - SCM_VALIDATE_INUM (1, n); - count = SCM_INUM (n); + count = scm_to_size_t (len); uvec = make_uvec (FUNC_NAME, SCM_UVEC_U8, count); if (SCM_UNBNDP (fill)) f = 0; @@ -472,7 +471,7 @@ SCM_DEFINE (scm_s8vector_p, "s8vector?", 1, 0, 0, SCM_DEFINE (scm_make_s8vector, "make-s8vector", 1, 1, 0, - (SCM n, SCM fill), + (SCM len, SCM fill), "Create a newly allocated homogeneous numeric vector which can\n" "hold @var{len} elements. If @var{fill} is given, it is used to\n" "initialize the elements, otherwise the contents of the vector\n" @@ -482,10 +481,9 @@ SCM_DEFINE (scm_make_s8vector, "make-s8vector", 1, 1, 0, SCM uvec; int_s8 * p; int_s8 f; - int count; + size_t count; - SCM_VALIDATE_INUM (1, n); - count = SCM_INUM (n); + count = scm_to_size_t (len); uvec = make_uvec (FUNC_NAME, SCM_UVEC_S8, count); if (SCM_UNBNDP (fill)) f = 0; @@ -660,7 +658,7 @@ SCM_DEFINE (scm_u16vector_p, "u16vector?", 1, 0, 0, SCM_DEFINE (scm_make_u16vector, "make-u16vector", 1, 1, 0, - (SCM n, SCM fill), + (SCM len, SCM fill), "Create a newly allocated homogeneous numeric vector which can\n" "hold @var{len} elements. If @var{fill} is given, it is used to\n" "initialize the elements, otherwise the contents of the vector\n" @@ -670,10 +668,9 @@ SCM_DEFINE (scm_make_u16vector, "make-u16vector", 1, 1, 0, SCM uvec; int_u16 * p; int_u16 f; - int count; + size_t count; - SCM_VALIDATE_INUM (1, n); - count = SCM_INUM (n); + count = scm_to_size_t (len); uvec = make_uvec (FUNC_NAME, SCM_UVEC_U16, count); if (SCM_UNBNDP (fill)) f = 0; @@ -830,7 +827,7 @@ SCM_DEFINE (scm_s16vector_p, "s16vector?", 1, 0, 0, SCM_DEFINE (scm_make_s16vector, "make-s16vector", 1, 1, 0, - (SCM n, SCM fill), + (SCM len, SCM fill), "Create a newly allocated homogeneous numeric vector which can\n" "hold @var{len} elements. If @var{fill} is given, it is used to\n" "initialize the elements, otherwise the contents of the vector\n" @@ -840,10 +837,9 @@ SCM_DEFINE (scm_make_s16vector, "make-s16vector", 1, 1, 0, SCM uvec; int_s16 * p; int_s16 f; - int count; + size_t count; - SCM_VALIDATE_INUM (1, n); - count = SCM_INUM (n); + count = scm_to_size_t (len); uvec = make_uvec (FUNC_NAME, SCM_UVEC_S16, count); if (SCM_UNBNDP (fill)) f = 0; @@ -1003,7 +999,7 @@ SCM_DEFINE (scm_u32vector_p, "u32vector?", 1, 0, 0, SCM_DEFINE (scm_make_u32vector, "make-u32vector", 1, 1, 0, - (SCM n, SCM fill), + (SCM len, SCM fill), "Create a newly allocated homogeneous numeric vector which can\n" "hold @var{len} elements. If @var{fill} is given, it is used to\n" "initialize the elements, otherwise the contents of the vector\n" @@ -1013,10 +1009,9 @@ SCM_DEFINE (scm_make_u32vector, "make-u32vector", 1, 1, 0, SCM uvec; int_u32 * p; int_u32 f; - int count; + size_t count; - SCM_VALIDATE_INUM (1, n); - count = SCM_INUM (n); + count = scm_to_size_t (len); uvec = make_uvec (FUNC_NAME, SCM_UVEC_U32, count); if (SCM_UNBNDP (fill)) f = 0; @@ -1174,7 +1169,7 @@ SCM_DEFINE (scm_s32vector_p, "s32vector?", 1, 0, 0, SCM_DEFINE (scm_make_s32vector, "make-s32vector", 1, 1, 0, - (SCM n, SCM fill), + (SCM len, SCM fill), "Create a newly allocated homogeneous numeric vector which can\n" "hold @var{len} elements. If @var{fill} is given, it is used to\n" "initialize the elements, otherwise the contents of the vector\n" @@ -1184,10 +1179,9 @@ SCM_DEFINE (scm_make_s32vector, "make-s32vector", 1, 1, 0, SCM uvec; int_s32 * p; int_s32 f; - int count; + size_t count; - SCM_VALIDATE_INUM (1, n); - count = SCM_INUM (n); + count = scm_to_size_t (len); uvec = make_uvec (FUNC_NAME, SCM_UVEC_S32, count); if (SCM_UNBNDP (fill)) f = 0; @@ -1347,7 +1341,7 @@ SCM_DEFINE (scm_u64vector_p, "u64vector?", 1, 0, 0, SCM_DEFINE (scm_make_u64vector, "make-u64vector", 1, 1, 0, - (SCM n, SCM fill), + (SCM len, SCM fill), "Create a newly allocated homogeneous numeric vector which can\n" "hold @var{len} elements. If @var{fill} is given, it is used to\n" "initialize the elements, otherwise the contents of the vector\n" @@ -1357,10 +1351,9 @@ SCM_DEFINE (scm_make_u64vector, "make-u64vector", 1, 1, 0, SCM uvec; int_u64 * p; int_u64 f; - int count; + size_t count; - SCM_VALIDATE_INUM (1, n); - count = SCM_INUM (n); + count = scm_to_size_t (len); uvec = make_uvec (FUNC_NAME, SCM_UVEC_U64, count); if (SCM_UNBNDP (fill)) f = 0; @@ -1518,7 +1511,7 @@ SCM_DEFINE (scm_s64vector_p, "s64vector?", 1, 0, 0, SCM_DEFINE (scm_make_s64vector, "make-s64vector", 1, 1, 0, - (SCM n, SCM fill), + (SCM len, SCM fill), "Create a newly allocated homogeneous numeric vector which can\n" "hold @var{len} elements. If @var{fill} is given, it is used to\n" "initialize the elements, otherwise the contents of the vector\n" @@ -1528,10 +1521,9 @@ SCM_DEFINE (scm_make_s64vector, "make-s64vector", 1, 1, 0, SCM uvec; int_s64 * p; int_s64 f; - int count; + size_t count; - SCM_VALIDATE_INUM (1, n); - count = SCM_INUM (n); + count = scm_to_size_t (len); uvec = make_uvec (FUNC_NAME, SCM_UVEC_S64, count); if (SCM_UNBNDP (fill)) f = 0; @@ -1691,7 +1683,7 @@ SCM_DEFINE (scm_f32vector_p, "f32vector?", 1, 0, 0, SCM_DEFINE (scm_make_f32vector, "make-f32vector", 1, 1, 0, - (SCM n, SCM fill), + (SCM len, SCM fill), "Create a newly allocated homogeneous numeric vector which can\n" "hold @var{len} elements. If @var{fill} is given, it is used to\n" "initialize the elements, otherwise the contents of the vector\n" @@ -1701,10 +1693,9 @@ SCM_DEFINE (scm_make_f32vector, "make-f32vector", 1, 1, 0, SCM uvec; float_f32 * p; float_f32 f; - int count; + size_t count; - SCM_VALIDATE_INUM (1, n); - count = SCM_INUM (n); + count = scm_to_size_t (len); uvec = make_uvec (FUNC_NAME, SCM_UVEC_F32, count); if (SCM_UNBNDP (fill)) f = 0; @@ -1887,7 +1878,7 @@ SCM_DEFINE (scm_f64vector_p, "f64vector?", 1, 0, 0, SCM_DEFINE (scm_make_f64vector, "make-f64vector", 1, 1, 0, - (SCM n, SCM fill), + (SCM len, SCM fill), "Create a newly allocated homogeneous numeric vector which can\n" "hold @var{len} elements. If @var{fill} is given, it is used to\n" "initialize the elements, otherwise the contents of the vector\n" @@ -1897,10 +1888,9 @@ SCM_DEFINE (scm_make_f64vector, "make-f64vector", 1, 1, 0, SCM uvec; float_f64 * p; float_f64 f; - int count; + size_t count; - SCM_VALIDATE_INUM (1, n); - count = SCM_INUM (n); + count = scm_to_size_t (len); uvec = make_uvec (FUNC_NAME, SCM_UVEC_F64, count); if (SCM_UNBNDP (fill)) f = 0; From 66998138b8b6379d7c4dcaf98839621e4918178d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 13:50:41 +0000 Subject: [PATCH 17/89] *** empty log message *** --- srfi/ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 8291a5b63..02dd4903e 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,12 @@ +2004-07-10 Marius Vollmer + + * srfi-13.c, srfi-14.c, srfi-4.c: Changed all uses of + SCM_VALIDATE_INUM, SCM_VALIDATE_INUM_COPY, SCM_VALIDATE_BIGINT, + SCM_VALIDATE_INUM_MIN, SCM_VALIDATE_INUM_MIN_COPY, + SCM_VALIDATE_INUM_MIN_DEF_COPY,SCM_VALIDATE_INUM_DEF, + SCM_VALIDATE_INUM_DEF_COPY, SCM_VALIDATE_INUM_RANGE, + SCM_VALIDATE_INUM_RANGE_COPY to scm_to_size_t or similar. + 2004-07-06 Marius Vollmer * srfi-1.c, srfi-13.c, srfi-14.c, srfi-4.c: Replaced all uses of From 5efd3c7d68a7ebf11b53bc47c799e28a5639c0e7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 13:55:04 +0000 Subject: [PATCH 18/89] (scm_to_signed_integer, scm_to_unsigned_integer): dot not accept inexact integers. * validate.h, deprecated.h (SCM_VALIDATE_INUM, SCM_VALIDATE_INUM_COPY, SCM_VALIDATE_BIGINT, SCM_VALIDATE_INUM_MIN, SCM_VALIDATE_INUM_MIN_COPY, SCM_VALIDATE_INUM_MIN_DEF_COPY,SCM_VALIDATE_INUM_DEF, SCM_VALIDATE_INUM_DEF_COPY, SCM_VALIDATE_INUM_RANGE, SCM_VALIDATE_INUM_RANGE_COPY): Deprecated because they make the fixnum/bignum distinction visible. Changed all uses to scm_to_size_t or similar. --- libguile/numbers.c | 67 +++++++++++----------------------------------- 1 file changed, 15 insertions(+), 52 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 42c839348..a41e8394d 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1478,9 +1478,7 @@ SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0, #define FUNC_NAME s_scm_logbit_p { unsigned long int iindex; - - SCM_VALIDATE_INUM_MIN (SCM_ARG1, index, 0); - iindex = (unsigned long int) SCM_INUM (index); + iindex = scm_to_ulong (index); if (SCM_INUMP (j)) { @@ -1770,10 +1768,7 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, #define FUNC_NAME s_scm_ash { long bits_to_shift; - - SCM_VALIDATE_INUM (2, cnt); - - bits_to_shift = SCM_INUM (cnt); + bits_to_shift = scm_to_long (cnt); if (bits_to_shift < 0) { @@ -1782,7 +1777,7 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, rounding, negative values require some special treatment. */ SCM div = scm_integer_expt (SCM_I_MAKINUM (2), - SCM_I_MAKINUM (-bits_to_shift)); + scm_from_long (-bits_to_shift)); /* scm_quotient assumes its arguments are integers, but it's legal to (ash 1/2 -1) */ if (scm_is_false (scm_negative_p (n))) @@ -1813,8 +1808,8 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, #define FUNC_NAME s_scm_bit_extract { unsigned long int istart, iend, bits; - SCM_VALIDATE_INUM_MIN_COPY (2, start,0, istart); - SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend); + istart = scm_to_ulong (start); + iend = scm_to_ulong (end); SCM_ASSERT_RANGE (3, end, (iend >= istart)); /* how many bits to keep */ @@ -2267,12 +2262,7 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, if (SCM_UNBNDP (radix)) base = 10; else - { - SCM_VALIDATE_INUM (2, radix); - base = SCM_INUM (radix); - /* FIXME: ask if range limit was OK, and if so, document */ - SCM_ASSERT_RANGE (2, radix, (base >= 2) && (base <= 36)); - } + base = scm_to_signed_integer (radix, 2, 36); if (SCM_INUMP (n)) { @@ -2951,9 +2941,14 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, #define FUNC_NAME s_scm_string_to_number { SCM answer; - int base; + unsigned int base; SCM_VALIDATE_STRING (1, string); - SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix,2,10, base); + + if (SCM_UNBNDP (radix)) + base = 10; + else + base = scm_to_unsigned_integer (radix, 2, INT_MAX); + answer = scm_i_mem2number (SCM_STRING_CHARS (string), SCM_STRING_LENGTH (string), base); @@ -5707,11 +5702,6 @@ scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max) return n >= min && n <= max; } } - else if (SCM_REALP (val)) - { - double n = SCM_REAL_VALUE (val); - return n == floor(n) && n >= min && n <= max; - } else return 0; } @@ -5756,11 +5746,6 @@ scm_is_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max) return n >= min && n <= max; } } - else if (SCM_REALP (val)) - { - double n = SCM_REAL_VALUE (val); - return n == floor (n) && n >= min && n <= max; - } else return 0; } @@ -5827,20 +5812,9 @@ scm_to_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max) goto out_of_range; } } - else if (SCM_REALP (val)) - { - double n = SCM_REAL_VALUE (val); - if (n != floor(n)) - goto wrong_type_arg; - if (n >= min && n <= max) - return n; - else - goto out_of_range; - } else { - wrong_type_arg: - scm_wrong_type_arg_msg (NULL, 0, val, "integer"); + scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); return 0; } } @@ -5898,20 +5872,9 @@ scm_to_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max) goto out_of_range; } } - else if (SCM_REALP (val)) - { - double n = SCM_REAL_VALUE (val); - if (n != floor(n)) - goto wrong_type_arg; - if (n >= min && n <= max) - return n; - else - goto out_of_range; - } else { - wrong_type_arg: - scm_wrong_type_arg_msg (NULL, 0, val, "integer"); + scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); return 0; } } From 7cee5b315a702049ba869150eb3d1658d38030d0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 14:34:59 +0000 Subject: [PATCH 19/89] (ipv6_net_to_num, scm_from_ipv6): Renamed ipv6_net_to_num to scm_from_ipv6, for converting from an IPv& byte-wise address to a SCM integer. Changed all uses. (ipv6_num_to_net, scm_to_ipv6): Renamed ipv6_num_to_net to scm_to_ipv6 and added type and range checking, for converting from an IPv& byte-wise address to a SCM integer. Changed all uses. (bignum_in_ipv6_range_p, VALIDATE_INET6): Removed, their function is now done by scm_to_ipv6. * validate.h, deprecated.h (SCM_VALIDATE_INUM, SCM_VALIDATE_INUM_COPY, SCM_VALIDATE_BIGINT, SCM_VALIDATE_INUM_MIN, SCM_VALIDATE_INUM_MIN_COPY, SCM_VALIDATE_INUM_MIN_DEF_COPY,SCM_VALIDATE_INUM_DEF, SCM_VALIDATE_INUM_DEF_COPY, SCM_VALIDATE_INUM_RANGE, SCM_VALIDATE_INUM_RANGE_COPY): Deprecated because they make the fixnum/bignum distinction visible. Changed all uses to scm_to_size_t or similar. --- libguile/socket.c | 137 ++++++++++++++++------------------------------ 1 file changed, 48 insertions(+), 89 deletions(-) diff --git a/libguile/socket.c b/libguile/socket.c index 811aef925..1582cb3c6 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -79,13 +79,7 @@ SCM_DEFINE (scm_htons, "htons", 1, 0, 0, "and returned as a new integer.") #define FUNC_NAME s_scm_htons { - unsigned short c_in; - - SCM_VALIDATE_INUM_COPY (1, value, c_in); - if (c_in != SCM_INUM (value)) - SCM_OUT_OF_RANGE (1, value); - - return SCM_I_MAKINUM (htons (c_in)); + return scm_from_ushort (htons (scm_to_ushort (value))); } #undef FUNC_NAME @@ -96,13 +90,7 @@ SCM_DEFINE (scm_ntohs, "ntohs", 1, 0, 0, "and returned as a new integer.") #define FUNC_NAME s_scm_ntohs { - unsigned short c_in; - - SCM_VALIDATE_INUM_COPY (1, value, c_in); - if (c_in != SCM_INUM (value)) - SCM_OUT_OF_RANGE (1, value); - - return SCM_I_MAKINUM (ntohs (c_in)); + return scm_from_ushort (ntohs (scm_to_ushort (value))); } #undef FUNC_NAME @@ -282,7 +270,8 @@ SCM_DEFINE (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0, /* convert a 128 bit IPv6 address in network order to a host ordered SCM integer. */ -static SCM ipv6_net_to_num (const scm_t_uint8 *src) +static SCM +scm_from_ipv6 (const scm_t_uint8 *src) { int i = 0; const scm_t_uint8 *ptr = src; @@ -346,12 +335,14 @@ static SCM ipv6_net_to_num (const scm_t_uint8 *src) /* convert a host ordered SCM integer to a 128 bit IPv6 address in network order. */ -static void ipv6_num_to_net (SCM src, scm_t_uint8 *dst) +static void +scm_to_ipv6 (scm_t_uint8 dst[16], SCM src) { - /* This code presumes that src has already been checked for range. */ if (SCM_INUMP (src)) { scm_t_signed_bits n = SCM_INUM (src); + if (n < 0) + scm_out_of_range (NULL, src); #ifdef WORDS_BIGENDIAN memset (dst, 0, 16 - sizeof (scm_t_signed_bits)); memcpy (dst + (16 - sizeof (scm_t_signed_bits)), @@ -367,10 +358,14 @@ static void ipv6_num_to_net (SCM src, scm_t_uint8 *dst) FLIP_NET_HOST_128 (dst); #endif } - else + else if (SCM_BIGP (src)) { - /* Presumes src has already been checked for fit -- see above. */ size_t count; + + if ((mpz_sgn (SCM_I_BIG_MPZ (src)) < 0) + || mpz_sizeinbase (SCM_I_BIG_MPZ (src), 2) > 128) + scm_out_of_range (NULL, src); + memset (dst, 0, 16); mpz_export (dst, &count, @@ -381,37 +376,10 @@ static void ipv6_num_to_net (SCM src, scm_t_uint8 *dst) SCM_I_BIG_MPZ (src)); scm_remember_upto_here_1 (src); } -} - -static int -bignum_in_ipv6_range_p (SCM address) -{ - int result; - int sgn = mpz_sgn (SCM_I_BIG_MPZ (address)); - - if (sgn < 0) - result = 0; else - { - int size = mpz_sizeinbase (SCM_I_BIG_MPZ (address), 2); - if (size > 128) result = 0; - else result = 1; - } - scm_remember_upto_here_1 (address); - return result; + scm_wrong_type_arg (NULL, 0, src); } -/* check that an SCM variable contains an IPv6 integer address. */ -#define VALIDATE_INET6(which_arg, address)\ - if (SCM_INUMP (address))\ - SCM_ASSERT_RANGE (which_arg, address, SCM_INUM (address) >= 0);\ - else\ - {\ - SCM_VALIDATE_BIGINT (which_arg, address);\ - SCM_ASSERT_RANGE (which_arg, address, \ - bignum_in_ipv6_range_p (address)); \ - } - #ifdef HAVE_INET_PTON SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0, (SCM family, SCM address), @@ -431,7 +399,7 @@ SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0, char dst[16]; int rv; - SCM_VALIDATE_INUM_COPY (1, family, af); + af = scm_to_int (family); SCM_ASSERT_RANGE (1, family, af == AF_INET || af == AF_INET6); SCM_VALIDATE_STRING_COPY (2, address, src); rv = inet_pton (af, src, dst); @@ -442,7 +410,7 @@ SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0, if (af == AF_INET) return scm_ulong2num (ntohl (*(scm_t_uint32 *) dst)); else - return ipv6_net_to_num ((char *) dst); + return scm_from_ipv6 ((char *) dst); } #undef FUNC_NAME #endif @@ -469,15 +437,12 @@ SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0, #endif char addr6[16]; - SCM_VALIDATE_INUM_COPY (1, family, af); + af = scm_to_int (family); SCM_ASSERT_RANGE (1, family, af == AF_INET || af == AF_INET6); if (af == AF_INET) *(scm_t_uint32 *) addr6 = htonl (SCM_NUM2ULONG (2, address)); else - { - VALIDATE_INET6 (2, address); - ipv6_num_to_net (address, addr6); - } + scm_to_ipv6 (addr6, address); if (inet_ntop (af, &addr6, dst, sizeof dst) == NULL) SCM_SYSERROR; return scm_makfrom0str (dst); @@ -508,10 +473,9 @@ SCM_DEFINE (scm_socket, "socket", 3, 0, 0, { int fd; - SCM_VALIDATE_INUM (1, family); - SCM_VALIDATE_INUM (2, style); - SCM_VALIDATE_INUM (3, proto); - fd = socket (SCM_INUM (family), SCM_INUM (style), SCM_INUM (proto)); + fd = socket (scm_to_int (family), + scm_to_int (style), + scm_to_int (proto)); if (fd == -1) SCM_SYSERROR; return SCM_SOCK_FD_TO_PORT (fd); @@ -531,13 +495,9 @@ SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0, int fam; int fd[2]; - SCM_VALIDATE_INUM (1, family); - SCM_VALIDATE_INUM (2, style); - SCM_VALIDATE_INUM (3, proto); + fam = scm_to_int (family); - fam = SCM_INUM (family); - - if (socketpair (fam, SCM_INUM (style), SCM_INUM (proto), fd) == -1) + if (socketpair (fam, scm_to_int (style), scm_to_int (proto), fd) == -1) SCM_SYSERROR; return scm_cons (SCM_SOCK_FD_TO_PORT (fd[0]), SCM_SOCK_FD_TO_PORT (fd[1])); @@ -571,8 +531,8 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); - SCM_VALIDATE_INUM_COPY (2, level, ilevel); - SCM_VALIDATE_INUM_COPY (3, optname, ioptname); + ilevel = scm_to_int (level); + ioptname = scm_to_int (optname); fd = SCM_FPORT_FDES (sock); if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1) @@ -590,7 +550,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, scm_long2num (ling->l_linger)); #else return scm_cons (scm_long2num (*(int *) optval), - SCM_I_MAKINUM (0)); + scm_from_int (0)); #endif } else @@ -638,8 +598,8 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0, sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); - SCM_VALIDATE_INUM_COPY (2, level, ilevel); - SCM_VALIDATE_INUM_COPY (3, optname, ioptname); + ilevel = scm_to_int (level); + ioptname = scm_to_int (optname); fd = SCM_FPORT_FDES (sock); @@ -732,10 +692,8 @@ SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0, int fd; sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); - SCM_VALIDATE_INUM (2, how); - SCM_ASSERT_RANGE(2, how,0 <= SCM_INUM (how) && 2 >= SCM_INUM (how)); fd = SCM_FPORT_FDES (sock); - if (shutdown (fd, SCM_INUM (how)) == -1) + if (shutdown (fd, scm_to_signed_integer (how, 0, 2)) == -1) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -763,7 +721,7 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, SCM_VALIDATE_ULONG_COPY (which_arg, address, addr); SCM_VALIDATE_CONS (which_arg + 1, *args); - SCM_VALIDATE_INUM_COPY (which_arg + 1, SCM_CAR (*args), port); + port = scm_to_int (SCM_CAR (*args)); *args = SCM_CDR (*args); soka = (struct sockaddr_in *) scm_malloc (sizeof (struct sockaddr_in)); if (!soka) @@ -788,9 +746,8 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, unsigned long flowinfo = 0; unsigned long scope_id = 0; - VALIDATE_INET6 (which_arg, address); SCM_VALIDATE_CONS (which_arg + 1, *args); - SCM_VALIDATE_INUM_COPY (which_arg + 1, SCM_CAR (*args), port); + port = scm_to_int (SCM_CAR (*args)); *args = SCM_CDR (*args); if (SCM_CONSP (*args)) { @@ -810,7 +767,7 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, soka->sin6_len = sizeof (struct sockaddr_in6); #endif soka->sin6_family = AF_INET6; - ipv6_num_to_net (address, soka->sin6_addr.s6_addr); + scm_to_ipv6 (soka->sin6_addr.s6_addr, address); soka->sin6_port = htons (port); soka->sin6_flowinfo = flowinfo; #ifdef HAVE_SIN6_SCOPE_ID @@ -879,9 +836,8 @@ SCM_DEFINE (scm_connect, "connect", 3, 0, 1, sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); - SCM_VALIDATE_INUM (2, fam); fd = SCM_FPORT_FDES (sock); - soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME, + soka = scm_fill_sockaddr (scm_to_int (fam), address, &args, 3, FUNC_NAME, &size); if (connect (fd, soka, size) == -1) { @@ -939,8 +895,7 @@ SCM_DEFINE (scm_bind, "bind", 3, 0, 1, sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); - SCM_VALIDATE_INUM (2, fam); - soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME, + soka = scm_fill_sockaddr (scm_to_int (fam), address, &args, 3, FUNC_NAME, &size); fd = SCM_FPORT_FDES (sock); if (bind (fd, soka, size) == -1) @@ -970,9 +925,8 @@ SCM_DEFINE (scm_listen, "listen", 2, 0, 0, int fd; sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); - SCM_VALIDATE_INUM (2, backlog); fd = SCM_FPORT_FDES (sock); - if (listen (fd, SCM_INUM (backlog)) == -1) + if (listen (fd, scm_to_int (backlog)) == -1) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -1007,7 +961,7 @@ scm_addr_vector (const struct sockaddr *address, int addr_size, result = scm_c_make_vector (5, SCM_UNSPECIFIED); SCM_VECTOR_SET(result, 0, scm_ulong2num ((unsigned long) fam)); - SCM_VECTOR_SET(result, 1, ipv6_net_to_num (nad->sin6_addr.s6_addr)); + SCM_VECTOR_SET(result, 1, scm_from_ipv6 (nad->sin6_addr.s6_addr)); SCM_VECTOR_SET(result, 2, scm_ulong2num ((unsigned long) ntohs (nad->sin6_port))); SCM_VECTOR_SET(result, 3, scm_ulong2num ((unsigned long) nad->sin6_flowinfo)); #ifdef HAVE_SIN6_SCOPE_ID @@ -1168,14 +1122,17 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_STRING (2, buf); - SCM_VALIDATE_INUM_DEF_COPY (3, flags,0, flg); + if (SCM_UNBNDP (flags)) + flg = 0; + else + flg = scm_to_int (flags); fd = SCM_FPORT_FDES (sock); SCM_SYSCALL (rv = recv (fd, SCM_STRING_CHARS (buf), SCM_STRING_LENGTH (buf), flg)); if (rv == -1) SCM_SYSERROR; - return SCM_I_MAKINUM (rv); + return scm_from_int (rv); } #undef FUNC_NAME @@ -1202,13 +1159,16 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_STRING (2, message); - SCM_VALIDATE_INUM_DEF_COPY (3, flags,0, flg); + if (SCM_UNBNDP (flags)) + flg = 0; + else + flg = scm_to_int (flags); fd = SCM_FPORT_FDES (sock); SCM_SYSCALL (rv = send (fd, SCM_STRING_CHARS (message), SCM_STRING_LENGTH (message), flg)); if (rv == -1) SCM_SYSERROR; - return SCM_I_MAKINUM (rv); + return scm_from_int (rv); } #undef FUNC_NAME @@ -1302,9 +1262,8 @@ SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_FPORT (1, sock); SCM_VALIDATE_STRING (2, message); - SCM_VALIDATE_INUM (3, fam); fd = SCM_FPORT_FDES (sock); - soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args_and_flags, 4, + soka = scm_fill_sockaddr (scm_to_int (fam), address, &args_and_flags, 4, FUNC_NAME, &size); if (SCM_NULLP (args_and_flags)) flg = 0; From a55c2b680920198892329bdf78c92ecc7553eb58 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 14:35:36 +0000 Subject: [PATCH 20/89] * validate.h, deprecated.h (SCM_VALIDATE_INUM, SCM_VALIDATE_INUM_COPY, SCM_VALIDATE_BIGINT, SCM_VALIDATE_INUM_MIN, SCM_VALIDATE_INUM_MIN_COPY, SCM_VALIDATE_INUM_MIN_DEF_COPY,SCM_VALIDATE_INUM_DEF, SCM_VALIDATE_INUM_DEF_COPY, SCM_VALIDATE_INUM_RANGE, SCM_VALIDATE_INUM_RANGE_COPY): Deprecated because they make the fixnum/bignum distinction visible. Changed all uses to scm_to_size_t or similar. --- libguile/ChangeLog | 27 ++++++++++++ libguile/backtrace.c | 4 +- libguile/chars.c | 3 +- libguile/error.c | 3 +- libguile/eval.c | 10 +++-- libguile/filesys.c | 68 ++++++++++++------------------ libguile/fports.c | 4 +- libguile/goops.c | 11 +---- libguile/hash.c | 12 +++--- libguile/hashtab.c | 24 ++++------- libguile/hooks.c | 12 ++---- libguile/ioext.c | 20 ++++----- libguile/list.c | 14 +++---- libguile/net_db.c | 7 ++-- libguile/ports.c | 27 ++++++------ libguile/posix.c | 94 ++++++++++++++++-------------------------- libguile/random.c | 3 +- libguile/regex-posix.c | 11 +++-- libguile/scmsigs.c | 33 ++++----------- libguile/simpos.c | 5 +-- libguile/sort.c | 6 +-- libguile/srcprop.c | 10 ++--- libguile/stacks.c | 5 +-- libguile/strings.c | 28 ++++++------- libguile/strop.c | 21 ++++------ libguile/struct.c | 26 +++++------- libguile/unif.c | 14 +++---- libguile/vectors.c | 31 +++++--------- 28 files changed, 221 insertions(+), 312 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3f8810034..565f78fb2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,30 @@ +2004-07-10 Marius Vollmer + + * socket.c (ipv6_net_to_num, scm_from_ipv6): Renamed + ipv6_net_to_num to scm_from_ipv6, for converting from an IPv& + byte-wise address to a SCM integer. Changed all uses. + (ipv6_num_to_net, scm_to_ipv6): Renamed ipv6_num_to_net to + scm_to_ipv6 and added type and range checking, for converting from + an IPv& byte-wise address to a SCM integer. Changed all uses. + (bignum_in_ipv6_range_p, VALIDATE_INET6): Removed, their function + is now done by scm_to_ipv6. + + * numbers.c (scm_to_signed_integer, scm_to_unsigned_integer): dot + not accept inexact integers. + + * validate.h, deprecated.h (SCM_VALIDATE_INUM, + SCM_VALIDATE_INUM_COPY, SCM_VALIDATE_BIGINT, + SCM_VALIDATE_INUM_MIN, SCM_VALIDATE_INUM_MIN_COPY, + SCM_VALIDATE_INUM_MIN_DEF_COPY,SCM_VALIDATE_INUM_DEF, + SCM_VALIDATE_INUM_DEF_COPY, SCM_VALIDATE_INUM_RANGE, + SCM_VALIDATE_INUM_RANGE_COPY): Deprecated because they make the + fixnum/bignum distinction visible. Changed all uses to + scm_to_size_t or similar. + +2004-07-09 Marius Vollmer + + * cpp_cnvt.awk: Use scm_from_int instead of SCM_MAKINUM. + 2004-07-10 Kevin Ryde * hash.c (scm_hashq, scm_hashv, scm_hash): Restrict to size>=1 rather diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 442d7e5c2..3e5080623 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -443,8 +443,6 @@ SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0, SCM_VALIDATE_OPOUTPORT (2, port); if (SCM_UNBNDP (indent)) indent = SCM_INUM0; - else - SCM_VALIDATE_INUM (3, indent); if (SCM_FRAME_PROC_P (frame)) /* Display an application. */ @@ -465,7 +463,7 @@ SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0, pstate->writingp = 1; pstate->fancyp = 1; - display_application (frame, SCM_INUM (indent), sport, port, pstate); + display_application (frame, scm_to_int (indent), sport, port, pstate); return SCM_BOOL_T; } else diff --git a/libguile/chars.c b/libguile/chars.c index c4fdf9b03..ea44ccfdc 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -249,8 +249,7 @@ SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0, "Return the character at position @var{n} in the ASCII sequence.") #define FUNC_NAME s_scm_integer_to_char { - SCM_VALIDATE_INUM_RANGE (1, n, 0, 256); - return SCM_MAKE_CHAR (SCM_INUM (n)); + return SCM_MAKE_CHAR (scm_to_uchar (n)); } #undef FUNC_NAME diff --git a/libguile/error.c b/libguile/error.c index 9968eb116..41588f7ce 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -148,8 +148,7 @@ SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0, "must be an integer value.") #define FUNC_NAME s_scm_strerror { - SCM_VALIDATE_INUM (1, err); - return scm_makfrom0str (SCM_I_STRERROR (SCM_INUM (err))); + return scm_makfrom0str (SCM_I_STRERROR (scm_to_int (err))); } #undef FUNC_NAME diff --git a/libguile/eval.c b/libguile/eval.c index 41f0b436b..af3d16719 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -328,6 +328,8 @@ syntax_error (const char* const msg, const SCM form, const SCM expr) * environment frame, the number of the binding within that frame, and a * boolean value indicating whether the binding is the last binding in the * frame. + * + * Frame numbers have 11 bits, relative offsets have 12 bits. */ #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc) @@ -339,6 +341,8 @@ syntax_error (const char* const msg, const SCM form, const SCM expr) #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20) #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n)) #define SCM_IDSTMSK (-SCM_IDINC) +#define SCM_IFRAMEMAX ((1<<11)-1) +#define SCM_IDISTMAX ((1<<12)-1) #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \ SCM_PACK ( \ ((frame_nr) << 8) \ @@ -365,10 +369,8 @@ SCM_DEFINE (scm_dbg_make_iloc, "dbg-make-iloc", 3, 0, 0, "offset @var{binding} and the cdr flag @var{cdrp}.") #define FUNC_NAME s_scm_dbg_make_iloc { - SCM_VALIDATE_INUM (1, frame); - SCM_VALIDATE_INUM (2, binding); - return SCM_MAKE_ILOC (SCM_INUM (frame), - SCM_INUM (binding), + return SCM_MAKE_ILOC (scm_to_unsigned_integer (frame, 0, SCM_IFRAME_MAX), + scm_to_unsigned_integer (binding, 0, SCM_IDIST_MAX), scm_is_true (cdrp)); } #undef FUNC_NAME diff --git a/libguile/filesys.c b/libguile/filesys.c index a836efb0a..7ae482288 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -201,22 +201,20 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0, object = SCM_COERCE_OUTPORT (object); - SCM_VALIDATE_INUM (2, owner); - SCM_VALIDATE_INUM (3, group); #ifdef HAVE_FCHOWN - if (SCM_INUMP (object) || (SCM_OPFPORTP (object))) + if (scm_is_integer (object) || (SCM_OPFPORTP (object))) { - int fdes = SCM_INUMP (object) ? SCM_INUM (object) - : SCM_FPORT_FDES (object); + int fdes = (SCM_OPFPORTP (object)? + SCM_FPORT_FDES (object) : scm_to_int (object)); - SCM_SYSCALL (rv = fchown (fdes, SCM_INUM (owner), SCM_INUM (group))); + SCM_SYSCALL (rv = fchown (fdes, scm_to_int (owner), scm_to_int (group))); } else #endif { SCM_VALIDATE_STRING (1, object); SCM_SYSCALL (rv = chown (SCM_STRING_CHARS (object), - SCM_INUM (owner), SCM_INUM (group))); + scm_to_int (owner), scm_to_int (group))); } if (rv == -1) SCM_SYSERROR; @@ -242,19 +240,18 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0, object = SCM_COERCE_OUTPORT (object); - SCM_VALIDATE_INUM (2, mode); - if (SCM_INUMP (object) || SCM_OPFPORTP (object)) + if (scm_is_integer (object) || SCM_OPFPORTP (object)) { - if (SCM_INUMP (object)) - fdes = SCM_INUM (object); + if (scm_is_integer (object)) + fdes = scm_to_int (object); else fdes = SCM_FPORT_FDES (object); - SCM_SYSCALL (rv = fchmod (fdes, SCM_INUM (mode))); + SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode))); } else { SCM_VALIDATE_STRING (1, object); - SCM_SYSCALL (rv = chmod (SCM_STRING_CHARS (object), SCM_INUM (mode))); + SCM_SYSCALL (rv = chmod (SCM_STRING_CHARS (object), scm_to_int (mode))); } if (rv == -1) SCM_SYSERROR; @@ -278,10 +275,9 @@ SCM_DEFINE (scm_umask, "umask", 0, 1, 0, } else { - SCM_VALIDATE_INUM (1, mode); - mask = umask (SCM_INUM (mode)); + mask = umask (scm_to_uint (mode)); } - return SCM_I_MAKINUM (mask); + return scm_from_uint (mask); } #undef FUNC_NAME @@ -380,8 +376,7 @@ SCM_DEFINE (scm_close, "close", 1, 0, 0, if (SCM_PORTP (fd_or_port)) return scm_close_port (fd_or_port); - SCM_VALIDATE_INUM (1, fd_or_port); - fd = SCM_INUM (fd_or_port); + fd = scm_to_int (fd_or_port); scm_evict_ports (fd); /* see scsh manual. */ SCM_SYSCALL (rv = close (fd)); /* following scsh, closing an already closed file descriptor is @@ -404,7 +399,7 @@ SCM_DEFINE (scm_close_fdes, "close-fdes", 1, 0, 0, int c_fd; int rv; - SCM_VALIDATE_INUM_COPY (1, fd, c_fd); + c_fd = scm_to_int (fd); SCM_SYSCALL (rv = close (c_fd)); if (rv < 0) SCM_SYSERROR; @@ -743,8 +738,7 @@ SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0, } else { - SCM_VALIDATE_INUM (2, mode); - SCM_SYSCALL (rv = mkdir (SCM_STRING_CHARS (path), SCM_INUM (mode))); + SCM_SYSCALL (rv = mkdir (SCM_STRING_CHARS (path), scm_to_uint (mode))); } if (rv != 0) SCM_SYSERROR; @@ -1213,16 +1207,13 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, time_ptr = 0; else { - if (SCM_INUMP (secs)) + if (scm_is_unsigned_integer (secs, 0, ULONG_MAX)) { - timeout.tv_sec = SCM_INUM (secs); + timeout.tv_sec = scm_to_ulong (secs); if (SCM_UNBNDP (usecs)) timeout.tv_usec = 0; else - { - SCM_VALIDATE_INUM (5, usecs); - timeout.tv_usec = SCM_INUM (usecs); - } + timeout.tv_usec = scm_to_long (usecs); } else { @@ -1288,25 +1279,20 @@ SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0, object = SCM_COERCE_OUTPORT (object); - SCM_VALIDATE_INUM (2, cmd); if (SCM_OPFPORTP (object)) fdes = SCM_FPORT_FDES (object); else - { - SCM_VALIDATE_INUM (1, object); - fdes = SCM_INUM (object); - } + fdes = scm_to_int (object); - if (SCM_UNBNDP (value)) { + if (SCM_UNBNDP (value)) ivalue = 0; - } else { - SCM_VALIDATE_INUM_COPY (SCM_ARG3, value, ivalue); - } + else + ivalue = scm_to_int (value); - SCM_SYSCALL (rv = fcntl (fdes, SCM_INUM (cmd), ivalue)); + SCM_SYSCALL (rv = fcntl (fdes, scm_to_int (cmd), ivalue)); if (rv == -1) SCM_SYSERROR; - return SCM_I_MAKINUM (rv); + return scm_from_int (rv); } #undef FUNC_NAME #endif /* HAVE_FCNTL */ @@ -1329,10 +1315,8 @@ SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0, fdes = SCM_FPORT_FDES (object); } else - { - SCM_VALIDATE_INUM (1, object); - fdes = SCM_INUM (object); - } + fdes = scm_to_int (object); + if (fsync (fdes) == -1) SCM_SYSERROR; return SCM_UNSPECIFIED; diff --git a/libguile/fports.c b/libguile/fports.c index af7116b80..b89a1999c 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -142,7 +142,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPFPORT (1,port); - SCM_VALIDATE_INUM_COPY (2,mode,cmode); + cmode = scm_to_int (mode); if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF) scm_out_of_range (FUNC_NAME, mode); @@ -165,7 +165,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, } else { - SCM_VALIDATE_INUM_COPY (3,size,csize); + csize = scm_to_int (size); if (csize < 0 || (cmode == _IONBF && csize > 0)) scm_out_of_range (FUNC_NAME, size); } diff --git a/libguile/goops.c b/libguile/goops.c index 4650add54..29a1f06ea 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1077,11 +1077,7 @@ SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0, unsigned long int i; SCM_VALIDATE_INSTANCE (1, obj); - SCM_VALIDATE_INUM (2, index); - SCM_ASSERT_RANGE (2, index, SCM_INUM (index) >= 0); - i = SCM_INUM (index); - SCM_ASSERT_RANGE (2, index, i < SCM_NUMBER_OF_SLOTS (obj)); - + i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1); return SCM_SLOT (obj, i); } #undef FUNC_NAME @@ -1095,10 +1091,7 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, unsigned long int i; SCM_VALIDATE_INSTANCE (1, obj); - SCM_VALIDATE_INUM (2, index); - SCM_ASSERT_RANGE (2, index, SCM_INUM (index) >= 0); - i = SCM_INUM (index); - SCM_ASSERT_RANGE (2, index, i < SCM_NUMBER_OF_SLOTS (obj)); + i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1); SCM_SET_SLOT (obj, i, value); diff --git a/libguile/hash.c b/libguile/hash.c index ed0ef5fbc..18c80c0dd 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -171,8 +171,8 @@ SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0, "different values, since @code{foo} will be garbage collected.") #define FUNC_NAME s_scm_hashq { - SCM_VALIDATE_INUM_MIN (2, size, 1); - return SCM_I_MAKINUM (scm_ihashq (key, SCM_INUM (size))); + unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX); + return scm_from_ulong (scm_ihashq (key, sz)); } #undef FUNC_NAME @@ -207,8 +207,8 @@ SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0, "different values, since @code{foo} will be garbage collected.") #define FUNC_NAME s_scm_hashv { - SCM_VALIDATE_INUM_MIN (2, size, 1); - return SCM_I_MAKINUM (scm_ihashv (key, SCM_INUM (size))); + unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX); + return scm_from_ulong (scm_ihashv (key, sz)); } #undef FUNC_NAME @@ -230,8 +230,8 @@ SCM_DEFINE (scm_hash, "hash", 2, 0, 0, "integer in the range 0 to @var{size} - 1.") #define FUNC_NAME s_scm_hash { - SCM_VALIDATE_INUM_MIN (2, size, 1); - return SCM_I_MAKINUM (scm_ihash (key, SCM_INUM (size))); + unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX); + return scm_from_ulong (scm_ihash (key, sz)); } #undef FUNC_NAME diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 1b83e4b0f..eae2f304a 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -312,11 +312,7 @@ SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0, if (SCM_UNBNDP (n)) return make_hash_table (0, 0, FUNC_NAME); else - { - int k; - SCM_VALIDATE_INUM_COPY (1, n, k); - return make_hash_table (0, k, FUNC_NAME); - } + return make_hash_table (0, scm_to_ulong (n), FUNC_NAME); } #undef FUNC_NAME @@ -335,11 +331,8 @@ SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0, if (SCM_UNBNDP (n)) return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME); else - { - int k; - SCM_VALIDATE_INUM_COPY (1, n, k); - return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, k, FUNC_NAME); - } + return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, + scm_to_ulong (n), FUNC_NAME); } #undef FUNC_NAME @@ -354,9 +347,8 @@ SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME); else { - int k; - SCM_VALIDATE_INUM_COPY (1, n, k); - return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, k, FUNC_NAME); + return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, + scm_to_ulong (n), FUNC_NAME); } } #undef FUNC_NAME @@ -374,10 +366,8 @@ SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0 FUNC_NAME); else { - int k; - SCM_VALIDATE_INUM_COPY (1, n, k); return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR, - k, + scm_to_ulong (n), FUNC_NAME); } } @@ -785,7 +775,7 @@ scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure) SCM answer = scm_call_2 (closure->hash, obj, scm_ulong2num ((unsigned long) n)); - return SCM_INUM (answer); + return scm_to_ulong (answer); } diff --git a/libguile/hooks.c b/libguile/hooks.c index 5be45b0bc..10a3e6525 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -154,18 +154,12 @@ SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0, "object to be used with the other hook procedures.") #define FUNC_NAME s_scm_make_hook { - int n; + unsigned int n; if (SCM_UNBNDP (n_args)) - { - n = 0; - } + n = 0; else - { - SCM_VALIDATE_INUM_COPY (SCM_ARG1, n_args, n); - if (n < 0 || n > 16) - SCM_OUT_OF_RANGE (SCM_ARG1, n_args); - } + n = scm_to_unsigned_integer (n_args, 0, 16); SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_UNPACK (SCM_EOL)); } diff --git a/libguile/ioext.c b/libguile/ioext.c index 9763e526d..0abce7f00 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -127,11 +127,11 @@ SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0, newfd = dup (oldfd); if (newfd == -1) SCM_SYSERROR; - fd = SCM_I_MAKINUM (newfd); + fd = scm_from_int (newfd); } else { - SCM_VALIDATE_INUM_COPY (2, fd, newfd); + newfd = scm_to_int (fd); if (oldfd != newfd) { scm_evict_ports (newfd); /* see scsh manual. */ @@ -161,8 +161,8 @@ SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0, int c_newfd; int rv; - SCM_VALIDATE_INUM_COPY (1, oldfd, c_oldfd); - SCM_VALIDATE_INUM_COPY (2, newfd, c_newfd); + c_oldfd = scm_to_int (oldfd); + c_newfd = scm_to_int (newfd); rv = dup2 (c_oldfd, c_newfd); if (rv == -1) SCM_SYSERROR; @@ -218,10 +218,9 @@ SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0, "same as that accepted by @ref{File Ports, open-file}.") #define FUNC_NAME s_scm_fdopen { - SCM_VALIDATE_INUM (1, fdes); SCM_VALIDATE_STRING (2, modes); - - return scm_fdes_to_port (SCM_INUM (fdes), SCM_STRING_CHARS (modes), SCM_BOOL_F); + return scm_fdes_to_port (scm_to_int (fdes), + SCM_STRING_CHARS (modes), SCM_BOOL_F); } #undef FUNC_NAME @@ -250,10 +249,9 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPFPORT (1, port); - SCM_VALIDATE_INUM (2, fd); stream = SCM_FSTREAM (port); old_fd = stream->fdes; - new_fd = SCM_INUM (fd); + new_fd = scm_to_int (fd); if (old_fd == new_fd) { return SCM_BOOL_F; @@ -279,8 +277,8 @@ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0, SCM result = SCM_EOL; int int_fd; long i; - - SCM_VALIDATE_INUM_COPY (1, fd, int_fd); + + int_fd = scm_to_int (fd); scm_mutex_lock (&scm_i_port_table_mutex); for (i = 0; i < scm_i_port_table_size; i++) diff --git a/libguile/list.c b/libguile/list.c index c22c42594..7654f6617 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -383,7 +383,7 @@ SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0, { SCM lst = list; unsigned long int i; - SCM_VALIDATE_INUM_MIN_COPY (2, k,0, i); + i = scm_to_ulong (k); while (SCM_CONSP (lst)) { if (i == 0) return SCM_CAR (lst); @@ -406,8 +406,7 @@ SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0, #define FUNC_NAME s_scm_list_set_x { SCM lst = list; - unsigned long int i; - SCM_VALIDATE_INUM_MIN_COPY (2, k,0, i); + unsigned long int i = scm_to_ulong (k); while (SCM_CONSP (lst)) { if (i == 0) { SCM_SETCAR (lst, val); @@ -437,8 +436,7 @@ SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0, "or returning the results of cdring @var{k} times down @var{lst}.") #define FUNC_NAME s_scm_list_tail { - register long i; - SCM_VALIDATE_INUM_MIN_COPY (2, k,0, i); + size_t i = scm_to_size_t (k); while (i-- > 0) { SCM_VALIDATE_CONS (1, lst); lst = SCM_CDR(lst); @@ -454,8 +452,7 @@ SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, #define FUNC_NAME s_scm_list_cdr_set_x { SCM lst = list; - unsigned long int i; - SCM_VALIDATE_INUM_MIN_COPY (2, k,0, i); + size_t i = scm_to_size_t (k); while (SCM_CONSP (lst)) { if (i == 0) { SCM_SETCDR (lst, val); @@ -484,9 +481,8 @@ SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0, { SCM answer; SCM * pos; - register long i; + size_t i = scm_to_size_t (k); - SCM_VALIDATE_INUM_MIN_COPY (2, k,0, i); answer = SCM_EOL; pos = &answer; while (i-- > 0) diff --git a/libguile/net_db.c b/libguile/net_db.c index b5c0c20e1..7076ce40b 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -333,12 +333,13 @@ SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0, SCM_VALIDATE_STRING (2, protocol); if (SCM_STRINGP (name)) { - entry = getservbyname (SCM_STRING_CHARS (name), SCM_STRING_CHARS (protocol)); + entry = getservbyname (SCM_STRING_CHARS (name), + SCM_STRING_CHARS (protocol)); } else { - SCM_VALIDATE_INUM (1, name); - entry = getservbyport (htons (SCM_INUM (name)), SCM_STRING_CHARS (protocol)); + entry = getservbyport (htons (scm_to_int (name)), + SCM_STRING_CHARS (protocol)); } if (!entry) SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name), errno); diff --git a/libguile/ports.c b/libguile/ports.c index dc35a908f..e277a9d82 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -598,9 +598,8 @@ SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0, "@code{--enable-guile-debug} builds.") #define FUNC_NAME s_scm_pt_member { - long i; - SCM_VALIDATE_INUM_COPY (1, index, i); - if (i < 0 || i >= scm_i_port_table_size) + size_t i = scm_to_size_t (index); + if (i >= scm_i_port_table_size) return SCM_BOOL_F; else return scm_i_port_table[i]->port; @@ -654,8 +653,7 @@ SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - SCM_VALIDATE_INUM (2, rcount); - SCM_REVEALED (port) = SCM_INUM (rcount); + SCM_REVEALED (port) = scm_to_int (rcount); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1351,8 +1349,12 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, fd_port = SCM_COERCE_OUTPORT (fd_port); - off = SCM_NUM2LONG (2, offset); - SCM_VALIDATE_INUM_COPY (3, whence, how); + if (sizeof (off_t) == sizeof (scm_t_intmax)) + off = scm_to_intmax (offset); + else + off = scm_to_long (offset); + how = scm_to_int (whence); + if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) SCM_OUT_OF_RANGE (3, whence); if (SCM_OPPORTP (fd_port)) @@ -1367,12 +1369,11 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, } else /* file descriptor?. */ { - SCM_VALIDATE_INUM (1, fd_port); - rv = lseek (SCM_INUM (fd_port), off, how); + rv = lseek (scm_to_int (fd_port), off, how); if (rv == -1) SCM_SYSERROR; } - return scm_long2num (rv); + return scm_from_intmax (rv); } #undef FUNC_NAME @@ -1472,8 +1473,7 @@ SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - SCM_VALIDATE_INUM (2, line); - SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line); + SCM_PTAB_ENTRY (port)->line_number = scm_to_int (line); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1504,8 +1504,7 @@ SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - SCM_VALIDATE_INUM (2, column); - SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column); + SCM_PTAB_ENTRY (port)->column_number = scm_to_int (column); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/posix.c b/libguile/posix.c index d2fb9571f..804e9a3d7 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -450,14 +450,12 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0, "@end defvar") #define FUNC_NAME s_scm_kill { - SCM_VALIDATE_INUM (1, pid); - SCM_VALIDATE_INUM (2, sig); /* Signal values are interned in scm_init_posix(). */ #ifdef HAVE_KILL - if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0) + if (kill (scm_to_int (pid), scm_to_int (sig)) != 0) #else - if ((int) SCM_INUM (pid) == getpid ()) - if (raise ((int) SCM_INUM (sig)) != 0) + if (scm_to_int (pid) == getpid ()) + if (raise (scm_to_int (sig)) != 0) #endif SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -506,19 +504,17 @@ SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0, int i; int status; int ioptions; - SCM_VALIDATE_INUM (1, pid); if (SCM_UNBNDP (options)) ioptions = 0; else { - SCM_VALIDATE_INUM (2, options); /* Flags are interned in scm_init_posix. */ - ioptions = SCM_INUM (options); + ioptions = scm_to_int (options); } - SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions)); + SCM_SYSCALL (i = waitpid (scm_to_int (pid), &status, ioptions)); if (i == -1) SCM_SYSERROR; - return scm_cons (SCM_I_MAKINUM (0L + i), SCM_I_MAKINUM (0L + status)); + return scm_cons (scm_from_int (i), scm_from_int (status)); } #undef FUNC_NAME #endif /* HAVE_WAITPID */ @@ -533,13 +529,11 @@ SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, { int lstatus; - SCM_VALIDATE_INUM (1, status); - /* On Ultrix, the WIF... macros assume their argument is an lvalue; go figure. SCM_INUM does not yield an lvalue. */ - lstatus = SCM_INUM (status); + lstatus = scm_to_int (status); if (WIFEXITED (lstatus)) - return (SCM_I_MAKINUM (WEXITSTATUS (lstatus))); + return (scm_from_int (WEXITSTATUS (lstatus))); else return SCM_BOOL_F; } @@ -553,11 +547,9 @@ SCM_DEFINE (scm_status_term_sig, "status:term-sig", 1, 0, 0, { int lstatus; - SCM_VALIDATE_INUM (1, status); - - lstatus = SCM_INUM (status); + lstatus = scm_to_int (status); if (WIFSIGNALED (lstatus)) - return SCM_I_MAKINUM (WTERMSIG (lstatus)); + return scm_from_int (WTERMSIG (lstatus)); else return SCM_BOOL_F; } @@ -571,11 +563,9 @@ SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0, { int lstatus; - SCM_VALIDATE_INUM (1, status); - - lstatus = SCM_INUM (status); + lstatus = scm_to_int (status); if (WIFSTOPPED (lstatus)) - return SCM_I_MAKINUM (WSTOPSIG (lstatus)); + return scm_from_int (WSTOPSIG (lstatus)); else return SCM_BOOL_F; } @@ -659,8 +649,7 @@ SCM_DEFINE (scm_setuid, "setuid", 1, 0, 0, "The return value is unspecified.") #define FUNC_NAME s_scm_setuid { - SCM_VALIDATE_INUM (1, id); - if (setuid (SCM_INUM (id)) != 0) + if (setuid (scm_to_int (id)) != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -673,8 +662,7 @@ SCM_DEFINE (scm_setgid, "setgid", 1, 0, 0, "The return value is unspecified.") #define FUNC_NAME s_scm_setgid { - SCM_VALIDATE_INUM (1, id); - if (setgid (SCM_INUM (id)) != 0) + if (setgid (scm_to_int (id)) != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -691,11 +679,10 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0, { int rv; - SCM_VALIDATE_INUM (1, id); #ifdef HAVE_SETEUID - rv = seteuid (SCM_INUM (id)); + rv = seteuid (scm_to_int (id)); #else - rv = setuid (SCM_INUM (id)); + rv = setuid (scm_to_int (id)); #endif if (rv != 0) SCM_SYSERROR; @@ -717,11 +704,10 @@ SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, { int rv; - SCM_VALIDATE_INUM (1, id); #ifdef HAVE_SETEUID - rv = setegid (SCM_INUM (id)); + rv = setegid (scm_to_int (id)); #else - rv = setgid (SCM_INUM (id)); + rv = setgid (scm_to_int (id)); #endif if (rv != 0) SCM_SYSERROR; @@ -757,10 +743,8 @@ SCM_DEFINE (scm_setpgid, "setpgid", 2, 0, 0, "The return value is unspecified.") #define FUNC_NAME s_scm_setpgid { - SCM_VALIDATE_INUM (1, pid); - SCM_VALIDATE_INUM (2, pgid); /* FIXME(?): may be known as setpgrp. */ - if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0) + if (setpgid (scm_to_int (pid), scm_to_int (pgid)) != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -867,9 +851,8 @@ SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0, port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPFPORT (1, port); - SCM_VALIDATE_INUM (2, pgid); fd = SCM_FPORT_FDES (port); - if (tcsetpgrp (fd, SCM_INUM (pgid)) == -1) + if (tcsetpgrp (fd, scm_to_int (pgid)) == -1) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -1218,8 +1201,7 @@ SCM_DEFINE (scm_access, "access?", 2, 0, 0, int rv; SCM_VALIDATE_STRING (1, path); - SCM_VALIDATE_INUM (2, how); - rv = access (SCM_STRING_CHARS (path), SCM_INUM (how)); + rv = access (SCM_STRING_CHARS (path), scm_to_int (how)); return scm_from_bool (!rv); } #undef FUNC_NAME @@ -1343,7 +1325,6 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, char *clocale; char *rv; - SCM_VALIDATE_INUM (1, category); if (SCM_UNBNDP (locale)) { clocale = NULL; @@ -1354,7 +1335,7 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, clocale = SCM_STRING_CHARS (locale); } - rv = setlocale (SCM_INUM (category), clocale); + rv = setlocale (scm_to_int (category), clocale); if (rv == NULL) SCM_SYSERROR; return scm_makfrom0str (rv); @@ -1386,8 +1367,6 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, SCM_VALIDATE_STRING (1, path); SCM_VALIDATE_SYMBOL (2, type); - SCM_VALIDATE_INUM (3, perms); - SCM_VALIDATE_INUM (4, dev); p = SCM_SYMBOL_CHARS (type); if (strcmp (p, "regular") == 0) @@ -1409,8 +1388,9 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, else SCM_OUT_OF_RANGE (2, type); - SCM_SYSCALL (val = mknod (SCM_STRING_CHARS (path), ctype | SCM_INUM (perms), - SCM_INUM (dev))); + SCM_SYSCALL (val = mknod (SCM_STRING_CHARS (path), + ctype | scm_to_int (perms), + scm_to_int (dev))); if (val != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1426,8 +1406,7 @@ SCM_DEFINE (scm_nice, "nice", 1, 0, 0, "The return value is unspecified.") #define FUNC_NAME s_scm_nice { - SCM_VALIDATE_INUM (1, incr); - if (nice(SCM_INUM(incr)) != 0) + if (nice (scm_to_int (incr)) != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -1553,8 +1532,8 @@ SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0, { int cwhich, cwho, ret; - SCM_VALIDATE_INUM_COPY (1, which, cwhich); - SCM_VALIDATE_INUM_COPY (2, who, cwho); + cwhich = scm_to_int (which); + cwho = scm_to_int (who); /* We have to clear errno and examine it later, because -1 is a legal return value for getpriority(). */ @@ -1562,7 +1541,7 @@ SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0, ret = getpriority (cwhich, cwho); if (errno != 0) SCM_SYSERROR; - return SCM_I_MAKINUM (ret); + return scm_from_int (ret); } #undef FUNC_NAME #endif /* HAVE_GETPRIORITY */ @@ -1587,9 +1566,9 @@ SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0, { int cwhich, cwho, cprio; - SCM_VALIDATE_INUM_COPY (1, which, cwhich); - SCM_VALIDATE_INUM_COPY (2, who, cwho); - SCM_VALIDATE_INUM_COPY (3, prio, cprio); + cwhich = scm_to_int (which); + cwho = scm_to_int (who); + cprio = scm_to_int (prio); if (setpriority (cwhich, cwho, cprio) == -1) SCM_SYSERROR; @@ -1714,18 +1693,17 @@ SCM_DEFINE (scm_flock, "flock", 2, 0, 0, "file descriptor or an open file descriptor port.") #define FUNC_NAME s_scm_flock { - int coperation, fdes; + int fdes; - if (SCM_INUMP (file)) - fdes = SCM_INUM (file); + if (scm_is_integer (file)) + fdes = scm_to_int (file); else { SCM_VALIDATE_OPFPORT (2, file); fdes = SCM_FPORT_FDES (file); } - SCM_VALIDATE_INUM_COPY (2, operation, coperation); - if (flock (fdes, coperation) == -1) + if (flock (fdes, scm_to_int (operation)) == -1) SCM_SYSERROR; return SCM_UNSPECIFIED; } diff --git a/libguile/random.c b/libguile/random.c index ace6234f0..a6ad9aae8 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -360,7 +360,8 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0, return scm_make_real (SCM_REAL_VALUE (n) * scm_c_uniform01 (SCM_RSTATE (state))); - SCM_VALIDATE_BIGINT (1, n); + if (!SCM_BIGP (n)) + SCM_WRONG_TYPE_ARG (1, n); return scm_c_random_bignum (SCM_RSTATE (state), n); } #undef FUNC_NAME diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 9a128bf42..a38f440ff 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -230,11 +230,14 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, SCM_VALIDATE_RGXP (1, rx); SCM_VALIDATE_STRING (2, str); - SCM_VALIDATE_INUM_DEF_COPY (3, start,0, offset); - SCM_ASSERT_RANGE (3, start, offset >= 0 && offset <= SCM_STRING_LENGTH (str)); + + if (SCM_UNBNDP (start)) + offset = 0; + else + offset = scm_to_signed_integer (start, 0, SCM_STRING_LENGTH (str)); + if (SCM_UNBNDP (flags)) flags = SCM_INUM0; - SCM_VALIDATE_INUM (4, flags); /* re_nsub doesn't account for the `subexpression' representing the whole regexp, so add 1 to nmatches. */ @@ -244,7 +247,7 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, matches = scm_malloc (sizeof (regmatch_t) * nmatches); status = regexec (SCM_RGX (rx), SCM_STRING_CHARS (str) + offset, nmatches, matches, - SCM_INUM (flags)); + scm_to_int (flags)); if (!status) { int i; diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index d5cb7c219..ad58fabe7 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -298,9 +298,8 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, SCM old_handler; - SCM_VALIDATE_INUM_COPY (1, signum, csig); - if (csig < 0 || csig >= NSIG) - SCM_OUT_OF_RANGE (1, signum); + csig = scm_to_signed_integer (signum, 0, NSIG-1); + #if defined(HAVE_SIGACTION) #if defined(SA_RESTART) && defined(HAVE_RESTARTABLE_SYSCALLS) /* don't allow SA_RESTART to be omitted if HAVE_RESTARTABLE_SYSCALLS @@ -311,10 +310,7 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, action.sa_flags = 0; #endif if (!SCM_UNBNDP (flags)) - { - SCM_VALIDATE_INUM (3, flags); - action.sa_flags |= SCM_INUM (flags); - } + action.sa_flags |= scm_to_int (flags); sigemptyset (&action.sa_mask); #endif @@ -497,10 +493,7 @@ SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0, "no previous alarm, the return value is zero.") #define FUNC_NAME s_scm_alarm { - unsigned int j; - SCM_VALIDATE_INUM (1, i); - j = alarm (SCM_INUM (i)); - return SCM_I_MAKINUM (j); + return scm_from_uint (alarm (scm_to_uint (i))); } #undef FUNC_NAME @@ -608,23 +601,16 @@ SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0, "of seconds remaining otherwise.") #define FUNC_NAME s_scm_sleep { - unsigned long j; - SCM_VALIDATE_INUM_MIN (1, i,0); - j = scm_thread_sleep (SCM_INUM(i)); - return scm_ulong2num (j); + return scm_from_ulong (scm_thread_sleep (scm_to_int (i))); } #undef FUNC_NAME SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0, (SCM i), - "Sleep for I microseconds. @code{usleep} is not available on\n" - "all platforms.") + "Sleep for @var{i} microseconds.") #define FUNC_NAME s_scm_usleep { - unsigned long j; - SCM_VALIDATE_INUM_MIN (1, i,0); - j = scm_thread_usleep (SCM_INUM (i)); - return scm_ulong2num (j); + return scm_from_ulong (scm_thread_usleep (scm_to_ulong (i))); } #undef FUNC_NAME @@ -634,11 +620,8 @@ SCM_DEFINE (scm_raise, "raise", 1, 0, 0, "@var{sig} is as described for the kill procedure.") #define FUNC_NAME s_scm_raise { - SCM_VALIDATE_INUM (1, sig); - SCM_DEFER_INTS; - if (kill (getpid (), (int) SCM_INUM (sig)) != 0) + if (kill (getpid (), scm_to_int (sig)) != 0) SCM_SYSERROR; - SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/simpos.c b/libguile/simpos.c index f6459c445..d23e949f4 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -218,10 +218,7 @@ SCM_DEFINE (scm_primitive_exit, "primitive-exit", 0, 1, 0, { int cstatus = 0; if (!SCM_UNBNDP (status)) - { - SCM_VALIDATE_INUM (1, status); - cstatus = SCM_INUM (status); - } + cstatus = scm_to_int (status); exit (cstatus); } #undef FUNC_NAME diff --git a/libguile/sort.c b/libguile/sort.c index 58d02f9e8..3128ffa3d 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -299,10 +299,8 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, vp = SCM_WRITABLE_VELTS (vec); /* vector pointer */ vlen = SCM_VECTOR_LENGTH (vec); - SCM_VALIDATE_INUM_MIN_COPY (3, startpos, 0, spos); - SCM_ASSERT_RANGE (3, startpos, spos <= vlen); - SCM_VALIDATE_INUM_RANGE (4, endpos,0, vlen+1); - len = SCM_INUM (endpos) - spos; + spos = scm_to_unsigned_integer (startpos, 0, vlen); + len = scm_to_unsigned_integer (endpos, 0, vlen) - spos; quicksort (&vp[spos], len, cmp, less); scm_remember_upto_here_1 (vec); diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 4e1c02834..a237fb06c 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -260,22 +260,20 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, } else if (SCM_EQ_P (scm_sym_line, key)) { - SCM_VALIDATE_INUM (3, datum); if (SRCPROPSP (p)) - SETSRCPROPLINE (p, SCM_INUM (datum)); + SETSRCPROPLINE (p, scm_to_int (datum)); else SCM_WHASHSET (scm_source_whash, h, - scm_make_srcprops (SCM_INUM (datum), 0, + scm_make_srcprops (scm_to_int (datum), 0, SCM_UNDEFINED, SCM_UNDEFINED, p)); } else if (SCM_EQ_P (scm_sym_column, key)) { - SCM_VALIDATE_INUM (3, datum); if (SRCPROPSP (p)) - SETSRCPROPCOL (p, SCM_INUM (datum)); + SETSRCPROPCOL (p, scm_to_int (datum)); else SCM_WHASHSET (scm_source_whash, h, - scm_make_srcprops (0, SCM_INUM (datum), + scm_make_srcprops (0, scm_to_int (datum), SCM_UNDEFINED, SCM_UNDEFINED, p)); } else if (SCM_EQ_P (scm_sym_filename, key)) diff --git a/libguile/stacks.c b/libguile/stacks.c index cf92a267f..483e3d4e5 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -551,10 +551,7 @@ SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0, unsigned long int c_index; SCM_VALIDATE_STACK (1, stack); - SCM_VALIDATE_INUM (2, index); - SCM_ASSERT_RANGE (1, index, SCM_INUM (index) >= 0); - c_index = SCM_INUM (index); - SCM_ASSERT_RANGE (1, index, c_index < SCM_STACK_LENGTH (stack)); + c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1); return scm_cons (stack, index); } #undef FUNC_NAME diff --git a/libguile/strings.c b/libguile/strings.c index 20000980b..ad8486c1d 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -227,11 +227,10 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, "indexing. @var{k} must be a valid index of @var{str}.") #define FUNC_NAME s_scm_string_ref { - long idx; + unsigned long idx; SCM_VALIDATE_STRING (1, str); - SCM_VALIDATE_INUM_COPY (2, k, idx); - SCM_ASSERT_RANGE (2, k, idx >= 0 && idx < SCM_STRING_LENGTH (str)); + idx = scm_to_unsigned_integer (k, 0, SCM_STRING_LENGTH(str)-1); return SCM_MAKE_CHAR (SCM_STRING_UCHARS (str)[idx]); } #undef FUNC_NAME @@ -244,10 +243,12 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, "@var{str}.") #define FUNC_NAME s_scm_string_set_x { + unsigned long idx; + SCM_VALIDATE_STRING (1, str); - SCM_VALIDATE_INUM_RANGE (2, k,0, SCM_STRING_LENGTH(str)); + idx = scm_to_unsigned_integer (k, 0, SCM_STRING_LENGTH(str)-1); SCM_VALIDATE_CHAR (3, chr); - SCM_STRING_UCHARS (str)[SCM_INUM (k)] = SCM_CHAR (chr); + SCM_STRING_UCHARS (str)[idx] = SCM_CHAR (chr); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -263,19 +264,16 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, "0 <= @var{start} <= @var{end} <= (string-length @var{str}).") #define FUNC_NAME s_scm_substring { - long int from; - long int to; + unsigned long int from; + unsigned long int to; SCM substr; SCM_VALIDATE_STRING (1, str); - SCM_VALIDATE_INUM (2, start); - SCM_VALIDATE_INUM_DEF (3, end, SCM_STRING_LENGTH (str)); - - from = SCM_INUM (start); - SCM_ASSERT_RANGE (2, start, 0 <= from && from <= SCM_STRING_LENGTH (str)); - to = SCM_INUM (end); - SCM_ASSERT_RANGE (3, end, from <= to && to <= SCM_STRING_LENGTH (str)); - + from = scm_to_unsigned_integer (start, 0, SCM_STRING_LENGTH(str)); + if (SCM_UNBNDP (end)) + to = SCM_STRING_LENGTH(str); + else + to = scm_to_unsigned_integer (end, from, SCM_STRING_LENGTH(str)); substr = scm_mem2string (&SCM_STRING_CHARS (str)[from], to - from); scm_remember_upto_here_1 (str); return substr; diff --git a/libguile/strop.c b/libguile/strop.c index ae83f2e24..415fd5068 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -165,19 +165,14 @@ SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, "@var{str1} and @var{str2} can be the same string.") #define FUNC_NAME s_scm_substring_move_x { - long s1, s2, e, len; + unsigned long s1, s2, e, len; SCM_VALIDATE_STRING (1, str1); - SCM_VALIDATE_INUM_COPY (2, start1, s1); - SCM_VALIDATE_INUM_COPY (3, end1, e); SCM_VALIDATE_STRING (4, str2); - SCM_VALIDATE_INUM_COPY (5, start2, s2); + s1 = scm_to_unsigned_integer (start1, 0, SCM_STRING_LENGTH(str1)); + e = scm_to_unsigned_integer (end1, s1, SCM_STRING_LENGTH(str1)); len = e - s1; - SCM_ASSERT_RANGE (3, end1, len >= 0); - SCM_ASSERT_RANGE (2, start1, s1 <= SCM_STRING_LENGTH (str1) && s1 >= 0); - SCM_ASSERT_RANGE (5, start2, s2 <= SCM_STRING_LENGTH (str2) && s2 >= 0); - SCM_ASSERT_RANGE (3, end1, e <= SCM_STRING_LENGTH (str1) && e >= 0); - SCM_ASSERT_RANGE (5, start2, len+s2 <= SCM_STRING_LENGTH (str2)); + s2 = scm_to_unsigned_integer (start2, 0, SCM_STRING_LENGTH(str2)-len); SCM_SYSCALL(memmove((void *)(&(SCM_STRING_CHARS(str2)[s2])), (void *)(&(SCM_STRING_CHARS(str1)[s1])), @@ -201,14 +196,12 @@ SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, "@end lisp") #define FUNC_NAME s_scm_substring_fill_x { - long i, e; + size_t i, e; char c; SCM_VALIDATE_STRING (1, str); - SCM_VALIDATE_INUM_COPY (2, start, i); - SCM_VALIDATE_INUM_COPY (3, end, e); + i = scm_to_unsigned_integer (start, 0, SCM_STRING_LENGTH (str)); + e = scm_to_unsigned_integer (end, i, SCM_STRING_LENGTH (str)); SCM_VALIDATE_CHAR_COPY (4, fill, c); - SCM_ASSERT_RANGE (2, start, i <= SCM_STRING_LENGTH (str) && i >= 0); - SCM_ASSERT_RANGE (3, end, e <= SCM_STRING_LENGTH (str) && e >= 0); while (i= 0 && pos < length, outrng); @@ -1252,7 +1250,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, } else { - SCM_VALIDATE_INUM_COPY (3, args, pos); + pos = scm_to_long (args); } length = SCM_INUM (scm_uniform_vector_length (v)); SCM_ASRTGO (pos >= 0 && pos < length, outrng); @@ -1804,7 +1802,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, SCM_VALIDATE_BOOL (1, item); SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME); - SCM_VALIDATE_INUM_COPY (3, k, pos); + pos = scm_to_long (k); SCM_ASSERT_RANGE (3, k, (pos <= SCM_BITVECTOR_LENGTH (v)) && (pos >= 0)); if (pos == SCM_BITVECTOR_LENGTH (v)) @@ -2201,7 +2199,7 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, SCM ra; unsigned long k; long n; - SCM_VALIDATE_INUM_COPY (1, ndim, k); + k = scm_to_ulong (ndim); while (k--) { n = scm_ilength (row); diff --git a/libguile/vectors.c b/libguile/vectors.c index e95ffdcd0..6aa9def6e 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -262,19 +262,13 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, "@var{start1} is greater than @var{start2}.") #define FUNC_NAME s_scm_vector_move_left_x { - long i; - long j; - long e; + size_t i, j, e; SCM_VALIDATE_VECTOR (1, vec1); - SCM_VALIDATE_INUM_COPY (2, start1, i); - SCM_VALIDATE_INUM_COPY (3, end1, e); SCM_VALIDATE_VECTOR (4, vec2); - SCM_VALIDATE_INUM_COPY (5, start2, j); - SCM_ASSERT_RANGE (2, start1, i <= SCM_VECTOR_LENGTH (vec1) && i >= 0); - SCM_ASSERT_RANGE (5, start2, j <= SCM_VECTOR_LENGTH (vec2) && j >= 0); - SCM_ASSERT_RANGE (3, end1, e <= SCM_VECTOR_LENGTH (vec1) && e >= 0); - SCM_ASSERT_RANGE (5, start2, e-i+j <= SCM_VECTOR_LENGTH (vec2)); + i = scm_to_unsigned_integer (start1, 0, SCM_VECTOR_LENGTH(vec1)); + e = scm_to_unsigned_integer (end1, i, SCM_VECTOR_LENGTH(vec1)); + j = scm_to_unsigned_integer (start2, 0, SCM_VECTOR_LENGTH(vec2)-(i-e)); while (i= 0); - SCM_ASSERT_RANGE (5, start2, j <= SCM_VECTOR_LENGTH (vec2) && j >= 0); - SCM_ASSERT_RANGE (3, end1, e <= SCM_VECTOR_LENGTH (vec1) && e >= 0); - j = e - i + j; - SCM_ASSERT_RANGE (5, start2, j <= SCM_VECTOR_LENGTH (vec2)); + i = scm_to_unsigned_integer (start1, 0, SCM_VECTOR_LENGTH(vec1)); + e = scm_to_unsigned_integer (end1, i, SCM_VECTOR_LENGTH(vec1)); + j = scm_to_unsigned_integer (start2, 0, SCM_VECTOR_LENGTH(vec2)-(i-e)); + + j += e - i; while (i < e) { j--; From abe1308cb9084da032016f8c158df45ef29919ae Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 14:39:12 +0000 Subject: [PATCH 21/89] (test_is_signed_integer, test_is_unsigned_integer): Expect inexact integers to fail. --- test-suite/standalone/test-conversion.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c index 6c718bf81..7dc792de9 100644 --- a/test-suite/standalone/test-conversion.c +++ b/test-suite/standalone/test-conversion.c @@ -40,6 +40,9 @@ test_is_signed_integer () SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX, 0); test_1 ("3.0", + SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX, + 0); + test_1 ("(inexact->exact 3.0)", SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX, 1); test_1 ("3.5", @@ -122,6 +125,9 @@ test_is_unsigned_integer () 0, SCM_T_UINTMAX_MAX, 0); test_2 ("3.0", + 0, SCM_T_UINTMAX_MAX, + 0); + test_2 ("(inexact->exact 3.0)", 0, SCM_T_UINTMAX_MAX, 1); test_2 ("3.5", From ac9a5a03e56f3851d93173df2bc7c2649d042de7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 14:39:56 +0000 Subject: [PATCH 22/89] use scm_is_true instead of SCM_NFALSEP in the examples. --- doc/ref/scheme-utility.texi | 762 ------------------------------------ 1 file changed, 762 deletions(-) diff --git a/doc/ref/scheme-utility.texi b/doc/ref/scheme-utility.texi index 4fa95c9a7..e69de29bb 100644 --- a/doc/ref/scheme-utility.texi +++ b/doc/ref/scheme-utility.texi @@ -1,762 +0,0 @@ -@c -*-texinfo-*- -@c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 -@c Free Software Foundation, Inc. -@c See the file guile.texi for copying conditions. - -@page -@node Utility Functions -@section General Utility Functions - -@c FIXME::martin: Review me! - -This chapter contains information about procedures which are not cleanly -tied to a specific data type. Because of their wide range of -applications, they are collected in a @dfn{utility} chapter. - -@menu -* Equality:: When are two values `the same'? -* Object Properties:: A modern interface to object properties. -* Sorting:: Sort utility procedures. -* Copying:: Copying deep structures. -* General Conversion:: Converting objects to strings. -* Hooks:: User-customizable event lists. -@end menu - - -@node Equality -@subsection Equality - -@c FIXME::martin: Review me! - -@cindex sameness -@cindex equality - -Three different kinds of @dfn{sameness} are defined in Scheme. - -@itemize @bullet -@item -Two values can refer to exactly the same object. - -@item -Two objects can have the same @dfn{value}. - -@item -Two objects can be structurally equivalent. -@end itemize - -The differentiation between these three kinds is important, because -determining whether two values are the same objects is very efficient, -while determining structural equivalence can be quite expensive -(consider comparing two very long lists). Therefore, three different -procedures for testing for equality are provided, which correspond to -the three kinds of @dfn{sameness} defined above. - -@rnindex eq? -@deffn {Scheme Procedure} eq? x y -@deffnx {C Function} scm_eq_p (x, y) -Return @code{#t} iff @var{x} references the same object as @var{y}. -@code{eq?} is similar to @code{eqv?} except that in some cases it is -capable of discerning distinctions finer than those detectable by -@code{eqv?}. -@end deffn - -@deftypefn {C Function} int scm_is_eq (SCM x, SCM y) -Return @code{1} when @var{x} and @var{y} are equal in the sense of -@code{eq?}, else return @code{0}. -@end deftypefn - -@rnindex eqv? -@deffn {Scheme Procedure} eqv? x y -@deffnx {C Function} scm_eqv_p (x, y) -The @code{eqv?} procedure defines a useful equivalence relation on objects. -Briefly, it returns @code{#t} if @var{x} and @var{y} should normally be -regarded as the same object. This relation is left slightly open to -interpretation, but works for comparing immediate integers, characters, -and inexact numbers. -@end deffn - -@rnindex equal? -@deffn {Scheme Procedure} equal? x y -@deffnx {C Function} scm_equal_p (x, y) -Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} -equivalent. @code{equal?} recursively compares the contents of pairs, -vectors, and strings, applying @code{eqv?} on other objects such as -numbers and symbols. A rule of thumb is that objects are generally -@code{equal?} if they print the same. @code{equal?} may fail to -terminate if its arguments are circular data structures. -@end deffn - - -@node Object Properties -@subsection Object Properties - -It's often useful to associate a piece of additional information with a -Scheme object even though that object does not have a dedicated slot -available in which the additional information could be stored. Object -properties allow you to do just that. - -An object property is most commonly used to associate one kind of -additional information with each instance of a class of similar Scheme -objects. For example, all procedures have a `name' property, which -stores the name of the variable in which the procedure was stored by a -@code{define} expression, or @code{#f} if the procedure wasn't created -by that kind of expression. - -Guile's representation of an object property is a procedure-with-setter -(@pxref{Procedures with Setters}) that can be used with the generalized -form of @code{set!} (REFFIXME) to set and retrieve that property for any -Scheme object. So, setting a property looks like this: - -@lisp -(set! (my-property obj1) value-for-obj1) -(set! (my-property obj2) value-for-obj2) -@end lisp - -@noindent -And retrieving values of the same property looks like this: - -@lisp -(my-property obj1) -@result{} -value-for-obj1 - -(my-property obj2) -@result{} -value-for-obj2 -@end lisp - -To create an object property in the first place, use the -@code{make-object-property} procedure: - -@lisp -(define my-property (make-object-property)) -@end lisp - -@deffn {Scheme Procedure} make-object-property -Create and return an object property. An object property is a -procedure-with-setter that can be called in two ways. @code{(set! -(@var{property} @var{obj}) @var{val})} sets @var{obj}'s @var{property} -to @var{val}. @code{(@var{property} @var{obj})} returns the current -setting of @var{obj}'s @var{property}. -@end deffn - -A single object property created by @code{make-object-property} can -associate distinct property values with all Scheme values that are -distinguishable by @code{eq?} (including, for example, integers). - -Internally, object properties are implemented using a weak key hash -table. This means that, as long as a Scheme value with property values -is protected from garbage collection, its property values are also -protected. When the Scheme value is collected, its entry in the -property table is removed and so the (ex-) property values are no longer -protected by the table. - -@menu -* Property Primitives:: Low level property implementation. -* Old-fashioned Properties:: An older approach to properties. -@end menu - - -@node Property Primitives -@subsubsection Low Level Property Implementation. - -@deffn {Scheme Procedure} primitive-make-property not-found-proc -@deffnx {C Function} scm_primitive_make_property (not_found_proc) -Create a @dfn{property token} that can be used with -@code{primitive-property-ref} and @code{primitive-property-set!}. -See @code{primitive-property-ref} for the significance of -@var{not-found-proc}. -@end deffn - -@deffn {Scheme Procedure} primitive-property-ref prop obj -@deffnx {C Function} scm_primitive_property_ref (prop, obj) -Return the property @var{prop} of @var{obj}. - -When no value has yet been associated with @var{prop} and @var{obj}, -the @var{not-found-proc} from @var{prop} is used. A call -@code{(@var{not-found-proc} @var{prop} @var{obj})} is made and the -result set as the property value. If @var{not-found-proc} is -@code{#f} then @code{#f} is the property value. -@end deffn - -@deffn {Scheme Procedure} primitive-property-set! prop obj val -@deffnx {C Function} scm_primitive_property_set_x (prop, obj, val) -Set the property @var{prop} of @var{obj} to @var{val}. -@end deffn - -@deffn {Scheme Procedure} primitive-property-del! prop obj -@deffnx {C Function} scm_primitive_property_del_x (prop, obj) -Remove any value associated with @var{prop} and @var{obj}. -@end deffn - - -@node Old-fashioned Properties -@subsubsection An Older Approach to Properties - -Traditionally, Lisp systems provide a different object property -interface to that provided by @code{make-object-property}, in which the -object property that is being set or retrieved is indicated by a symbol. - -Guile includes this older kind of interface as well, but it may well be -removed in a future release, as it is less powerful than -@code{make-object-property} and so increases the size of the Guile -library for no benefit. (And it is trivial to write a compatibility -layer in Scheme.) - -@deffn {Scheme Procedure} object-properties obj -@deffnx {C Function} scm_object_properties (obj) -Return @var{obj}'s property list. -@end deffn - -@deffn {Scheme Procedure} set-object-properties! obj alist -@deffnx {C Function} scm_set_object_properties_x (obj, alist) -Set @var{obj}'s property list to @var{alist}. -@end deffn - -@deffn {Scheme Procedure} object-property obj key -@deffnx {C Function} scm_object_property (obj, key) -Return the property of @var{obj} with name @var{key}. -@end deffn - -@deffn {Scheme Procedure} set-object-property! obj key value -@deffnx {C Function} scm_set_object_property_x (obj, key, value) -In @var{obj}'s property list, set the property named @var{key} -to @var{value}. -@end deffn - - -@node Sorting -@subsection Sorting - -@c FIXME::martin: Review me! - -@cindex sorting -@cindex sorting lists -@cindex sorting vectors - -Sorting is very important in computer programs. Therefore, Guile comes -with several sorting procedures built-in. As always, procedures with -names ending in @code{!} are side-effecting, that means that they may -modify their parameters in order to produce their results. - -The first group of procedures can be used to merge two lists (which must -be already sorted on their own) and produce sorted lists containing -all elements of the input lists. - -@deffn {Scheme Procedure} merge alist blist less -@deffnx {C Function} scm_merge (alist, blist, less) -Merge two already sorted lists into one. -Given two lists @var{alist} and @var{blist}, such that -@code{(sorted? alist less?)} and @code{(sorted? blist less?)}, -return a new list in which the elements of @var{alist} and -@var{blist} have been stably interleaved so that -@code{(sorted? (merge alist blist less?) less?)}. -Note: this does _not_ accept vectors. -@end deffn - -@deffn {Scheme Procedure} merge! alist blist less -@deffnx {C Function} scm_merge_x (alist, blist, less) -Takes two lists @var{alist} and @var{blist} such that -@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and -returns a new list in which the elements of @var{alist} and -@var{blist} have been stably interleaved so that - @code{(sorted? (merge alist blist less?) less?)}. -This is the destructive variant of @code{merge} -Note: this does _not_ accept vectors. -@end deffn - -The following procedures can operate on sequences which are either -vectors or list. According to the given arguments, they return sorted -vectors or lists, respectively. The first of the following procedures -determines whether a sequence is already sorted, the other sort a given -sequence. The variants with names starting with @code{stable-} are -special in that they maintain a special property of the input sequences: -If two or more elements are the same according to the comparison -predicate, they are left in the same order as they appeared in the -input. - -@deffn {Scheme Procedure} sorted? items less -@deffnx {C Function} scm_sorted_p (items, less) -Return @code{#t} iff @var{items} is a list or a vector such that -for all 1 <= i <= m, the predicate @var{less} returns true when -applied to all elements i - 1 and i -@end deffn - -@deffn {Scheme Procedure} sort items less -@deffnx {C Function} scm_sort (items, less) -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence -elements. This is not a stable sort. -@end deffn - -@deffn {Scheme Procedure} sort! items less -@deffnx {C Function} scm_sort_x (items, less) -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence -elements. The sorting is destructive, that means that the -input sequence is modified to produce the sorted result. -This is not a stable sort. -@end deffn - -@deffn {Scheme Procedure} stable-sort items less -@deffnx {C Function} scm_stable_sort (items, less) -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence elements. -This is a stable sort. -@end deffn - -@deffn {Scheme Procedure} stable-sort! items less -@deffnx {C Function} scm_stable_sort_x (items, less) -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence elements. -The sorting is destructive, that means that the input sequence -is modified to produce the sorted result. -This is a stable sort. -@end deffn - -The procedures in the last group only accept lists or vectors as input, -as their names indicate. - -@deffn {Scheme Procedure} sort-list items less -@deffnx {C Function} scm_sort_list (items, less) -Sort the list @var{items}, using @var{less} for comparing the -list elements. This is a stable sort. -@end deffn - -@deffn {Scheme Procedure} sort-list! items less -@deffnx {C Function} scm_sort_list_x (items, less) -Sort the list @var{items}, using @var{less} for comparing the -list elements. The sorting is destructive, that means that the -input list is modified to produce the sorted result. -This is a stable sort. -@end deffn - -@deffn {Scheme Procedure} restricted-vector-sort! vec less startpos endpos -@deffnx {C Function} scm_restricted_vector_sort_x (vec, less, startpos, endpos) -Sort the vector @var{vec}, using @var{less} for comparing -the vector elements. @var{startpos} and @var{endpos} delimit -the range of the vector which gets sorted. The return value -is not specified. -@end deffn - - -@node Copying -@subsection Copying Deep Structures - -@c FIXME::martin: Review me! - -The procedures for copying lists (@pxref{Lists}) only produce a flat -copy of the input list, and currently Guile does not even contain -procedures for copying vectors. @code{copy-tree} can be used for these -application, as it does not only copy the spine of a list, but also -copies any pairs in the cars of the input lists. - -@deffn {Scheme Procedure} copy-tree obj -@deffnx {C Function} scm_copy_tree (obj) -Recursively copy the data tree that is bound to @var{obj}, and return a -pointer to the new data structure. @code{copy-tree} recurses down the -contents of both pairs and vectors (since both cons cells and vector -cells may point to arbitrary objects), and stops recursing when it hits -any other object. -@end deffn - - -@node General Conversion -@subsection General String Conversion - -@c FIXME::martin: Review me! - -When debugging Scheme programs, but also for providing a human-friendly -interface, a procedure for converting any Scheme object into string -format is very useful. Conversion from/to strings can of course be done -with specialized procedures when the data type of the object to convert -is known, but with this procedure, it is often more comfortable. - -@code{object->string} converts an object by using a print procedure for -writing to a string port, and then returning the resulting string. -Converting an object back from the string is only possible if the object -type has a read syntax and the read syntax is preserved by the printing -procedure. - -@deffn {Scheme Procedure} object->string obj [printer] -@deffnx {C Function} scm_object_to_string (obj, printer) -Return a Scheme string obtained by printing @var{obj}. -Printing function can be specified by the optional second -argument @var{printer} (default: @code{write}). -@end deffn - - -@node Hooks -@subsection Hooks -@tpindex Hooks - -A hook is a list of procedures to be called at well defined points in -time. Typically, an application provides a hook @var{h} and promises -its users that it will call all of the procedures in @var{h} at a -defined point in the application's processing. By adding its own -procedure to @var{h}, an application user can tap into or even influence -the progress of the application. - -Guile itself provides several such hooks for debugging and customization -purposes: these are listed in a subsection below. - -When an application first creates a hook, it needs to know how many -arguments will be passed to the hook's procedures when the hook is run. -The chosen number of arguments (which may be none) is declared when the -hook is created, and all the procedures that are added to that hook must -be capable of accepting that number of arguments. - -A hook is created using @code{make-hook}. A procedure can be added to -or removed from a hook using @code{add-hook!} or @code{remove-hook!}, -and all of a hook's procedures can be removed together using -@code{reset-hook!}. When an application wants to run a hook, it does so -using @code{run-hook}. - -@menu -* Hook Example:: Hook usage by example. -* Hook Reference:: Reference of all hook procedures. -* C Hooks:: Hooks for use from C code. -* GC Hooks:: Garbage collection hooks. -* REPL Hooks:: Hooks into the Guile REPL. -@end menu - - -@node Hook Example -@subsubsection Hook Usage by Example - -Hook usage is shown by some examples in this section. First, we will -define a hook of arity 2 --- that is, the procedures stored in the hook -will have to accept two arguments. - -@lisp -(define hook (make-hook 2)) -hook -@result{} # -@end lisp - -Now we are ready to add some procedures to the newly created hook with -@code{add-hook!}. In the following example, two procedures are added, -which print different messages and do different things with their -arguments. - -@lisp -(add-hook! hook (lambda (x y) - (display "Foo: ") - (display (+ x y)) - (newline))) -(add-hook! hook (lambda (x y) - (display "Bar: ") - (display (* x y)) - (newline))) -@end lisp - -Once the procedures have been added, we can invoke the hook using -@code{run-hook}. - -@lisp -(run-hook hook 3 4) -@print{} Bar: 12 -@print{} Foo: 7 -@end lisp - -Note that the procedures are called in the reverse of the order with -which they were added. This is because the default behaviour of -@code{add-hook!} is to add its procedure to the @emph{front} of the -hook's procedure list. You can force @code{add-hook!} to add its -procedure to the @emph{end} of the list instead by providing a third -@code{#t} argument on the second call to @code{add-hook!}. - -@lisp -(add-hook! hook (lambda (x y) - (display "Foo: ") - (display (+ x y)) - (newline))) -(add-hook! hook (lambda (x y) - (display "Bar: ") - (display (* x y)) - (newline)) - #t) ; @r{<- Change here!} - -(run-hook hook 3 4) -@print{} Foo: 7 -@print{} Bar: 12 -@end lisp - - -@node Hook Reference -@subsubsection Hook Reference - -When you create a hook with @code{make-hook}, you must specify the arity -of the procedures which can be added to the hook. If the arity is not -given explicitly as an argument to @code{make-hook}, it defaults to -zero. All procedures of a given hook must have the same arity, and when -the procedures are invoked using @code{run-hook}, the number of -arguments passed must match the arity specified at hook creation time. - -The order in which procedures are added to a hook matters. If the third -parameter to @code{add-hook!} is omitted or is equal to @code{#f}, the -procedure is added in front of the procedures which might already be on -that hook, otherwise the procedure is added at the end. The procedures -are always called from the front to the end of the list when they are -invoked via @code{run-hook}. - -The ordering of the list of procedures returned by @code{hook->list} -matches the order in which those procedures would be called if the hook -was run using @code{run-hook}. - -Note that the C functions in the following entries are for handling -@dfn{Scheme-level} hooks in C. There are also @dfn{C-level} hooks which -have their own interface (@pxref{C Hooks}). - -@deffn {Scheme Procedure} make-hook [n_args] -@deffnx {C Function} scm_make_hook (n_args) -Create a hook for storing procedure of arity @var{n_args}. -@var{n_args} defaults to zero. The returned value is a hook -object to be used with the other hook procedures. -@end deffn - -@deffn {Scheme Procedure} hook? x -@deffnx {C Function} scm_hook_p (x) -Return @code{#t} if @var{x} is a hook, @code{#f} otherwise. -@end deffn - -@deffn {Scheme Procedure} hook-empty? hook -@deffnx {C Function} scm_hook_empty_p (hook) -Return @code{#t} if @var{hook} is an empty hook, @code{#f} -otherwise. -@end deffn - -@deffn {Scheme Procedure} add-hook! hook proc [append_p] -@deffnx {C Function} scm_add_hook_x (hook, proc, append_p) -Add the procedure @var{proc} to the hook @var{hook}. The -procedure is added to the end if @var{append_p} is true, -otherwise it is added to the front. The return value of this -procedure is not specified. -@end deffn - -@deffn {Scheme Procedure} remove-hook! hook proc -@deffnx {C Function} scm_remove_hook_x (hook, proc) -Remove the procedure @var{proc} from the hook @var{hook}. The -return value of this procedure is not specified. -@end deffn - -@deffn {Scheme Procedure} reset-hook! hook -@deffnx {C Function} scm_reset_hook_x (hook) -Remove all procedures from the hook @var{hook}. The return -value of this procedure is not specified. -@end deffn - -@deffn {Scheme Procedure} hook->list hook -@deffnx {C Function} scm_hook_to_list (hook) -Convert the procedure list of @var{hook} to a list. -@end deffn - -@deffn {Scheme Procedure} run-hook hook . args -@deffnx {C Function} scm_run_hook (hook, args) -Apply all procedures from the hook @var{hook} to the arguments -@var{args}. The order of the procedure application is first to -last. The return value of this procedure is not specified. -@end deffn - -If, in C code, you are certain that you have a hook object and well -formed argument list for that hook, you can also use -@code{scm_c_run_hook}, which is identical to @code{scm_run_hook} but -does no type checking. - -@deftypefn {C Function} void scm_c_run_hook (SCM hook, SCM args) -The same as @code{scm_run_hook} but without any type checking to confirm -that @var{hook} is actually a hook object and that @var{args} is a -well-formed list matching the arity of the hook. -@end deftypefn - -For C code, @code{SCM_HOOKP} is a faster alternative to -@code{scm_hook_p}: - -@deftypefn {C Macro} int SCM_HOOKP (x) -Return 1 if @var{x} is a Scheme-level hook, 0 otherwise. -@end deftypefn - - -@subsubsection Handling Scheme-level hooks from C code - -Here is an example of how to handle Scheme-level hooks from C code using -the above functions. - -@example -if (SCM_NFALSEP (scm_hook_p (obj))) - /* handle Scheme-level hook using C functions */ - scm_reset_hook_x (obj); -else - /* do something else (obj is not a hook) */ -@end example - - -@node C Hooks -@subsubsection Hooks For C Code. - -The hooks already described are intended to be populated by Scheme-level -procedures. In addition to this, the Guile library provides an -independent set of interfaces for the creation and manipulation of hooks -that are designed to be populated by functions implemented in C. - -The original motivation here was to provide a kind of hook that could -safely be invoked at various points during garbage collection. -Scheme-level hooks are unsuitable for this purpose as running them could -itself require memory allocation, which would then invoke garbage -collection recursively @dots{} However, it is also the case that these -hooks are easier to work with than the Scheme-level ones if you only -want to register C functions with them. So if that is mainly what your -code needs to do, you may prefer to use this interface. - -To create a C hook, you should allocate storage for a structure of type -@code{scm_t_c_hook} and then initialize it using @code{scm_c_hook_init}. - -@deftp {C Type} scm_t_c_hook -Data type for a C hook. The internals of this type should be treated as -opaque. -@end deftp - -@deftp {C Enum} scm_t_c_hook_type -Enumeration of possible hook types, which are: - -@table @code -@item SCM_C_HOOK_NORMAL -@vindex SCM_C_HOOK_NORMAL -Type of hook for which all the registered functions will always be called. -@item SCM_C_HOOK_OR -@vindex SCM_C_HOOK_OR -Type of hook for which the sequence of registered functions will be -called only until one of them returns C true (a non-NULL pointer). -@item SCM_C_HOOK_AND -@vindex SCM_C_HOOK_AND -Type of hook for which the sequence of registered functions will be -called only until one of them returns C false (a NULL pointer). -@end table -@end deftp - -@deftypefn {C Function} void scm_c_hook_init (scm_t_c_hook *hook, void *hook_data, scm_t_c_hook_type type) -Initialize the C hook at memory pointed to by @var{hook}. @var{type} -should be one of the values of the @code{scm_t_c_hook_type} enumeration, -and controls how the hook functions will be called. @var{hook_data} is -a closure parameter that will be passed to all registered hook functions -when they are called. -@end deftypefn - -To add or remove a C function from a C hook, use @code{scm_c_hook_add} -or @code{scm_c_hook_remove}. A hook function must expect three -@code{void *} parameters which are, respectively: - -@table @var -@item hook_data -The hook closure data that was specified at the time the hook was -initialized by @code{scm_c_hook_init}. - -@item func_data -The function closure data that was specified at the time that that -function was registered with the hook by @code{scm_c_hook_add}. - -@item data -The call closure data specified by the @code{scm_c_hook_run} call that -runs the hook. -@end table - -@deftp {C Type} scm_t_c_hook_function -Function type for a C hook function: takes three @code{void *} -parameters and returns a @code{void *} result. -@end deftp - -@deftypefn {C Function} void scm_c_hook_add (scm_t_c_hook *hook, scm_t_c_hook_function func, void *func_data, int appendp) -Add function @var{func}, with function closure data @var{func_data}, to -the C hook @var{hook}. The new function is appended to the hook's list -of functions if @var{appendp} is non-zero, otherwise prepended. -@end deftypefn - -@deftypefn {C Function} void scm_c_hook_remove (scm_t_c_hook *hook, scm_t_c_hook_function func, void *func_data) -Remove function @var{func}, with function closure data @var{func_data}, -from the C hook @var{hook}. @code{scm_c_hook_remove} checks both -@var{func} and @var{func_data} so as to allow for the same @var{func} -being registered multiple times with different closure data. -@end deftypefn - -Finally, to invoke a C hook, call the @code{scm_c_hook_run} function -specifying the hook and the call closure data for this run: - -@deftypefn {C Function} {void *} scm_c_hook_run (scm_t_c_hook *hook, void *data) -Run the C hook @var{hook} will call closure data @var{data}. Subject to -the variations for hook types @code{SCM_C_HOOK_OR} and -@code{SCM_C_HOOK_AND}, @code{scm_c_hook_run} calls @var{hook}'s -registered functions in turn, passing them the hook's closure data, each -function's closure data, and the call closure data. - -@code{scm_c_hook_run}'s return value is the return value of the last -function to be called. -@end deftypefn - - -@node GC Hooks -@subsubsection Hooks for Garbage Collection - -Whenever Guile performs a garbage collection, it calls the following -hooks in the order shown. - -@defvr {C Hook} scm_before_gc_c_hook -C hook called at the very start of a garbage collection, after setting -@code{scm_gc_running_p} to 1, but before entering the GC critical -section. - -If garbage collection is blocked because @code{scm_block_gc} is -non-zero, GC exits early soon after calling this hook, and no further -hooks will be called. -@end defvr - -@defvr {C Hook} scm_before_mark_c_hook -C hook called before beginning the mark phase of garbage collection, -after the GC thread has entered a critical section. -@end defvr - -@defvr {C Hook} scm_before_sweep_c_hook -C hook called before beginning the sweep phase of garbage collection. -This is the same as at the end of the mark phase, since nothing else -happens between marking and sweeping. -@end defvr - -@defvr {C Hook} scm_after_sweep_c_hook -C hook called after the end of the sweep phase of garbage collection, -but while the GC thread is still inside its critical section. -@end defvr - -@defvr {C Hook} scm_after_gc_c_hook -C hook called at the very end of a garbage collection, after the GC -thread has left its critical section. -@end defvr - -@defvr {Scheme Hook} after-gc-hook -@vindex scm_after_gc_hook -Scheme hook with arity 0. This hook is run asynchronously -(@pxref{Asyncs}) soon after the GC has completed and any other events -that were deferred during garbage collection have been processed. (Also -accessible from C with the name @code{scm_after_gc_hook}.) -@end defvr - -All the C hooks listed here have type @code{SCM_C_HOOK_NORMAL}, are -initialized with hook closure data NULL, are are invoked by -@code{scm_c_hook_run} with call closure data NULL. - -@cindex guardians, testing for GC'd objects -The Scheme hook @code{after-gc-hook} is particularly useful in -conjunction with guardians (@pxref{Guardians}). Typically, if you are -using a guardian, you want to call the guardian after garbage collection -to see if any of the objects added to the guardian have been collected. -By adding a thunk that performs this call to @code{after-gc-hook}, you -can ensure that your guardian is tested after every garbage collection -cycle. - - -@node REPL Hooks -@subsubsection Hooks into the Guile REPL - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: From cd2825a8e02cfbb96de3832553b7623eeccab7a4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 14:42:51 +0000 Subject: [PATCH 23/89] (Integers): Talk more about inexact and exact integers. --- doc/ref/scheme-data.texi | 58 +++++++++++++++++++++++++++------------- 1 file changed, 39 insertions(+), 19 deletions(-) diff --git a/doc/ref/scheme-data.texi b/doc/ref/scheme-data.texi index 3cf12e953..f9bab52a9 100755 --- a/doc/ref/scheme-data.texi +++ b/doc/ref/scheme-data.texi @@ -310,20 +310,39 @@ For example, a C @code{int} can be handled with @code{scm_to_int} and @code{scm_from_int}. Guile also defines a few C integer types of its own, to help with differences between systems. - C integer types that are not covered can be -handled with the generic @code{scm_to_signed_integer} and -@code{scm_from_signed_integer} for signed types, or with -@code{scm_to_unsigned_integer} and @code{scm_from_unsigned_integer} -for unsigned types. +C integer types that are not covered can be handled with the generic +@code{scm_to_signed_integer} and @code{scm_from_signed_integer} for +signed types, or with @code{scm_to_unsigned_integer} and +@code{scm_from_unsigned_integer} for unsigned types. + +Scheme integers can be exact and inexact. For example, a number +written as @code{3.0} with an explicit decimal-point is inexact, but +it is also an integer. The functions @code{integer?} and +@code{scm_is_integer} report true for such a number, but the functions +@code{scm_is_signed_integer} and @code{scm_is_unsigned_integer} only +allow exact integers and thus report false. Likewise, the conversion +functions like @code{scm_to_signed_integer} only accept exact +integers. + +The motivation for this behavior is that the inexactness of a number +should not be lost silently. If you want to allow inexact integers, +you can explicitely insert a call to @code{inexact->exact} or to its C +equivalent @code{scm_inexact_to_exact}. (Only inexact integers will +be converted by this call into exact integers; inexact non-integers +will become exact fractions.) @deffn {Scheme Procedure} integer? x @deffnx {C Function} scm_integer_p (x) -Return @code{#t} if @var{x} is an integer number, else @code{#f}. +Return @code{#t} if @var{x} is an exactor inexact integer number, else +@code{#f}. @lisp (integer? 487) @result{} #t +(integer? 3.0) +@result{} #t + (integer? -3.4) @result{} #f @@ -360,8 +379,8 @@ to use them directly instead of the types provided by Guile. @deftypefn {C Function} int scm_is_signed_integer (SCM x, scm_t_intmax min, scm_t_intmax max) @deftypefnx {C Function} int scm_is_unsigned_integer (SCM x, scm_t_uintmax min, scm_t_uintmax max) -Return @code{1} when @var{x} represents an integer that is between -@var{min} and @var{max}, inclusive. +Return @code{1} when @var{x} represents an exact integer that is +between @var{min} and @var{max}, inclusive. These functions can be used to check whether a @code{SCM} value will fit into a given range, such as the range of a given C integer type. @@ -371,16 +390,16 @@ type, use one of the conversion functions directly. @deftypefn {C Function} scm_t_intmax scm_to_signed_integer (SCM x, scm_t_intmax min, scm_t_intmax max) @deftypefnx {C Function} scm_t_uintmax scm_to_unsigned_integer (SCM x, scm_t_uintmax min, scm_t_uintmax max) -When @var{x} represents an integer that is between @var{min} and +When @var{x} represents an exact integer that is between @var{min} and @var{max} inclusive, return that integer. Else signal an error, -either a `wrong-type' error when @var{x} is not an integer, or an -`out-of-range' error when it doesn't fit the given range. +either a `wrong-type' error when @var{x} is not an exact integer, or +an `out-of-range' error when it doesn't fit the given range. @end deftypefn @deftypefn {C Function} SCM scm_from_signed_integer (scm_t_intmax x) @deftypefnx {C Function} SCM scm_from_unsigned_integer (scm_t_uintmax x) -Return the @code{SCM} value that represents the integer @var{x}. -This function will always succeed. +Return the @code{SCM} value that represents the integer @var{x}. This +function will always succeed and will always return an exact number. @end deftypefn @deftypefn {C Function} char scm_to_char (SCM x) @@ -392,7 +411,7 @@ This function will always succeed. @deftypefnx {C Function} {unsigned int} scm_to_uint (SCM x) @deftypefnx {C Function} long scm_to_long (SCM x) @deftypefnx {C Function} {unsigned long} scm_to_ulong (SCM x) -@deftypefnx {C Function} long long scm_to_long_long (SCM x) +@deftypefnx {C Function} {long long} scm_to_long_long (SCM x) @deftypefnx {C Function} {unsigned long long} scm_to_ulong_long (SCM x) @deftypefnx {C Function} size_t scm_to_size_t (SCM x) @deftypefnx {C Function} ssize_t scm_to_ssize_t (SCM x) @@ -406,9 +425,9 @@ This function will always succeed. @deftypefnx {C Function} scm_t_uint64 scm_to_uint64 (SCM x) @deftypefnx {C Function} scm_t_intmax scm_to_intmax (SCM x) @deftypefnx {C Function} scm_t_uintmax scm_to_uintmax (SCM x) -When @var{x} represents an integer that fits into the indicated C -type, return that integer. Else signal an error, either a -`wrong-type' error when @var{x} is not an integer, or an +When @var{x} represents an exact integer that fits into the indicated +C type, return that integer. Else signal an error, either a +`wrong-type' error when @var{x} is not an exact integer, or an `out-of-range' error when it doesn't fit the given range. The functions @code{scm_to_long_long}, @code{scm_to_ulong_long}, @@ -440,7 +459,8 @@ the corresponding types are. @deftypefnx {C Function} SCM scm_from_intmax (scm_t_intmax x) @deftypefnx {C Function} SCM scm_from_uintmax (scm_t_uintmax x) Return the @code{SCM} value that represents the integer @var{x}. -These functions will always succeed. +These functions will always succeed and will always return an exact +number. @end deftypefn @node Reals and Rationals @@ -845,7 +865,7 @@ The C comparison functions below always takes two arguments, while the Scheme functions can take an arbitrary number. Also keep in mind that the C functions return one of the Scheme boolean values @code{SCM_BOOL_T} or @code{SCM_BOOL_F} which are both true as far as C -is concerned. Thus, always write @code{SCM_NFALSEP (scm_num_eq_p (x, +is concerned. Thus, always write @code{scm_is_true (scm_num_eq_p (x, y))} when testing the two Scheme numbers @code{x} and @code{y} for equality, for example. From 5f7fa54d98bb6da17eb94b12a2558d9fbce0a421 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 14:43:33 +0000 Subject: [PATCH 24/89] Updated for new scm_is_bool, scm_is_true, etc. --- doc/ref/gh.texi | 2 +- doc/ref/program.texi | 782 ------------------------------------------- 2 files changed, 1 insertion(+), 783 deletions(-) diff --git a/doc/ref/gh.texi b/doc/ref/gh.texi index 457e257d0..3f2fb523b 100644 --- a/doc/ref/gh.texi +++ b/doc/ref/gh.texi @@ -904,7 +904,7 @@ Use @code{SCM_DEFER_INTS} and @code{SCM_ALLOW_INTS} instead. Note that these macros are used without parentheses, as in @code{SCM_DEFER_INTS;}. @item @code{gh_bool2scm} -Use @code{SCM_BOOL} instead. +Use @code{scm_from_bool} instead. @item @code{gh_ulong2scm} Use @code{scm_ulong2num} instead. diff --git a/doc/ref/program.texi b/doc/ref/program.texi index 92a2db933..e69de29bb 100644 --- a/doc/ref/program.texi +++ b/doc/ref/program.texi @@ -1,782 +0,0 @@ -@c -*-texinfo-*- -@c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 -@c Free Software Foundation, Inc. -@c See the file guile.texi for copying conditions. - -@page -@node Programming Overview -@section An Overview of Guile Programming - -Guile is designed as an extension language interpreter that is -straightforward to integrate with applications written in C (and C++). -The big win here for the application developer is that Guile -integration, as the Guile web page says, ``lowers your project's -hacktivation energy.'' Lowering the hacktivation energy means that you, -as the application developer, @emph{and your users}, reap the benefits -that flow from being able to extend the application in a high level -extension language rather than in plain old C. - -In abstract terms, it's difficult to explain what this really means and -what the integration process involves, so instead let's begin by jumping -straight into an example of how you might integrate Guile into an -existing program, and what you could expect to gain by so doing. With -that example under our belts, we'll then return to a more general -analysis of the arguments involved and the range of programming options -available. - -@menu -* Extending Dia:: How one might extend Dia using Guile. -* Scheme vs C:: Why Scheme is more hackable than C. -* Testbed Example:: Example: using Guile in a testbed. -* Programming Options:: Options for Guile programming. -* User Programming:: How about application users? -@end menu - - -@node Extending Dia -@subsection How One Might Extend Dia Using Guile - -Dia is a free software program for drawing schematic diagrams like flow -charts and floor plans (REFFIXME). This section conducts the thought -experiment of adding Guile to Dia. In so doing, it aims to illustrate -several of the steps and considerations involved in adding Guile to -applications in general. - -@menu -* Dia Objective:: Deciding why you want to add Guile. -* Dia Steps:: Four steps required to add Guile. -* Dia Smobs:: How to represent Dia data in Scheme. -* Dia Primitives:: Writing Guile primitives for Dia. -* Dia Hook:: Providing a hook for Scheme evaluation. -* Dia Structure:: Overall structure for adding Guile. -* Dia Advanced:: Going further with Dia and Guile. -@end menu - - -@node Dia Objective -@subsubsection Deciding Why You Want to Add Guile - -First off, you should understand why you want to add Guile to Dia at -all, and that means forming a picture of what Dia does and how it does -it. So, what are the constituents of the Dia application? - -@itemize @bullet -@item -Most importantly, the @dfn{application domain objects} --- in other -words, the concepts that differentiate Dia from another application such -as a word processor or spreadsheet: shapes, templates, connectors, -pages, plus the properties of all these things. - -@item -The code that manages the graphical face of the application, including -the layout and display of the objects above. - -@item -The code that handles input events, which indicate that the application -user is wanting to do something. -@end itemize - -@noindent -(In other words, a textbook example of the @dfn{model - view - -controller} paradigm.) - -Next question: how will Dia benefit once the Guile integration is -complete? Several (positive!) answers are possible here, and the choice -is obviously up to the application developers. Still, one answer is -that the main benefit will be the ability to manipulate Dia's -application domain objects from Scheme. - -Suppose that Dia made a set of procedures available in Scheme, -representing the most basic operations on objects such as shapes, -connectors, and so on. Using Scheme, the application user could then -write code that builds upon these basic operations to create more -complex procedures. For example, given basic procedures to enumerate -the objects on a page, to determine whether an object is a square, and -to change the fill pattern of a single shape, the user can write a -Scheme procedure to change the fill pattern of all squares on the -current page: - -@lisp -(define (change-squares'-fill-pattern new-pattern) - (for-each-shape current-page - (lambda (shape) - (if (square? shape) - (change-fill-pattern shape new-pattern))))) -@end lisp - - -@node Dia Steps -@subsubsection Four Steps Required to Add Guile - -Assuming this objective, four steps are needed to achieve it. - -First, you need a way of representing your application-specific objects ---- such as @code{shape} in the previous example --- when they are -passed into the Scheme world. Unless your objects are so simple that -they map naturally into builtin Scheme data types like numbers and -strings, you will probably want to use Guile's @dfn{SMOB} interface to -create a new Scheme data type for your objects. - -Second, you need to write code for the basic operations like -@code{for-each-shape} and @code{square?} such that they access and -manipulate your existing data structures correctly, and then make these -operations available as @dfn{primitives} on the Scheme level. - -Third, you need to provide some mechanism within the Dia application -that a user can hook into to cause arbitrary Scheme code to be -evaluated. - -Finally, you need to restructure your top-level application C code a -little so that it initializes the Guile interpreter correctly and -declares your @dfn{SMOBs} and @dfn{primitives} to the Scheme world. - -The following subsections expand on these four points in turn. - - -@node Dia Smobs -@subsubsection How to Represent Dia Data in Scheme - -For all but the most trivial applications, you will probably want to -allow some representation of your domain objects to exist on the Scheme -level. This is where the idea of SMOBs comes in, and with it issues of -lifetime management and garbage collection. - -To get more concrete about this, let's look again at the example we gave -earlier of how application users can use Guile to build higher-level -functions from the primitives that Dia itself provides. - -@lisp -(define (change-squares'-fill-pattern new-pattern) - (for-each-shape current-page - (lambda (shape) - (if (square? shape) - (change-fill-pattern shape new-pattern))))) -@end lisp - -Consider what is stored here in the variable @code{shape}. For each -shape on the current page, the @code{for-each-shape} primitive calls -@code{(lambda (shape) @dots{})} with an argument representing that -shape. Question is: how is that argument represented on the Scheme -level? The issues are as follows. - -@itemize @bullet -@item -Whatever the representation, it has to be decodable again by the C code -for the @code{square?} and @code{change-fill-pattern} primitives. In -other words, a primitive like @code{square?} has somehow to be able to -turn the value that it receives back into something that points to the -underlying C structure describing a shape. - -@item -The representation must also cope with Scheme code holding on to the -value for later use. What happens if the Scheme code stores -@code{shape} in a global variable, but then that shape is deleted (in a -way that the Scheme code is not aware of), and later on some other -Scheme code uses that global variable again in a call to, say, -@code{square?}? - -@item -The lifetime and memory allocation of objects that exist @emph{only} in -the Scheme world is managed automatically by Guile's garbage collector -using one simple rule: when there are no remaining references to an -object, the object is considered dead and so its memory is freed. But -for objects that exist in both C and Scheme, the picture is more -complicated; in the case of Dia, where the @code{shape} argument passes -transiently in and out of the Scheme world, it would be quite wrong the -@strong{delete} the underlying C shape just because the Scheme code has -finished evaluation. How do we avoid this happening? -@end itemize - -One resolution of these issues is for the Scheme-level representation of -a shape to be a new, Scheme-specific C structure wrapped up as a SMOB. -The SMOB is what is passed into and out of Scheme code, and the -Scheme-specific C structure inside the SMOB points to Dia's underlying C -structure so that the code for primitives like @code{square?} can get at -it. - -To cope with an underlying shape being deleted while Scheme code is -still holding onto a Scheme shape value, the underlying C structure -should have a new field that points to the Scheme-specific SMOB. When a -shape is deleted, the relevant code chains through to the -Scheme-specific structure and sets its pointer back to the underlying -structure to NULL. Thus the SMOB value for the shape continues to -exist, but any primitive code that tries to use it will detect that the -underlying shape has been deleted because the underlying structure -pointer is NULL. - -So, to summarize the steps involved in this resolution of the problem -(and assuming that the underlying C structure for a shape is -@code{struct dia_shape}): - -@itemize @bullet -@item -Define a new Scheme-specific structure that @emph{points} to the -underlying C structure: - -@lisp -struct dia_guile_shape -@{ - struct dia_shape * c_shape; /* NULL => deleted */ -@} -@end lisp - -@item -Add a field to @code{struct dia_shape} that points to its @code{struct -dia_guile_shape} if it has one --- - -@lisp -struct dia_shape -@{ - @dots{} - struct dia_guile_shape * guile_shape; -@} -@end lisp - -@noindent ---- so that C code can set @code{guile_shape->c_shape} to NULL when the -underlying shape is deleted. - -@item -Wrap @code{struct dia_guile_shape} as a SMOB type. - -@item -Whenever you need to represent a C shape onto the Scheme level, create a -SMOB instance for it, and pass that. - -@item -In primitive code that receives a shape SMOB instance, check the -@code{c_shape} field when decoding it, to find out whether the -underlying C shape is still there. -@end itemize - -As far as memory management is concerned, the SMOB values and their -Scheme-specific structures are under the control of the garbage -collector, whereas the underlying C structures are explicitly managed in -exactly the same way that Dia managed them before we thought of adding -Guile. - -When the garbage collector decides to free a shape SMOB value, it calls -the @dfn{SMOB free} function that was specified when defining the shape -SMOB type. To maintain the correctness of the @code{guile_shape} field -in the underlying C structure, this function should chain through to the -underlying C structure (if it still exists) and set its -@code{guile_shape} field to NULL. - -For full documentation on defining and using SMOB types, see -@ref{Defining New Types (Smobs)}. - - -@node Dia Primitives -@subsubsection Writing Guile Primitives for Dia - -Once the details of object representation are decided, writing the -primitive function code that you need is usually straightforward. - -A primitive is simply a C function whose arguments and return value are -all of type @code{SCM}, and whose body does whatever you want it to do. -As an example, here is a possible implementation of the @code{square?} -primitive: - -@lisp -#define FUNC_NAME "square?" -static SCM square_p (SCM shape) -@{ - struct dia_guile_shape * guile_shape; - - /* Check that arg is really a shape SMOB. */ - SCM_VALIDATE_SHAPE (SCM_ARG1, shape); - - /* Access Scheme-specific shape structure. */ - guile_shape = SCM_SMOB_DATA (shape); - - /* Find out if underlying shape exists and is a - square; return answer as a Scheme boolean. */ - return SCM_BOOL (guile_shape->c_shape && - (guile_shape->c_shape->type == DIA_SQUARE)); -@} -#undef FUNC_NAME -@end lisp - -Notice how easy it is to chain through from the @code{SCM shape} -parameter that @code{square_p} receives --- which is a SMOB --- to the -Scheme-specific structure inside the SMOB, and thence to the underlying -C structure for the shape. - -In this code, @code{SCM_SMOB_DATA} and @code{SCM_BOOL} are macros from -the standard Guile API. @code{SCM_VALIDATE_SHAPE} is a macro that you -should define as part of your SMOB definition: it checks that the passed -parameter is of the expected type. This is needed to guard against -Scheme code using the @code{square?} procedure incorrectly, as in -@code{(square? "hello")}; Scheme's latent typing means that usage errors -like this must be caught at run time. - -Having written the C code for your primitives, you need to make them -available as Scheme procedures by calling the @code{scm_c_define_gsubr} -function. @code{scm_c_define_gsubr} (REFFIXME) takes arguments that -specify the Scheme-level name for the primitive and how many required, -optional and rest arguments it can accept. The @code{square?} primitive -always requires exactly one argument, so the call to make it available -in Scheme reads like this: - -@lisp -scm_c_define_gsubr ("square?", 1, 0, 0, square_p); -@end lisp - -For where to put this call, see the subsection after next on the -structure of Guile-enabled code (@pxref{Dia Structure}). - - -@node Dia Hook -@subsubsection Providing a Hook for the Evaluation of Scheme Code - -To make the Guile integration useful, you have to design some kind of -hook into your application that application users can use to cause their -Scheme code to be evaluated. - -Technically, this is straightforward; you just have to decide on a -mechanism that is appropriate for your application. Think of Emacs, for -example: when you type @kbd{@key{ESC} :}, you get a prompt where you can -type in any Elisp code, which Emacs will then evaluate. Or, again like -Emacs, you could provide a mechanism (such as an init file) to allow -Scheme code to be associated with a particular key sequence, and -evaluate the code when that key sequence is entered. - -In either case, once you have the Scheme code that you want to evaluate, -as a null terminated string, you can tell Guile to evaluate it by -calling the @code{scm_c_eval_string} function. - - -@node Dia Structure -@subsubsection Top-level Structure of Guile-enabled Dia - -Let's assume that the pre-Guile Dia code looks structurally like this: - -@itemize @bullet -@item -@code{main ()} - -@itemize @bullet -@item -do lots of initialization and setup stuff -@item -enter Gtk main loop -@end itemize -@end itemize - -When you add Guile to a program, one (rather technical) requirement is -that Guile's garbage collector needs to know where the bottom of the C -stack is. The easiest way to ensure this is to use -@code{scm_boot_guile} like this: - -@itemize @bullet -@item -@code{main ()} - -@itemize @bullet -@item -do lots of initialization and setup stuff -@item -@code{scm_boot_guile (argc, argv, inner_main, NULL)} -@end itemize - -@item -@code{inner_main ()} - -@itemize @bullet -@item -define all SMOB types -@item -export primitives to Scheme using @code{scm_c_define_gsubr} -@item -enter Gtk main loop -@end itemize -@end itemize - -In other words, you move the guts of what was previously in your -@code{main} function into a new function called @code{inner_main}, and -then add a @code{scm_boot_guile} call, with @code{inner_main} as a -parameter, to the end of @code{main}. - -Assuming that you are using SMOBs and have written primitive code as -described in the preceding subsections, you also need to insert calls to -declare your new SMOBs and export the primitives to Scheme. These -declarations must happen @emph{inside} the dynamic scope of the -@code{scm_boot_guile} call, but also @emph{before} any code is run that -could possibly use them --- the beginning of @code{inner_main} is an -ideal place for this. - - -@node Dia Advanced -@subsubsection Going Further with Dia and Guile - -The steps described so far implement an initial Guile integration that -already gives a lot of additional power to Dia application users. But -there are further steps that you could take, and it's interesting to -consider a few of these. - -In general, you could progressively move more of Dia's source code from -C into Scheme. This might make the code more maintainable and -extensible, and it could open the door to new programming paradigms that -are tricky to effect in C but straightforward in Scheme. - -A specific example of this is that you could use the guile-gtk package, -which provides Scheme-level procedures for most of the Gtk+ library, to -move the code that lays out and displays Dia objects from C to Scheme. - -As you follow this path, it naturally becomes less useful to maintain a -distinction between Dia's original non-Guile-related source code, and -its later code implementing SMOBs and primitives for the Scheme world. - -For example, suppose that the original source code had a -@code{dia_change_fill_pattern} function: - -@lisp -void dia_change_fill_pattern (struct dia_shape * shape, - struct dia_pattern * pattern) -@{ - /* real pattern change work */ -@} -@end lisp - -During initial Guile integration, you add a @code{change_fill_pattern} -primitive for Scheme purposes, which accesses the underlying structures -from its SMOB values and uses @code{dia_change_fill_pattern} to do the -real work: - -@lisp -SCM change_fill_pattern (SCM shape, SCM pattern) -@{ - struct dia_shape * d_shape; - struct dia_pattern * d_pattern; - - @dots{} - - dia_change_fill_pattern (d_shape, d_pattern); - - return SCM_UNSPECIFIED; -@} -@end lisp - -At this point, it makes sense to keep @code{dia_change_fill_pattern} and -@code{change_fill_pattern} separate, because -@code{dia_change_fill_pattern} can also be called without going through -Scheme at all, say because the user clicks a button which causes a -C-registered Gtk+ callback to be called. - -But, if the code for creating buttons and registering their callbacks is -moved into Scheme (using guile-gtk), it may become true that -@code{dia_change_fill_pattern} can no longer be called other than -through Scheme. In which case, it makes sense to abolish it and move -its contents directly into @code{change_fill_pattern}, like this: - -@lisp -SCM change_fill_pattern (SCM shape, SCM pattern) -@{ - struct dia_shape * d_shape; - struct dia_pattern * d_pattern; - - @dots{} - - /* real pattern change work */ - - return SCM_UNSPECIFIED; -@} -@end lisp - -So further Guile integration progressively @emph{reduces} the amount of -functional C code that you have to maintain over the long term. - -A similar argument applies to data representation. In the discussion of -SMOBs earlier, issues arose because of the different memory management -and lifetime models that normally apply to data structures in C and in -Scheme. However, with further Guile integration, you can resolve this -issue in a more radical way by allowing all your data structures to be -under the control of the garbage collector, and kept alive by references -from the Scheme world. Instead of maintaining an array or linked list -of shapes in C, you would instead maintain a list in Scheme. - -Rather like the coalescing of @code{dia_change_fill_pattern} and -@code{change_fill_pattern}, the practical upshot of such a change is -that you would no longer have to keep the @code{dia_shape} and -@code{dia_guile_shape} structures separate, and so wouldn't need to -worry about the pointers between them. Instead, you could change the -SMOB definition to wrap the @code{dia_shape} structure directly, and -send @code{dia_guile_shape} off to the scrap yard. Cut out the middle -man! - -Finally, we come to the holy grail of Guile's free software / extension -language approach. Once you have a Scheme representation for -interesting Dia data types like shapes, and a handy bunch of primitives -for manipulating them, it suddenly becomes clear that you have a bundle -of functionality that could have far-ranging use beyond Dia itself. In -other words, the data types and primitives could now become a library, -and Dia becomes just one of the many possible applications using that -library --- albeit, at this early stage, a rather important one! - -In this model, Guile becomes just the glue that binds everything -together. Imagine an application that usefully combined functionality -from Dia, Gnumeric and GnuCash --- it's tricky right now, because no -such application yet exists; but it'll happen some day @dots{} - - -@node Scheme vs C -@subsection Why Scheme is More Hackable Than C - -Underlying Guile's value proposition is the assumption that programming -in a high level language, specifically Guile's implementation of Scheme, -is necessarily better in some way than programming in C. What do we -mean by this claim, and how can we be so sure? - -One class of advantages applies not only to Scheme, but more generally -to any interpretable, high level, scripting language, such as Emacs -Lisp, Python, Ruby, or @TeX{}'s macro language. Common features of all -such languages, when compared to C, are that: - -@itemize @bullet -@item -They lend themselves to rapid and experimental development cycles, -owing usually to a combination of their interpretability and the -integrated development environment in which they are used. - -@item -They free developers from some of the low level bookkeeping tasks -associated with C programming, notably memory management. - -@item -They provide high level features such as container objects and exception -handling that make common programming tasks easier. -@end itemize - -In the case of Scheme, particular features that make programming easier ---- and more fun! --- are its powerful mechanisms for abstracting parts -of programs (closures --- @pxref{About Closure}) and for iteration -(@pxref{while do}). - -The evidence in support of this argument is empirical: the huge amount -of code that has been written in extension languages for applications -that support this mechanism. Most notable are extensions written in -Emacs Lisp for GNU Emacs, in @TeX{}'s macro language for @TeX{}, and in -Script-Fu for the Gimp, but there is increasingly now a significant code -eco-system for Guile-based applications as well, such as Lilypond and -GnuCash. It is close to inconceivable that similar amounts of -functionality could have been added to these applications just by -writing new code in their base implementation languages. - - -@node Testbed Example -@subsection Example: Using Guile for an Application Testbed - -As an example of what this means in practice, imagine writing a testbed -for an application that is tested by submitting various requests (via a -C interface) and validating the output received. Suppose further that -the application keeps an idea of its current state, and that the -``correct'' output for a given request may depend on the current -application state. A complete ``white box''@footnote{A @dfn{white box} -test plan is one that incorporates knowledge of the internal design of -the application under test.} test plan for this application would aim to -submit all possible requests in each distinguishable state, and validate -the output for all request/state combinations. - -To write all this test code in C would be very tedious. Suppose instead -that the testbed code adds a single new C function, to submit an -arbitrary request and return the response, and then uses Guile to export -this function as a Scheme procedure. The rest of the testbed can then -be written in Scheme, and so benefits from all the advantages of -programming in Scheme that were described in the previous section. - -(In this particular example, there is an additional benefit of writing -most of the testbed in Scheme. A common problem for white box testing -is that mistakes and mistaken assumptions in the application under test -can easily be reproduced in the testbed code. It is more difficult to -copy mistakes like this when the testbed is written in a different -language from the application.) - - -@node Programming Options -@subsection A Choice of Programming Options - -The preceding arguments and example point to a model of Guile -programming that is applicable in many cases. According to this model, -Guile programming involves a balance between C and Scheme programming, -with the aim being to extract the greatest possible Scheme level benefit -from the least amount of C level work. - -The C level work required in this model usually consists of packaging -and exporting functions and application objects such that they can be -seen and manipulated on the Scheme level. To help with this, Guile's C -language interface includes utility features that aim to make this kind -of integration very easy for the application developer. These features -are documented later in this part of the manual: see REFFIXME. - -This model, though, is really just one of a range of possible -programming options. If all of the functionality that you need is -available from Scheme, you could choose instead to write your whole -application in Scheme (or one of the other high level languages that -Guile supports through translation), and simply use Guile as an -interpreter for Scheme. (In the future, we hope that Guile will also be -able to compile Scheme code, so lessening the performance gap between C -and Scheme code.) Or, at the other end of the C--Scheme scale, you -could write the majority of your application in C, and only call out to -Guile occasionally for specific actions such as reading a configuration -file or executing a user-specified extension. The choices boil down to -two basic questions: - -@itemize @bullet -@item -Which parts of the application do you write in C, and which in Scheme -(or another high level translated language)? - -@item -How do you design the interface between the C and Scheme parts of your -application? -@end itemize - -These are of course design questions, and the right design for any given -application will always depend upon the particular requirements that you -are trying to meet. In the context of Guile, however, there are some -generally applicable considerations that can help you when designing -your answers. - -@menu -* Available Functionality:: What functionality is already available? -* Basic Constraints:: Functional and performance constraints. -* Style Choices:: Your preferred programming style. -* Program Control:: What controls program execution? -@end menu - - -@node Available Functionality -@subsubsection What Functionality is Already Available? - -Suppose, for the sake of argument, that you would prefer to write your -whole application in Scheme. Then the API available to you consists of: - -@itemize @bullet -@item -standard Scheme - -@item -plus the extensions to standard Scheme provided by -Guile in its core distribution - -@item -plus any additional functionality that you or others have packaged so -that it can be loaded as a Guile Scheme module. -@end itemize - -A module in the last category can either be a pure Scheme module --- in -other words a collection of utility procedures coded in Scheme --- or a -module that provides a Scheme interface to an extension library coded in -C --- in other words a nice package where someone else has done the work -of wrapping up some useful C code for you. The set of available modules -is growing quickly and already includes such useful examples as -@code{(gtk gtk)}, which makes Gtk+ drawing functions available in -Scheme, and @code{(database postgres)}, which provides SQL access to a -Postgres database. - -Given the growing collection of pre-existing modules, it is quite -feasible that your application could be implemented by combining a -selection of these modules together with new application code written in -Scheme. - -If this approach is not enough, because the functionality that your -application needs is not already available in this form, and it is -impossible to write the new functionality in Scheme, you will need to -write some C code. If the required function is already available in C -(e.g. in a library), all you need is a little glue to connect it to the -world of Guile. If not, you need both to write the basic code and to -plumb it into Guile. - -In either case, two general considerations are important. Firstly, what -is the interface by which the functionality is presented to the Scheme -world? Does the interface consist only of function calls (for example, -a simple drawing interface), or does it need to include @dfn{objects} of -some kind that can be passed between C and Scheme and manipulated by -both worlds. Secondly, how does the lifetime and memory management of -objects in the C code relate to the garbage collection governed approach -of Scheme objects? In the case where the basic C code is not already -written, most of the difficulties of memory management can be avoided by -using Guile's C interface features from the start. - -For the full documentation on writing C code for Guile and connecting -existing C code to the Guile world, see REFFIXME. - - -@node Basic Constraints -@subsubsection Functional and Performance Constraints - - -@node Style Choices -@subsubsection Your Preferred Programming Style - - -@node Program Control -@subsubsection What Controls Program Execution? - - -@node User Programming -@subsection How About Application Users? - -So far we have considered what Guile programming means for an -application developer. But what if you are instead @emph{using} an -existing Guile-based application, and want to know what your -options are for programming and extending this application? - -The answer to this question varies from one application to another, -because the options available depend inevitably on whether the -application developer has provided any hooks for you to hang your own -code on and, if there are such hooks, what they allow you to -do.@footnote{Of course, in the world of free software, you always have -the freedom to modify the application's source code to your own -requirements. Here we are concerned with the extension options that the -application has provided for without your needing to modify its source -code.} For example@dots{} - -@itemize @bullet -@item -If the application permits you to load and execute any Guile code, the -world is your oyster. You can extend the application in any way that -you choose. - -@item -A more cautious application might allow you to load and execute Guile -code, but only in a @dfn{safe} environment, where the interface -available is restricted by the application from the standard Guile API. - -@item -Or a really fearful application might not provide a hook to really -execute user code at all, but just use Scheme syntax as a convenient way -for users to specify application data or configuration options. -@end itemize - -In the last two cases, what you can do is, by definition, restricted by -the application, and you should refer to the application's own manual to -find out your options. - -The most well known example of the first case is Emacs, with its -extension language Emacs Lisp: as well as being a text editor, Emacs -supports the loading and execution of arbitrary Emacs Lisp code. The -result of such openness has been dramatic: Emacs now benefits from -user-contributed Emacs Lisp libraries that extend the basic editing -function to do everything from reading news to psychoanalysis and -playing adventure games. The only limitation is that extensions are -restricted to the functionality provided by Emacs's built-in set of -primitive operations. For example, you can interact and display data by -manipulating the contents of an Emacs buffer, but you can't pop-up and -draw a window with a layout that is totally different to the Emacs -standard. - -This situation with a Guile application that supports the loading of -arbitrary user code is similar, except perhaps even more so, because -Guile also supports the loading of extension libraries written in C. -This last point enables user code to add new primitive operations to -Guile, and so to bypass the limitation present in Emacs Lisp. - -At this point, the distinction between an application developer and an -application user becomes rather blurred. Instead of seeing yourself as -a user extending an application, you could equally well say that you are -developing a new application of your own using some of the primitive -functionality provided by the original application. As such, all the -discussions of the preceding sections of this chapter are relevant to -how you can proceed with developing your extension. From 0523f1c0d87d8a9069090bc1021ddb18dfa55de2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 14:43:55 +0000 Subject: [PATCH 25/89] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ test-suite/ChangeLog | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 6fb52e813..9ae359e23 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2004-07-10 Marius Vollmer + + * scheme-data.texi (Integers): Talk more about inexact and exact + integers. + 2004-07-10 Kevin Ryde * srfi-modules.texi (SRFI-0): Add srfi-6 to the identifiers provided diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index f6038fea3..7b613745f 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-07-10 Marius Vollmer + + * standalone/test-conversion.c (test_is_signed_integer, + test_is_unsigned_integer): Expect inexact integers to fail. + 2004-07-10 Kevin Ryde * tests/hash.test: New file. From be49d1df07370f215e90bfee1aa86643a9da5545 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 10 Jul 2004 15:25:01 +0000 Subject: [PATCH 26/89] =?UTF-8?q?Replaced=20all=20uses=20of=20deprecated?= =?UTF-8?q?=20SCM=5FFALSEP,=20SCM=5FNFALSEP,=20SCM=5FBOOL,=20SCM=5FNEGATE?= =?UTF-8?q?=5FBOOL,=20and=20SCM=5FBOOLP=20with=20scm=5Fis=5Ffalse,=20scm?= =?UTF-8?q?=5Fis=5Ftrue,=20scm=5Ffrom=5Fbool,=20and=20scm=5Fis=5Fbool,=20r?= =?UTF-8?q?espectively.=20=20Thanks=20to=20Andreas=20V=C3=B6gele!?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- guile-readline/readline.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 1c4b3eee3..9f7b39df0 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -136,7 +136,7 @@ static SCM before_read; static int current_input_getc (FILE *in SCM_UNUSED) { - if (promptp && !SCM_FALSEP (before_read)) + if (promptp && scm_is_true (before_read)) { scm_apply (before_read, SCM_EOL, SCM_EOL); promptp = 0; @@ -190,9 +190,9 @@ SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, SCM_EOL); } - if (!(SCM_UNBNDP (read_hook) || SCM_FALSEP (read_hook))) + if (!(SCM_UNBNDP (read_hook) || scm_is_false (read_hook))) { - if (!(SCM_NFALSEP (scm_thunk_p (read_hook)))) + if (scm_is_false (scm_thunk_p (read_hook))) { --in_readline; scm_wrong_type_arg (s_scm_readline, SCM_ARG4, read_hook); @@ -377,9 +377,9 @@ SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, SCM ans; SCM_VALIDATE_STRING (1,text); #ifdef HAVE_RL_FILENAME_COMPLETION_FUNCTION - s = rl_filename_completion_function (SCM_STRING_CHARS (text), SCM_NFALSEP (continuep)); + s = rl_filename_completion_function (SCM_STRING_CHARS (text), scm_is_true (continuep)); #else - s = filename_completion_function (SCM_STRING_CHARS (text), SCM_NFALSEP (continuep)); + s = filename_completion_function (SCM_STRING_CHARS (text), scm_is_true (continuep)); #endif ans = scm_makfrom0str (s); free (s); @@ -400,15 +400,15 @@ completion_function (char *text, int continuep) SCM compfunc = SCM_VARIABLE_REF (scm_readline_completion_function_var); SCM res; - if (SCM_FALSEP (compfunc)) + if (scm_is_false (compfunc)) return NULL; /* #f => completion disabled */ else { SCM t = scm_makfrom0str (text); - SCM c = continuep ? SCM_BOOL_T : SCM_BOOL_F; + SCM c = scm_from_bool (continuep); res = scm_apply (compfunc, scm_list_2 (t, c), SCM_EOL); - if (SCM_FALSEP (res)) + if (scm_is_false (res)) return NULL; if (!SCM_STRINGP (res)) From a0dbcd9cc3de488e61e14c85da0a9e2f578eb097 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 19 Jul 2004 00:43:37 +0000 Subject: [PATCH 27/89] 2004-05-25 Matthias Koeppe * format.scm: Remove the arbitrary limit of 100 iterations for the ~{...~} control structure. --- ice-9/format.scm | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/ice-9/format.scm b/ice-9/format.scm index f10c39fcc..98e2216e4 100644 --- a/ice-9/format.scm +++ b/ice-9/format.scm @@ -647,8 +647,7 @@ (case modifier ((colon) (if (not max-iterations) (set! max-iterations 1))) - ((colon-at at) (format:error "illegal modifier")) - (else (if (not max-iterations) (set! max-iterations 100)))) + ((colon-at at) (format:error "illegal modifier"))) (if (not (null? params)) (format:error "no parameters allowed in ~~}")) (if (zero? iteration-nest) @@ -670,7 +669,8 @@ (list-tail args arg-pos)))) (i 0 (+ i 1))) ((or (>= arg-pos args-len) - (>= i max-iterations)))))) + (and max-iterations + (>= i max-iterations))))))) ((sublists) (let ((args (next-arg)) (args-len 0)) @@ -679,7 +679,8 @@ (set! args-len (length args)) (do ((arg-pos 0 (+ arg-pos 1))) ((or (>= arg-pos args-len) - (>= arg-pos max-iterations))) + (and max-iterations + (>= arg-pos max-iterations)))) (let ((sublist (list-ref args arg-pos))) (if (not (list? sublist)) (format:error @@ -696,7 +697,8 @@ args arg-pos)))) (i 0 (+ i 1))) ((or (>= arg-pos args-len) - (>= i max-iterations)) + (and max-iterations + (>= i max-iterations))) arg-pos)))) (add-arg-pos usedup-args))) ((rest-sublists) @@ -705,7 +707,8 @@ (usedup-args (do ((arg-pos 0 (+ arg-pos 1))) ((or (>= arg-pos args-len) - (>= arg-pos max-iterations)) + (and max-iterations + (>= arg-pos max-iterations))) arg-pos) (let ((sublist (list-ref args arg-pos))) (if (not (list? sublist)) From dc510157bedba19d4194d4dcf6d6076f73182130 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 19 Jul 2004 00:48:37 +0000 Subject: [PATCH 28/89] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index c7524f3c9..883d3ce20 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2004-05-25 Matthias Koeppe + + * format.scm: Remove the arbitrary limit of 100 iterations for the + ~{...~} control structure. + 2004-07-10 Kevin Ryde * and-let-star.scm (and-let*): Remove unused variable "val". From 4fb318013bee1dab79acda62e64f298c028256c1 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 19 Jul 2004 00:58:04 +0000 Subject: [PATCH 29/89] 2004-05-25 Matthias Koeppe * tests/format.test (~{): Test no arbitrary iteration limit. --- test-suite/tests/format.test | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index f9d47c289..90f24efaf 100644 --- a/test-suite/tests/format.test +++ b/test-suite/tests/format.test @@ -1,7 +1,7 @@ ;;;; format.test --- test suite for Guile's CL-ish format -*- scheme -*- ;;;; Matthias Koeppe --- June 2001 ;;;; -;;;; Copyright (C) 2001, 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2003, 2004 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 @@ -39,3 +39,14 @@ "xyz\nabc\n")) (pass-if "format ~F (format-out-substr) maintains the column correctly" (= (string-length (format "~@F~20T" 1)) 20))) + +;;; +;;; ~{ +;;; + +(with-test-prefix "~{ iteration" + + ;; In Guile 1.6.4 and earlier, the maximum iterations parameter defaulted + ;; to 100, but it's now like Common Lisp where the default is no limit + (pass-if "no arbitrary iteration limit" + (= (string-length (format "~{~a~}" (make-list 200 #\b))) 200))) From ae13e8e1ca81494bd45bc5e86750b67979036470 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 19 Jul 2004 00:59:27 +0000 Subject: [PATCH 30/89] *** empty log message *** --- test-suite/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 7b613745f..61a8bc208 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2004-05-25 Matthias Koeppe + + * tests/format.test (~{): Test no arbitrary iteration limit. + 2004-07-10 Marius Vollmer * standalone/test-conversion.c (test_is_signed_integer, From 3aa13a0579ec82845fa5374ac3fdf673d874d3e0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 23 Jul 2004 15:29:27 +0000 Subject: [PATCH 31/89] (SCM_INUMP, SCM_NINUMP, SCM_INUM): Deprecated by reenaming them to SCM_I_INUMP, SCM_I_NINUMP and SCM_I_INUM, respectively and adding deprecated versions to deprecated.h and deprecated.c. Changed all uses to either use the SCM_I_ variants or scm_is_*, scm_to_*, or scm_from_*, as appropriate. --- libguile/deprecated.c | 18 +++++++++++++++++- libguile/deprecated.h | 36 +++++++++++++++++++----------------- libguile/numbers.h | 8 ++++---- 3 files changed, 40 insertions(+), 22 deletions(-) diff --git a/libguile/deprecated.c b/libguile/deprecated.c index a0275ccb9..eb1150456 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -1110,7 +1110,23 @@ SCM_MAKINUM (scm_t_signed_bits val) { scm_c_issue_deprecation_warning ("SCM_MAKINUM is deprecated. Use scm_from_int or similar instead."); - return scm_from_int (val); + return SCM_I_MAKINUM (val); +} + +int +SCM_INUMP (SCM obj) +{ + scm_c_issue_deprecation_warning + ("SCM_INUMP is deprecated. Use scm_is_integer or similar instead."); + return SCM_I_INUMP (obj); +} + +scm_t_signed_bits +SCM_INUM (SCM obj) +{ + scm_c_issue_deprecation_warning + ("SCM_INUM is deprecated. Use scm_to_int or similar instead."); + return scm_to_intmax (obj); } void diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 7f71bb4d7..8b89fec78 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -277,8 +277,8 @@ SCM_API SCM scm_gentemp (SCM prefix, SCM obarray); #define SCM_VALIDATE_NUMBER_COPY(pos, z, cvar) \ do { \ - if (SCM_INUMP (z)) \ - cvar = (double) SCM_INUM (z); \ + if (SCM_I_INUMP (z)) \ + cvar = (double) SCM_I_INUM (z); \ else if (SCM_REALP (z)) \ cvar = SCM_REAL_VALUE (z); \ else if (SCM_BIGP (z)) \ @@ -323,31 +323,33 @@ SCM_API SCM scm_gentemp (SCM prefix, SCM obarray); ^ (SCM_UNPACK (SCM_BOOL_T) \ ^ SCM_UNPACK (SCM_BOOL_F)))) -SCM_API SCM SCM_MAKINUM (scm_t_signed_bits val); - /* Users shouldn't know about INUMs. */ +SCM_API SCM SCM_MAKINUM (scm_t_signed_bits val); +SCM_API int SCM_INUMP (SCM obj); +SCM_API scm_t_signed_bits SCM_INUM (SCM obj); + #define SCM_VALIDATE_INUM(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, INUMP, "exact integer") #define SCM_VALIDATE_INUM_COPY(pos, k, cvar) \ do { \ - SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ - cvar = SCM_INUM (k); \ + SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \ + cvar = SCM_I_INUM (k); \ } while (0) #define SCM_VALIDATE_BIGINT(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, BIGP, "bignum") #define SCM_VALIDATE_INUM_MIN(pos, k, min) \ do { \ - SCM_ASSERT (SCM_INUMP(k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE (pos, k, (SCM_INUM (k) >= min)); \ + SCM_ASSERT (SCM_I_INUMP(k), k, pos, FUNC_NAME); \ + SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \ } while (0) #define SCM_VALIDATE_INUM_MIN_COPY(pos, k, min, cvar) \ do { \ - SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE (pos, k, (SCM_INUM (k) >= min)); \ + SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \ + SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \ cvar = SCM_INUM (k); \ } while (0) @@ -355,8 +357,8 @@ SCM_API SCM SCM_MAKINUM (scm_t_signed_bits val); do { \ if (SCM_UNBNDP (k)) \ k = SCM_I_MAKINUM (default); \ - SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE (pos, k, (SCM_INUM (k) >= min)); \ + SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \ + SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \ cvar = SCM_INUM (k); \ } while (0) @@ -364,7 +366,7 @@ SCM_API SCM SCM_MAKINUM (scm_t_signed_bits val); do { \ if (SCM_UNBNDP (k)) \ k = SCM_I_MAKINUM (default); \ - else SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ + else SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \ } while (0) #define SCM_VALIDATE_INUM_DEF_COPY(pos, k, default, cvar) \ @@ -376,17 +378,17 @@ SCM_API SCM SCM_MAKINUM (scm_t_signed_bits val); } \ else \ { \ - SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ + SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \ cvar = SCM_INUM (k); \ } \ } while (0) /* [low, high) */ #define SCM_VALIDATE_INUM_RANGE(pos, k, low, high) \ - do { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); \ + do { SCM_ASSERT(SCM_I_INUMP(k), k, pos, FUNC_NAME); \ SCM_ASSERT_RANGE(pos, k, \ - (SCM_INUM (k) >= low && \ - SCM_INUM (k) < high)); \ + (SCM_I_INUM (k) >= low && \ + SCM_I_INUM (k) < high)); \ } while (0) #define SCM_VALIDATE_INUM_RANGE_COPY(pos, k, low, high, cvar) \ diff --git a/libguile/numbers.h b/libguile/numbers.h index 47e8cfe42..405b80bf0 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -66,11 +66,11 @@ #endif /* (-1 == (((-1) << 2) + 2) >> 2) */ -#define SCM_INUMP(x) (2 & SCM_UNPACK (x)) -#define SCM_NINUMP(x) (!SCM_INUMP (x)) +#define SCM_I_INUMP(x) (2 & SCM_UNPACK (x)) +#define SCM_I_NINUMP(x) (!SCM_I_INUMP (x)) #define SCM_I_MAKINUM(x) \ (SCM_PACK ((((scm_t_signed_bits) (x)) << 2) + scm_tc2_int)) -#define SCM_INUM(x) (SCM_SRS ((scm_t_signed_bits) SCM_UNPACK (x), 2)) +#define SCM_I_INUM(x) (SCM_SRS ((scm_t_signed_bits) SCM_UNPACK (x), 2)) /* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */ #define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM) @@ -145,7 +145,7 @@ #define SCM_I_BIG_MPZ(x) (*((mpz_t *) (SCM_CELL_OBJECT_LOC((x),1)))) #define SCM_BIGP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_big) -#define SCM_NUMBERP(x) (SCM_INUMP(x) || SCM_NUMP(x)) +#define SCM_NUMBERP(x) (SCM_I_INUMP(x) || SCM_NUMP(x)) #define SCM_NUMP(x) (!SCM_IMP(x) \ && (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) \ || ((0xfbff & SCM_CELL_TYPE (x)) == scm_tc7_number))) From 928e0f421070bb610f3375d5808a6378d5edfa1b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 23 Jul 2004 15:34:07 +0000 Subject: [PATCH 32/89] (scm_i_dowinds): Removed unused code that would call the unexisting scm_cross_dynwind_binding_scope for inums on the windlist. --- libguile/dynwind.c | 84 +++++++++++++++++++--------------------------- 1 file changed, 34 insertions(+), 50 deletions(-) diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 8dc5a4e03..ff46c1720 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -284,42 +284,34 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data) scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data); wind_elt = SCM_CAR (to); -#if 0 - if (SCM_INUMP (wind_elt)) + if (FRAME_P (wind_elt)) { - scm_cross_dynwind_binding_scope (wind_elt, 0); + if (!FRAME_REWINDABLE_P (wind_elt)) + scm_misc_error ("dowinds", + "cannot invoke continuation from this context", + SCM_EOL); + } + else if (WINDER_P (wind_elt)) + { + if (WINDER_REWIND_P (wind_elt)) + WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt)); } else -#endif { - if (FRAME_P (wind_elt)) + wind_key = SCM_CAR (wind_elt); + /* key = #t | symbol | thunk | list of variables */ + if (SCM_NIMP (wind_key)) { - if (!FRAME_REWINDABLE_P (wind_elt)) - scm_misc_error ("dowinds", - "cannot invoke continuation from this context", - SCM_EOL); - } - else if (WINDER_P (wind_elt)) - { - if (WINDER_REWIND_P (wind_elt)) - WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt)); - } - else - { - wind_key = SCM_CAR (wind_elt); - /* key = #t | symbol | thunk | list of variables */ - if (SCM_NIMP (wind_key)) + if (SCM_CONSP (wind_key)) { - if (SCM_CONSP (wind_key)) - { - if (SCM_VARIABLEP (SCM_CAR (wind_key))) - scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); - } - else if (SCM_TYP3 (wind_key) == scm_tc3_closure) - scm_call_0 (wind_key); + if (SCM_VARIABLEP (SCM_CAR (wind_key))) + scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); } + else if (SCM_TYP3 (wind_key) == scm_tc3_closure) + scm_call_0 (wind_key); } } + scm_dynwinds = to; } else @@ -330,38 +322,30 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data) wind_elt = SCM_CAR (scm_dynwinds); scm_dynwinds = SCM_CDR (scm_dynwinds); -#if 0 - if (SCM_INUMP (wind_elt)) + if (FRAME_P (wind_elt)) { - scm_cross_dynwind_binding_scope (wind_elt, 0); + /* Nothing to do. */ + } + else if (WINDER_P (wind_elt)) + { + if (!WINDER_REWIND_P (wind_elt)) + WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt)); } else -#endif { - if (FRAME_P (wind_elt)) + wind_key = SCM_CAR (wind_elt); + if (SCM_NIMP (wind_key)) { - /* Nothing to do. */ - } - else if (WINDER_P (wind_elt)) - { - if (!WINDER_REWIND_P (wind_elt)) - WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt)); - } - else - { - wind_key = SCM_CAR (wind_elt); - if (SCM_NIMP (wind_key)) + if (SCM_CONSP (wind_key)) { - if (SCM_CONSP (wind_key)) - { - if (SCM_VARIABLEP (SCM_CAR (wind_key))) - scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); - } - else if (SCM_TYP3 (wind_key) == scm_tc3_closure) - scm_call_0 (SCM_CDR (wind_elt)); + if (SCM_VARIABLEP (SCM_CAR (wind_key))) + scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); } + else if (SCM_TYP3 (wind_key) == scm_tc3_closure) + scm_call_0 (SCM_CDR (wind_elt)); } } + delta--; goto tail; /* scm_dowinds(to, delta-1); */ } From e11e83f3d99305ada6354cae7123fb8c0e998703 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 23 Jul 2004 15:43:02 +0000 Subject: [PATCH 33/89] * deprecated.h, deprecated.c, numbers.h (SCM_INUMP, SCM_NINUMP, SCM_INUM): Deprecated by reenaming them to SCM_I_INUMP, SCM_I_NINUMP and SCM_I_INUM, respectively and adding deprecated versions to deprecated.h and deprecated.c. Changed all uses to either use the SCM_I_ variants or scm_is_*, scm_to_*, or scm_from_*, as appropriate. --- libguile/ChangeLog | 15 +- libguile/backtrace.c | 28 ++- libguile/convert.i.c | 24 +-- libguile/debug-malloc.c | 2 +- libguile/dynl.c | 2 +- libguile/environments.c | 12 +- libguile/error.c | 4 +- libguile/eval.c | 50 ++--- libguile/feature.c | 2 +- libguile/filesys.c | 30 +-- libguile/fports.c | 8 +- libguile/futures.c | 4 +- libguile/gc.c | 30 ++- libguile/gdbint.c | 10 +- libguile/gh_data.c | 32 +-- libguile/goops.c | 52 +++-- libguile/gsubr.c | 6 +- libguile/guardians.c | 2 +- libguile/hash.c | 16 +- libguile/hashtab.c | 4 +- libguile/hooks.c | 6 +- libguile/ioext.c | 8 +- libguile/list.c | 2 +- libguile/net_db.c | 12 +- libguile/num2float.i.c | 39 ---- libguile/num2integral.i.c | 264 ----------------------- libguile/numbers.c | 430 +++++++++++++++++++------------------- libguile/objects.c | 24 +-- libguile/options.c | 12 +- libguile/ports.c | 20 +- libguile/posix.c | 82 ++++---- libguile/print.c | 2 +- libguile/procprop.c | 4 +- libguile/procs.c | 2 +- libguile/ramap.c | 99 +++++---- libguile/random.c | 14 +- libguile/read.c | 4 +- libguile/regex-posix.c | 10 +- libguile/rw.c | 8 +- libguile/scmsigs.c | 16 +- libguile/simpos.c | 4 +- libguile/socket.c | 76 +++---- libguile/sort.c | 8 +- libguile/srcprop.c | 10 +- libguile/stacks.c | 24 +-- libguile/stacks.h | 11 +- libguile/stime.c | 55 ++--- libguile/strings.c | 36 ++-- libguile/strop.c | 24 +-- libguile/strports.c | 9 +- libguile/struct.c | 12 +- libguile/symbols.c | 2 +- libguile/tags.h | 2 +- libguile/throw.c | 4 +- libguile/unif.c | 223 ++++++++++---------- libguile/vectors.c | 32 ++- libguile/version.c | 12 +- libguile/weaks.c | 73 +++---- libguile/win32-socket.c | 4 +- 59 files changed, 840 insertions(+), 1172 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 565f78fb2..650dbb8b4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,7 +1,20 @@ +2004-07-23 Marius Vollmer + + * deprecated.h, deprecated.c, numbers.h (SCM_INUMP, SCM_NINUMP, + SCM_INUM): Deprecated by reenaming them to SCM_I_INUMP, + SCM_I_NINUMP and SCM_I_INUM, respectively and adding deprecated + versions to deprecated.h and deprecated.c. Changed all uses to + either use the SCM_I_ variants or scm_is_*, scm_to_*, or + scm_from_*, as appropriate. + + * dynwind.c (scm_i_dowinds): Removed unused code that would call + the unexisting scm_cross_dynwind_binding_scope for inums on the + windlist. + 2004-07-10 Marius Vollmer * socket.c (ipv6_net_to_num, scm_from_ipv6): Renamed - ipv6_net_to_num to scm_from_ipv6, for converting from an IPv& + ipv6_net_to_num to scm_from_ipv6, for converting from an IPv6 byte-wise address to a SCM integer. Changed all uses. (ipv6_num_to_net, scm_to_ipv6): Renamed ipv6_num_to_net to scm_to_ipv6 and added type and range checking, for converting from diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 3e5080623..591108d14 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -92,9 +92,9 @@ display_header (SCM source, SCM port) if (scm_is_true (line) && scm_is_true (col)) { scm_putc (':', port); - scm_intprint (SCM_INUM (line) + 1, 10, port); + scm_intprint (scm_to_long (line) + 1, 10, port); scm_putc (':', port); - scm_intprint (SCM_INUM (col) + 1, 10, port); + scm_intprint (scm_to_long (col) + 1, 10, port); } } else @@ -339,10 +339,8 @@ SCM_DEFINE (scm_set_print_params_x, "set-print-params!", 1, 0, 0, SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, params, n); for (ls = params; !SCM_NULL_OR_NIL_P (ls); ls = SCM_CDR (ls)) SCM_ASSERT (scm_ilength (SCM_CAR (params)) == 2 - && SCM_INUMP (SCM_CAAR (ls)) - && SCM_INUM (SCM_CAAR (ls)) >= 0 - && SCM_INUMP (SCM_CADAR (ls)) - && SCM_INUM (SCM_CADAR (ls)) >= 0, + && scm_is_unsigned_integer (SCM_CAAR (ls), 0, INT_MAX) + && scm_is_unsigned_integer (SCM_CADAR (ls), 0, INT_MAX), params, SCM_ARG2, s_scm_set_print_params_x); @@ -352,8 +350,8 @@ SCM_DEFINE (scm_set_print_params_x, "set-print-params!", 1, 0, 0, print_params = new_params; for (i = 0; i < n; ++i) { - print_params[i].level = SCM_INUM (SCM_CAAR (params)); - print_params[i].length = SCM_INUM (SCM_CADAR (params)); + print_params[i].level = scm_to_int (SCM_CAAR (params)); + print_params[i].length = scm_to_int (SCM_CADAR (params)); params = SCM_CDR (params); } n_print_params = n; @@ -545,7 +543,7 @@ display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate) else if (scm_is_true (line)) { int i, j=0; - for (i = SCM_INUM (line)+1; i > 0; i = i/10, j++) + for (i = scm_to_int (line)+1; i > 0; i = i/10, j++) ; indent (4-j, port); } @@ -553,7 +551,7 @@ display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate) if (scm_is_false (line)) scm_puts (" ?", port); else - scm_intprint (SCM_INUM (line) + 1, 10, port); + scm_intprint (scm_to_int (line) + 1, 10, port); scm_puts (": ", port); } @@ -642,11 +640,11 @@ display_backtrace_body (struct display_backtrace_args *a) /* Argument checking and extraction. */ SCM_VALIDATE_STACK (1, a->stack); SCM_VALIDATE_OPOUTPORT (2, a->port); - n_frames = SCM_INUM (scm_stack_length (a->stack)); - n = SCM_INUMP (a->depth) ? SCM_INUM (a->depth) : SCM_BACKTRACE_DEPTH; + n_frames = scm_to_int (scm_stack_length (a->stack)); + n = scm_is_integer (a->depth) ? scm_to_int (a->depth) : SCM_BACKTRACE_DEPTH; if (SCM_BACKWARDS_P) { - beg = SCM_INUMP (a->first) ? SCM_INUM (a->first) : 0; + beg = scm_is_integer (a->first) ? scm_to_int (a->first) : 0; end = beg + n - 1; if (end >= n_frames) end = n_frames - 1; @@ -654,9 +652,9 @@ display_backtrace_body (struct display_backtrace_args *a) } else { - if (SCM_INUMP (a->first)) + if (scm_is_integer (a->first)) { - beg = SCM_INUM (a->first); + beg = scm_to_int (a->first); end = beg - n + 1; if (end < 0) end = 0; diff --git a/libguile/convert.i.c b/libguile/convert.i.c index b66e31806..df9f88359 100644 --- a/libguile/convert.i.c +++ b/libguile/convert.i.c @@ -23,9 +23,9 @@ SCM2CTYPES (SCM obj, CTYPE *data) val = SCM_CAR (list); #if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS /* check integer ranges */ - if (SCM_INUMP (val)) + if (SCM_I_INUMP (val)) { - scm_t_signed_bits v = SCM_INUM (val); + scm_t_signed_bits v = SCM_I_INUM (val); CTYPE c = (CTYPE) v; SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c); } @@ -41,9 +41,9 @@ SCM2CTYPES (SCM obj, CTYPE *data) #elif defined (FLOATTYPE) /* real values, big numbers and immediate values are valid for float conversions */ - if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_INUMP (val)) + if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_I_INUMP (val)) #else - if (!SCM_BIGP (val) && !SCM_INUMP (val)) + if (!SCM_BIGP (val) && !SCM_I_INUMP (val)) #endif /* FLOATTYPE */ SCM_WRONG_TYPE_ARG (SCM_ARG1, val); } @@ -58,8 +58,8 @@ SCM2CTYPES (SCM obj, CTYPE *data) for (i = 0; scm_is_true (scm_pair_p (list)); list = SCM_CDR (list), i++) { val = SCM_CAR (list); - if (SCM_INUMP (val)) - data[i] = (CTYPE) SCM_INUM (val); + if (SCM_I_INUMP (val)) + data[i] = (CTYPE) SCM_I_INUM (val); else if (SCM_BIGP (val)) data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME); #if defined (FLOATTYPE) @@ -83,9 +83,9 @@ SCM2CTYPES (SCM obj, CTYPE *data) val = SCM_VELTS (obj)[i]; #if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS /* check integer ranges */ - if (SCM_INUMP (val)) + if (SCM_I_INUMP (val)) { - scm_t_signed_bits v = SCM_INUM (val); + scm_t_signed_bits v = SCM_I_INUM (val); CTYPE c = (CTYPE) v; SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c); } @@ -101,9 +101,9 @@ SCM2CTYPES (SCM obj, CTYPE *data) #elif defined (FLOATTYPE) /* real values, big numbers and immediate values are valid for float conversions */ - if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_INUMP (val)) + if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_I_INUMP (val)) #else - if (!SCM_BIGP (val) && !SCM_INUMP (val)) + if (!SCM_BIGP (val) && !SCM_I_INUMP (val)) #endif /* FLOATTYPE */ SCM_WRONG_TYPE_ARG (SCM_ARG1, val); } @@ -117,8 +117,8 @@ SCM2CTYPES (SCM obj, CTYPE *data) for (i = 0; i < n; i++) { val = SCM_VELTS (obj)[i]; - if (SCM_INUMP (val)) - data[i] = (CTYPE) SCM_INUM (val); + if (SCM_I_INUMP (val)) + data[i] = (CTYPE) SCM_I_INUM (val); else if (SCM_BIGP (val)) data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME); #if defined (FLOATTYPE) diff --git a/libguile/debug-malloc.c b/libguile/debug-malloc.c index c51b3f9f8..55f30d80a 100644 --- a/libguile/debug-malloc.c +++ b/libguile/debug-malloc.c @@ -217,7 +217,7 @@ SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0, for (i = 0; i < malloc_type_size + N_SEEK; ++i) if (malloc_type[i].key) res = scm_acons (scm_makfrom0str ((char *) malloc_type[i].key), - SCM_I_MAKINUM ((int) malloc_type[i].data), + scm_from_int ((int) malloc_type[i].data), res); return res; } diff --git a/libguile/dynl.c b/libguile/dynl.c index 775836cfa..834a98939 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -314,7 +314,7 @@ SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0, result = (*fptr) (argc, argv); free (argv); - return SCM_I_MAKINUM (0L + result); + return scm_from_int (result); } #undef FUNC_NAME diff --git a/libguile/environments.c b/libguile/environments.c index e907f6f76..70e7dbc0a 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -481,7 +481,7 @@ static int observer_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED) { SCM address = scm_ulong2num (SCM_UNPACK (type)); - SCM base16 = scm_number_to_string (address, SCM_I_MAKINUM (16)); + SCM base16 = scm_number_to_string (address, scm_from_int (16)); scm_puts ("#funcs = funcs; body->observers = SCM_EOL; - body->weak_observers = scm_make_weak_value_alist_vector (SCM_I_MAKINUM (1)); + body->weak_observers = scm_make_weak_value_alist_vector (scm_from_int (1)); } @@ -979,7 +979,7 @@ static int leaf_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED) { SCM address = scm_ulong2num (SCM_UNPACK (type)); - SCM base16 = scm_number_to_string (address, SCM_I_MAKINUM (16)); + SCM base16 = scm_number_to_string (address, scm_from_int (16)); scm_puts ("#= 0, s_bad_expression, expr); ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); slot_nr = SCM_CADR (cdr_expr); - ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr); + ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr); SCM_SETCAR (expr, SCM_IM_SLOT_REF); SCM_SETCDR (cdr_expr, slot_nr); @@ -2212,7 +2212,7 @@ scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED) ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_expression, expr); slot_nr = SCM_CADR (cdr_expr); - ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr); + ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr); SCM_SETCAR (expr, SCM_IM_SLOT_SET_X); return expr; @@ -3729,14 +3729,24 @@ dispatch: { SCM z = SCM_CDDR (x); SCM tmp = SCM_CADR (z); - specializers = SCM_INUM (SCM_CAR (z)); + specializers = scm_to_ulong (SCM_CAR (z)); /* Compute a hash value for searching the method cache. There * are two variants for computing the hash value, a (rather) * complicated one, and a simple one. For the complicated one * explained below, tmp holds a number that is used in the * computation. */ - if (SCM_INUMP (tmp)) + if (SCM_VECTORP (tmp)) + { + /* This method of determining the hash value is much + * simpler: Set the hash value to zero and just perform a + * linear search through the method cache. */ + method_cache = tmp; + mask = (unsigned long int) ((long) -1); + hash_value = 0; + cache_end_pos = SCM_VECTOR_LENGTH (method_cache); + } + else { /* Use the signature of the actual arguments to determine * the hash value. This is done as follows: Each class has @@ -3753,7 +3763,7 @@ dispatch: * where dispatch is called, such that hopefully the hash * value that is computed will directly point to the right * method in the method cache. */ - unsigned long int hashset = SCM_INUM (tmp); + unsigned long int hashset = scm_to_ulong (tmp); unsigned long int counter = specializers + 1; SCM tmp_arg = arg1; hash_value = 0; @@ -3766,20 +3776,10 @@ dispatch: } z = SCM_CDDR (z); method_cache = SCM_CADR (z); - mask = SCM_INUM (SCM_CAR (z)); + mask = scm_to_ulong (SCM_CAR (z)); hash_value &= mask; cache_end_pos = hash_value; } - else - { - /* This method of determining the hash value is much - * simpler: Set the hash value to zero and just perform a - * linear search through the method cache. */ - method_cache = tmp; - mask = (unsigned long int) ((long) -1); - hash_value = 0; - cache_end_pos = SCM_VECTOR_LENGTH (method_cache); - } } { @@ -3830,7 +3830,7 @@ dispatch: x = SCM_CDR (x); { SCM instance = EVALCAR (x, env); - unsigned long int slot = SCM_INUM (SCM_CDR (x)); + unsigned long int slot = SCM_I_INUM (SCM_CDR (x)); RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); } @@ -3839,7 +3839,7 @@ dispatch: x = SCM_CDR (x); { SCM instance = EVALCAR (x, env); - unsigned long int slot = SCM_INUM (SCM_CADR (x)); + unsigned long int slot = SCM_I_INUM (SCM_CADR (x)); SCM value = EVALCAR (SCM_CDDR (x), env); SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value); RETURN (SCM_UNSPECIFIED); @@ -4142,9 +4142,9 @@ dispatch: case scm_tc7_subr_1o: RETURN (SCM_SUBRF (proc) (arg1)); case scm_tc7_dsubr: - if (SCM_INUMP (arg1)) + if (SCM_I_INUMP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); + RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); } else if (SCM_REALP (arg1)) { @@ -4829,9 +4829,9 @@ tail: case scm_tc7_dsubr: if (SCM_UNBNDP (arg1) || !SCM_NULLP (args)) scm_wrong_num_args (proc); - if (SCM_INUMP (arg1)) + if (SCM_I_INUMP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); + RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); } else if (SCM_REALP (arg1)) { @@ -5181,9 +5181,9 @@ call_lsubr_1 (SCM proc, SCM arg1) static SCM call_dsubr_1 (SCM proc, SCM arg1) { - if (SCM_INUMP (arg1)) + if (SCM_I_INUMP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); + RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); } else if (SCM_REALP (arg1)) { @@ -5417,7 +5417,7 @@ check_map_args (SCM argv, } if (elt_len != len) - scm_out_of_range_pos (who, ve[i], SCM_I_MAKINUM (i + 2)); + scm_out_of_range_pos (who, ve[i], scm_from_long (i + 2)); } scm_remember_upto_here_1 (argv); diff --git a/libguile/feature.c b/libguile/feature.c index 1f67de618..e6b212351 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -98,7 +98,7 @@ scm_init_feature() #endif scm_add_feature ("threads"); - scm_c_define ("char-code-limit", SCM_I_MAKINUM (SCM_CHAR_CODE_LIMIT)); + scm_c_define ("char-code-limit", scm_from_int (SCM_CHAR_CODE_LIMIT)); #include "libguile/feature.x" } diff --git a/libguile/filesys.c b/libguile/filesys.c index 7ae482288..79cfa0131 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -299,7 +299,7 @@ SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0, SCM_SYSCALL (fd = open (SCM_STRING_CHARS (path), iflags, imode)); if (fd == -1) SCM_SYSERROR; - return SCM_I_MAKINUM (fd); + return scm_from_int (fd); } #undef FUNC_NAME @@ -336,7 +336,7 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0, int fd; int iflags; - fd = SCM_INUM (scm_open_fdes (path, flags, mode)); + fd = scm_to_int (scm_open_fdes (path, flags, mode)); iflags = SCM_NUM2INT (2, flags); if (iflags & O_RDWR) { @@ -476,7 +476,7 @@ scm_stat2scm (struct stat *stat_temp) else SCM_VECTOR_SET(ans, 13, scm_sym_unknown); - SCM_VECTOR_SET(ans, 14, SCM_I_MAKINUM ((~S_IFMT) & mode)); + SCM_VECTOR_SET(ans, 14, scm_from_int ((~S_IFMT) & mode)); /* the layout of the bits in ve[14] is intended to be portable. If there are systems that don't follow the usual convention, @@ -505,7 +505,7 @@ scm_stat2scm (struct stat *stat_temp) tmp <<= 1; if (S_IXOTH & mode) tmp += 1; - SCM_VECTOR_SET(ans, 14, SCM_I_MAKINUM (tmp)); + SCM_VECTOR_SET(ans, 14, scm_from_int (tmp)); */ } @@ -602,12 +602,12 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, int fdes; struct stat stat_temp; - if (SCM_INUMP (object)) + if (scm_is_integer (object)) { #ifdef __MINGW32__ - SCM_SYSCALL (rv = fstat_Win32 (SCM_INUM (object), &stat_temp)); + SCM_SYSCALL (rv = fstat_Win32 (scm_to_int (object), &stat_temp)); #else - SCM_SYSCALL (rv = fstat (SCM_INUM (object), &stat_temp)); + SCM_SYSCALL (rv = fstat (scm_to_int (object), &stat_temp)); #endif } else if (SCM_STRINGP (object)) @@ -974,9 +974,9 @@ set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos) { int fd; - if (SCM_INUMP (element)) + if (scm_is_integer (element)) { - fd = SCM_INUM (element); + fd = scm_to_int (element); } else { @@ -1055,9 +1055,9 @@ get_element (SELECT_TYPE *set, SCM element, SCM list) { int fd; - if (SCM_INUMP (element)) + if (scm_is_integer (element)) { - fd = SCM_INUM (element); + fd = scm_to_int (element); } else { @@ -1478,12 +1478,12 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, #else if (len > 0 && s[0] == '/') #endif /* ndef __MINGW32__ */ - return scm_substring (filename, SCM_INUM0, SCM_I_MAKINUM (1)); + return scm_substring (filename, SCM_INUM0, scm_from_int (1)); else return scm_dot_string; } else - return scm_substring (filename, SCM_INUM0, SCM_I_MAKINUM (i + 1)); + return scm_substring (filename, SCM_INUM0, scm_from_int (i + 1)); } #undef FUNC_NAME @@ -1532,12 +1532,12 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, #else if (len > 0 && f[0] == '/') #endif /* ndef __MINGW32__ */ - return scm_substring (filename, SCM_INUM0, SCM_I_MAKINUM (1)); + return scm_substring (filename, SCM_INUM0, scm_from_int (1)); else return scm_dot_string; } else - return scm_substring (filename, SCM_I_MAKINUM (i + 1), SCM_I_MAKINUM (end + 1)); + return scm_substring (filename, scm_from_int (i+1), scm_from_int (end+1)); } #undef FUNC_NAME diff --git a/libguile/fports.c b/libguile/fports.c index b89a1999c..3cdf110b3 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -214,7 +214,7 @@ scm_evict_ports (int fd) fp->fdes = dup (fd); if (fp->fdes == -1) scm_syserror ("scm_evict_ports"); - scm_set_port_revealed_x (port, SCM_I_MAKINUM (0)); + scm_set_port_revealed_x (port, scm_from_int (0)); } } } @@ -845,9 +845,9 @@ scm_init_fports () { scm_tc16_fport = scm_make_fptob (); - scm_c_define ("_IOFBF", SCM_I_MAKINUM (_IOFBF)); - scm_c_define ("_IOLBF", SCM_I_MAKINUM (_IOLBF)); - scm_c_define ("_IONBF", SCM_I_MAKINUM (_IONBF)); + scm_c_define ("_IOFBF", scm_from_int (_IOFBF)); + scm_c_define ("_IOLBF", scm_from_int (_IOLBF)); + scm_c_define ("_IONBF", scm_from_int (_IONBF)); #include "libguile/fports.x" } diff --git a/libguile/futures.c b/libguile/futures.c index b2bb99e10..07cf6e6a3 100644 --- a/libguile/futures.c +++ b/libguile/futures.c @@ -60,7 +60,7 @@ count (SCM ls) ++n; ls = SCM_FUTURE_NEXT (ls); } - return SCM_I_MAKINUM (n); + return scm_from_int (n); } extern SCM scm_future_cache_status (void); @@ -76,7 +76,7 @@ SCM_DEFINE (scm_future_cache_status, "future-cache-status", 0, 0, 0, count (young), count (old), count (undead), - SCM_I_MAKINUM (nd)); + scm_from_int (nd)); } #undef FUNC_NAME diff --git a/libguile/gc.c b/libguile/gc.c index b1679c743..21657dc24 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -191,18 +191,11 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, scm_debug_cell_accesses_p = 1; scm_expensive_debug_cell_accesses_p = 0; } - else if (SCM_INUMP (flag)) - { - long int f = SCM_INUM (flag); - if (f <= 0) - SCM_OUT_OF_RANGE (1, flag); - scm_debug_cells_gc_interval = f; - scm_debug_cell_accesses_p = 1; - scm_expensive_debug_cell_accesses_p = 1; - } else { - SCM_WRONG_TYPE_ARG (1, flag); + scm_debug_cells_gc_interval = scm_to_signed_integer (flag, 0, INT_MAX); + scm_debug_cell_accesses_p = 1; + scm_expensive_debug_cell_accesses_p = 1; } return SCM_UNSPECIFIED; } @@ -720,8 +713,8 @@ scm_gc_protect_object (SCM obj) /* This critical section barrier will be replaced by a mutex. */ SCM_REDEFER_INTS; - handle = scm_hashq_create_handle_x (scm_protects, obj, SCM_I_MAKINUM (0)); - SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), SCM_I_MAKINUM (1))); + handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0)); + SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1))); protected_obj_count ++; @@ -752,8 +745,8 @@ scm_gc_unprotect_object (SCM obj) } else { - SCM count = scm_difference (SCM_CDR (handle), SCM_I_MAKINUM (1)); - if (SCM_EQ_P (count, SCM_I_MAKINUM (0))) + SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1)); + if (SCM_EQ_P (count, scm_from_int (0))) scm_hashq_remove_x (scm_protects, obj); else SCM_SETCDR (handle, count); @@ -774,8 +767,9 @@ scm_gc_register_root (SCM *p) /* This critical section barrier will be replaced by a mutex. */ SCM_REDEFER_INTS; - handle = scm_hashv_create_handle_x (scm_gc_registered_roots, key, SCM_I_MAKINUM (0)); - SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), SCM_I_MAKINUM (1))); + handle = scm_hashv_create_handle_x (scm_gc_registered_roots, key, + scm_from_int (0)); + SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1))); SCM_REALLOW_INTS; } @@ -798,8 +792,8 @@ scm_gc_unregister_root (SCM *p) } else { - SCM count = scm_difference (SCM_CDR (handle), SCM_I_MAKINUM (1)); - if (SCM_EQ_P (count, SCM_I_MAKINUM (0))) + SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1)); + if (SCM_EQ_P (count, scm_from_int (0))) scm_hashv_remove_x (scm_gc_registered_roots, key); else SCM_SETCDR (handle, count); diff --git a/libguile/gdbint.c b/libguile/gdbint.c index effd735e0..fe7cd7c94 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -183,10 +183,10 @@ gdb_read (char *str) } SCM_BEGIN_FOREIGN_BLOCK; unmark_port (gdb_input_port); - scm_seek (gdb_input_port, SCM_INUM0, SCM_I_MAKINUM (SEEK_SET)); + scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET)); scm_puts (str, gdb_input_port); scm_truncate_file (gdb_input_port, SCM_UNDEFINED); - scm_seek (gdb_input_port, SCM_INUM0, SCM_I_MAKINUM (SEEK_SET)); + scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET)); /* Read one object */ tok_buf_mark_p = SCM_GC_MARK_P (tok_buf); SCM_CLEAR_GC_MARK (tok_buf); @@ -242,7 +242,7 @@ gdb_print (SCM obj) RESET_STRING; SCM_BEGIN_FOREIGN_BLOCK; /* Reset stream */ - scm_seek (gdb_output_port, SCM_INUM0, SCM_I_MAKINUM (SEEK_SET)); + scm_seek (gdb_output_port, SCM_INUM0, scm_from_int (SEEK_SET)); scm_write (obj, gdb_output_port); scm_truncate_file (gdb_output_port, SCM_UNDEFINED); { @@ -285,13 +285,13 @@ scm_init_gdbint () scm_print_carefully_p = 0; port = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_I_MAKINUM (0), SCM_UNDEFINED), + scm_make_string (scm_from_int (0), SCM_UNDEFINED), SCM_OPN | SCM_WRTNG, s); gdb_output_port = scm_permanent_object (port); port = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_I_MAKINUM (0), SCM_UNDEFINED), + scm_make_string (scm_from_int (0), SCM_UNDEFINED), SCM_OPN | SCM_RDNG | SCM_WRTNG, s); gdb_input_port = scm_permanent_object (port); diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 0bc5e4f1a..b1cfd5096 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -103,7 +103,7 @@ gh_ints2scm (const int *d, long n) long i; SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); for (i = 0; i < n; ++i) - SCM_VECTOR_SET (v, i, (SCM_FIXABLE (d[i]) ? SCM_I_MAKINUM (d[i]) : scm_i_long2big (d[i]))); + SCM_VECTOR_SET (v, i, scm_from_int (d[i])); return v; } @@ -232,9 +232,9 @@ gh_scm2chars (SCM obj, char *m) for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; - if (SCM_INUMP (val)) + if (SCM_I_INUMP (val)) { - v = SCM_INUM (val); + v = SCM_I_INUM (val); if (v < -128 || v > 255) scm_out_of_range (0, obj); } @@ -246,7 +246,7 @@ gh_scm2chars (SCM obj, char *m) if (m == NULL) return NULL; for (i = 0; i < n; ++i) - m[i] = SCM_INUM (SCM_VELTS (obj)[i]); + m[i] = SCM_I_INUM (SCM_VELTS (obj)[i]); break; #if SCM_HAVE_ARRAYS case scm_tc7_byvect: @@ -291,9 +291,9 @@ gh_scm2shorts (SCM obj, short *m) for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; - if (SCM_INUMP (val)) + if (SCM_I_INUMP (val)) { - v = SCM_INUM (val); + v = SCM_I_INUM (val); if (v < -32768 || v > 65535) scm_out_of_range (0, obj); } @@ -305,7 +305,7 @@ gh_scm2shorts (SCM obj, short *m) if (m == NULL) return NULL; for (i = 0; i < n; ++i) - m[i] = SCM_INUM (SCM_VELTS (obj)[i]); + m[i] = SCM_I_INUM (SCM_VELTS (obj)[i]); break; #if SCM_HAVE_ARRAYS case scm_tc7_svect: @@ -341,7 +341,7 @@ gh_scm2longs (SCM obj, long *m) for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; - if (!SCM_INUMP (val) && !SCM_BIGP (val)) + if (!SCM_I_INUMP (val) && !SCM_BIGP (val)) scm_wrong_type_arg (0, 0, obj); } if (m == 0) @@ -351,8 +351,8 @@ gh_scm2longs (SCM obj, long *m) for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; - m[i] = SCM_INUMP (val) - ? SCM_INUM (val) + m[i] = SCM_I_INUMP (val) + ? SCM_I_INUM (val) : scm_num2long (val, 0, NULL); } break; @@ -391,7 +391,7 @@ gh_scm2floats (SCM obj, float *m) for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; - if (!SCM_INUMP (val) + if (!SCM_I_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val))) scm_wrong_type_arg (0, 0, val); } @@ -402,8 +402,8 @@ gh_scm2floats (SCM obj, float *m) for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; - if (SCM_INUMP (val)) - m[i] = SCM_INUM (val); + if (SCM_I_INUMP (val)) + m[i] = SCM_I_INUM (val); else if (SCM_BIGP (val)) m[i] = scm_num2long (val, 0, NULL); else @@ -454,7 +454,7 @@ gh_scm2doubles (SCM obj, double *m) for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; - if (!SCM_INUMP (val) + if (!SCM_I_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val))) scm_wrong_type_arg (0, 0, val); } @@ -465,8 +465,8 @@ gh_scm2doubles (SCM obj, double *m) for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; - if (SCM_INUMP (val)) - m[i] = SCM_INUM (val); + if (SCM_I_INUMP (val)) + m[i] = SCM_I_INUM (val); else if (SCM_BIGP (val)) m[i] = scm_num2long (val, 0, NULL); else diff --git a/libguile/goops.c b/libguile/goops.c index 29a1f06ea..bf6c03a51 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -310,7 +310,7 @@ compute_getters_n_setters (SCM slots) } *cdrloc = scm_cons (scm_cons (SCM_CAAR (slots), scm_cons (init, - SCM_I_MAKINUM (i++))), + scm_from_int (i++))), SCM_EOL); cdrloc = SCM_CDRLOC (*cdrloc); } @@ -454,18 +454,18 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, * in goops.scm:compute-getters-n-setters */ #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \ - (SCM_INUMP (SCM_CDDR (gns)) \ + (SCM_I_INUMP (SCM_CDDR (gns)) \ || (SCM_CONSP (SCM_CDDR (gns)) \ && SCM_CONSP (SCM_CDDDR (gns)) \ && SCM_CONSP (SCM_CDDDDR (gns)))) #define SCM_GNS_INDEX(gns) \ - (SCM_INUMP (SCM_CDDR (gns)) \ - ? SCM_INUM (SCM_CDDR (gns)) \ - : SCM_INUM (SCM_CAR (SCM_CDDDDR (gns)))) + (SCM_I_INUMP (SCM_CDDR (gns)) \ + ? SCM_I_INUM (SCM_CDDR (gns)) \ + : scm_to_long (SCM_CAR (SCM_CDDDDR (gns)))) #define SCM_GNS_SIZE(gns) \ - (SCM_INUMP (SCM_CDDR (gns)) \ + (SCM_I_INUMP (SCM_CDDR (gns)) \ ? 1 \ - : SCM_INUM (SCM_CADR (SCM_CDDDDR (gns)))) + : scm_to_long (SCM_CADR (SCM_CDDDDR (gns)))) SCM_KEYWORD (k_class, "class"); SCM_KEYWORD (k_allocation, "allocation"); @@ -484,10 +484,10 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, slots = SCM_SLOT (class, scm_si_slots); getters_n_setters = SCM_SLOT (class, scm_si_getters_n_setters); nfields = SCM_SLOT (class, scm_si_nfields); - if (!SCM_INUMP (nfields) || SCM_INUM (nfields) < 0) + if (!SCM_I_INUMP (nfields) || SCM_I_INUM (nfields) < 0) SCM_MISC_ERROR ("bad value in nfields slot: ~S", scm_list_1 (nfields)); - n = 2 * SCM_INUM (nfields); + n = 2 * SCM_I_INUM (nfields); if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1 && SCM_SUBCLASSP (class, scm_class_class)) SCM_MISC_ERROR ("class object doesn't have enough fields: ~S", @@ -600,7 +600,7 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity); else { - long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); + long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields)); #if 0 /* * We could avoid calling scm_gc_malloc in the allocation code @@ -649,7 +649,7 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots) SCM_SET_SLOT (z, scm_si_direct_supers, dsupers); cpl = compute_cpl (z); slots = build_slots_list (maplist (dslots), cpl); - nfields = SCM_I_MAKINUM (scm_ilength (slots)); + nfields = scm_from_int (scm_ilength (slots)); g_n_s = compute_getters_n_setters (slots); SCM_SET_SLOT (z, scm_si_name, name); @@ -779,7 +779,7 @@ create_basic_classes (void) SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL); SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL); /* will be changed */ /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */ - SCM_SET_SLOT (scm_class_class, scm_si_nfields, SCM_I_MAKINUM (SCM_N_CLASS_SLOTS)); + SCM_SET_SLOT (scm_class_class, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS)); /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters, compute_getters_n_setters (slots_of_class)); */ SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F); @@ -1062,7 +1062,7 @@ SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0, "the value from @var{obj}.") #define FUNC_NAME s_scm_at_assert_bound_ref { - SCM value = SCM_SLOT (obj, SCM_INUM (index)); + SCM value = SCM_SLOT (obj, scm_to_int (index)); if (SCM_GOOPS_UNBOUNDP (value)) return CALL_GF1 ("slot-unbound", obj); return value; @@ -1129,9 +1129,12 @@ get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef) /* Two cases here: * - access is an integer (the offset of this slot in the slots vector) * - otherwise (car access) is the getter function to apply + * + * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so + * we can just assume fixnums here. */ - if (SCM_INUMP (access)) - return SCM_SLOT (obj, SCM_INUM (access)); + if (SCM_I_INUMP (access)) + return SCM_SLOT (obj, SCM_I_INUM (access)); else { /* We must evaluate (apply (car access) (list obj)) @@ -1166,9 +1169,12 @@ set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value) /* Two cases here: * - access is an integer (the offset of this slot in the slots vector) * - otherwise (cadr access) is the setter function to apply + * + * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so + * we can just assume fixnums here. */ - if (SCM_INUMP (access)) - SCM_SET_SLOT (obj, SCM_INUM (access), value); + if (SCM_I_INUMP (access)) + SCM_SET_SLOT (obj, SCM_I_INUM (access), value); else { /* We must evaluate (apply (cadr l) (list obj value)) @@ -1382,7 +1388,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, /* Most instances */ if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT) { - n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); + n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields)); m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct"); return wrap_init (class, m, n); } @@ -1391,7 +1397,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN) return scm_make_foreign_object (class, initargs); - n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); + n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields)); /* Entities */ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY) @@ -1622,7 +1628,7 @@ scm_make_method_cache (SCM gf) { return scm_list_5 (SCM_IM_DISPATCH, scm_sym_args, - SCM_I_MAKINUM (1), + scm_from_int (1), scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE, list_of_no_method), gf); @@ -2712,11 +2718,11 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, scm_list_1 (slot)))); { SCM n = SCM_SLOT (class, scm_si_nfields); - SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, SCM_I_MAKINUM (1)); + SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1)); SCM_SET_SLOT (class, scm_si_getters_n_setters, scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters), scm_list_1 (gns)))); - SCM_SET_SLOT (class, scm_si_nfields, SCM_I_MAKINUM (SCM_INUM (n) + 1)); + SCM_SET_SLOT (class, scm_si_nfields, scm_sum (n, scm_from_int (1))); } } } @@ -2816,7 +2822,7 @@ scm_init_goops_builtins (void) scm_permanent_object (scm_goops_lookup_closure); scm_components = scm_permanent_object (scm_make_weak_key_hash_table - (SCM_I_MAKINUM (37))); + (scm_from_int (37))); goops_rstate = scm_c_make_rstate ("GOOPS", 5); diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 419fad40d..4f8faefa0 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -86,7 +86,7 @@ create_gsubr (int define, const char *name, } SCM_SET_GSUBR_PROC (cclo, subr); SCM_SET_GSUBR_TYPE (cclo, - SCM_I_MAKINUM (SCM_GSUBR_MAKTYPE (req, opt, rst))); + scm_from_int (SCM_GSUBR_MAKTYPE (req, opt, rst))); if (SCM_REC_PROCNAMES_P) scm_set_procedure_property_x (cclo, scm_sym_name, sym); if (define) @@ -187,13 +187,13 @@ scm_gsubr_apply (SCM args) SCM self = SCM_CAR (args); SCM (*fcn)() = SCM_SUBRF (SCM_GSUBR_PROC (self)); SCM v[SCM_GSUBR_MAX]; - long typ = SCM_INUM (SCM_GSUBR_TYPE (self)); + int typ = scm_to_int (SCM_GSUBR_TYPE (self)); long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ); #if 0 if (n > SCM_GSUBR_MAX) scm_misc_error (FUNC_NAME, "Function ~S has illegal arity ~S.", - scm_list_2 (self, SCM_I_MAKINUM (n))); + scm_list_2 (self, scm_from_int (n))); #endif args = SCM_CDR (args); for (i = 0; i < SCM_GSUBR_REQ (typ); i++) { diff --git a/libguile/guardians.c b/libguile/guardians.c index 95f95c745..706fbcb47 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -604,7 +604,7 @@ scm_init_guardians () whine_about_self_centered_zombies, 0, 0); greedily_guarded_whash = - scm_permanent_object (scm_make_doubly_weak_hash_table (SCM_I_MAKINUM (31))); + scm_permanent_object (scm_make_doubly_weak_hash_table (scm_from_int (31))); #include "libguile/guardians.x" } diff --git a/libguile/hash.c b/libguile/hash.c index 18c80c0dd..4415bf82f 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -57,7 +57,7 @@ scm_hasher(SCM obj, unsigned long n, size_t d) switch (SCM_ITAG3 (obj)) { case scm_tc3_int_1: case scm_tc3_int_2: - return SCM_INUM(obj) % n; /* SCM_INUMP(obj) */ + return SCM_I_INUM(obj) % n; /* SCM_INUMP(obj) */ case scm_tc3_imm24: if (SCM_CHARP(obj)) return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n; @@ -91,20 +91,20 @@ scm_hasher(SCM obj, unsigned long n, size_t d) case scm_tc7_number: switch SCM_TYP16 (obj) { case scm_tc16_big: - return SCM_INUM (scm_modulo (obj, SCM_I_MAKINUM (n))); + return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n))); case scm_tc16_real: { double r = SCM_REAL_VALUE (obj); - if (floor (r) == r) { - obj = scm_inexact_to_exact (obj); - if SCM_IMP (obj) return SCM_INUM (obj) % n; - return SCM_INUM (scm_modulo (obj, SCM_I_MAKINUM (n))); - } + if (floor (r) == r) + { + obj = scm_inexact_to_exact (obj); + return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n))); + } } /* Fall through */ case scm_tc16_complex: case scm_tc16_fraction: - obj = scm_number_to_string (obj, SCM_I_MAKINUM (10)); + obj = scm_number_to_string (obj, scm_from_int (10)); /* Fall through */ } /* Fall through */ diff --git a/libguile/hashtab.c b/libguile/hashtab.c index eae2f304a..311827cce 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -90,7 +90,7 @@ make_hash_table (int flags, unsigned long k, const char *func_name) { perform the final scan for broken references. Instead we do that ourselves in scan_weak_hashtables. */ vector = scm_i_allocate_weak_vector (flags | SCM_WVECTF_NOSCAN, - SCM_I_MAKINUM (n), + scm_from_int (n), SCM_EOL, func_name); else @@ -155,7 +155,7 @@ scm_i_rehash (SCM table, if (SCM_HASHTABLE_WEAK_P (table)) new_buckets = scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table) | SCM_WVECTF_NOSCAN, - SCM_I_MAKINUM (new_size), + scm_from_ulong (new_size), SCM_EOL, func_name); else diff --git a/libguile/hooks.c b/libguile/hooks.c index 10a3e6525..1c316ef69 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -202,9 +202,9 @@ SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0, SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (proc)), proc, SCM_ARG2, FUNC_NAME); n_args = SCM_HOOK_ARITY (hook); - if (SCM_INUM (SCM_CAR (arity)) > n_args + if (scm_to_int (SCM_CAR (arity)) > n_args || (scm_is_false (SCM_CADDR (arity)) - && (SCM_INUM (SCM_CAR (arity)) + SCM_INUM (SCM_CADR (arity)) + && (scm_to_int (SCM_CAR (arity)) + scm_to_int (SCM_CADR (arity)) < n_args))) scm_wrong_type_arg (FUNC_NAME, 2, proc); rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)); @@ -254,7 +254,7 @@ SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1, SCM_VALIDATE_HOOK (1, hook); if (scm_ilength (args) != SCM_HOOK_ARITY (hook)) SCM_MISC_ERROR ("Hook ~S requires ~A arguments", - scm_list_2 (hook, SCM_I_MAKINUM (SCM_HOOK_ARITY (hook)))); + scm_list_2 (hook, scm_from_int (SCM_HOOK_ARITY (hook)))); scm_c_run_hook (hook, args); return SCM_UNSPECIFIED; } diff --git a/libguile/ioext.c b/libguile/ioext.c index 0abce7f00..09392c057 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -53,7 +53,7 @@ SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_ftell { - return scm_seek (fd_port, SCM_INUM0, SCM_I_MAKINUM (SEEK_CUR)); + return scm_seek (fd_port, SCM_INUM0, scm_from_int (SEEK_CUR)); } #undef FUNC_NAME @@ -114,8 +114,8 @@ SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0, fd_or_port = SCM_COERCE_OUTPORT (fd_or_port); - if (SCM_INUMP (fd_or_port)) - oldfd = SCM_INUM (fd_or_port); + if (scm_is_integer (fd_or_port)) + oldfd = scm_to_int (fd_or_port); else { SCM_VALIDATE_OPFPORT (1, fd_or_port); @@ -178,7 +178,7 @@ SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPFPORT (1, port); - return SCM_I_MAKINUM (SCM_FPORT_FDES (port)); + return scm_from_int (SCM_FPORT_FDES (port)); } #undef FUNC_NAME diff --git a/libguile/list.c b/libguile/list.c index 7654f6617..18a0f70e7 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -196,7 +196,7 @@ SCM_DEFINE (scm_length, "length", 1, 0, 0, { long i; SCM_VALIDATE_LIST_COPYLEN (1, lst, i); - return SCM_I_MAKINUM (i); + return scm_from_long (i); } #undef FUNC_NAME diff --git a/libguile/net_db.c b/libguile/net_db.c index 7076ce40b..c1e2765fe 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -171,8 +171,8 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, SCM_VECTOR_SET(result, 0, scm_mem2string (entry->h_name, strlen (entry->h_name))); SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->h_aliases)); - SCM_VECTOR_SET(result, 2, SCM_I_MAKINUM (entry->h_addrtype + 0L)); - SCM_VECTOR_SET(result, 3, SCM_I_MAKINUM (entry->h_length + 0L)); + SCM_VECTOR_SET(result, 2, scm_from_int (entry->h_addrtype)); + SCM_VECTOR_SET(result, 3, scm_from_int (entry->h_length)); if (sizeof (struct in_addr) != entry->h_length) { SCM_VECTOR_SET(result, 4, SCM_BOOL_F); @@ -239,8 +239,8 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net), errno); SCM_VECTOR_SET(result, 0, scm_mem2string (entry->n_name, strlen (entry->n_name))); SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->n_aliases)); - SCM_VECTOR_SET(result, 2, SCM_I_MAKINUM (entry->n_addrtype + 0L)); - SCM_VECTOR_SET(result, 3, scm_ulong2num (entry->n_net + 0L)); + SCM_VECTOR_SET(result, 2, scm_from_int (entry->n_addrtype)); + SCM_VECTOR_SET(result, 3, scm_from_ulong (entry->n_net)); return result; } #undef FUNC_NAME @@ -285,7 +285,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol), errno); SCM_VECTOR_SET(result, 0, scm_mem2string (entry->p_name, strlen (entry->p_name))); SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->p_aliases)); - SCM_VECTOR_SET(result, 2, SCM_I_MAKINUM (entry->p_proto + 0L)); + SCM_VECTOR_SET(result, 2, scm_from_int (entry->p_proto)); return result; } #undef FUNC_NAME @@ -299,7 +299,7 @@ scm_return_entry (struct servent *entry) SCM_VECTOR_SET(result, 0, scm_mem2string (entry->s_name, strlen (entry->s_name))); SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->s_aliases)); - SCM_VECTOR_SET(result, 2, SCM_I_MAKINUM (ntohs (entry->s_port) + 0L)); + SCM_VECTOR_SET(result, 2, scm_from_uint16 (ntohs (entry->s_port))); SCM_VECTOR_SET(result, 3, scm_mem2string (entry->s_proto, strlen (entry->s_proto))); return result; } diff --git a/libguile/num2float.i.c b/libguile/num2float.i.c index bfcf4bd10..e69de29bb 100644 --- a/libguile/num2float.i.c +++ b/libguile/num2float.i.c @@ -1,39 +0,0 @@ -/* this file is #include'd (several times) by numbers.c */ - -FTYPE -NUM2FLOAT (SCM num, unsigned long int pos, const char *s_caller) -{ - if (SCM_INUMP (num)) - return SCM_INUM (num); - else if (SCM_BIGP (num)) - { /* bignum */ - FTYPE res = mpz_get_d (SCM_I_BIG_MPZ (num)); - if (! xisinf (res)) - return res; - else - scm_out_of_range (s_caller, num); - } - else if (SCM_REALP (num)) - return SCM_REAL_VALUE (num); - else - scm_wrong_type_arg (s_caller, pos, num); -} - -SCM -FLOAT2NUM (FTYPE n) -{ - SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0); - SCM_REAL_VALUE (z) = n; - return z; -} - -/* clean up */ -#undef FLOAT2NUM -#undef NUM2FLOAT -#undef FTYPE - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/num2integral.i.c b/libguile/num2integral.i.c index c5523b38f..e69de29bb 100644 --- a/libguile/num2integral.i.c +++ b/libguile/num2integral.i.c @@ -1,264 +0,0 @@ -/* this file is #include'd (many times) by numbers.c */ - -#if HAVE_CONFIG_H -# include -#endif - -#ifndef UNSIGNED_ITYPE -# if UNSIGNED -# define UNSIGNED_ITYPE ITYPE -# else -# define UNSIGNED_ITYPE unsigned ITYPE -# endif -#endif - -#define UNSIGNED_ITYPE_MAX (~((UNSIGNED_ITYPE)0)) - -#ifndef SIZEOF_ITYPE -#error SIZEOF_ITYPE must be defined. -#endif - -#if UNSIGNED -# if SIZEOF_ITYPE == SIZEOF_UNSIGNED_SHORT -# define BIGMPZ_FITSP mpz_fits_ushort_p -# elif SIZEOF_ITYPE == SIZEOF_UNSIGNED_INT -# define BIGMPZ_FITSP mpz_fits_uint_p -# elif SIZEOF_ITYPE == SIZEOF_UNSIGNED_LONG -# define BIGMPZ_FITSP mpz_fits_ulong_p -# else -# define BIGMPZ_FITSP ((int (*)(void *)) 0) -# endif /* sizeof checks */ -#else -/* UNSIGNED is not defined */ -# if SIZEOF_ITYPE == SIZEOF_SHORT -# define BIGMPZ_FITSP mpz_fits_sshort_p -# elif SIZEOF_ITYPE == SIZEOF_INT -# define BIGMPZ_FITSP mpz_fits_sint_p -# elif SIZEOF_ITYPE == SIZEOF_LONG -# define BIGMPZ_FITSP mpz_fits_slong_p -# else -# define BIGMPZ_FITSP ((int (*)(void *)) 0) -# endif /* sizeof checks */ -#endif /* UNSIGNED check */ - -/* We rely heavily on the compiler's optimizer to remove branches that - have constant value guards. */ - -ITYPE -NUM2INTEGRAL (SCM num, unsigned long int pos, const char *s_caller) -{ - if (SCM_INUMP (num)) - { /* immediate */ - scm_t_signed_bits n = SCM_INUM (num); - - if (UNSIGNED && (n < 0)) - scm_out_of_range (s_caller, num); - - if (SIZEOF_ITYPE >= SIZEOF_SCM_T_BITS) - /* the target type is large enough to hold any possible inum */ - return (ITYPE) n; - else - { -#if SIZEOF_SCM_T_BITS > SIZEOF_ITYPE - /* an inum can be out of range, so check */ - if (UNSIGNED) /* n is known to be >= 0 */ - { - if (((scm_t_bits) n) > UNSIGNED_ITYPE_MAX) - scm_out_of_range (s_caller, num); - } - else if (((ITYPE) n) != n) - scm_out_of_range (s_caller, num); -#endif - return (ITYPE) n; - } - } - else if (SCM_BIGP (num)) - { /* bignum */ - if (SIZEOF_ITYPE < SIZEOF_SCM_T_BITS) - scm_out_of_range (s_caller, num); - else - { - /* make sure the result will fit */ - if (BIGMPZ_FITSP != 0) - { - int fits_p = BIGMPZ_FITSP (SCM_I_BIG_MPZ (num)); - scm_remember_upto_here_1 (num); - if (!fits_p) - scm_out_of_range (s_caller, num); - } - else - { - size_t itype_bits = sizeof (ITYPE) * SCM_CHAR_BIT; - int sgn = mpz_sgn (SCM_I_BIG_MPZ (num)); - size_t numbits; - - if (UNSIGNED) - { - if (sgn < 0) - scm_out_of_range (s_caller, num); - } - - numbits = mpz_sizeinbase (SCM_I_BIG_MPZ (num), 2); - - if (UNSIGNED) - { - if (numbits > itype_bits) - scm_out_of_range (s_caller, num); - } - else - { - if (sgn >= 0) - { - /* positive, require num < 2^(itype_bits-1) */ - if (numbits > itype_bits-1) - scm_out_of_range (s_caller, num); - } - else - { - /* negative, require abs(num) < 2^(itype_bits-1), but - also allow num == -2^(itype_bits-1), the latter - detected by numbits==itype_bits plus the lowest - (and only) 1 bit at position itype_bits-1 */ - if (numbits > itype_bits - || (numbits == itype_bits - && (mpz_scan1 (SCM_I_BIG_MPZ (num), 0) - != itype_bits - 1))) - scm_out_of_range (s_caller, num); - } - } - } - - if (UNSIGNED && (SIZEOF_ITYPE <= SIZEOF_UNSIGNED_LONG)) - { - ITYPE result = (ITYPE) mpz_get_ui (SCM_I_BIG_MPZ (num)); - scm_remember_upto_here_1 (num); - return result; - } - else if ((!UNSIGNED) && (SIZEOF_ITYPE <= SIZEOF_LONG)) - { - ITYPE result = (ITYPE) mpz_get_si (SCM_I_BIG_MPZ (num)); - scm_remember_upto_here_1 (num); - return result; - } - else - { - int sgn = mpz_sgn (SCM_I_BIG_MPZ (num)); - ITYPE result = 0; - size_t count; - - mpz_export (&result, - &count, -#ifdef WORDS_BIGENDIAN - 1, -#else - -1, -#endif - SIZEOF_ITYPE, - 0, - 0, - SCM_I_BIG_MPZ (num)); - /* mpz_export doesn't handle sign */ - if (sgn < 0) result = - result; - scm_remember_upto_here_1 (num); - return result; - } - } - } - else - scm_wrong_type_arg (s_caller, pos, num); -} - - -SCM -INTEGRAL2NUM (ITYPE n) -{ - /* If we know the size of the type, determine at compile time - whether we need to perform the FIXABLE test or not. This is not - done to get more optimal code out of the compiler (it can figure - this out on its own already), but to avoid a spurious warning. - If we don't know the size, assume that the test must be done. - */ - - /* have to use #if here rather than if because of gcc warnings about - limited range */ -#if SIZEOF_ITYPE < SIZEOF_SCM_T_BITS - return SCM_I_MAKINUM ((scm_t_signed_bits) n); -#else /* not SIZEOF_ITYPE < SIZEOF_SCM_T_BITS */ - if (UNSIGNED) - { - if (SCM_POSFIXABLE (n)) - return SCM_I_MAKINUM ((scm_t_signed_bits) n); - } - else - { - if (SCM_FIXABLE (n)) - return SCM_I_MAKINUM ((scm_t_signed_bits) n); - } - return INTEGRAL2BIG (n); -#endif /* not SIZEOF_ITYPE < SIZEOF_SCM_T_BITS */ -} - -SCM -INTEGRAL2BIG (ITYPE n) -{ - if (UNSIGNED && (SIZEOF_ITYPE <= SIZEOF_LONG)) - { - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); - mpz_init_set_ui (SCM_I_BIG_MPZ (z), n); - return z; - } - else if ((!UNSIGNED) && (SIZEOF_ITYPE <= SIZEOF_UNSIGNED_LONG)) - { - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); - mpz_init_set_si (SCM_I_BIG_MPZ (z), n); - return z; - } - else - { - int neg_input = 0; - SCM result = scm_i_mkbig (); - - /* mpz_import doesn't handle sign -- have to use #if here rather - than if b/c gcc warnings for ushort, etc. */ -#if !UNSIGNED - if (n < 0) - { - neg_input = 1; - n = - n; - } -#endif - - mpz_import (SCM_I_BIG_MPZ (result), - 1, /* one word */ - 1, /* word order irrelevant when just one word */ - SIZEOF_ITYPE, /* word size */ - 0, /* native endianness within word */ - 0, /* no nails */ - &n); - - /* mpz_import doesn't handle sign */ - if (!UNSIGNED) - { - if (neg_input) - mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result)); - } - return result; - } -} - -/* clean up */ -#undef INTEGRAL2NUM -#undef INTEGRAL2BIG -#undef NUM2INTEGRAL -#undef UNSIGNED -#undef ITYPE -#undef SIZEOF_ITYPE -#undef UNSIGNED_ITYPE -#undef UNSIGNED_ITYPE_MAX -#undef BIGMPZ_FITSP - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/numbers.c b/libguile/numbers.c index a41e8394d..a6e5c69e5 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -78,7 +78,7 @@ #define SCM_I_NUMTAG_REAL scm_tc16_real #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex #define SCM_I_NUMTAG(x) \ - (SCM_INUMP(x) ? SCM_I_NUMTAG_INUM \ + (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \ : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \ : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \ : SCM_I_NUMTAG_NOTNUM))) @@ -329,7 +329,7 @@ scm_make_ratio (SCM numerator, SCM denominator) { /* First make sure the arguments are proper. */ - if (SCM_INUMP (denominator)) + if (SCM_I_INUMP (denominator)) { if (SCM_EQ_P (denominator, SCM_INUM0)) scm_num_overflow ("make-ratio"); @@ -341,7 +341,7 @@ scm_make_ratio (SCM numerator, SCM denominator) if (!(SCM_BIGP(denominator))) SCM_WRONG_TYPE_ARG (2, denominator); } - if (!SCM_INUMP (numerator) && !SCM_BIGP (numerator)) + if (!SCM_I_INUMP (numerator) && !SCM_BIGP (numerator)) SCM_WRONG_TYPE_ARG (1, numerator); /* Then flip signs so that the denominator is positive. @@ -355,15 +355,15 @@ scm_make_ratio (SCM numerator, SCM denominator) /* Now consider for each of the four fixnum/bignum combinations whether the rational number is really an integer. */ - if (SCM_INUMP (numerator)) + if (SCM_I_INUMP (numerator)) { - long x = SCM_INUM (numerator); + long x = SCM_I_INUM (numerator); if (SCM_EQ_P (numerator, SCM_INUM0)) return SCM_INUM0; - if (SCM_INUMP (denominator)) + if (SCM_I_INUMP (denominator)) { long y; - y = SCM_INUM (denominator); + y = SCM_I_INUM (denominator); if (x == y) return SCM_I_MAKINUM(1); if ((x % y) == 0) @@ -383,9 +383,9 @@ scm_make_ratio (SCM numerator, SCM denominator) } else if (SCM_BIGP (numerator)) { - if (SCM_INUMP (denominator)) + if (SCM_I_INUMP (denominator)) { - long yy = SCM_INUM (denominator); + long yy = SCM_I_INUM (denominator); if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy)) return scm_divide (numerator, denominator); } @@ -437,7 +437,7 @@ SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_exact_p { - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) return SCM_BOOL_T; if (SCM_BIGP (x)) return SCM_BOOL_T; @@ -456,9 +456,9 @@ SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_odd_p { - if (SCM_INUMP (n)) + if (SCM_I_INUMP (n)) { - long val = SCM_INUM (n); + long val = SCM_I_INUM (n); return scm_from_bool ((val & 1L) != 0); } else if (SCM_BIGP (n)) @@ -491,9 +491,9 @@ SCM_DEFINE (scm_even_p, "even?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_even_p { - if (SCM_INUMP (n)) + if (SCM_I_INUMP (n)) { - long val = SCM_INUM (n); + long val = SCM_I_INUM (n); return scm_from_bool ((val & 1L) == 0); } else if (SCM_BIGP (n)) @@ -642,9 +642,9 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, "Return the absolute value of @var{x}.") #define FUNC_NAME { - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - long int xx = SCM_INUM (x); + long int xx = SCM_I_INUM (x); if (xx >= 0) return x; else if (SCM_POSFIXABLE (-xx)) @@ -688,12 +688,12 @@ SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient); SCM scm_quotient (SCM x, SCM y) { - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) { - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); if (yy == 0) scm_num_overflow (s_quotient); else @@ -707,7 +707,7 @@ scm_quotient (SCM x, SCM y) } else if (SCM_BIGP (y)) { - if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM) + if ((SCM_I_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM) && (mpz_cmp_ui (SCM_I_BIG_MPZ (y), - SCM_MOST_NEGATIVE_FIXNUM) == 0)) { @@ -723,9 +723,9 @@ scm_quotient (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); if (yy == 0) scm_num_overflow (s_quotient); else if (yy == 1) @@ -772,22 +772,22 @@ SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder); SCM scm_remainder (SCM x, SCM y) { - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); if (yy == 0) scm_num_overflow (s_remainder); else { - long z = SCM_INUM (x) % yy; + long z = SCM_I_INUM (x) % yy; return SCM_I_MAKINUM (z); } } else if (SCM_BIGP (y)) { - if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM) + if ((SCM_I_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM) && (mpz_cmp_ui (SCM_I_BIG_MPZ (y), - SCM_MOST_NEGATIVE_FIXNUM) == 0)) { @@ -803,9 +803,9 @@ scm_remainder (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); if (yy == 0) scm_num_overflow (s_remainder); else @@ -845,12 +845,12 @@ SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo); SCM scm_modulo (SCM x, SCM y) { - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) { - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); if (yy == 0) scm_num_overflow (s_modulo); else @@ -921,9 +921,9 @@ scm_modulo (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); if (yy == 0) scm_num_overflow (s_modulo); else @@ -976,12 +976,12 @@ scm_gcd (SCM x, SCM y) if (SCM_UNBNDP (y)) return SCM_UNBNDP (x) ? SCM_INUM0 : x; - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long xx = SCM_INUM (x); - long yy = SCM_INUM (y); + long xx = SCM_I_INUM (x); + long yy = SCM_I_INUM (y); long u = xx < 0 ? -xx : xx; long v = yy < 0 ? -yy : yy; long result; @@ -1034,12 +1034,12 @@ scm_gcd (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { unsigned long result; long yy; big_inum: - yy = SCM_INUM (y); + yy = SCM_I_INUM (y); if (yy == 0) return scm_abs (x); if (yy < 0) @@ -1080,14 +1080,14 @@ scm_lcm (SCM n1, SCM n2) n2 = SCM_I_MAKINUM (1L); } - SCM_GASSERT2 (SCM_INUMP (n1) || SCM_BIGP (n1), + SCM_GASSERT2 (SCM_I_INUMP (n1) || SCM_BIGP (n1), g_lcm, n1, n2, SCM_ARG1, s_lcm); - SCM_GASSERT2 (SCM_INUMP (n2) || SCM_BIGP (n2), + SCM_GASSERT2 (SCM_I_INUMP (n2) || SCM_BIGP (n2), g_lcm, n1, n2, SCM_ARGn, s_lcm); - if (SCM_INUMP (n1)) + if (SCM_I_INUMP (n1)) { - if (SCM_INUMP (n2)) + if (SCM_I_INUMP (n2)) { SCM d = scm_gcd (n1, n2); if (SCM_EQ_P (d, SCM_INUM0)) @@ -1101,7 +1101,7 @@ scm_lcm (SCM n1, SCM n2) inumbig: { SCM result = scm_i_mkbig (); - long nn1 = SCM_INUM (n1); + long nn1 = SCM_I_INUM (n1); if (nn1 == 0) return SCM_INUM0; if (nn1 < 0) nn1 = - nn1; mpz_lcm_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n2), nn1); @@ -1113,7 +1113,7 @@ scm_lcm (SCM n1, SCM n2) else { /* big n1 */ - if (SCM_INUMP (n2)) + if (SCM_I_INUMP (n2)) { SCM_SWAP (n1, n2); goto inumbig; @@ -1197,12 +1197,12 @@ SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); } - if (SCM_INUMP (n1)) + if (SCM_I_INUMP (n1)) { - nn1 = SCM_INUM (n1); - if (SCM_INUMP (n2)) + nn1 = SCM_I_INUM (n1); + if (SCM_I_INUMP (n2)) { - long nn2 = SCM_INUM (n2); + long nn2 = SCM_I_INUM (n2); return SCM_I_MAKINUM (nn1 & nn2); } else if SCM_BIGP (n2) @@ -1225,10 +1225,10 @@ SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, } else if (SCM_BIGP (n1)) { - if (SCM_INUMP (n2)) + if (SCM_I_INUMP (n2)) { SCM_SWAP (n1, n2); - nn1 = SCM_INUM (n1); + nn1 = SCM_I_INUM (n1); goto intbig; } else if (SCM_BIGP (n2)) @@ -1271,12 +1271,12 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); } - if (SCM_INUMP (n1)) + if (SCM_I_INUMP (n1)) { - nn1 = SCM_INUM (n1); - if (SCM_INUMP (n2)) + nn1 = SCM_I_INUM (n1); + if (SCM_I_INUMP (n2)) { - long nn2 = SCM_INUM (n2); + long nn2 = SCM_I_INUM (n2); return SCM_I_MAKINUM (nn1 | nn2); } else if (SCM_BIGP (n2)) @@ -1299,10 +1299,10 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, } else if (SCM_BIGP (n1)) { - if (SCM_INUMP (n2)) + if (SCM_I_INUMP (n2)) { SCM_SWAP (n1, n2); - nn1 = SCM_INUM (n1); + nn1 = SCM_I_INUM (n1); goto intbig; } else if (SCM_BIGP (n2)) @@ -1347,12 +1347,12 @@ SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr, SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); } - if (SCM_INUMP (n1)) + if (SCM_I_INUMP (n1)) { - nn1 = SCM_INUM (n1); - if (SCM_INUMP (n2)) + nn1 = SCM_I_INUM (n1); + if (SCM_I_INUMP (n2)) { - long nn2 = SCM_INUM (n2); + long nn2 = SCM_I_INUM (n2); return SCM_I_MAKINUM (nn1 ^ nn2); } else if (SCM_BIGP (n2)) @@ -1373,10 +1373,10 @@ SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr, } else if (SCM_BIGP (n1)) { - if (SCM_INUMP (n2)) + if (SCM_I_INUMP (n2)) { SCM_SWAP (n1, n2); - nn1 = SCM_INUM (n1); + nn1 = SCM_I_INUM (n1); goto intbig; } else if (SCM_BIGP (n2)) @@ -1408,12 +1408,12 @@ SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0, { long int nj; - if (SCM_INUMP (j)) + if (SCM_I_INUMP (j)) { - nj = SCM_INUM (j); - if (SCM_INUMP (k)) + nj = SCM_I_INUM (j); + if (SCM_I_INUMP (k)) { - long nk = SCM_INUM (k); + long nk = SCM_I_INUM (k); return scm_from_bool (nj & nk); } else if (SCM_BIGP (k)) @@ -1437,10 +1437,10 @@ SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0, } else if (SCM_BIGP (j)) { - if (SCM_INUMP (k)) + if (SCM_I_INUMP (k)) { SCM_SWAP (j, k); - nj = SCM_INUM (j); + nj = SCM_I_INUM (j); goto intbig; } else if (SCM_BIGP (k)) @@ -1480,11 +1480,11 @@ SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0, unsigned long int iindex; iindex = scm_to_ulong (index); - if (SCM_INUMP (j)) + if (SCM_I_INUMP (j)) { /* bits above what's in an inum follow the sign bit */ iindex = min (iindex, SCM_LONG_BIT - 1); - return scm_from_bool ((1L << iindex) & SCM_INUM (j)); + return scm_from_bool ((1L << iindex) & SCM_I_INUM (j)); } else if (SCM_BIGP (j)) { @@ -1511,12 +1511,12 @@ SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_lognot { - if (SCM_INUMP (n)) { + if (SCM_I_INUMP (n)) { /* No overflow here, just need to toggle all the bits making up the inum. Enhancement: No need to strip the tag and add it back, could just xor a block of 1 bits, if that worked with the various debug versions of the SCM typedef. */ - return SCM_I_MAKINUM (~ SCM_INUM (n)); + return SCM_I_MAKINUM (~ SCM_I_INUM (n)); } else if (SCM_BIGP (n)) { SCM result = scm_i_mkbig (); @@ -1537,8 +1537,8 @@ coerce_to_big (SCM in, mpz_t out) { if (SCM_BIGP (in)) mpz_set (out, SCM_I_BIG_MPZ (in)); - else if (SCM_INUMP (in)) - mpz_set_si (out, SCM_INUM (in)); + else if (SCM_I_INUMP (in)) + mpz_set_si (out, SCM_I_INUM (in)); else return 0; @@ -1672,8 +1672,8 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, else if (SCM_EQ_P (n, SCM_I_MAKINUM (-1L))) return scm_is_false (scm_even_p (k)) ? n : acc; - if (SCM_INUMP (k)) - i2 = SCM_INUM (k); + if (SCM_I_INUMP (k)) + i2 = SCM_I_INUM (k); else if (SCM_BIGP (k)) { z_i2 = scm_i_clonebig (k, 1); @@ -1815,9 +1815,9 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, /* how many bits to keep */ bits = iend - istart; - if (SCM_INUMP (n)) + if (SCM_I_INUMP (n)) { - long int in = SCM_INUM (n); + long int in = SCM_I_INUM (n); /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */ @@ -1886,10 +1886,10 @@ SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_logcount { - if (SCM_INUMP (n)) + if (SCM_I_INUMP (n)) { unsigned long int c = 0; - long int nn = SCM_INUM (n); + long int nn = SCM_I_INUM (n); if (nn < 0) nn = -1 - nn; while (nn) @@ -1934,11 +1934,11 @@ SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_integer_length { - if (SCM_INUMP (n)) + if (SCM_I_INUMP (n)) { unsigned long int c = 0; unsigned int l = 4; - long int nn = SCM_INUM (n); + long int nn = SCM_I_INUM (n); if (nn < 0) nn = -1 - nn; while (nn) @@ -2264,10 +2264,10 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, else base = scm_to_signed_integer (radix, 2, 36); - if (SCM_INUMP (n)) + if (SCM_I_INUMP (n)) { char num_buf [SCM_INTBUFLEN]; - size_t length = scm_iint2str (SCM_INUM (n), base, num_buf); + size_t length = scm_iint2str (SCM_I_INUM (n), base, num_buf); return scm_mem2string (num_buf, length); } else if (SCM_BIGP (n)) @@ -3064,7 +3064,7 @@ SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0, "fulfilled if @var{x} is an integer number.") #define FUNC_NAME s_scm_rational_p { - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) return SCM_BOOL_T; else if (SCM_IMP (x)) return SCM_BOOL_F; @@ -3089,7 +3089,7 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, #define FUNC_NAME s_scm_integer_p { double r; - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) return SCM_BOOL_T; if (SCM_IMP (x)) return SCM_BOOL_F; @@ -3128,12 +3128,12 @@ SCM scm_num_eq_p (SCM x, SCM y) { again: - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) { - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); return scm_from_bool (xx == yy); } else if (SCM_BIGP (y)) @@ -3150,7 +3150,7 @@ scm_num_eq_p (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) return SCM_BOOL_F; else if (SCM_BIGP (y)) { @@ -3185,8 +3185,8 @@ scm_num_eq_p (SCM x, SCM y) } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) - return scm_from_bool (SCM_REAL_VALUE (x) == (double) SCM_INUM (y)); + if (SCM_I_INUMP (y)) + return scm_from_bool (SCM_REAL_VALUE (x) == (double) SCM_I_INUM (y)); else if (SCM_BIGP (y)) { int cmp; @@ -3216,8 +3216,8 @@ scm_num_eq_p (SCM x, SCM y) } else if (SCM_COMPLEXP (x)) { - if (SCM_INUMP (y)) - return scm_from_bool ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y)) + if (SCM_I_INUMP (y)) + return scm_from_bool ((SCM_COMPLEX_REAL (x) == (double) SCM_I_INUM (y)) && (SCM_COMPLEX_IMAG (x) == 0.0)); else if (SCM_BIGP (y)) { @@ -3254,7 +3254,7 @@ scm_num_eq_p (SCM x, SCM y) } else if (SCM_FRACTIONP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) return SCM_BOOL_F; else if (SCM_BIGP (y)) return SCM_BOOL_F; @@ -3305,12 +3305,12 @@ SCM scm_less_p (SCM x, SCM y) { again: - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) { - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); return scm_from_bool (xx < yy); } else if (SCM_BIGP (y)) @@ -3334,7 +3334,7 @@ scm_less_p (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); scm_remember_upto_here_1 (x); @@ -3362,8 +3362,8 @@ scm_less_p (SCM x, SCM y) } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) - return scm_from_bool (SCM_REAL_VALUE (x) < (double) SCM_INUM (y)); + if (SCM_I_INUMP (y)) + return scm_from_bool (SCM_REAL_VALUE (x) < (double) SCM_I_INUM (y)); else if (SCM_BIGP (y)) { int cmp; @@ -3390,7 +3390,7 @@ scm_less_p (SCM x, SCM y) } else if (SCM_FRACTIONP (x)) { - if (SCM_INUMP (y) || SCM_BIGP (y)) + if (SCM_I_INUMP (y) || SCM_BIGP (y)) { /* "a/b < y" becomes "a < y*b" */ y = scm_product (y, SCM_FRACTION_DENOMINATOR (x)); @@ -3491,7 +3491,7 @@ SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p); SCM scm_zero_p (SCM z) { - if (SCM_INUMP (z)) + if (SCM_I_INUMP (z)) return scm_from_bool (SCM_EQ_P (z, SCM_INUM0)); else if (SCM_BIGP (z)) return SCM_BOOL_F; @@ -3514,8 +3514,8 @@ SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p); SCM scm_positive_p (SCM x) { - if (SCM_INUMP (x)) - return scm_from_bool (SCM_INUM (x) > 0); + if (SCM_I_INUMP (x)) + return scm_from_bool (SCM_I_INUM (x) > 0); else if (SCM_BIGP (x)) { int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); @@ -3538,8 +3538,8 @@ SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p); SCM scm_negative_p (SCM x) { - if (SCM_INUMP (x)) - return scm_from_bool (SCM_INUM (x) < 0); + if (SCM_I_INUMP (x)) + return scm_from_bool (SCM_I_INUM (x) < 0); else if (SCM_BIGP (x)) { int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); @@ -3571,18 +3571,18 @@ scm_max (SCM x, SCM y) { if (SCM_UNBNDP (x)) SCM_WTA_DISPATCH_0 (g_max, s_max); - else if (SCM_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x)) + else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x)) return x; else SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max); } - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) { - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); return (xx < yy) ? y : x; } else if (SCM_BIGP (y)) @@ -3607,7 +3607,7 @@ scm_max (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); scm_remember_upto_here_1 (x); @@ -3637,9 +3637,9 @@ scm_max (SCM x, SCM y) } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - double z = SCM_INUM (y); + double z = SCM_I_INUM (y); /* if x==NaN then "<" is false and we return NaN */ return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x; } @@ -3668,7 +3668,7 @@ scm_max (SCM x, SCM y) } else if (SCM_FRACTIONP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { goto use_less; } @@ -3703,18 +3703,18 @@ scm_min (SCM x, SCM y) { if (SCM_UNBNDP (x)) SCM_WTA_DISPATCH_0 (g_min, s_min); - else if (SCM_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x)) + else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x)) return x; else SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min); } - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) { - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); return (xx < yy) ? x : y; } else if (SCM_BIGP (y)) @@ -3739,7 +3739,7 @@ scm_min (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); scm_remember_upto_here_1 (x); @@ -3769,9 +3769,9 @@ scm_min (SCM x, SCM y) } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - double z = SCM_INUM (y); + double z = SCM_I_INUM (y); /* if x==NaN then "<" is false and we return NaN */ return (z < SCM_REAL_VALUE (x)) ? scm_make_real (z) : x; } @@ -3800,7 +3800,7 @@ scm_min (SCM x, SCM y) } else if (SCM_FRACTIONP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { goto use_less; } @@ -3839,12 +3839,12 @@ scm_sum (SCM x, SCM y) SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum); } - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long xx = SCM_INUM (x); - long yy = SCM_INUM (y); + long xx = SCM_I_INUM (x); + long yy = SCM_I_INUM (y); long int z = xx + yy; return SCM_FIXABLE (z) ? SCM_I_MAKINUM (z) : scm_i_long2big (z); } @@ -3855,12 +3855,12 @@ scm_sum (SCM x, SCM y) } else if (SCM_REALP (y)) { - long int xx = SCM_INUM (x); + long int xx = SCM_I_INUM (x); return scm_make_real (xx + SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { - long int xx = SCM_INUM (x); + long int xx = SCM_I_INUM (x); return scm_make_complex (xx + SCM_COMPLEX_REAL (y), SCM_COMPLEX_IMAG (y)); } @@ -3872,12 +3872,12 @@ scm_sum (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { long int inum; int bigsgn; add_big_inum: - inum = SCM_INUM (y); + inum = SCM_I_INUM (y); if (inum == 0) return x; bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x)); @@ -3938,8 +3938,8 @@ scm_sum (SCM x, SCM y) } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) - return scm_make_real (SCM_REAL_VALUE (x) + SCM_INUM (y)); + if (SCM_I_INUMP (y)) + return scm_make_real (SCM_REAL_VALUE (x) + SCM_I_INUM (y)); else if (SCM_BIGP (y)) { double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x); @@ -3958,8 +3958,8 @@ scm_sum (SCM x, SCM y) } else if (SCM_COMPLEXP (x)) { - if (SCM_INUMP (y)) - return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_INUM (y), + if (SCM_I_INUMP (y)) + return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_I_INUM (y), SCM_COMPLEX_IMAG (x)); else if (SCM_BIGP (y)) { @@ -3982,7 +3982,7 @@ scm_sum (SCM x, SCM y) } else if (SCM_FRACTIONP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x), scm_product (y, SCM_FRACTION_DENOMINATOR (x))), SCM_FRACTION_DENOMINATOR (x)); @@ -4021,9 +4021,9 @@ scm_difference (SCM x, SCM y) if (SCM_UNBNDP (x)) SCM_WTA_DISPATCH_0 (g_difference, s_difference); else - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - long xx = -SCM_INUM (x); + long xx = -SCM_I_INUM (x); if (SCM_FIXABLE (xx)) return SCM_I_MAKINUM (xx); else @@ -4044,12 +4044,12 @@ scm_difference (SCM x, SCM y) SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference); } - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long int xx = SCM_INUM (x); - long int yy = SCM_INUM (y); + long int xx = SCM_I_INUM (x); + long int yy = SCM_I_INUM (y); long int z = xx - yy; if (SCM_FIXABLE (z)) return SCM_I_MAKINUM (z); @@ -4059,7 +4059,7 @@ scm_difference (SCM x, SCM y) else if (SCM_BIGP (y)) { /* inum-x - big-y */ - long xx = SCM_INUM (x); + long xx = SCM_I_INUM (x); if (xx == 0) return scm_i_clonebig (y, 0); @@ -4087,12 +4087,12 @@ scm_difference (SCM x, SCM y) } else if (SCM_REALP (y)) { - long int xx = SCM_INUM (x); + long int xx = SCM_I_INUM (x); return scm_make_real (xx - SCM_REAL_VALUE (y)); } else if (SCM_COMPLEXP (y)) { - long int xx = SCM_INUM (x); + long int xx = SCM_I_INUM (x); return scm_make_complex (xx - SCM_COMPLEX_REAL (y), - SCM_COMPLEX_IMAG (y)); } @@ -4106,10 +4106,10 @@ scm_difference (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { /* big-x - inum-y */ - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); scm_remember_upto_here_1 (x); @@ -4169,8 +4169,8 @@ scm_difference (SCM x, SCM y) } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) - return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y)); + if (SCM_I_INUMP (y)) + return scm_make_real (SCM_REAL_VALUE (x) - SCM_I_INUM (y)); else if (SCM_BIGP (y)) { double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y)); @@ -4189,8 +4189,8 @@ scm_difference (SCM x, SCM y) } else if (SCM_COMPLEXP (x)) { - if (SCM_INUMP (y)) - return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y), + if (SCM_I_INUMP (y)) + return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_I_INUM (y), SCM_COMPLEX_IMAG (x)); else if (SCM_BIGP (y)) { @@ -4213,7 +4213,7 @@ scm_difference (SCM x, SCM y) } else if (SCM_FRACTIONP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) /* a/b - c = (a - cb) / b */ return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), scm_product(y, SCM_FRACTION_DENOMINATOR (x))), @@ -4258,12 +4258,12 @@ scm_product (SCM x, SCM y) SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product); } - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { long xx; intbig: - xx = SCM_INUM (x); + xx = SCM_I_INUM (x); switch (xx) { @@ -4271,12 +4271,12 @@ scm_product (SCM x, SCM y) case 1: return y; break; } - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); long kk = xx * yy; SCM k = SCM_I_MAKINUM (kk); - if ((kk == SCM_INUM (k)) && (kk / xx == yy)) + if ((kk == SCM_I_INUM (k)) && (kk / xx == yy)) return k; else { @@ -4305,7 +4305,7 @@ scm_product (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { SCM_SWAP (x, y); goto intbig; @@ -4340,8 +4340,8 @@ scm_product (SCM x, SCM y) } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) - return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x)); + if (SCM_I_INUMP (y)) + return scm_make_real (SCM_I_INUM (y) * SCM_REAL_VALUE (x)); else if (SCM_BIGP (y)) { double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x); @@ -4360,9 +4360,9 @@ scm_product (SCM x, SCM y) } else if (SCM_COMPLEXP (x)) { - if (SCM_INUMP (y)) - return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x), - SCM_INUM (y) * SCM_COMPLEX_IMAG (x)); + if (SCM_I_INUMP (y)) + return scm_make_complex (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x), + SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x)); else if (SCM_BIGP (y)) { double z = mpz_get_d (SCM_I_BIG_MPZ (y)); @@ -4391,7 +4391,7 @@ scm_product (SCM x, SCM y) } else if (SCM_FRACTIONP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) return scm_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)), SCM_FRACTION_DENOMINATOR (x)); else if (SCM_BIGP (y)) @@ -4422,8 +4422,8 @@ double scm_num2dbl (SCM a, const char *why) #define FUNC_NAME why { - if (SCM_INUMP (a)) - return (double) SCM_INUM (a); + if (SCM_I_INUMP (a)) + return (double) SCM_I_INUM (a); else if (SCM_BIGP (a)) { double result = mpz_get_d (SCM_I_BIG_MPZ (a)); @@ -4486,9 +4486,9 @@ scm_i_divide (SCM x, SCM y, int inexact) { if (SCM_UNBNDP (x)) SCM_WTA_DISPATCH_0 (g_divide, s_divide); - else if (SCM_INUMP (x)) + else if (SCM_I_INUMP (x)) { - long xx = SCM_INUM (x); + long xx = SCM_I_INUM (x); if (xx == 1 || xx == -1) return x; #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO @@ -4542,12 +4542,12 @@ scm_i_divide (SCM x, SCM y, int inexact) SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); } - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) { - long yy = SCM_INUM (y); + long yy = SCM_I_INUM (y); if (yy == 0) { #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO @@ -4617,9 +4617,9 @@ scm_i_divide (SCM x, SCM y, int inexact) } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long int yy = SCM_INUM (y); + long int yy = SCM_I_INUM (y); if (yy == 0) { #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO @@ -4726,9 +4726,9 @@ scm_i_divide (SCM x, SCM y, int inexact) else if (SCM_REALP (x)) { double rx = SCM_REAL_VALUE (x); - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long int yy = SCM_INUM (y); + long int yy = SCM_I_INUM (y); #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO if (yy == 0) scm_num_overflow (s_divide); @@ -4766,9 +4766,9 @@ scm_i_divide (SCM x, SCM y, int inexact) { double rx = SCM_COMPLEX_REAL (x); double ix = SCM_COMPLEX_IMAG (x); - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long int yy = SCM_INUM (y); + long int yy = SCM_I_INUM (y); #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO if (yy == 0) scm_num_overflow (s_divide); @@ -4822,9 +4822,9 @@ scm_i_divide (SCM x, SCM y, int inexact) } else if (SCM_FRACTIONP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long int yy = SCM_INUM (y); + long int yy = SCM_I_INUM (y); #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO if (yy == 0) scm_num_overflow (s_divide); @@ -5001,7 +5001,7 @@ SCM_DEFINE (scm_round_number, "round", 1, 0, 0, "round towards the even one.") #define FUNC_NAME s_scm_round_number { - if (SCM_INUMP (x) || SCM_BIGP (x)) + if (SCM_I_INUMP (x) || SCM_BIGP (x)) return x; else if (SCM_REALP (x)) return scm_make_real (scm_round (SCM_REAL_VALUE (x))); @@ -5027,7 +5027,7 @@ SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0, "Round the number @var{x} towards minus infinity.") #define FUNC_NAME s_scm_floor { - if (SCM_INUMP (x) || SCM_BIGP (x)) + if (SCM_I_INUMP (x) || SCM_BIGP (x)) return x; else if (SCM_REALP (x)) return scm_make_real (floor (SCM_REAL_VALUE (x))); @@ -5058,7 +5058,7 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0, "Round the number @var{x} towards infinity.") #define FUNC_NAME s_scm_ceiling { - if (SCM_INUMP (x) || SCM_BIGP (x)) + if (SCM_I_INUMP (x) || SCM_BIGP (x)) return x; else if (SCM_REALP (x)) return scm_make_real (ceil (SCM_REAL_VALUE (x))); @@ -5137,8 +5137,8 @@ static void scm_two_doubles (SCM x, static void scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy) { - if (SCM_INUMP (x)) - xy->x = SCM_INUM (x); + if (SCM_I_INUMP (x)) + xy->x = SCM_I_INUM (x); else if (SCM_BIGP (x)) xy->x = scm_i_big2dbl (x); else if (SCM_REALP (x)) @@ -5148,8 +5148,8 @@ scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy) else scm_wrong_type_arg (sstring, SCM_ARG1, x); - if (SCM_INUMP (y)) - xy->y = SCM_INUM (y); + if (SCM_I_INUMP (y)) + xy->y = SCM_I_INUM (y); else if (SCM_BIGP (y)) xy->y = scm_i_big2dbl (y); else if (SCM_REALP (y)) @@ -5229,7 +5229,7 @@ SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part); SCM scm_real_part (SCM z) { - if (SCM_INUMP (z)) + if (SCM_I_INUMP (z)) return z; else if (SCM_BIGP (z)) return z; @@ -5250,7 +5250,7 @@ SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part); SCM scm_imag_part (SCM z) { - if (SCM_INUMP (z)) + if (SCM_I_INUMP (z)) return SCM_INUM0; else if (SCM_BIGP (z)) return SCM_INUM0; @@ -5270,7 +5270,7 @@ SCM_GPROC (s_numerator, "numerator", 1, 0, 0, scm_numerator, g_numerator); SCM scm_numerator (SCM z) { - if (SCM_INUMP (z)) + if (SCM_I_INUMP (z)) return z; else if (SCM_BIGP (z)) return z; @@ -5292,7 +5292,7 @@ SCM_GPROC (s_denominator, "denominator", 1, 0, 0, scm_denominator, g_denominator SCM scm_denominator (SCM z) { - if (SCM_INUMP (z)) + if (SCM_I_INUMP (z)) return SCM_I_MAKINUM (1); else if (SCM_BIGP (z)) return SCM_I_MAKINUM (1); @@ -5314,9 +5314,9 @@ SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude); SCM scm_magnitude (SCM z) { - if (SCM_INUMP (z)) + if (SCM_I_INUMP (z)) { - long int zz = SCM_INUM (z); + long int zz = SCM_I_INUM (z); if (zz >= 0) return z; else if (SCM_POSFIXABLE (-zz)) @@ -5359,9 +5359,9 @@ scm_angle (SCM z) scm_flo0 to save allocating a new flonum with scm_make_real each time. But if atan2 follows the floating point rounding mode, then the value is not a constant. Maybe it'd be close enough though. */ - if (SCM_INUMP (z)) + if (SCM_I_INUMP (z)) { - if (SCM_INUM (z) >= 0) + if (SCM_I_INUM (z) >= 0) return scm_flo0; else return scm_make_real (atan2 (0.0, -1.0)); @@ -5401,8 +5401,8 @@ SCM_GPROC (s_exact_to_inexact, "exact->inexact", 1, 0, 0, scm_exact_to_inexact, SCM scm_exact_to_inexact (SCM z) { - if (SCM_INUMP (z)) - return scm_make_real ((double) SCM_INUM (z)); + if (SCM_I_INUMP (z)) + return scm_make_real ((double) SCM_I_INUM (z)); else if (SCM_BIGP (z)) return scm_make_real (scm_i_big2dbl (z)); else if (SCM_FRACTIONP (z)) @@ -5419,7 +5419,7 @@ SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, "Return an exact number that is numerically closest to @var{z}.") #define FUNC_NAME s_scm_inexact_to_exact { - if (SCM_INUMP (z)) + if (SCM_I_INUMP (z)) return z; else if (SCM_BIGP (z)) return z; @@ -5456,7 +5456,7 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, "Return an exact number that is within @var{err} of @var{x}.") #define FUNC_NAME s_scm_rationalize { - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) return x; else if (SCM_BIGP (x)) return x; @@ -5656,9 +5656,9 @@ scm_is_integer (SCM val) int scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max) { - if (SCM_INUMP (val)) + if (SCM_I_INUMP (val)) { - scm_t_signed_bits n = SCM_INUM (val); + scm_t_signed_bits n = SCM_I_INUM (val); return n >= min && n <= max; } else if (SCM_BIGP (val)) @@ -5709,9 +5709,9 @@ scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max) int scm_is_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max) { - if (SCM_INUMP (val)) + if (SCM_I_INUMP (val)) { - scm_t_signed_bits n = SCM_INUM (val); + scm_t_signed_bits n = SCM_I_INUM (val); return n >= 0 && ((scm_t_uintmax)n) >= min && ((scm_t_uintmax)n) <= max; } else if (SCM_BIGP (val)) @@ -5753,9 +5753,9 @@ scm_is_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max) scm_t_intmax scm_to_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max) { - if (SCM_INUMP (val)) + if (SCM_I_INUMP (val)) { - scm_t_signed_bits n = SCM_INUM (val); + scm_t_signed_bits n = SCM_I_INUM (val); if (n >= min && n <= max) return n; else @@ -5822,9 +5822,9 @@ scm_to_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max) scm_t_uintmax scm_to_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max) { - if (SCM_INUMP (val)) + if (SCM_I_INUMP (val)) { - scm_t_signed_bits n = SCM_INUM (val); + scm_t_signed_bits n = SCM_I_INUM (val); if (n >= 0 && ((scm_t_uintmax)n) >= min && ((scm_t_uintmax)n) <= max) return n; else diff --git a/libguile/objects.c b/libguile/objects.c index f999a4f37..ca5c2c29f 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -234,18 +234,25 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, SCM scm_mcache_lookup_cmethod (SCM cache, SCM args) { - long i, n, end, mask; + unsigned long i, mask, n, end; SCM ls, methods, z = SCM_CDDR (cache); - n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */ + n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */ methods = SCM_CADR (z); - if (SCM_INUMP (methods)) + if (SCM_VECTORP (methods)) + { + /* cache format #1: prepare for linear search */ + mask = -1; + i = 0; + end = SCM_VECTOR_LENGTH (methods); + } + else { /* cache format #2: compute a hash value */ - long hashset = SCM_INUM (methods); + unsigned long hashset = scm_to_ulong (methods); long j = n; z = SCM_CDDR (z); - mask = SCM_INUM (SCM_CAR (z)); + mask = scm_to_ulong (SCM_CAR (z)); methods = SCM_CADR (z); i = 0; ls = args; @@ -260,13 +267,6 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) i &= mask; end = i; } - else /* SCM_VECTORP (methods) */ - { - /* cache format #1: prepare for linear search */ - mask = -1; - i = 0; - end = SCM_VECTOR_LENGTH (methods); - } /* Search for match */ do diff --git a/libguile/options.c b/libguile/options.c index 9262d34fa..41cadc7b5 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -92,9 +92,8 @@ SCM_SYMBOL (scm_no_sym, "no"); static SCM protected_objects = SCM_EOL; - -/* Return a list of the current option setting. The format of an option - * setting is described in the above documentation. */ +/* Return a list of the current option setting. The format of an + * option setting is described in the above documentation. */ static SCM get_option_setting (const scm_t_option options[], unsigned int n) { @@ -109,7 +108,7 @@ get_option_setting (const scm_t_option options[], unsigned int n) ls = scm_cons (SCM_PACK (options[i].name), ls); break; case SCM_OPTION_INTEGER: - ls = scm_cons (SCM_I_MAKINUM (options[i].val), ls); + ls = scm_cons (scm_from_unsigned_integer (options[i].val), ls); ls = scm_cons (SCM_PACK (options[i].name), ls); break; case SCM_OPTION_SCM: @@ -138,7 +137,7 @@ get_documented_option_setting (const scm_t_option options[], unsigned int n) ls = scm_cons (options[i].val ? scm_yes_sym : scm_no_sym, ls); break; case SCM_OPTION_INTEGER: - ls = scm_cons (SCM_I_MAKINUM (options[i].val), ls); + ls = scm_cons (scm_from_unsigned_integer (options[i].val), ls); break; case SCM_OPTION_SCM: ls = scm_cons (SCM_PACK (options[i].val), ls); @@ -189,8 +188,7 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c case SCM_OPTION_INTEGER: args = SCM_CDR (args); SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG1, s); - SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), args, SCM_ARG1, s); - flags[i] = SCM_INUM (SCM_CAR (args)); + flags[i] = scm_to_size_t (SCM_CAR (args)); break; case SCM_OPTION_SCM: args = SCM_CDR (args); diff --git a/libguile/ports.c b/libguile/ports.c index e277a9d82..101244d84 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -587,7 +587,7 @@ SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0, "is only included in @code{--enable-guile-debug} builds.") #define FUNC_NAME s_scm_pt_size { - return SCM_I_MAKINUM (scm_i_port_table_size); + return scm_from_int (scm_i_port_table_size); } #undef FUNC_NAME @@ -640,7 +640,7 @@ SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - return SCM_I_MAKINUM (scm_revealed_count (port)); + return scm_from_int (scm_revealed_count (port)); } #undef FUNC_NAME @@ -1412,16 +1412,16 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, if (SCM_STRINGP (object)) SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL); - length = scm_seek (object, SCM_INUM0, SCM_I_MAKINUM (SEEK_CUR)); + length = scm_seek (object, SCM_INUM0, scm_from_int (SEEK_CUR)); } c_length = SCM_NUM2LONG (2, length); if (c_length < 0) SCM_MISC_ERROR ("negative offset", SCM_EOL); object = SCM_COERCE_OUTPORT (object); - if (SCM_INUMP (object)) + if (scm_is_integer (object)) { - SCM_SYSCALL (rv = ftruncate (SCM_INUM (object), c_length)); + SCM_SYSCALL (rv = ftruncate (scm_to_int (object), c_length)); } else if (SCM_OPOUTPORTP (object)) { @@ -1461,7 +1461,7 @@ SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - return SCM_I_MAKINUM (SCM_LINUM (port)); + return scm_from_int (SCM_LINUM (port)); } #undef FUNC_NAME @@ -1492,7 +1492,7 @@ SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - return SCM_I_MAKINUM (SCM_COL (port)); + return scm_from_int (SCM_COL (port)); } #undef FUNC_NAME @@ -1635,9 +1635,9 @@ void scm_init_ports () { /* lseek() symbols. */ - scm_c_define ("SEEK_SET", SCM_I_MAKINUM (SEEK_SET)); - scm_c_define ("SEEK_CUR", SCM_I_MAKINUM (SEEK_CUR)); - scm_c_define ("SEEK_END", SCM_I_MAKINUM (SEEK_END)); + scm_c_define ("SEEK_SET", scm_from_int (SEEK_SET)); + scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR)); + scm_c_define ("SEEK_END", scm_from_int (SEEK_END)); scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port, write_void_port); diff --git a/libguile/posix.c b/libguile/posix.c index 804e9a3d7..79f8ea2ad 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -283,7 +283,7 @@ SCM_DEFINE (scm_setgroups, "setgroups", 1, 0, 0, size = ngroups * sizeof (GETGROUPS_T); if (size / sizeof (GETGROUPS_T) != ngroups) - SCM_OUT_OF_RANGE (SCM_ARG1, SCM_I_MAKINUM (ngroups)); + SCM_OUT_OF_RANGE (SCM_ARG1, scm_from_int (ngroups)); groups = scm_malloc (size); for(i = 0; i < ngroups; i++) groups [i] = SCM_NUM2ULONG (1, SCM_VECTOR_REF (group_vec, i)); @@ -318,9 +318,9 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_INUMP (user)) + else if (scm_is_integer (user)) { - entry = getpwuid (SCM_INUM (user)); + entry = getpwuid (scm_to_int (user)); } else { @@ -387,8 +387,8 @@ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_INUMP (name)) - SCM_SYSCALL (entry = getgrgid (SCM_INUM (name))); + else if (scm_is_integer (name)) + SCM_SYSCALL (entry = getgrgid (scm_to_int (name))); else { SCM_VALIDATE_STRING (1, name); @@ -530,7 +530,7 @@ SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, int lstatus; /* On Ultrix, the WIF... macros assume their argument is an lvalue; - go figure. SCM_INUM does not yield an lvalue. */ + go figure. */ lstatus = scm_to_int (status); if (WIFEXITED (lstatus)) return (scm_from_int (WEXITSTATUS (lstatus))); @@ -579,7 +579,7 @@ SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0, "process.") #define FUNC_NAME s_scm_getppid { - return SCM_I_MAKINUM (0L + getppid ()); + return scm_from_int (getppid ()); } #undef FUNC_NAME #endif /* HAVE_GETPPID */ @@ -591,7 +591,7 @@ SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0, "Return an integer representing the current real user ID.") #define FUNC_NAME s_scm_getuid { - return SCM_I_MAKINUM (0L + getuid ()); + return scm_from_int (getuid ()); } #undef FUNC_NAME @@ -602,7 +602,7 @@ SCM_DEFINE (scm_getgid, "getgid", 0, 0, 0, "Return an integer representing the current real group ID.") #define FUNC_NAME s_scm_getgid { - return SCM_I_MAKINUM (0L + getgid ()); + return scm_from_int (getgid ()); } #undef FUNC_NAME @@ -617,9 +617,9 @@ SCM_DEFINE (scm_geteuid, "geteuid", 0, 0, 0, #define FUNC_NAME s_scm_geteuid { #ifdef HAVE_GETEUID - return SCM_I_MAKINUM (0L + geteuid ()); + return scm_from_int (geteuid ()); #else - return SCM_I_MAKINUM (0L + getuid ()); + return scm_from_int (getuid ()); #endif } #undef FUNC_NAME @@ -634,9 +634,9 @@ SCM_DEFINE (scm_getegid, "getegid", 0, 0, 0, #define FUNC_NAME s_scm_getegid { #ifdef HAVE_GETEUID - return SCM_I_MAKINUM (0L + getegid ()); + return scm_from_int (getegid ()); #else - return SCM_I_MAKINUM (0L + getgid ()); + return scm_from_int (getgid ()); #endif } #undef FUNC_NAME @@ -727,7 +727,7 @@ SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0, { int (*fn)(); fn = (int (*) ()) getpgrp; - return SCM_I_MAKINUM (fn (0)); + return scm_from_int (fn (0)); } #undef FUNC_NAME #endif /* HAVE_GETPGRP */ @@ -831,7 +831,7 @@ SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0, fd = SCM_FPORT_FDES (port); if ((pgid = tcgetpgrp (fd)) == -1) SCM_SYSERROR; - return SCM_I_MAKINUM (pgid); + return scm_from_int (pgid); } #undef FUNC_NAME #endif /* HAVE_TCGETPGRP */ @@ -1016,7 +1016,7 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0, pid = fork (); if (pid == -1) SCM_SYSERROR; - return SCM_I_MAKINUM (0L+pid); + return scm_from_int (pid); } #undef FUNC_NAME #endif /* HAVE_FORK */ @@ -1211,7 +1211,7 @@ SCM_DEFINE (scm_getpid, "getpid", 0, 0, 0, "Return an integer representing the current process ID.") #define FUNC_NAME s_scm_getpid { - return SCM_I_MAKINUM ((unsigned long) getpid ()); + return scm_from_ulong (getpid ()); } #undef FUNC_NAME @@ -1275,8 +1275,8 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, if (ptr[SCM_STRING_LENGTH (str) - 1] == '=') { char *alt; - SCM name = scm_substring (str, SCM_I_MAKINUM (0), - SCM_I_MAKINUM (SCM_STRING_LENGTH (str) - 1)); + SCM name = scm_substring (str, scm_from_int (0), + scm_from_int (SCM_STRING_LENGTH (str)-1)); if (getenv (SCM_STRING_CHARS (name)) == NULL) { alt = scm_malloc (SCM_STRING_LENGTH (str) + 2); @@ -1819,70 +1819,70 @@ scm_init_posix () scm_add_feature ("EIDs"); #endif #ifdef WAIT_ANY - scm_c_define ("WAIT_ANY", SCM_I_MAKINUM (WAIT_ANY)); + scm_c_define ("WAIT_ANY", scm_from_int (WAIT_ANY)); #endif #ifdef WAIT_MYPGRP - scm_c_define ("WAIT_MYPGRP", SCM_I_MAKINUM (WAIT_MYPGRP)); + scm_c_define ("WAIT_MYPGRP", scm_from_int (WAIT_MYPGRP)); #endif #ifdef WNOHANG - scm_c_define ("WNOHANG", SCM_I_MAKINUM (WNOHANG)); + scm_c_define ("WNOHANG", scm_from_int (WNOHANG)); #endif #ifdef WUNTRACED - scm_c_define ("WUNTRACED", SCM_I_MAKINUM (WUNTRACED)); + scm_c_define ("WUNTRACED", scm_from_int (WUNTRACED)); #endif /* access() symbols. */ - scm_c_define ("R_OK", SCM_I_MAKINUM (R_OK)); - scm_c_define ("W_OK", SCM_I_MAKINUM (W_OK)); - scm_c_define ("X_OK", SCM_I_MAKINUM (X_OK)); - scm_c_define ("F_OK", SCM_I_MAKINUM (F_OK)); + scm_c_define ("R_OK", scm_from_int (R_OK)); + scm_c_define ("W_OK", scm_from_int (W_OK)); + scm_c_define ("X_OK", scm_from_int (X_OK)); + scm_c_define ("F_OK", scm_from_int (F_OK)); #ifdef LC_COLLATE - scm_c_define ("LC_COLLATE", SCM_I_MAKINUM (LC_COLLATE)); + scm_c_define ("LC_COLLATE", scm_from_int (LC_COLLATE)); #endif #ifdef LC_CTYPE - scm_c_define ("LC_CTYPE", SCM_I_MAKINUM (LC_CTYPE)); + scm_c_define ("LC_CTYPE", scm_from_int (LC_CTYPE)); #endif #ifdef LC_MONETARY - scm_c_define ("LC_MONETARY", SCM_I_MAKINUM (LC_MONETARY)); + scm_c_define ("LC_MONETARY", scm_from_int (LC_MONETARY)); #endif #ifdef LC_NUMERIC - scm_c_define ("LC_NUMERIC", SCM_I_MAKINUM (LC_NUMERIC)); + scm_c_define ("LC_NUMERIC", scm_from_int (LC_NUMERIC)); #endif #ifdef LC_TIME - scm_c_define ("LC_TIME", SCM_I_MAKINUM (LC_TIME)); + scm_c_define ("LC_TIME", scm_from_int (LC_TIME)); #endif #ifdef LC_MESSAGES - scm_c_define ("LC_MESSAGES", SCM_I_MAKINUM (LC_MESSAGES)); + scm_c_define ("LC_MESSAGES", scm_from_int (LC_MESSAGES)); #endif #ifdef LC_ALL - scm_c_define ("LC_ALL", SCM_I_MAKINUM (LC_ALL)); + scm_c_define ("LC_ALL", scm_from_int (LC_ALL)); #endif #ifdef PIPE_BUF scm_c_define ("PIPE_BUF", scm_long2num (PIPE_BUF)); #endif #ifdef PRIO_PROCESS - scm_c_define ("PRIO_PROCESS", SCM_I_MAKINUM (PRIO_PROCESS)); + scm_c_define ("PRIO_PROCESS", scm_from_int (PRIO_PROCESS)); #endif #ifdef PRIO_PGRP - scm_c_define ("PRIO_PGRP", SCM_I_MAKINUM (PRIO_PGRP)); + scm_c_define ("PRIO_PGRP", scm_from_int (PRIO_PGRP)); #endif #ifdef PRIO_USER - scm_c_define ("PRIO_USER", SCM_I_MAKINUM (PRIO_USER)); + scm_c_define ("PRIO_USER", scm_from_int (PRIO_USER)); #endif #ifdef LOCK_SH - scm_c_define ("LOCK_SH", SCM_I_MAKINUM (LOCK_SH)); + scm_c_define ("LOCK_SH", scm_from_int (LOCK_SH)); #endif #ifdef LOCK_EX - scm_c_define ("LOCK_EX", SCM_I_MAKINUM (LOCK_EX)); + scm_c_define ("LOCK_EX", scm_from_int (LOCK_EX)); #endif #ifdef LOCK_UN - scm_c_define ("LOCK_UN", SCM_I_MAKINUM (LOCK_UN)); + scm_c_define ("LOCK_UN", scm_from_int (LOCK_UN)); #endif #ifdef LOCK_NB - scm_c_define ("LOCK_NB", SCM_I_MAKINUM (LOCK_NB)); + scm_c_define ("LOCK_NB", scm_from_int (LOCK_NB)); #endif #include "libguile/cpp_sig_symbols.c" diff --git a/libguile/print.c b/libguile/print.c index 1974b318c..e43462a51 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -366,7 +366,7 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) break; case scm_tc3_int_1: case scm_tc3_int_2: - scm_intprint (SCM_INUM (exp), 10, port); + scm_intprint (SCM_I_INUM (exp), 10, port); break; case scm_tc3_imm24: if (SCM_CHARP (exp)) diff --git a/libguile/procprop.c b/libguile/procprop.c index 3ba22e0a5..1c6727e0f 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -87,7 +87,7 @@ scm_i_procedure_arity (SCM proc) case scm_tc7_cclo: if (SCM_EQ_P (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply)) { - int type = SCM_INUM (SCM_GSUBR_TYPE (proc)); + int type = scm_to_int (SCM_GSUBR_TYPE (proc)); a += SCM_GSUBR_REQ (type); o = SCM_GSUBR_OPT (type); r = SCM_GSUBR_REST (type); @@ -130,7 +130,7 @@ scm_i_procedure_arity (SCM proc) default: return SCM_BOOL_F; } - return scm_list_3 (SCM_I_MAKINUM (a), SCM_I_MAKINUM (o), scm_from_bool(r)); + return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r)); } static SCM diff --git a/libguile/procs.c b/libguile/procs.c index 68da589ac..42869182c 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -149,7 +149,7 @@ SCM_DEFINE (scm_make_cclo, "make-cclo", 2, 0, 0, "@var{len} objects for its usage.") #define FUNC_NAME s_scm_make_cclo { - return scm_makcclo (proc, SCM_INUM (len)); + return scm_makcclo (proc, scm_to_size_t (len)); } #undef FUNC_NAME #endif diff --git a/libguile/ramap.c b/libguile/ramap.c index f570d4807..62b04d62c 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -191,7 +191,7 @@ scm_ra_matchp (SCM ra0, SCM ras) case scm_tc7_cvect: s0->lbnd = 0; s0->inc = 1; - s0->ubnd = SCM_INUM (scm_uniform_vector_length (ra0)) - 1; + s0->ubnd = scm_to_long (scm_uniform_vector_length (ra0)) - 1; break; case scm_tc7_smob: if (!SCM_ARRAYP (ra0)) @@ -231,7 +231,7 @@ scm_ra_matchp (SCM ra0, SCM ras) if (1 != ndim) return 0; - length = SCM_INUM (scm_uniform_vector_length (ra1)); + length = scm_to_ulong (scm_uniform_vector_length (ra1)); switch (exact) { @@ -310,7 +310,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) if (SCM_IMP (vra0)) goto gencase; if (!SCM_ARRAYP (vra0)) { - unsigned long int length = SCM_INUM (scm_uniform_vector_length (vra0)); + unsigned long int length = scm_to_ulong (scm_uniform_vector_length (vra0)); vra1 = scm_make_ra (1); SCM_ARRAY_BASE (vra1) = 0; SCM_ARRAY_DIMS (vra1)->lbnd = 0; @@ -368,7 +368,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) } else { - unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra0)); + unsigned long length = scm_to_ulong (scm_uniform_vector_length (ra0)); kmax = 0; SCM_ARRAY_DIMS (vra0)->lbnd = 0; SCM_ARRAY_DIMS (vra0)->ubnd = length - 1; @@ -399,7 +399,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) *plvra = scm_cons (vra1, SCM_EOL); plvra = SCM_CDRLOC (*plvra); } - inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_I_MAKINUM (-1L)); + inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), scm_from_int (-1)); vinds = (long *) SCM_VELTS (inds); for (k = 0; k <= kmax; k++) vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd; @@ -459,7 +459,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) { default: for (i = base; n--; i += inc) - scm_array_set_x (ra, fill, SCM_I_MAKINUM (i)); + scm_array_set_x (ra, fill, scm_from_ulong (i)); break; case scm_tc7_vector: case scm_tc7_wvect: @@ -474,11 +474,11 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) case scm_tc7_byvect: if (SCM_CHARP (fill)) fill = SCM_I_MAKINUM ((char) SCM_CHAR (fill)); - SCM_ASRTGO (SCM_INUMP (fill) - && -128 <= SCM_INUM (fill) && SCM_INUM (fill) < 128, + SCM_ASRTGO (SCM_I_INUMP (fill) + && -128 <= SCM_I_INUM (fill) && SCM_I_INUM (fill) < 128, badarg2); for (i = base; n--; i += inc) - ((char *) SCM_UVECTOR_BASE (ra))[i] = SCM_INUM (fill); + ((char *) SCM_UVECTOR_BASE (ra))[i] = SCM_I_INUM (fill); break; case scm_tc7_bvect: { /* scope */ @@ -539,12 +539,12 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) break; } case scm_tc7_svect: - SCM_ASRTGO (SCM_INUMP (fill), badarg2); + SCM_ASRTGO (SCM_I_INUMP (fill), badarg2); { /* scope */ - short f = SCM_INUM (fill); + short f = SCM_I_INUM (fill); short *ve = (short *) SCM_VELTS (ra); - if (f != SCM_INUM (fill)) + if (f != SCM_I_INUM (fill)) SCM_OUT_OF_RANGE (2, fill); for (i = base; n--; i += inc) ve[i] = f; @@ -625,7 +625,7 @@ racp (SCM src, SCM dst) for (; n-- > 0; i_s += inc_s, i_d += inc_d) scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), - SCM_I_MAKINUM (i_d)); + scm_from_ulong (i_d)); break; case scm_tc7_string: if (SCM_TYP7 (src) != scm_tc7_string) @@ -992,7 +992,7 @@ scm_ra_sum (SCM ra0, SCM ras) SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; for (; n-- > 0; i0 += inc0, i1 += inc1) scm_array_set_x (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), - SCM_I_MAKINUM (i0)); + scm_from_ulong (i0)); break; } case scm_tc7_uvect: @@ -1028,7 +1028,7 @@ scm_ra_difference (SCM ra0, SCM ras) for (; n-- > 0; i0 += inc0) scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED), - SCM_I_MAKINUM (i0)); + scm_from_ulong (i0)); break; } case scm_tc7_fvect: @@ -1051,7 +1051,7 @@ scm_ra_difference (SCM ra0, SCM ras) { SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_I_MAKINUM (i0)); + scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), scm_from_ulong (i0)); break; } case scm_tc7_fvect: @@ -1087,7 +1087,7 @@ scm_ra_product (SCM ra0, SCM ras) SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; for (; n-- > 0; i0 += inc0, i1 += inc1) scm_array_set_x (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), - SCM_I_MAKINUM (i0)); + scm_from_ulong (i0)); break; } case scm_tc7_uvect: @@ -1133,7 +1133,7 @@ scm_ra_divide (SCM ra0, SCM ras) { SCM e0 = SCM_UNDEFINED; for (; n-- > 0; i0 += inc0) - scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_I_MAKINUM (i0)); + scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), scm_from_ulong (i0)); break; } case scm_tc7_fvect: @@ -1166,7 +1166,7 @@ scm_ra_divide (SCM ra0, SCM ras) { SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_I_MAKINUM (i0)); + scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), scm_from_ulong (i0)); break; } case scm_tc7_fvect: @@ -1213,7 +1213,7 @@ ramap (SCM ra0, SCM proc, SCM ras) ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) for (; i <= n; i++) - scm_array_set_x (ra0, scm_call_0 (proc), SCM_I_MAKINUM (i * inc + base)); + scm_array_set_x (ra0, scm_call_0 (proc), scm_from_long (i * inc + base)); else { SCM ra1 = SCM_CAR (ras); @@ -1234,10 +1234,10 @@ ramap (SCM ra0, SCM proc, SCM ras) for (; i <= n; i++, i1 += inc1) { args = SCM_EOL; - for (k = SCM_INUM (scm_uniform_vector_length (ras)); k--;) - args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_I_MAKINUM (i)), args); + for (k = scm_to_ulong (scm_uniform_vector_length (ras)); k--;) + args = scm_cons (scm_uniform_vector_ref (ve[k], scm_from_long (i)), args); args = scm_cons (scm_cvref (ra1, i1, SCM_UNDEFINED), args); - scm_array_set_x (ra0, scm_apply_0 (proc, args), SCM_I_MAKINUM (i * inc + base)); + scm_array_set_x (ra0, scm_apply_0 (proc, args), scm_from_long (i * inc + base)); } } return 1; @@ -1259,7 +1259,7 @@ ramap_dsubr (SCM ra0, SCM proc, SCM ras) default: gencase: for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_call_1 (proc, RVREF (ra1, i1, e1)), SCM_I_MAKINUM (i0)); + scm_array_set_x (ra0, scm_call_1 (proc, RVREF (ra1, i1, e1)), scm_from_ulong (i0)); break; case scm_tc7_fvect: { @@ -1332,11 +1332,10 @@ ramap_rp (SCM ra0, SCM proc, SCM ras) if (SCM_BITVEC_REF (ra0, i0)) { /* DIRK:FIXME:: There should be a way to access the elements - of a cell as raw data. Further: How can we be sure that - the values fit into an inum? + of a cell as raw data. */ - SCM n1 = SCM_I_MAKINUM (((long *) SCM_UNPACK (SCM_CDR (ra1)))[i1]); - SCM n2 = SCM_I_MAKINUM (((long *) SCM_UNPACK (SCM_CDR (ra2)))[i2]); + SCM n1 = scm_from_long (((long *) SCM_UNPACK (SCM_CDR (ra1)))[i1]); + SCM n2 = scm_from_long (((long *) SCM_UNPACK (SCM_CDR (ra2)))[i2]); if (scm_is_false (SCM_SUBRF (proc) (n1, n2))) SCM_BITVEC_CLR (ra0, i0); } @@ -1402,10 +1401,10 @@ ramap_1 (SCM ra0, SCM proc, SCM ras) ra1 = SCM_ARRAY_V (ra1); if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0)) for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED)), SCM_I_MAKINUM (i0)); + scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED)), scm_from_ulong (i0)); else for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1)), SCM_I_MAKINUM (i0)); + scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1)), scm_from_ulong (i0)); return 1; } @@ -1429,11 +1428,11 @@ ramap_2o (SCM ra0, SCM proc, SCM ras) for (; n-- > 0; i0 += inc0, i1 += inc1) scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED), - SCM_I_MAKINUM (i0)); + scm_from_ulong (i0)); else for (; n-- > 0; i0 += inc0, i1 += inc1) scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED), - SCM_I_MAKINUM (i0)); + scm_from_ulong (i0)); } else { @@ -1446,12 +1445,12 @@ ramap_2o (SCM ra0, SCM proc, SCM ras) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)), - SCM_I_MAKINUM (i0)); + scm_from_ulong (i0)); else for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)), - SCM_I_MAKINUM (i0)); + scm_from_ulong (i0)); } return 1; } @@ -1468,7 +1467,7 @@ ramap_a (SCM ra0, SCM proc, SCM ras) ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) for (; n-- > 0; i0 += inc0) - scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_I_MAKINUM (i0)); + scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), scm_from_ulong (i0)); else { SCM ra1 = SCM_CAR (ras); @@ -1477,7 +1476,7 @@ ramap_a (SCM ra0, SCM proc, SCM ras) ra1 = SCM_ARRAY_V (ra1); for (; n-- > 0; i0 += inc0, i1 += inc1) scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), - SCM_I_MAKINUM (i0)); + scm_from_ulong (i0)); } return 1; } @@ -1542,11 +1541,11 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, if (SCM_NULLP (lra)) { SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED); - if (SCM_INUMP(fill)) + if (SCM_I_INUMP(fill)) { prot = scm_array_prototype (ra0); if (SCM_INEXACTP (prot)) - fill = scm_make_real ((double) SCM_INUM (fill)); + fill = scm_make_real ((double) SCM_I_INUM (fill)); } scm_array_fill_x (ra0, fill); @@ -1627,8 +1626,8 @@ rafe (SCM ra0, SCM proc, SCM ras) for (; i <= n; i++, i0 += inc0, i1 += inc1) { args = SCM_EOL; - for (k = SCM_INUM (scm_uniform_vector_length (ras)); k--;) - args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_I_MAKINUM (i)), args); + for (k = scm_to_ulong (scm_uniform_vector_length (ras)); k--;) + args = scm_cons (scm_uniform_vector_ref (ve[k], scm_from_long (i)), args); args = scm_cons2 (scm_cvref (ra0, i0, SCM_UNDEFINED), scm_cvref (ra1, i1, SCM_UNDEFINED), args); scm_apply_0 (proc, args); } @@ -1682,7 +1681,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, case scm_tc7_wvect: { for (i = 0; i < SCM_VECTOR_LENGTH (ra); i++) - SCM_VECTOR_SET(ra, i, scm_call_1 (proc, SCM_I_MAKINUM (i))); + SCM_VECTOR_SET(ra, i, scm_call_1 (proc, scm_from_long (i))); return SCM_UNSPECIFIED; } case scm_tc7_string: @@ -1698,17 +1697,17 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, case scm_tc7_dvect: case scm_tc7_cvect: { - unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra)); + unsigned long int length = scm_to_ulong (scm_uniform_vector_length (ra)); for (i = 0; i < length; i++) - scm_array_set_x (ra, scm_call_1 (proc, SCM_I_MAKINUM (i)), - SCM_I_MAKINUM (i)); + scm_array_set_x (ra, scm_call_1 (proc, scm_from_ulong (i)), + scm_from_ulong (i)); return SCM_UNSPECIFIED; } case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (ra), badarg); { SCM args = SCM_EOL; - SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), SCM_I_MAKINUM (-1L)); + SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), scm_from_int (-1)); long *vinds = (long *) SCM_VELTS (inds); int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1; if (kmax < 0) @@ -1725,10 +1724,10 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, for (; vinds[k] <= SCM_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++) { for (j = kmax + 1, args = SCM_EOL; j--;) - args = scm_cons (SCM_I_MAKINUM (vinds[j]), args); + args = scm_cons (scm_from_long (vinds[j]), args); scm_array_set_x (SCM_ARRAY_V (ra), scm_apply_0 (proc, args), - SCM_I_MAKINUM (i)); + scm_from_ulong (i)); i += SCM_ARRAY_DIMS (ra)[k].inc; } k--; @@ -1767,7 +1766,7 @@ raeql_1 (SCM ra0, SCM as_equal, SCM ra1) ra0 = SCM_ARRAY_V (ra0); } else - n = SCM_INUM (scm_uniform_vector_length (ra0)); + n = scm_to_ulong (scm_uniform_vector_length (ra0)); if (SCM_ARRAYP (ra1)) { i1 = SCM_ARRAY_BASE (ra1); @@ -1898,7 +1897,7 @@ raeql (SCM ra0, SCM as_equal, SCM ra1) { s0->inc = 1; s0->lbnd = 0; - s0->ubnd = SCM_INUM (scm_uniform_vector_length (v0)) - 1; + s0->ubnd = scm_to_long (scm_uniform_vector_length (v0)) - 1; unroll = 0; } if (SCM_ARRAYP (ra1)) @@ -1918,7 +1917,7 @@ raeql (SCM ra0, SCM as_equal, SCM ra1) return 0; s1->inc = 1; s1->lbnd = 0; - s1->ubnd = SCM_INUM (scm_uniform_vector_length (v1)) - 1; + s1->ubnd = scm_to_long (scm_uniform_vector_length (v1)) - 1; unroll = 0; } if (SCM_TYP7 (v0) != SCM_TYP7 (v1)) diff --git a/libguile/random.c b/libguile/random.c index a6ad9aae8..e98794ca4 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -349,11 +349,11 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0, if (SCM_UNBNDP (state)) state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (2, state); - if (SCM_INUMP (n)) + if (SCM_I_INUMP (n)) { - unsigned long m = SCM_INUM (n); + unsigned long m = SCM_I_INUM (n); SCM_ASSERT_RANGE (1, n, m > 0); - return SCM_I_MAKINUM (scm_c_random (SCM_RSTATE (state), m)); + return scm_from_ulong (scm_c_random (SCM_RSTATE (state), m)); } SCM_VALIDATE_NIM (1, n); if (SCM_REALP (n)) @@ -424,7 +424,7 @@ SCM_DEFINE (scm_random_normal, "random:normal", 0, 1, 0, static void vector_scale (SCM v, double c) { - int n = SCM_INUM (scm_uniform_vector_length (v)); + int n = scm_to_int (scm_uniform_vector_length (v)); if (SCM_VECTORP (v)) while (--n >= 0) SCM_REAL_VALUE (SCM_VELTS (v)[n]) *= c; @@ -437,7 +437,7 @@ static double vector_sum_squares (SCM v) { double x, sum = 0.0; - int n = SCM_INUM (scm_uniform_vector_length (v)); + int n = scm_to_int (scm_uniform_vector_length (v)); if (SCM_VECTORP (v)) while (--n >= 0) { @@ -475,7 +475,7 @@ SCM_DEFINE (scm_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0, scm_random_normal_vector_x (v, state); vector_scale (v, pow (scm_c_uniform01 (SCM_RSTATE (state)), - 1.0 / SCM_INUM (scm_uniform_vector_length (v))) + 1.0 / scm_to_int (scm_uniform_vector_length (v))) / sqrt (vector_sum_squares (v))); return SCM_UNSPECIFIED; } @@ -514,7 +514,7 @@ SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0, if (SCM_UNBNDP (state)) state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (2, state); - n = SCM_INUM (scm_uniform_vector_length (v)); + n = scm_to_int (scm_uniform_vector_length (v)); if (SCM_VECTORP (v)) while (--n >= 0) SCM_VECTOR_SET (v, n, scm_make_real (scm_c_normal01 (SCM_RSTATE (state)))); diff --git a/libguile/read.c b/libguile/read.c index ebaf1ed29..7f301531b 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -462,8 +462,8 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) * checked whether the resulting fixnum is in the range of * characters. */ p = scm_i_mem2number (SCM_STRING_CHARS (*tok_buf), j, 8); - if (SCM_INUMP (p)) - return SCM_MAKE_CHAR (SCM_INUM (p)); + if (SCM_I_INUMP (p)) + return SCM_MAKE_CHAR (SCM_I_INUM (p)); } for (c = 0; c < scm_n_charnames; c++) if (scm_charnames[c] diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index a38f440ff..20d4e9274 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -98,12 +98,12 @@ scm_regexp_error_msg (int regerrno, regex_t *rx) never returns, we would never have the opportunity to free it. Creating it as a SCM object means that the system will GC it at some point. */ - errmsg = scm_make_string (SCM_I_MAKINUM (80), SCM_UNDEFINED); + errmsg = scm_make_string (scm_from_int (80), SCM_UNDEFINED); SCM_DEFER_INTS; l = regerror (regerrno, rx, SCM_STRING_CHARS (errmsg), 80); if (l > 80) { - errmsg = scm_make_string (SCM_I_MAKINUM (l), SCM_UNDEFINED); + errmsg = scm_make_string (scm_from_int (l), SCM_UNDEFINED); regerror (regerrno, rx, SCM_STRING_CHARS (errmsg), l); } SCM_ALLOW_INTS; @@ -174,10 +174,10 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, flag = flags; while (!SCM_NULLP (flag)) { - if (SCM_INUM (SCM_CAR (flag)) == REG_BASIC) + if (scm_to_int (SCM_CAR (flag)) == REG_BASIC) cflags &= ~REG_EXTENDED; else - cflags |= SCM_INUM (SCM_CAR (flag)); + cflags |= scm_to_int (SCM_CAR (flag)); flag = SCM_CDR (flag); } @@ -257,7 +257,7 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, SCM_VECTOR_SET(mvec,0, str); for (i = 0; i < nmatches; ++i) if (matches[i].rm_so == -1) - SCM_VECTOR_SET(mvec,i+1, scm_cons (SCM_I_MAKINUM (-1), SCM_I_MAKINUM (-1))); + SCM_VECTOR_SET(mvec,i+1, scm_cons (scm_from_int (-1), scm_from_int (-1))); else SCM_VECTOR_SET(mvec,i+1,scm_cons (scm_long2num (matches[i].rm_so + offset), scm_long2num (matches[i].rm_eo + offset))); diff --git a/libguile/rw.c b/libguile/rw.c index 0b5eba9f2..15d1efd13 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -116,8 +116,8 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, read_len = last - offset; } - if (SCM_INUMP (port_or_fdes)) - fdes = SCM_INUM (port_or_fdes); + if (scm_is_integer (port_or_fdes)) + fdes = scm_to_int (port_or_fdes); else { SCM port = SCM_UNBNDP (port_or_fdes) ? scm_cur_inp : port_or_fdes; @@ -212,8 +212,8 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, if (write_len == 0) return SCM_INUM0; - if (SCM_INUMP (port_or_fdes)) - fdes = SCM_INUM (port_or_fdes); + if (scm_is_integer (port_or_fdes)) + fdes = scm_to_int (port_or_fdes); else { SCM port = SCM_UNBNDP (port_or_fdes) ? scm_cur_outp : port_or_fdes; diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index ad58fabe7..fba285d24 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -327,15 +327,15 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, old_handler = SCM_VECTOR_REF(*signal_handlers, csig); if (SCM_UNBNDP (handler)) query_only = 1; - else if (SCM_EQ_P (scm_integer_p (handler), SCM_BOOL_T)) + else if (scm_is_integer (handler)) { if (SCM_NUM2LONG (2, handler) == (long) SIG_DFL || SCM_NUM2LONG (2, handler) == (long) SIG_IGN) { #ifdef HAVE_SIGACTION - action.sa_handler = (SIGRETTYPE (*) (int)) SCM_INUM (handler); + action.sa_handler = (SIGRETTYPE (*) (int)) scm_to_int (handler); #else - chandler = (SIGRETTYPE (*) (int)) SCM_INUM (handler); + chandler = (SIGRETTYPE (*) (int)) scm_to_int (handler); #endif install_handler (csig, SCM_BOOL_F, SCM_BOOL_F); } @@ -426,7 +426,7 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, if (old_action.sa_handler == SIG_DFL || old_action.sa_handler == SIG_IGN) old_handler = scm_long2num ((long) old_action.sa_handler); SCM_ALLOW_INTS; - return scm_cons (old_handler, SCM_I_MAKINUM (old_action.sa_flags)); + return scm_cons (old_handler, scm_from_int (old_action.sa_flags)); #else if (query_only) { @@ -445,7 +445,7 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, if (old_chandler == SIG_DFL || old_chandler == SIG_IGN) old_handler = scm_long2num ((long) old_chandler); SCM_ALLOW_INTS; - return scm_cons (old_handler, SCM_I_MAKINUM (0)); + return scm_cons (old_handler, scm_from_int (0)); #endif } #undef FUNC_NAME @@ -688,9 +688,9 @@ scm_init_scmsigs () #if defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER) /* Stuff needed by setitimer and getitimer. */ - scm_c_define ("ITIMER_REAL", SCM_I_MAKINUM (ITIMER_REAL)); - scm_c_define ("ITIMER_VIRTUAL", SCM_I_MAKINUM (ITIMER_VIRTUAL)); - scm_c_define ("ITIMER_PROF", SCM_I_MAKINUM (ITIMER_PROF)); + scm_c_define ("ITIMER_REAL", scm_from_int (ITIMER_REAL)); + scm_c_define ("ITIMER_VIRTUAL", scm_from_int (ITIMER_VIRTUAL)); + scm_c_define ("ITIMER_PROF", scm_from_int (ITIMER_PROF)); #endif /* defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER) */ #include "libguile/scmsigs.x" diff --git a/libguile/simpos.c b/libguile/simpos.c index d23e949f4..a37423f56 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -75,7 +75,7 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, rv = system (SCM_STRING_CHARS (cmd)); if (rv == -1 || (rv == 127 && errno != 0)) SCM_SYSERROR; - return SCM_I_MAKINUM (rv); + return scm_from_int (rv); } #undef FUNC_NAME #endif /* HAVE_SYSTEM */ @@ -183,7 +183,7 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint)); scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit)); scm_remember_upto_here_2 (oldint, oldquit); - return SCM_I_MAKINUM (0L + status); + return scm_from_int (status); } } else diff --git a/libguile/socket.c b/libguile/socket.c index 1582cb3c6..556ba4c0d 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -338,9 +338,9 @@ scm_from_ipv6 (const scm_t_uint8 *src) static void scm_to_ipv6 (scm_t_uint8 dst[16], SCM src) { - if (SCM_INUMP (src)) + if (SCM_I_INUMP (src)) { - scm_t_signed_bits n = SCM_INUM (src); + scm_t_signed_bits n = SCM_I_INUM (src); if (n < 0) scm_out_of_range (NULL, src); #ifdef WORDS_BIGENDIAN @@ -804,7 +804,7 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, } #endif default: - scm_out_of_range (proc, SCM_I_MAKINUM (fam)); + scm_out_of_range (proc, scm_from_int (fam)); } } #undef FUNC_NAME @@ -992,7 +992,7 @@ scm_addr_vector (const struct sockaddr *address, int addr_size, #endif default: scm_misc_error (proc, "Unrecognised address family: ~A", - scm_list_1 (SCM_I_MAKINUM (fam))); + scm_list_1 (scm_from_int (fam))); } return result; } @@ -1228,7 +1228,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, else address = SCM_BOOL_F; - return scm_cons (SCM_I_MAKINUM (rv), address); + return scm_cons (scm_from_int (rv), address); } #undef FUNC_NAME @@ -1283,7 +1283,7 @@ SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, SCM_SYSERROR; } free (soka); - return SCM_I_MAKINUM (rv); + return scm_from_int (rv); } #undef FUNC_NAME @@ -1294,29 +1294,29 @@ scm_init_socket () { /* protocol families. */ #ifdef AF_UNSPEC - scm_c_define ("AF_UNSPEC", SCM_I_MAKINUM (AF_UNSPEC)); + scm_c_define ("AF_UNSPEC", scm_from_int (AF_UNSPEC)); #endif #ifdef AF_UNIX - scm_c_define ("AF_UNIX", SCM_I_MAKINUM (AF_UNIX)); + scm_c_define ("AF_UNIX", scm_from_int (AF_UNIX)); #endif #ifdef AF_INET - scm_c_define ("AF_INET", SCM_I_MAKINUM (AF_INET)); + scm_c_define ("AF_INET", scm_from_int (AF_INET)); #endif #ifdef AF_INET6 - scm_c_define ("AF_INET6", SCM_I_MAKINUM (AF_INET6)); + scm_c_define ("AF_INET6", scm_from_int (AF_INET6)); #endif #ifdef PF_UNSPEC - scm_c_define ("PF_UNSPEC", SCM_I_MAKINUM (PF_UNSPEC)); + scm_c_define ("PF_UNSPEC", scm_from_int (PF_UNSPEC)); #endif #ifdef PF_UNIX - scm_c_define ("PF_UNIX", SCM_I_MAKINUM (PF_UNIX)); + scm_c_define ("PF_UNIX", scm_from_int (PF_UNIX)); #endif #ifdef PF_INET - scm_c_define ("PF_INET", SCM_I_MAKINUM (PF_INET)); + scm_c_define ("PF_INET", scm_from_int (PF_INET)); #endif #ifdef PF_INET6 - scm_c_define ("PF_INET6", SCM_I_MAKINUM (PF_INET6)); + scm_c_define ("PF_INET6", scm_from_int (PF_INET6)); #endif /* standard addresses. */ @@ -1335,82 +1335,82 @@ scm_init_socket () /* socket types. */ #ifdef SOCK_STREAM - scm_c_define ("SOCK_STREAM", SCM_I_MAKINUM (SOCK_STREAM)); + scm_c_define ("SOCK_STREAM", scm_from_int (SOCK_STREAM)); #endif #ifdef SOCK_DGRAM - scm_c_define ("SOCK_DGRAM", SCM_I_MAKINUM (SOCK_DGRAM)); + scm_c_define ("SOCK_DGRAM", scm_from_int (SOCK_DGRAM)); #endif #ifdef SOCK_RAW - scm_c_define ("SOCK_RAW", SCM_I_MAKINUM (SOCK_RAW)); + scm_c_define ("SOCK_RAW", scm_from_int (SOCK_RAW)); #endif /* setsockopt level. */ #ifdef SOL_SOCKET - scm_c_define ("SOL_SOCKET", SCM_I_MAKINUM (SOL_SOCKET)); + scm_c_define ("SOL_SOCKET", scm_from_int (SOL_SOCKET)); #endif #ifdef SOL_IP - scm_c_define ("SOL_IP", SCM_I_MAKINUM (SOL_IP)); + scm_c_define ("SOL_IP", scm_from_int (SOL_IP)); #endif #ifdef SOL_TCP - scm_c_define ("SOL_TCP", SCM_I_MAKINUM (SOL_TCP)); + scm_c_define ("SOL_TCP", scm_from_int (SOL_TCP)); #endif #ifdef SOL_UDP - scm_c_define ("SOL_UDP", SCM_I_MAKINUM (SOL_UDP)); + scm_c_define ("SOL_UDP", scm_from_int (SOL_UDP)); #endif /* setsockopt names. */ #ifdef SO_DEBUG - scm_c_define ("SO_DEBUG", SCM_I_MAKINUM (SO_DEBUG)); + scm_c_define ("SO_DEBUG", scm_from_int (SO_DEBUG)); #endif #ifdef SO_REUSEADDR - scm_c_define ("SO_REUSEADDR", SCM_I_MAKINUM (SO_REUSEADDR)); + scm_c_define ("SO_REUSEADDR", scm_from_int (SO_REUSEADDR)); #endif #ifdef SO_STYLE - scm_c_define ("SO_STYLE", SCM_I_MAKINUM (SO_STYLE)); + scm_c_define ("SO_STYLE", scm_from_int (SO_STYLE)); #endif #ifdef SO_TYPE - scm_c_define ("SO_TYPE", SCM_I_MAKINUM (SO_TYPE)); + scm_c_define ("SO_TYPE", scm_from_int (SO_TYPE)); #endif #ifdef SO_ERROR - scm_c_define ("SO_ERROR", SCM_I_MAKINUM (SO_ERROR)); + scm_c_define ("SO_ERROR", scm_from_int (SO_ERROR)); #endif #ifdef SO_DONTROUTE - scm_c_define ("SO_DONTROUTE", SCM_I_MAKINUM (SO_DONTROUTE)); + scm_c_define ("SO_DONTROUTE", scm_from_int (SO_DONTROUTE)); #endif #ifdef SO_BROADCAST - scm_c_define ("SO_BROADCAST", SCM_I_MAKINUM (SO_BROADCAST)); + scm_c_define ("SO_BROADCAST", scm_from_int (SO_BROADCAST)); #endif #ifdef SO_SNDBUF - scm_c_define ("SO_SNDBUF", SCM_I_MAKINUM (SO_SNDBUF)); + scm_c_define ("SO_SNDBUF", scm_from_int (SO_SNDBUF)); #endif #ifdef SO_RCVBUF - scm_c_define ("SO_RCVBUF", SCM_I_MAKINUM (SO_RCVBUF)); + scm_c_define ("SO_RCVBUF", scm_from_int (SO_RCVBUF)); #endif #ifdef SO_KEEPALIVE - scm_c_define ("SO_KEEPALIVE", SCM_I_MAKINUM (SO_KEEPALIVE)); + scm_c_define ("SO_KEEPALIVE", scm_from_int (SO_KEEPALIVE)); #endif #ifdef SO_OOBINLINE - scm_c_define ("SO_OOBINLINE", SCM_I_MAKINUM (SO_OOBINLINE)); + scm_c_define ("SO_OOBINLINE", scm_from_int (SO_OOBINLINE)); #endif #ifdef SO_NO_CHECK - scm_c_define ("SO_NO_CHECK", SCM_I_MAKINUM (SO_NO_CHECK)); + scm_c_define ("SO_NO_CHECK", scm_from_int (SO_NO_CHECK)); #endif #ifdef SO_PRIORITY - scm_c_define ("SO_PRIORITY", SCM_I_MAKINUM (SO_PRIORITY)); + scm_c_define ("SO_PRIORITY", scm_from_int (SO_PRIORITY)); #endif #ifdef SO_LINGER - scm_c_define ("SO_LINGER", SCM_I_MAKINUM (SO_LINGER)); + scm_c_define ("SO_LINGER", scm_from_int (SO_LINGER)); #endif /* recv/send options. */ #ifdef MSG_OOB - scm_c_define ("MSG_OOB", SCM_I_MAKINUM (MSG_OOB)); + scm_c_define ("MSG_OOB", scm_from_int (MSG_OOB)); #endif #ifdef MSG_PEEK - scm_c_define ("MSG_PEEK", SCM_I_MAKINUM (MSG_PEEK)); + scm_c_define ("MSG_PEEK", scm_from_int (MSG_PEEK)); #endif #ifdef MSG_DONTROUTE - scm_c_define ("MSG_DONTROUTE", SCM_I_MAKINUM (MSG_DONTROUTE)); + scm_c_define ("MSG_DONTROUTE", scm_from_int (MSG_DONTROUTE)); #endif #ifdef __MINGW32__ diff --git a/libguile/sort.c b/libguile/sort.c index 3128ffa3d..35aea629f 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -592,8 +592,8 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, len = SCM_VECTOR_LENGTH (items); scm_restricted_vector_sort_x (items, less, - SCM_I_MAKINUM (0L), - SCM_I_MAKINUM (len)); + scm_from_int (0), + scm_from_long (len)); return items; } else @@ -631,8 +631,8 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0, scm_array_copy_x (items, sortvec); scm_restricted_vector_sort_x (sortvec, less, - SCM_I_MAKINUM (0L), - SCM_I_MAKINUM (len)); + scm_from_int (0), + scm_from_long (len)); return sortvec; } #endif diff --git a/libguile/srcprop.c b/libguile/srcprop.c index a237fb06c..72f2db490 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -141,8 +141,8 @@ scm_srcprops_to_plist (SCM obj) plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist); if (!SCM_UNBNDP (SRCPROPFNAME (obj))) plist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), plist); - plist = scm_acons (scm_sym_column, SCM_I_MAKINUM (SRCPROPCOL (obj)), plist); - plist = scm_acons (scm_sym_line, SCM_I_MAKINUM (SRCPROPLINE (obj)), plist); + plist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), plist); + plist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), plist); plist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), plist); return plist; } @@ -203,8 +203,8 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, if (!SRCPROPSP (p)) goto plist; if (SCM_EQ_P (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p)); - else if (SCM_EQ_P (scm_sym_line, key)) p = SCM_I_MAKINUM (SRCPROPLINE (p)); - else if (SCM_EQ_P (scm_sym_column, key)) p = SCM_I_MAKINUM (SRCPROPCOL (p)); + else if (SCM_EQ_P (scm_sym_line, key)) p = scm_from_int (SRCPROPLINE (p)); + else if (SCM_EQ_P (scm_sym_column, key)) p = scm_from_int (SRCPROPCOL (p)); else if (SCM_EQ_P (scm_sym_filename, key)) p = SRCPROPFNAME (p); else if (SCM_EQ_P (scm_sym_copy, key)) p = SRCPROPCOPY (p); else @@ -310,7 +310,7 @@ scm_init_srcprop () scm_set_smob_free (scm_tc16_srcprops, srcprops_free); scm_set_smob_print (scm_tc16_srcprops, srcprops_print); - scm_source_whash = scm_make_weak_key_hash_table (SCM_I_MAKINUM (2047)); + scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047)); scm_c_define ("source-whash", scm_source_whash); #include "libguile/srcprop.x" diff --git a/libguile/stacks.c b/libguile/stacks.c index 483e3d4e5..8fd4dc8cc 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -457,7 +457,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, size = n * SCM_FRAME_N_SLOTS; /* Make the stack object. */ - stack = scm_make_struct (scm_stack_type, SCM_I_MAKINUM (size), SCM_EOL); + stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL); SCM_STACK (stack) -> id = id; iframe = &SCM_STACK (stack) -> tail[0]; SCM_STACK (stack) -> frames = iframe; @@ -483,10 +483,10 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, } narrow_stack (stack, - SCM_INUMP (inner_cut) ? SCM_INUM (inner_cut) : n, - SCM_INUMP (inner_cut) ? 0 : inner_cut, - SCM_INUMP (outer_cut) ? SCM_INUM (outer_cut) : n, - SCM_INUMP (outer_cut) ? 0 : outer_cut); + scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n, + scm_is_integer (inner_cut) ? 0 : inner_cut, + scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n, + scm_is_integer (outer_cut) ? 0 : outer_cut); n = SCM_STACK (stack) -> length; } @@ -562,7 +562,7 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0, #define FUNC_NAME s_scm_stack_length { SCM_VALIDATE_STACK (1, stack); - return SCM_I_MAKINUM (SCM_STACK_LENGTH (stack)); + return scm_from_int (SCM_STACK_LENGTH (stack)); } #undef FUNC_NAME @@ -611,7 +611,7 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, if (!dframe || SCM_VOIDFRAMEP (*dframe)) return SCM_BOOL_F; - stack = scm_make_struct (scm_stack_type, SCM_I_MAKINUM (SCM_FRAME_N_SLOTS), + stack = scm_make_struct (scm_stack_type, scm_from_int (SCM_FRAME_N_SLOTS), SCM_EOL); SCM_STACK (stack) -> length = 1; SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0]; @@ -628,7 +628,7 @@ SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0, #define FUNC_NAME s_scm_frame_number { SCM_VALIDATE_FRAME (1, frame); - return SCM_I_MAKINUM (SCM_FRAME_NUMBER (frame)); + return scm_from_int (SCM_FRAME_NUMBER (frame)); } #undef FUNC_NAME @@ -673,11 +673,11 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, { unsigned long int n; SCM_VALIDATE_FRAME (1, frame); - n = SCM_INUM (SCM_CDR (frame)) + 1; + n = scm_to_ulong (SCM_CDR (frame)) + 1; if (n >= SCM_STACK_LENGTH (SCM_CAR (frame))) return SCM_BOOL_F; else - return scm_cons (SCM_CAR (frame), SCM_I_MAKINUM (n)); + return scm_cons (SCM_CAR (frame), scm_from_ulong (n)); } #undef FUNC_NAME @@ -689,11 +689,11 @@ SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0, { unsigned long int n; SCM_VALIDATE_FRAME (1, frame); - n = SCM_INUM (SCM_CDR (frame)); + n = scm_to_ulong (SCM_CDR (frame)); if (n == 0) return SCM_BOOL_F; else - return scm_cons (SCM_CAR (frame), SCM_I_MAKINUM (n - 1)); + return scm_cons (SCM_CAR (frame), scm_from_ulong (n - 1)); } #undef FUNC_NAME diff --git a/libguile/stacks.h b/libguile/stacks.h index b15bf2ed0..4e68a67a5 100644 --- a/libguile/stacks.h +++ b/libguile/stacks.h @@ -53,18 +53,17 @@ SCM_API SCM scm_stack_type; #define SCM_FRAMEP(obj) \ (SCM_CONSP (obj) && SCM_STACKP (SCM_CAR (obj)) \ - && SCM_INUMP (SCM_CDR (obj)) && SCM_INUM (SCM_CDR (obj)) >= 0 \ - && ((unsigned long int) SCM_INUM (SCM_CDR (obj)) \ - < SCM_STACK_LENGTH (SCM_CAR (obj)))) + && scm_is_unsigned_integer (SCM_CDR (obj), \ + 0, SCM_STACK_LENGTH (SCM_CAR (obj))-1)) #define SCM_FRAME_REF(frame, slot) \ -(SCM_STACK (SCM_CAR (frame)) -> frames[SCM_INUM (SCM_CDR (frame))].slot) \ +(SCM_STACK (SCM_CAR (frame)) -> frames[scm_to_size_t (SCM_CDR (frame))].slot) #define SCM_FRAME_NUMBER(frame) \ (SCM_BACKWARDS_P \ - ? SCM_INUM (SCM_CDR (frame)) \ + ? scm_to_size_t (SCM_CDR (frame)) \ : (SCM_STACK_LENGTH (SCM_CAR (frame)) \ - - SCM_INUM (SCM_CDR (frame)) \ + - scm_to_size_t (SCM_CDR (frame)) \ - 1)) \ #define SCM_FRAME_FLAGS(frame) SCM_FRAME_REF (frame, flags) diff --git a/libguile/stime.c b/libguile/stime.c index 86fdab3ab..dcea1e237 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -124,10 +124,10 @@ SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, time_buffer.time -= scm_your_base.time; tmp = scm_long2num (time_buffer.millitm - scm_your_base.millitm); tmp = scm_sum (tmp, - scm_product (SCM_I_MAKINUM (1000), - SCM_I_MAKINUM (time_buffer.time))); + scm_product (scm_from_int (1000), + scm_from_int (time_buffer.time))); return scm_quotient (scm_product (tmp, SCM_I_MAKINUM (SCM_TIME_UNITS_PER_SECOND)), - SCM_I_MAKINUM (1000)); + scm_from_int (1000)); #else return scm_long2num((time((timet*)0) - scm_your_base) * (int)SCM_TIME_UNITS_PER_SECOND); #endif /* HAVE_FTIME */ @@ -243,7 +243,7 @@ SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0, ftime(&time); return scm_cons (scm_long2num ((long) time.time), - SCM_I_MAKINUM (time.millitm * 1000)); + scm_from_int (time.millitm * 1000)); # else timet timv; @@ -251,7 +251,7 @@ SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0, if ((timv = time (0)) == -1) SCM_SYSERROR; SCM_ALLOW_INTS; - return scm_cons (scm_long2num (timv), SCM_I_MAKINUM (0)); + return scm_cons (scm_long2num (timv), scm_from_int (0)); # endif #endif } @@ -262,16 +262,16 @@ filltime (struct tm *bd_time, int zoff, const char *zname) { SCM result = scm_c_make_vector (11, SCM_UNDEFINED); - SCM_VECTOR_SET (result,0, SCM_I_MAKINUM (bd_time->tm_sec)); - SCM_VECTOR_SET (result,1, SCM_I_MAKINUM (bd_time->tm_min)); - SCM_VECTOR_SET (result,2, SCM_I_MAKINUM (bd_time->tm_hour)); - SCM_VECTOR_SET (result,3, SCM_I_MAKINUM (bd_time->tm_mday)); - SCM_VECTOR_SET (result,4, SCM_I_MAKINUM (bd_time->tm_mon)); - SCM_VECTOR_SET (result,5, SCM_I_MAKINUM (bd_time->tm_year)); - SCM_VECTOR_SET (result,6, SCM_I_MAKINUM (bd_time->tm_wday)); - SCM_VECTOR_SET (result,7, SCM_I_MAKINUM (bd_time->tm_yday)); - SCM_VECTOR_SET (result,8, SCM_I_MAKINUM (bd_time->tm_isdst)); - SCM_VECTOR_SET (result,9, SCM_I_MAKINUM (zoff)); + SCM_VECTOR_SET (result,0, scm_from_int (bd_time->tm_sec)); + SCM_VECTOR_SET (result,1, scm_from_int (bd_time->tm_min)); + SCM_VECTOR_SET (result,2, scm_from_int (bd_time->tm_hour)); + SCM_VECTOR_SET (result,3, scm_from_int (bd_time->tm_mday)); + SCM_VECTOR_SET (result,4, scm_from_int (bd_time->tm_mon)); + SCM_VECTOR_SET (result,5, scm_from_int (bd_time->tm_year)); + SCM_VECTOR_SET (result,6, scm_from_int (bd_time->tm_wday)); + SCM_VECTOR_SET (result,7, scm_from_int (bd_time->tm_yday)); + SCM_VECTOR_SET (result,8, scm_from_int (bd_time->tm_isdst)); + SCM_VECTOR_SET (result,9, scm_from_int (zoff)); SCM_VECTOR_SET (result,10, zname ? scm_makfrom0str (zname) : SCM_BOOL_F); return result; } @@ -455,22 +455,22 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) velts = SCM_VELTS (sbd_time); for (i = 0; i < 10; i++) { - SCM_ASSERT (SCM_INUMP (velts[i]), sbd_time, pos, subr); + SCM_ASSERT (scm_is_integer (velts[i]), sbd_time, pos, subr); } SCM_ASSERT (scm_is_false (velts[10]) || SCM_STRINGP (velts[10]), sbd_time, pos, subr); - lt->tm_sec = SCM_INUM (velts[0]); - lt->tm_min = SCM_INUM (velts[1]); - lt->tm_hour = SCM_INUM (velts[2]); - lt->tm_mday = SCM_INUM (velts[3]); - lt->tm_mon = SCM_INUM (velts[4]); - lt->tm_year = SCM_INUM (velts[5]); - lt->tm_wday = SCM_INUM (velts[6]); - lt->tm_yday = SCM_INUM (velts[7]); - lt->tm_isdst = SCM_INUM (velts[8]); + lt->tm_sec = scm_to_int (velts[0]); + lt->tm_min = scm_to_int (velts[1]); + lt->tm_hour = scm_to_int (velts[2]); + lt->tm_mday = scm_to_int (velts[3]); + lt->tm_mon = scm_to_int (velts[4]); + lt->tm_year = scm_to_int (velts[5]); + lt->tm_wday = scm_to_int (velts[6]); + lt->tm_yday = scm_to_int (velts[7]); + lt->tm_isdst = scm_to_int (velts[8]); #ifdef HAVE_TM_ZONE - lt->tm_gmtoff = SCM_INUM (velts[9]); + lt->tm_gmtoff = scm_to_int (velts[9]); if (scm_is_false (velts[10])) lt->tm_zone = NULL; else @@ -717,7 +717,8 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, } SCM_ALLOW_INTS; - return scm_cons (filltime (&t, 0, NULL), SCM_I_MAKINUM (rest - str)); + return scm_cons (filltime (&t, 0, NULL), + scm_from_signed_integer (rest - str)); } #undef FUNC_NAME #endif /* HAVE_STRPTIME */ diff --git a/libguile/strings.c b/libguile/strings.c index ad8486c1d..8d6b8b7b0 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -183,30 +183,20 @@ SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, "of the @var{string} are unspecified.") #define FUNC_NAME s_scm_make_string { - if (SCM_INUMP (k)) + size_t i = scm_to_unsigned_integer (k, 0, SCM_STRING_MAX_LENGTH); + SCM res = scm_allocate_string (i); + + if (!SCM_UNBNDP (chr)) { - long int i = SCM_INUM (k); - SCM res; - - SCM_ASSERT_RANGE (1, k, i >= 0); - - res = scm_allocate_string (i); - if (!SCM_UNBNDP (chr)) - { - unsigned char *dst; - - SCM_VALIDATE_CHAR (2, chr); - - dst = SCM_STRING_UCHARS (res); - memset (dst, SCM_CHAR (chr), i); - } - - return res; + unsigned char *dst; + + SCM_VALIDATE_CHAR (2, chr); + + dst = SCM_STRING_UCHARS (res); + memset (dst, SCM_CHAR (chr), i); } - else if (SCM_BIGP (k)) - SCM_OUT_OF_RANGE (1, k); - else - SCM_WRONG_TYPE_ARG (1, k); + + return res; } #undef FUNC_NAME @@ -217,7 +207,7 @@ SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0, #define FUNC_NAME s_scm_string_length { SCM_VALIDATE_STRING (1, string); - return SCM_I_MAKINUM (SCM_STRING_LENGTH (string)); + return scm_from_size_t (SCM_STRING_LENGTH (string)); } #undef FUNC_NAME diff --git a/libguile/strop.c b/libguile/strop.c index 415fd5068..0400870cc 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -61,27 +61,21 @@ scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, SCM_ASSERT (SCM_CHARP (chr), chr, SCM_ARG2, why); if (scm_is_false (sub_start)) - sub_start = SCM_I_MAKINUM (0); - - SCM_ASSERT (SCM_INUMP (sub_start), sub_start, SCM_ARG3, why); - lower = SCM_INUM (sub_start); - if (lower < 0 || lower > SCM_STRING_LENGTH (*str)) - scm_out_of_range (why, sub_start); + lower = 0; + else + lower = scm_to_signed_integer (sub_start, 0, SCM_STRING_LENGTH(*str)); if (scm_is_false (sub_end)) - sub_end = SCM_I_MAKINUM (SCM_STRING_LENGTH (*str)); - - SCM_ASSERT (SCM_INUMP (sub_end), sub_end, SCM_ARG4, why); - upper = SCM_INUM (sub_end); - if (upper < SCM_INUM (sub_start) || upper > SCM_STRING_LENGTH (*str)) - scm_out_of_range (why, sub_end); + upper = SCM_STRING_LENGTH (*str); + else + upper = scm_to_signed_integer (sub_end, lower, SCM_STRING_LENGTH(*str)); if (direction > 0) { p = SCM_STRING_UCHARS (*str) + lower; ch = SCM_CHAR (chr); - for (x = SCM_INUM (sub_start); x < upper; ++x, ++p) + for (x = lower; x < upper; ++x, ++p) if (*p == ch) return x; } @@ -124,7 +118,7 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, pos = scm_i_index (&str, chr, 1, frm, to, FUNC_NAME); return (pos < 0 ? SCM_BOOL_F - : SCM_I_MAKINUM (pos)); + : scm_from_long (pos)); } #undef FUNC_NAME @@ -154,7 +148,7 @@ SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0, pos = scm_i_index (&str, chr, -1, frm, to, FUNC_NAME); return (pos < 0 ? SCM_BOOL_F - : SCM_I_MAKINUM (pos)); + : scm_from_long (pos)); } #undef FUNC_NAME diff --git a/libguile/strports.c b/libguile/strports.c index f718c07cb..30ce38509 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -250,13 +250,12 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) { SCM z; scm_t_port *pt; - size_t str_len; + size_t str_len, c_pos; - SCM_ASSERT (SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller); SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG1, caller); str_len = SCM_STRING_LENGTH (str); - if (SCM_INUM (pos) > str_len) - scm_out_of_range (caller, pos); + c_pos = scm_to_unsigned_integer (pos, 0, str_len); + if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG))) scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL); @@ -266,7 +265,7 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) SCM_SETSTREAM (z, SCM_UNPACK (str)); SCM_SET_CELL_TYPE(z, scm_tc16_strport|modes); pt->write_buf = pt->read_buf = SCM_STRING_UCHARS (str); - pt->read_pos = pt->write_pos = pt->read_buf + SCM_INUM (pos); + pt->read_pos = pt->write_pos = pt->read_buf + c_pos; pt->write_buf_size = pt->read_buf_size = str_len; pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size; diff --git a/libguile/struct.c b/libguile/struct.c index 3cc390784..6535064fd 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -114,7 +114,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, { if (field_desc[x + 2] != '-') SCM_MISC_ERROR ("missing dash field at position ~A", - scm_list_1 (SCM_I_MAKINUM (x / 2))); + scm_list_1 (scm_from_int (x / 2))); x += 2; goto recheck_ref; } @@ -789,14 +789,14 @@ void scm_init_struct () { scm_struct_table - = scm_permanent_object (scm_make_weak_key_hash_table (SCM_I_MAKINUM (31))); + = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31))); required_vtable_fields = scm_makfrom0str ("prsrpw"); scm_permanent_object (required_vtable_fields); - scm_c_define ("vtable-index-layout", SCM_I_MAKINUM (scm_vtable_index_layout)); - scm_c_define ("vtable-index-vtable", SCM_I_MAKINUM (scm_vtable_index_vtable)); + scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout)); + scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable)); scm_c_define ("vtable-index-printer", - SCM_I_MAKINUM (scm_vtable_index_printer)); - scm_c_define ("vtable-offset-user", SCM_I_MAKINUM (scm_vtable_offset_user)); + scm_from_int (scm_vtable_index_printer)); + scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user)); #include "libguile/struct.x" } diff --git a/libguile/symbols.c b/libguile/symbols.c index 5fe06b269..1783a47bd 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -406,7 +406,7 @@ scm_c_symbol2str (SCM obj, char *str, size_t *lenp) void scm_symbols_prehistory () { - symbols = scm_make_weak_key_hash_table (SCM_I_MAKINUM (2139)); + symbols = scm_make_weak_key_hash_table (scm_from_int (2139)); scm_permanent_object (symbols); } diff --git a/libguile/tags.h b/libguile/tags.h index 82669e3cb..614d9e83f 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -384,7 +384,7 @@ typedef unsigned long scm_t_bits; /* Checking if a SCM variable holds an immediate integer: See numbers.h for * the definition of the following macros: SCM_I_FIXNUM_BIT, - * SCM_MOST_POSITIVE_FIXNUM, SCM_INUMP, SCM_I_MAKINUM, SCM_INUM. */ + * SCM_MOST_POSITIVE_FIXNUM, SCM_I_INUMP, SCM_I_MAKINUM, SCM_I_INUM. */ /* Checking if a SCM variable holds a pair (for historical reasons, in Guile * also known as a cons-cell): This is done by first checking that the SCM diff --git a/libguile/throw.c b/libguile/throw.c index c40000bdd..0f27e93a1 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -372,8 +372,8 @@ scm_exit_status (SCM args) { SCM cqa = SCM_CAR (args); - if (SCM_INUMP (cqa)) - return (SCM_INUM (cqa)); + if (scm_is_integer (cqa)) + return (scm_to_int (cqa)); else if (scm_is_false (cqa)) return 1; } diff --git a/libguile/unif.c b/libguile/unif.c index c383dd845..3d81b95c4 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -170,8 +170,8 @@ scm_make_uve (long k, SCM prot) return make_uve (scm_tc7_byvect, k, sizeof (char)); else if (SCM_CHARP (prot)) return scm_allocate_string (sizeof (char) * k); - else if (SCM_INUMP (prot)) - return make_uve (SCM_INUM (prot) > 0 ? scm_tc7_uvect : scm_tc7_ivect, + else if (SCM_I_INUMP (prot)) + return make_uve (SCM_I_INUM (prot) > 0 ? scm_tc7_uvect : scm_tc7_ivect, k, sizeof (long)); else if (SCM_FRACTIONP (prot)) @@ -218,11 +218,11 @@ SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, badarg1:SCM_WRONG_TYPE_ARG (1, v); case scm_tc7_vector: case scm_tc7_wvect: - return SCM_I_MAKINUM (SCM_VECTOR_LENGTH (v)); + return scm_from_size_t (SCM_VECTOR_LENGTH (v)); case scm_tc7_string: - return SCM_I_MAKINUM (SCM_STRING_LENGTH (v)); + return scm_from_size_t (SCM_STRING_LENGTH (v)); case scm_tc7_bvect: - return SCM_I_MAKINUM (SCM_BITVECTOR_LENGTH (v)); + return scm_from_size_t (SCM_BITVECTOR_LENGTH (v)); case scm_tc7_byvect: case scm_tc7_uvect: case scm_tc7_ivect: @@ -233,7 +233,7 @@ SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, #if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: #endif - return SCM_I_MAKINUM (SCM_UVECTOR_LENGTH (v)); + return scm_from_size_t (SCM_UVECTOR_LENGTH (v)); } } #undef FUNC_NAME @@ -280,10 +280,10 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, protp = SCM_EQ_P (prot, SCM_MAKE_CHAR ('\0')); break; case scm_tc7_uvect: - protp = SCM_INUMP(prot) && SCM_INUM(prot)>0; + protp = SCM_I_INUMP(prot) && SCM_I_INUM(prot)>0; break; case scm_tc7_ivect: - protp = SCM_INUMP(prot) && SCM_INUM(prot)<=0; + protp = SCM_I_INUMP(prot) && SCM_I_INUM(prot)<=0; break; case scm_tc7_svect: protp = SCM_SYMBOLP (prot) @@ -347,10 +347,10 @@ SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, case scm_tc7_llvect: #endif case scm_tc7_svect: - return SCM_I_MAKINUM (1L); + return scm_from_int (1); case scm_tc7_smob: if (SCM_ARRAYP (ra)) - return SCM_I_MAKINUM (SCM_ARRAY_NDIM (ra)); + return scm_from_size_t (SCM_ARRAY_NDIM (ra)); return SCM_INUM0; } } @@ -397,10 +397,10 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, s = SCM_ARRAY_DIMS (ra); while (k--) res = scm_cons (s[k].lbnd - ? scm_cons2 (SCM_I_MAKINUM (s[k].lbnd), - SCM_I_MAKINUM (s[k].ubnd), + ? scm_cons2 (scm_from_long (s[k].lbnd), + scm_from_long (s[k].ubnd), SCM_EOL) - : SCM_I_MAKINUM (1 + s[k].ubnd), + : scm_from_long (1 + s[k].ubnd), res); return res; } @@ -425,7 +425,7 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, #define FUNC_NAME s_scm_shared_array_offset { SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME); - return SCM_I_MAKINUM (SCM_ARRAY_BASE (ra)); + return scm_from_int (SCM_ARRAY_BASE (ra)); } #undef FUNC_NAME @@ -442,7 +442,7 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, k = SCM_ARRAY_NDIM (ra); s = SCM_ARRAY_DIMS (ra); while (k--) - res = scm_cons (SCM_I_MAKINUM (s[k].inc), res); + res = scm_cons (scm_from_long (s[k].inc), res); return res; } #undef FUNC_NAME @@ -460,19 +460,19 @@ scm_aind (SCM ra, SCM args, const char *what) register unsigned long pos = SCM_ARRAY_BASE (ra); register unsigned long k = SCM_ARRAY_NDIM (ra); scm_t_array_dim *s = SCM_ARRAY_DIMS (ra); - if (SCM_INUMP (args)) + if (scm_is_integer (args)) { if (k != 1) scm_error_num_args_subr (what); - return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); + return pos + (scm_to_long (args) - s->lbnd) * (s->inc); } while (k && SCM_CONSP (args)) { ind = SCM_CAR (args); args = SCM_CDR (args); - if (!SCM_INUMP (ind)) + if (!scm_is_integer (ind)) scm_misc_error (what, s_bad_ind, SCM_EOL); - j = SCM_INUM (ind); + j = scm_to_long (ind); if (j < s->lbnd || j > s->ubnd) scm_out_of_range (what, ind); pos += (j - s->lbnd) * (s->inc); @@ -520,25 +520,25 @@ scm_shap2ra (SCM args, const char *what) for (; !SCM_NULLP (args); s++, args = SCM_CDR (args)) { spec = SCM_CAR (args); - if (SCM_INUMP (spec)) + if (scm_is_integer (spec)) { - if (SCM_INUM (spec) < 0) + if (scm_to_long (spec) < 0) scm_misc_error (what, s_bad_spec, SCM_EOL); s->lbnd = 0; - s->ubnd = SCM_INUM (spec) - 1; + s->ubnd = scm_to_long (spec) - 1; s->inc = 1; } else { - if (!SCM_CONSP (spec) || !SCM_INUMP (SCM_CAR (spec))) + if (!SCM_CONSP (spec) || !scm_is_integer (SCM_CAR (spec))) scm_misc_error (what, s_bad_spec, SCM_EOL); - s->lbnd = SCM_INUM (SCM_CAR (spec)); + s->lbnd = scm_to_long (SCM_CAR (spec)); sp = SCM_CDR (spec); if (!SCM_CONSP (sp) - || !SCM_INUMP (SCM_CAR (sp)) + || !scm_is_integer (SCM_CAR (sp)) || !SCM_NULLP (SCM_CDR (sp))) scm_misc_error (what, s_bad_spec, SCM_EOL); - s->ubnd = SCM_INUM (SCM_CAR (sp)); + s->ubnd = scm_to_long (SCM_CAR (sp)); s->inc = 1; } } @@ -559,13 +559,13 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, scm_t_array_dim *s; SCM ra; - if (SCM_INUMP (dims)) + if (scm_is_integer (dims)) { - SCM answer = scm_make_uve (SCM_INUM (dims), prot); + SCM answer = scm_make_uve (scm_to_long (dims), prot); if (!SCM_UNBNDP (fill)) scm_array_fill_x (answer, fill); else if (SCM_SYMBOLP (prot)) - scm_array_fill_x (answer, SCM_I_MAKINUM (0)); + scm_array_fill_x (answer, scm_from_int (0)); else scm_array_fill_x (answer, prot); return answer; @@ -590,7 +590,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, if (!SCM_UNBNDP (fill)) scm_array_fill_x (ra, fill); else if (SCM_SYMBOLP (prot)) - scm_array_fill_x (ra, SCM_I_MAKINUM (0)); + scm_array_fill_x (ra, scm_from_int (0)); else scm_array_fill_x (ra, prot); @@ -672,13 +672,13 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, { SCM_ARRAY_V (ra) = oldra; old_min = 0; - old_max = SCM_INUM (scm_uniform_vector_length (oldra)) - 1; + old_max = scm_to_long (scm_uniform_vector_length (oldra)) - 1; } inds = SCM_EOL; s = SCM_ARRAY_DIMS (ra); for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) { - inds = scm_cons (SCM_I_MAKINUM (s[k].lbnd), inds); + inds = scm_cons (scm_from_long (s[k].lbnd), inds); if (s[k].ubnd < s[k].lbnd) { if (1 == SCM_ARRAY_NDIM (ra)) @@ -693,14 +693,13 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, i = (size_t) scm_aind (oldra, imap, FUNC_NAME); else { - if (SCM_NINUMP (imap)) - + if (!scm_is_integer (imap)) { - if (scm_ilength (imap) != 1 || !SCM_INUMP (SCM_CAR (imap))) + if (scm_ilength (imap) != 1 || !scm_is_integer (SCM_CAR (imap))) SCM_MISC_ERROR (s_bad_ind, SCM_EOL); imap = SCM_CAR (imap); } - i = SCM_INUM (imap); + i = scm_to_size_t (imap); } SCM_ARRAY_BASE (ra) = new_min = new_max = i; indptr = inds; @@ -709,20 +708,20 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, { if (s[k].ubnd > s[k].lbnd) { - SCM_SETCAR (indptr, SCM_I_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1)); + SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1))); imap = scm_apply_0 (mapfunc, scm_reverse (inds)); if (SCM_ARRAYP (oldra)) s[k].inc = scm_aind (oldra, imap, FUNC_NAME) - i; else { - if (SCM_NINUMP (imap)) + if (!scm_is_integer (imap)) { - if (scm_ilength (imap) != 1 || !SCM_INUMP (SCM_CAR (imap))) + if (scm_ilength (imap) != 1 || !scm_is_integer (SCM_CAR (imap))) SCM_MISC_ERROR (s_bad_ind, SCM_EOL); imap = SCM_CAR (imap); } - s[k].inc = (long) SCM_INUM (imap) - i; + s[k].inc = scm_to_long (imap) - i; } i += s[k].inc; if (s[k].inc > 0) @@ -739,7 +738,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) { SCM v = SCM_ARRAY_V (ra); - unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); + unsigned long int length = scm_to_ulong (scm_uniform_vector_length (v)); if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) return v; if (s->ubnd < s->lbnd) @@ -812,11 +811,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, ndim = 0; for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) { - SCM_ASSERT (SCM_INUMP (ve[k]), ve[k], (SCM_ARG2 + k), - FUNC_NAME); - i = SCM_INUM (ve[k]); - if (i < 0 || i >= SCM_ARRAY_NDIM (ra)) - scm_out_of_range (FUNC_NAME, ve[k]); + i = scm_to_signed_integer (ve[k], 0, SCM_ARRAY_NDIM(ra)); if (ndim < i) ndim = i; } @@ -831,7 +826,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, } for (k = SCM_ARRAY_NDIM (ra); k--;) { - i = SCM_INUM (ve[k]); + i = scm_to_int (ve[k]); s = &(SCM_ARRAY_DIMS (ra)[k]); r = &(SCM_ARRAY_DIMS (res)[i]); if (r->ubnd < r->lbnd) @@ -890,7 +885,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, SCM_VALIDATE_REST_ARGUMENT (axes); if (SCM_NULLP (axes)) - axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_I_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); + axes = scm_cons ((SCM_ARRAYP (ra) ? scm_from_size_t (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); ninr = scm_ilength (axes); if (ninr < 0) SCM_WRONG_NUM_ARGS (); @@ -915,7 +910,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, case scm_tc7_llvect: #endif s->lbnd = 0; - s->ubnd = SCM_INUM (scm_uniform_vector_length (ra)) - 1; + s->ubnd = scm_to_long (scm_uniform_vector_length (ra)) - 1; s->inc = 1; SCM_ARRAY_V (ra_inr) = ra; SCM_ARRAY_BASE (ra_inr) = 0; @@ -932,15 +927,15 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, noutr = ndim - ninr; if (noutr < 0) SCM_WRONG_NUM_ARGS (); - axv = scm_make_string (SCM_I_MAKINUM (ndim), SCM_MAKE_CHAR (0)); + axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0)); res = scm_make_ra (noutr); SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr); SCM_ARRAY_V (res) = ra_inr; for (k = 0; k < ninr; k++, axes = SCM_CDR (axes)) { - if (!SCM_INUMP (SCM_CAR (axes))) + if (!scm_is_integer (SCM_CAR (axes))) SCM_MISC_ERROR ("bad axis", SCM_EOL); - j = SCM_INUM (SCM_CAR (axes)); + j = scm_to_int (SCM_CAR (axes)); SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd; SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd; SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc; @@ -981,8 +976,7 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, { ind = SCM_CAR (args); args = SCM_CDR (args); - SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, FUNC_NAME); - pos = SCM_INUM (ind); + pos = scm_to_long (ind); } tail: switch SCM_TYP7 (v) @@ -1002,7 +996,7 @@ tail: else while (!0) { - j = SCM_INUM (ind); + j = scm_to_long (ind); if (!(j >= (s->lbnd) && j <= (s->ubnd))) { SCM_ASRTGO (--k == scm_ilength (args), wna); @@ -1014,7 +1008,7 @@ tail: ind = SCM_CAR (args); args = SCM_CDR (args); s++; - if (!SCM_INUMP (ind)) + if (!scm_is_integer (ind)) SCM_MISC_ERROR (s_bad_ind, SCM_EOL); } SCM_ASRTGO (0 == k, wna); @@ -1035,8 +1029,8 @@ tail: case scm_tc7_vector: case scm_tc7_wvect: { - unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); - SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna); + unsigned long length = scm_to_ulong (scm_uniform_vector_length (v)); + SCM_ASRTGO (SCM_NULLP (args) && scm_is_integer (ind), wna); return scm_from_bool(pos >= 0 && pos < length); } } @@ -1071,15 +1065,15 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, unsigned long int length; if (SCM_NIMP (args)) { - SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME); - pos = SCM_INUM (SCM_CAR (args)); + SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, FUNC_NAME); + pos = scm_to_long (SCM_CAR (args)); SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); } else { pos = scm_to_long (args); } - length = SCM_INUM (scm_uniform_vector_length (v)); + length = scm_to_ulong (scm_uniform_vector_length (v)); SCM_ASRTGO (pos >= 0 && pos < length, outrng); } switch SCM_TYP7 (v) @@ -1092,7 +1086,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, /* not reached */ outrng: - scm_out_of_range (FUNC_NAME, SCM_I_MAKINUM (pos)); + scm_out_of_range (FUNC_NAME, scm_from_long (pos)); wna: SCM_WRONG_NUM_ARGS (); case scm_tc7_smob: @@ -1117,17 +1111,17 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, case scm_tc7_string: return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]); case scm_tc7_byvect: - return SCM_I_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]); + return scm_from_char (((char *) SCM_UVECTOR_BASE (v))[pos]); case scm_tc7_uvect: - return scm_ulong2num (((unsigned long *) SCM_VELTS (v))[pos]); + return scm_from_ulong (((unsigned long *) SCM_VELTS (v))[pos]); case scm_tc7_ivect: - return scm_long2num (((signed long *) SCM_VELTS (v))[pos]); + return scm_from_long (((signed long *) SCM_VELTS (v))[pos]); case scm_tc7_svect: - return SCM_I_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]); + return scm_from_short (((short *) SCM_CELL_WORD_1 (v))[pos]); #if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: - return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]); + return scm_from_long_long (((long long *) SCM_CELL_WORD_1 (v))[pos]); #endif case scm_tc7_fvect: @@ -1163,16 +1157,16 @@ scm_cvref (SCM v, unsigned long pos, SCM last) case scm_tc7_string: return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]); case scm_tc7_byvect: - return SCM_I_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]); + return scm_from_char (((char *) SCM_UVECTOR_BASE (v))[pos]); case scm_tc7_uvect: - return scm_ulong2num(((unsigned long *) SCM_VELTS (v))[pos]); + return scm_from_ulong (((unsigned long *) SCM_VELTS (v))[pos]); case scm_tc7_ivect: - return scm_long2num(((signed long *) SCM_VELTS (v))[pos]); + return scm_from_long (((signed long *) SCM_VELTS (v))[pos]); case scm_tc7_svect: - return SCM_I_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]); + return scm_from_short (((short *) SCM_CELL_WORD_1 (v))[pos]); #if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: - return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]); + return scm_from_long_long (((long long *) SCM_CELL_WORD_1 (v))[pos]); #endif case scm_tc7_fvect: if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0)) @@ -1244,15 +1238,14 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, unsigned long int length; if (SCM_CONSP (args)) { - SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), args, SCM_ARG3, FUNC_NAME); SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); - pos = SCM_INUM (SCM_CAR (args)); + pos = scm_to_long (SCM_CAR (args)); } else { pos = scm_to_long (args); } - length = SCM_INUM (scm_uniform_vector_length (v)); + length = scm_to_ulong (scm_uniform_vector_length (v)); SCM_ASRTGO (pos >= 0 && pos < length, outrng); } switch (SCM_TYP7 (v)) @@ -1261,7 +1254,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, SCM_WRONG_TYPE_ARG (1, v); /* not reached */ outrng: - scm_out_of_range (FUNC_NAME, SCM_I_MAKINUM (pos)); + scm_out_of_range (FUNC_NAME, scm_from_long (pos)); wna: SCM_WRONG_NUM_ARGS (); case scm_tc7_smob: /* enclosed */ @@ -1280,9 +1273,8 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, break; case scm_tc7_byvect: if (SCM_CHARP (obj)) - obj = SCM_I_MAKINUM ((char) SCM_CHAR (obj)); - SCM_ASRTGO (SCM_INUMP (obj), badobj); - ((char *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj); + obj = scm_from_char ((char) SCM_CHAR (obj)); + ((char *) SCM_UVECTOR_BASE (v))[pos] = scm_to_char (obj); break; case scm_tc7_uvect: ((unsigned long *) SCM_UVECTOR_BASE (v))[pos] @@ -1293,8 +1285,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, = scm_num2long (obj, SCM_ARG2, FUNC_NAME); break; case scm_tc7_svect: - SCM_ASRTGO (SCM_INUMP (obj), badobj); - ((short *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj); + ((short *) SCM_UVECTOR_BASE (v))[pos] = scm_to_short (obj); break; #if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: @@ -1390,7 +1381,7 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, { SCM v = SCM_ARRAY_V (ra); - unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); + unsigned long length = scm_to_ulong (scm_uniform_vector_length (v)); if ((len == length) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc) return v; } @@ -1471,12 +1462,12 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, if (SCM_UNBNDP (port_or_fd)) port_or_fd = scm_cur_inp; else - SCM_ASSERT (SCM_INUMP (port_or_fd) + SCM_ASSERT (scm_is_integer (port_or_fd) || (SCM_OPINPORTP (port_or_fd)), port_or_fd, SCM_ARG2, FUNC_NAME); vlen = (SCM_TYP7 (v) == scm_tc7_smob ? 0 - : SCM_INUM (scm_uniform_vector_length (v))); + : scm_to_long (scm_uniform_vector_length (v))); loop: switch SCM_TYP7 (v) @@ -1595,7 +1586,7 @@ loop: } else /* file descriptor. */ { - SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd), + SCM_SYSCALL (ans = read (scm_to_int (port_or_fd), base + (cstart + offset) * sz, (sz * (cend - offset)))); if (ans == -1) @@ -1607,7 +1598,7 @@ loop: if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra)) scm_array_copy_x (cra, ra); - return SCM_I_MAKINUM (ans); + return scm_from_long (ans); } #undef FUNC_NAME @@ -1637,12 +1628,12 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, if (SCM_UNBNDP (port_or_fd)) port_or_fd = scm_cur_outp; else - SCM_ASSERT (SCM_INUMP (port_or_fd) + SCM_ASSERT (scm_is_integer (port_or_fd) || (SCM_OPOUTPORTP (port_or_fd)), port_or_fd, SCM_ARG2, FUNC_NAME); vlen = (SCM_TYP7 (v) == scm_tc7_smob ? 0 - : SCM_INUM (scm_uniform_vector_length (v))); + : scm_to_long (scm_uniform_vector_length (v))); loop: switch SCM_TYP7 (v) @@ -1729,7 +1720,7 @@ loop: } else /* file descriptor. */ { - SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd), + SCM_SYSCALL (ans = write (scm_to_int (port_or_fd), base + (cstart + offset) * sz, (sz * (cend - offset)))); if (ans == -1) @@ -1738,7 +1729,7 @@ loop: if (SCM_TYP7 (v) == scm_tc7_bvect) ans *= SCM_LONG_BIT; - return SCM_I_MAKINUM (ans); + return scm_from_long (ans); } #undef FUNC_NAME @@ -1770,7 +1761,7 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, w >>= 4; } if (i == 0) { - return SCM_I_MAKINUM (count); + return scm_from_ulong (count); } else { --i; w = SCM_UNPACK (SCM_VELTS (bitvector)[i]); @@ -1826,17 +1817,17 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, switch (w & 0x0f) { default: - return SCM_I_MAKINUM (pos); + return scm_from_long (pos); case 2: case 6: case 10: case 14: - return SCM_I_MAKINUM (pos + 1); + return scm_from_long (pos + 1); case 4: case 12: - return SCM_I_MAKINUM (pos + 2); + return scm_from_long (pos + 2); case 8: - return SCM_I_MAKINUM (pos + 3); + return scm_from_long (pos + 3); case 0: pos += 4; w >>= 4; @@ -1897,7 +1888,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); if (k >= vlen) - scm_out_of_range (FUNC_NAME, SCM_I_MAKINUM (k)); + scm_out_of_range (FUNC_NAME, scm_from_long (k)); SCM_BITVEC_CLR(v, k); } else if (SCM_EQ_P (obj, SCM_BOOL_T)) @@ -1905,7 +1896,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); if (k >= vlen) - scm_out_of_range (FUNC_NAME, SCM_I_MAKINUM (k)); + scm_out_of_range (FUNC_NAME, scm_from_long (k)); SCM_BITVEC_SET(v, k); } else @@ -1967,7 +1958,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); if (k >= vlen) - scm_out_of_range (FUNC_NAME, SCM_I_MAKINUM (k)); + scm_out_of_range (FUNC_NAME, scm_from_long (k)); if (!SCM_BITVEC_REF(v, k)) count++; } @@ -1976,7 +1967,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); if (k >= vlen) - scm_out_of_range (FUNC_NAME, SCM_I_MAKINUM (k)); + scm_out_of_range (FUNC_NAME, scm_from_long (k)); if (SCM_BITVEC_REF (v, k)) count++; } @@ -1997,13 +1988,13 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, for (; k; k >>= 4) count += cnt_tab[k & 0x0f]; if (0 == i--) - return SCM_I_MAKINUM (count); + return scm_from_long (count); /* urg. repetitive (see above.) */ k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK(SCM_VELTS (v)[i]) : ~SCM_UNPACK (SCM_VELTS (v)[i])); } } - return SCM_I_MAKINUM (count); + return scm_from_long (count); } #undef FUNC_NAME @@ -2080,7 +2071,7 @@ ra2l (SCM ra, unsigned long base, unsigned long k) do { i -= inc; - res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), SCM_I_MAKINUM (i)), res); + res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), scm_from_size_t (i)), res); } while (i != base); return res; @@ -2124,21 +2115,21 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, signed char *data = (signed char *) SCM_VELTS (v); unsigned long k = SCM_UVECTOR_LENGTH (v); while (k != 0) - res = scm_cons (SCM_I_MAKINUM (data[--k]), res); + res = scm_cons (scm_from_schar (data[--k]), res); return res; } case scm_tc7_uvect: { - long *data = (long *)SCM_VELTS(v); + unsigned long *data = (unsigned long *)SCM_VELTS(v); for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_ulong2num(data[k]), res); + res = scm_cons(scm_from_ulong (data[k]), res); return res; } case scm_tc7_ivect: { long *data = (long *)SCM_VELTS(v); for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_long2num(data[k]), res); + res = scm_cons(scm_from_long (data[k]), res); return res; } case scm_tc7_svect: @@ -2204,7 +2195,7 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, { n = scm_ilength (row); SCM_ASSERT (n >= 0, lst, SCM_ARG3, FUNC_NAME); - shp = scm_cons (SCM_I_MAKINUM (n), shp); + shp = scm_cons (scm_from_long (n), shp); if (SCM_NIMP (row)) row = SCM_CAR (row); } @@ -2218,9 +2209,9 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, } if (!SCM_ARRAYP (ra)) { - unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra)); + unsigned long length = scm_to_ulong (scm_uniform_vector_length (ra)); for (k = 0; k < length; k++, lst = SCM_CDR (lst)) - scm_array_set_x (ra, SCM_CAR (lst), SCM_I_MAKINUM (k)); + scm_array_set_x (ra, SCM_CAR (lst), scm_from_ulong (k)); return ra; } if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0)) @@ -2258,7 +2249,7 @@ l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k) { if (!SCM_CONSP (lst)) return 0; - scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_I_MAKINUM (base)); + scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), scm_from_ulong (base)); base += inc; lst = SCM_CDR (lst); } @@ -2275,7 +2266,7 @@ rapr1 (SCM ra, unsigned long j, unsigned long k, SCM port, scm_print_state *psta long inc = 1; long n = (SCM_TYP7 (ra) == scm_tc7_smob ? 0 - : SCM_INUM (scm_uniform_vector_length (ra))); + : scm_to_long (scm_uniform_vector_length (ra))); int enclosed = 0; tail: switch SCM_TYP7 (ra) @@ -2325,7 +2316,7 @@ tail: default: /* scm_tc7_bvect and scm_tc7_llvect only? */ if (n-- > 0) - scm_iprin1 (scm_uniform_vector_ref (ra, SCM_I_MAKINUM (j)), port, pstate); + scm_iprin1 (scm_uniform_vector_ref (ra, scm_from_ulong (j)), port, pstate); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); @@ -2568,9 +2559,9 @@ loop: case scm_tc7_byvect: return SCM_MAKE_CHAR ('\0'); case scm_tc7_uvect: - return SCM_I_MAKINUM (1L); + return scm_from_int (1); case scm_tc7_ivect: - return SCM_I_MAKINUM (-1L); + return scm_from_int (-1); case scm_tc7_svect: return scm_str2symbol ("s"); #if SCM_SIZEOF_LONG_LONG != 0 @@ -2613,8 +2604,8 @@ scm_init_unif () scm_set_smob_free (scm_tc16_array, array_free); scm_set_smob_print (scm_tc16_array, scm_raprin1); scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p); - exactly_one_third = scm_permanent_object (scm_make_ratio (SCM_I_MAKINUM (1), - SCM_I_MAKINUM (3))); + exactly_one_third = scm_permanent_object (scm_make_ratio (scm_from_int (1), + scm_from_int (3))); scm_add_feature ("array"); #include "libguile/unif.x" } diff --git a/libguile/vectors.c b/libguile/vectors.c index 6aa9def6e..ea08b0c2a 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -46,7 +46,7 @@ scm_vector_length (SCM v) { SCM_GASSERT1 (SCM_VECTORP(v), g_vector_length, v, SCM_ARG1, s_vector_length); - return SCM_I_MAKINUM (SCM_VECTOR_LENGTH (v)); + return scm_from_size_t (SCM_VECTOR_LENGTH (v)); } SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); @@ -114,10 +114,12 @@ scm_vector_ref (SCM v, SCM k) { SCM_GASSERT2 (SCM_VECTORP (v), g_vector_ref, v, k, SCM_ARG1, s_vector_ref); - SCM_GASSERT2 (SCM_INUMP (k), + SCM_GASSERT2 (SCM_I_INUMP (k), g_vector_ref, v, k, SCM_ARG2, s_vector_ref); - SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_VECTOR_LENGTH (v) && SCM_INUM (k) >= 0); - return SCM_VELTS (v)[(long) SCM_INUM (k)]; + SCM_ASSERT_RANGE (2, k, + SCM_I_INUM (k) < SCM_VECTOR_LENGTH (v) + && SCM_I_INUM (k) >= 0); + return SCM_VELTS (v)[(long) SCM_I_INUM (k)]; } #undef FUNC_NAME @@ -141,11 +143,13 @@ scm_vector_set_x (SCM v, SCM k, SCM obj) SCM_GASSERTn (SCM_VECTORP (v), g_vector_set_x, scm_list_3 (v, k, obj), SCM_ARG1, s_vector_set_x); - SCM_GASSERTn (SCM_INUMP (k), + SCM_GASSERTn (SCM_I_INUMP (k), g_vector_set_x, scm_list_3 (v, k, obj), SCM_ARG2, s_vector_set_x); - SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_VECTOR_LENGTH (v) && SCM_INUM (k) >= 0); - SCM_VECTOR_SET (v, (long) SCM_INUM(k), obj); + SCM_ASSERT_RANGE (2, k, + SCM_I_INUM (k) < SCM_VECTOR_LENGTH (v) + && SCM_I_INUM (k) >= 0); + SCM_VECTOR_SET (v, (long) SCM_I_INUM(k), obj); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -159,18 +163,12 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, "unspecified.") #define FUNC_NAME s_scm_make_vector { + size_t l = scm_to_unsigned_integer (k, 0, SCM_VECTOR_MAX_LENGTH); + if (SCM_UNBNDP (fill)) fill = SCM_UNSPECIFIED; - - if (SCM_INUMP (k)) - { - SCM_ASSERT_RANGE (1, k, SCM_INUM (k) >= 0); - return scm_c_make_vector (SCM_INUM (k), fill); - } - else if (SCM_BIGP (k)) - SCM_OUT_OF_RANGE (1, k); - else - SCM_WRONG_TYPE_ARG (1, k); + + return scm_c_make_vector (l, fill); } #undef FUNC_NAME diff --git a/libguile/version.c b/libguile/version.c index 9c25cf608..3a811f01e 100644 --- a/libguile/version.c +++ b/libguile/version.c @@ -35,8 +35,8 @@ SCM_DEFINE (scm_major_version, "major-version", 0, 0, 0, "E.g., the 1 in \"1.6.5\".") #define FUNC_NAME s_scm_major_version { - return scm_number_to_string (SCM_I_MAKINUM(SCM_MAJOR_VERSION), - SCM_I_MAKINUM(10)); + return scm_number_to_string (scm_from_int (SCM_MAJOR_VERSION), + scm_from_int (10)); } #undef FUNC_NAME @@ -48,8 +48,8 @@ SCM_DEFINE (scm_minor_version, "minor-version", 0, 0, 0, "E.g., the 6 in \"1.6.5\".") #define FUNC_NAME s_scm_minor_version { - return scm_number_to_string (SCM_I_MAKINUM(SCM_MINOR_VERSION), - SCM_I_MAKINUM(10)); + return scm_number_to_string (scm_from_int (SCM_MINOR_VERSION), + scm_from_int (10)); } #undef FUNC_NAME @@ -61,8 +61,8 @@ SCM_DEFINE (scm_micro_version, "micro-version", 0, 0, 0, "E.g., the 5 in \"1.6.5\".") #define FUNC_NAME s_scm_micro_version { - return scm_number_to_string (SCM_I_MAKINUM(SCM_MICRO_VERSION), - SCM_I_MAKINUM(10)); + return scm_number_to_string (scm_from_int (SCM_MICRO_VERSION), + scm_from_int (10)); } #undef FUNC_NAME diff --git a/libguile/weaks.c b/libguile/weaks.c index 33df4519e..2b0eba6eb 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -75,46 +75,37 @@ SCM scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill, const char* caller) #define FUNC_NAME caller { - if (SCM_INUMP (size)) + size_t c_size; + SCM v; + + c_size = scm_to_unsigned_integer (size, 0, SCM_VECTOR_MAX_LENGTH); + + if (c_size > 0) { - size_t c_size; - SCM v; - - SCM_ASSERT_RANGE (1, size, SCM_INUM (size) >= 0); - c_size = SCM_INUM (size); - - if (c_size > 0) - { - scm_t_bits *base; - size_t j; - - if (SCM_UNBNDP (fill)) - fill = SCM_UNSPECIFIED; - - SCM_ASSERT_RANGE (1, size, c_size <= SCM_VECTOR_MAX_LENGTH); - base = scm_gc_malloc (c_size * sizeof (scm_t_bits), "weak vector"); - for (j = 0; j != c_size; ++j) - base[j] = SCM_UNPACK (fill); - v = scm_double_cell (SCM_MAKE_VECTOR_TAG (c_size, scm_tc7_wvect), - (scm_t_bits) base, - type, - SCM_UNPACK (SCM_EOL)); - scm_remember_upto_here_1 (fill); - } - else - { - v = scm_double_cell (SCM_MAKE_VECTOR_TAG (0, scm_tc7_wvect), - (scm_t_bits) NULL, - type, - SCM_UNPACK (SCM_EOL)); - } - - return v; + scm_t_bits *base; + size_t j; + + if (SCM_UNBNDP (fill)) + fill = SCM_UNSPECIFIED; + + base = scm_gc_malloc (c_size * sizeof (scm_t_bits), "weak vector"); + for (j = 0; j != c_size; ++j) + base[j] = SCM_UNPACK (fill); + v = scm_double_cell (SCM_MAKE_VECTOR_TAG (c_size, scm_tc7_wvect), + (scm_t_bits) base, + type, + SCM_UNPACK (SCM_EOL)); + scm_remember_upto_here_1 (fill); } - else if (SCM_BIGP (size)) - SCM_OUT_OF_RANGE (1, size); else - SCM_WRONG_TYPE_ARG (1, size); + { + v = scm_double_cell (SCM_MAKE_VECTOR_TAG (0, scm_tc7_wvect), + (scm_t_bits) NULL, + type, + SCM_UNPACK (SCM_EOL)); + } + + return v; } #undef FUNC_NAME @@ -150,7 +141,7 @@ SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, while the vector is being created. */ i = scm_ilength (l); SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME); - res = scm_make_weak_vector (SCM_I_MAKINUM (i), SCM_UNSPECIFIED); + res = scm_make_weak_vector (scm_from_int (i), SCM_UNSPECIFIED); /* no alloc, so this loop is safe. @@ -192,7 +183,7 @@ SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, #define FUNC_NAME s_scm_make_weak_key_alist_vector { return scm_i_allocate_weak_vector - (1, SCM_UNBNDP (size) ? SCM_I_MAKINUM (31) : size, SCM_EOL, FUNC_NAME); + (1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL, FUNC_NAME); } #undef FUNC_NAME @@ -204,7 +195,7 @@ SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, #define FUNC_NAME s_scm_make_weak_value_alist_vector { return scm_i_allocate_weak_vector - (2, SCM_UNBNDP (size) ? SCM_I_MAKINUM (31) : size, SCM_EOL, FUNC_NAME); + (2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL, FUNC_NAME); } #undef FUNC_NAME @@ -216,7 +207,7 @@ SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", #define FUNC_NAME s_scm_make_doubly_weak_alist_vector { return scm_i_allocate_weak_vector - (3, SCM_UNBNDP (size) ? SCM_I_MAKINUM (31) : size, SCM_EOL, FUNC_NAME); + (3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL, FUNC_NAME); } #undef FUNC_NAME diff --git a/libguile/win32-socket.c b/libguile/win32-socket.c index 3d6cb6625..bc2d839de 100644 --- a/libguile/win32-socket.c +++ b/libguile/win32-socket.c @@ -614,9 +614,9 @@ scm_socket_symbols_Win32 (socket_error_t * e) if (e->error) { if (e->correct_str) - scm_c_define (e->correct_str, SCM_I_MAKINUM (e->error)); + scm_c_define (e->correct_str, scm_from_int (e->error)); if (e->replace && e->replace_str) - scm_c_define (e->replace_str, SCM_I_MAKINUM (e->replace)); + scm_c_define (e->replace_str, scm_from_int (e->replace)); } e++; } From d5b203a684426645d22eac20f30fbdebb1bdb5d2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 23 Jul 2004 15:51:33 +0000 Subject: [PATCH 34/89] *** empty log message *** --- NEWS | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/NEWS b/NEWS index 3a3dfb024..69aa932aa 100644 --- a/NEWS +++ b/NEWS @@ -598,6 +598,27 @@ starting the week. * Changes to the C interface +** Many of the old macros for doing type conversions between C and + Scheme have been deprecated and replaced with functions (or macros + that behave like functions). + +This was done to ... + +These are the deprecated macros and their replacements: + + SCM_EQ_P -> scm_is_eq + SCM_FALSEP -> scm_is_false + SCM_NFALSEP -> scm_is_true + SCM_BOOL -> scm_from_bool + SCM_NEGATE_BOOL -> scm_from_bool (! ...) + SCM_BOOLP -> scm_is_bool + SCM_BOOL_NOT -> scm_not + + SCM_INUMP -> scm_is_integer or similar + SCM_NINUMP -> !scm_is_integer or similar + SCM_MAKINUM -> scm_from_int or similar + SCM_INUM -> scm_to_int or similar + ** SCM_CELL_WORD_LOC has been deprecated. Use the new macro SCM_CELL_OBJECT_LOC instead, which return a pointer From 26a4995c587e57fdd657d2adbe0e4b4db4565e50 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 23 Jul 2004 23:38:50 +0000 Subject: [PATCH 35/89] Use define-module, to as not to import common-list into subsequent tests (eg. srfi-1 where `every' provokes a warning). --- test-suite/tests/common-list.test | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/test-suite/tests/common-list.test b/test-suite/tests/common-list.test index c60e364e5..424916bb5 100644 --- a/test-suite/tests/common-list.test +++ b/test-suite/tests/common-list.test @@ -1,5 +1,5 @@ ;;;; common-list.test --- tests guile's common list functions -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2004 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -15,8 +15,10 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -(use-modules (ice-9 documentation) - (ice-9 common-list)) +(define-module (test-suite test-common-list) + #:use-module (test-suite lib) + #:use-module (ice-9 documentation) + #:use-module (ice-9 common-list)) ;;; From cd6f7d0bd22c0d511251d5eb019dde2c48a1b477 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 23 Jul 2004 23:41:35 +0000 Subject: [PATCH 36/89] Use #:duplicates (last) to suppress warnings about current-time and raise replacing core bindings. --- test-suite/tests/srfi-19.test | 1 + test-suite/tests/srfi-34.test | 1 + 2 files changed, 2 insertions(+) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index 84364e24c..4300bf0f5 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -22,6 +22,7 @@ ;; separate module, or later tests will fail. (define-module (test-suite test-srfi-19) + :duplicates (last) ;; avoid warning about srfi-19 replacing `current-time' :use-module (test-suite lib) :use-module (srfi srfi-19) :use-module (ice-9 format)) diff --git a/test-suite/tests/srfi-34.test b/test-suite/tests/srfi-34.test index d8f1521c2..066930b69 100644 --- a/test-suite/tests/srfi-34.test +++ b/test-suite/tests/srfi-34.test @@ -18,6 +18,7 @@ ;;;; Boston, MA 02111-1307 USA (define-module (test-suite test-srfi-34) + :duplicates (last) ;; avoid warning about srfi-34 replacing `raise' :use-module (test-suite lib) :use-module (srfi srfi-13) :use-module (srfi srfi-34)) From 16ea0eb96a56ed5c35f7df46557440820cd1be3f Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 23 Jul 2004 23:41:56 +0000 Subject: [PATCH 37/89] Add a copyright year. --- test-suite/tests/srfi-34.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/tests/srfi-34.test b/test-suite/tests/srfi-34.test index 066930b69..3f648f71b 100644 --- a/test-suite/tests/srfi-34.test +++ b/test-suite/tests/srfi-34.test @@ -1,6 +1,6 @@ ;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*- ;;;; -;;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2004 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 From 6364df3429f7f191abcfddb85ba69361fd74651f Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 23 Jul 2004 23:43:57 +0000 Subject: [PATCH 38/89] *** empty log message *** --- test-suite/ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 61a8bc208..259f62a17 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,12 @@ +2004-07-24 Kevin Ryde + + * tests/common-list.test: Use define-module, to as not to import + common-list into subsequent tests (eg. srfi-1 where `every' provokes a + warning). + + * tests/srfi-19.test, tests/srfi-34.test: Use #:duplicates (last) to + suppress warnings about current-time and raise replacing core bindings. + 2004-05-25 Matthias Koeppe * tests/format.test (~{): Test no arbitrary iteration limit. From 50dc1840005092b8b311ab2f3b4745df214ae519 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 23 Jul 2004 23:51:58 +0000 Subject: [PATCH 39/89] (scm_i_misc_mutex): New SCM_GLOBAL_MUTEX. --- libguile/threads.c | 6 ++++++ libguile/threads.h | 4 +++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/libguile/threads.c b/libguile/threads.c index 11e3fdd39..a94e0698d 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1329,6 +1329,12 @@ scm_init_threads (SCM_STACKITEM *base) threads_initialized_p = 1; } +/* scm_i_misc_mutex is intended for miscellaneous uses, to protect + operations which are non-reentrant or non-thread-safe but which are + either not important enough or not used often enough to deserve their own + private mutex. */ +SCM_GLOBAL_MUTEX (scm_i_misc_mutex); + void scm_init_thread_procs () { diff --git a/libguile/threads.h b/libguile/threads.h index d81f70335..4faf54c3b 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -3,7 +3,7 @@ #ifndef SCM_THREADS_H #define SCM_THREADS_H -/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -242,6 +242,8 @@ extern scm_t_key scm_i_thread_key; SCM_API scm_t_key scm_i_root_state_key; SCM_API void scm_i_set_thread_data (void *); +SCM_API scm_t_mutex scm_i_misc_mutex; + #endif /* SCM_THREADS_H */ /* From 33bea692e5193750d76882d065ba1f77c56ffa94 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 23 Jul 2004 23:52:55 +0000 Subject: [PATCH 40/89] * threads.c, threads.h (scm_i_misc_mutex): New SCM_GLOBAL_MUTEX. * posix.c (scm_crypt): Use it to protect static data in crypt(). --- libguile/posix.c | 36 +++++++++++++++++++++++++++++++----- 1 file changed, 31 insertions(+), 5 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 79f8ea2ad..1bc5d6ccd 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1426,20 +1426,46 @@ SCM_DEFINE (scm_sync, "sync", 0, 0, 0, #undef FUNC_NAME #endif /* HAVE_SYNC */ + +/* crypt() returns a pointer to a static buffer, so we use scm_i_misc_mutex + to avoid another thread overwriting it. A test program running crypt + continuously in two threads can be quickly seen tripping this problem. + crypt() is pretty slow normally, so a mutex shouldn't add much overhead. + + glibc has a thread-safe crypt_r, but (in version 2.3.2) it runs a lot + slower (about 5x) than plain crypt if you pass an uninitialized data + block each time. Presumably there's some one-time setups. The best way + to use crypt_r for parallel execution in multiple threads would probably + be to maintain a little pool of initialized crypt_data structures, take + one and use it, then return it to the pool. That pool could be garbage + collected so it didn't add permanently to memory use if only a few crypt + calls are made. But we expect crypt will be used rarely, and even more + rarely will there be any desire for lots of parallel execution on + multiple cpus. So for now we don't bother with anything fancy, just + ensure it works. */ + #if HAVE_CRYPT -SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, +SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, (SCM key, SCM salt), "Encrypt @var{key} using @var{salt} as the salt value to the\n" "crypt(3) library call.") #define FUNC_NAME s_scm_crypt { - char * p; - + SCM ret; SCM_VALIDATE_STRING (1, key); SCM_VALIDATE_STRING (2, salt); - p = crypt (SCM_STRING_CHARS (key), SCM_STRING_CHARS (salt)); - return scm_makfrom0str (p); + scm_frame_begin (0); + scm_frame_unwind_handler ((void(*)(void*)) scm_mutex_unlock, + &scm_i_misc_mutex, + SCM_F_WIND_EXPLICITLY); + scm_mutex_lock (&scm_i_misc_mutex); + + ret = scm_makfrom0str (crypt (SCM_STRING_CHARS (key), + SCM_STRING_CHARS (salt))); + + scm_frame_end (); + return ret; } #undef FUNC_NAME #endif /* HAVE_CRYPT */ From 5eef0f619ad131dc7054abf5685649df0ec91811 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 24 Jul 2004 00:08:47 +0000 Subject: [PATCH 41/89] (SRFI-0): Revise for clarity, drop BNF in favour of plain description, emphasise this is just for portable programs. --- doc/ref/srfi-modules.texi | 137 +++++++++++++++----------------------- 1 file changed, 54 insertions(+), 83 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index f67544946..cecb1664a 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -77,100 +77,71 @@ automatically (@pxref{Invoking Guile}). @node SRFI-0 @subsection SRFI-0 - cond-expand @cindex SRFI-0 -@findex cond-expand -@c FIXME::martin: Review me! +This SRFI lets a portable Scheme program test for the presence of +certain features, and adapt itself by using different blocks of code, +or fail if the necessary features are not available. There's no +module to load, this is in the Guile core. -SRFI-0 defines a means for checking whether a Scheme implementation has -support for a specified feature. The syntactic form @code{cond-expand}, -which implements this means, has the following syntax. +A program designed only for Guile will generally not need this +mechanism, such a program can of course directly use the various +documented parts of Guile. -@example -@group - - --> (cond-expand +) - | (cond-expand * (else )) - - --> ( *) - - --> - | (and *) - | (or *) - | (not ) - - --> -@end group -@end example - -When evaluated, this form checks all clauses in order, until it finds -one whose feature requirement is satisfied. Then the form expands into -the commands or definitions in the clause. A requirement is tested as -follows: - -@itemize @bullet -@item -If it is a symbol, it is satisfied if the feature identifier is -supported. - -@item -If it is an @code{and} form, all requirements must be satisfied. If no -requirements are given, it is satisfied, too. - -@item -If it is an @code{or} form, at least one of the requirements must be -satisfied. If no requirements are given, it is not satisfied. - -@item -If it is a @code{not} form, the feature requirement must @emph{not} be +@deffn syntax cond-expand (feature body@dots{}) @dots{} +Expand to the @var{body} of the first clause whose @var{feature} +specification is satisfied. It is an error if no @var{feature} is satisfied. -@item -If the feature requirement is the keyword @code{else} and it is the last -clause, it is satisfied if no prior clause matched. -@end itemize +Features are symbols such as @code{srfi-1}, and a feature +specification can use @code{and}, @code{or} and @code{not} forms to +test combinations. The last clause can be an @code{else}, to be used +if no other passes. -If no clause is satisfied, an error is signalled. - -Since @code{cond-expand} is needed to tell what a Scheme implementation -provides, it must be accessible without using any -implementation-dependent operations, such as @code{use-modules} in -Guile. Thus, it is not necessary to use any module to get access to -this form. - -Currently, the feature identifiers @code{guile}, @code{r5rs}, @code{srfi-0} and -@code{srfi-6} are supported. The other SRFIs are not in that list by -default, because the SRFI modules must be explicitly used before their -exported bindings can be used. - -So if a Scheme program wishes to use SRFI-8, it has two possibilities: -First, it can check whether the running Scheme implementation is Guile, -and if it is, it can use the appropriate module: - -@lisp -(cond-expand - (guile - (use-modules (srfi srfi-8))) - (srfi-8 - #t)) - ;; otherwise fail. -@end lisp - -The other possibility is to use the @code{--use-srfi} command line -option when invoking Guile (@pxref{Invoking Guile}). When you do that, -the specified SRFI support modules will be loaded and add their feature -identifier to the list of symbols checked by @code{cond-expand}. - -So, if you invoke Guile like this: +For example, define a private version of @code{alist-cons} if SRFI-1 +is not available. @example -$ guile --use-srfi=8 +(cond-expand (srfi-1 + ) + (else + (define (alist-cons key val alist) + (cons (cons key val) alist)))) @end example -the following snippet will expand to @code{'hooray}. +Or demand a certain set of SRFIs (list operations, string ports, +@code{receive} and string operations), failing if they're not +available. -@lisp -(cond-expand (srfi-8 'hooray)) -@end lisp +@example +(cond-expand ((and srfi-1 srfi-6 srfi-8 srfi-13) + )) +@end example +@end deffn + +The Guile core provides features @code{guile}, @code{r5rs}, +@code{srfi-0} and @code{srfi-6} initially. Other SRFI feature symbols +are defined once their code has been loaded with @code{use-modules}, +since only then are their bindings available. + +The @samp{--use-srfi} command line option (@pxref{Invoking Guile}) is +a good way to load SRFIs to satisfy @code{cond-expand} when running a +portable program. + +Testing the @code{guile} feature allows a program to adapt itself to +the Guile module system, but still run on other Scheme systems. For +example the following demands SRFI-8 (@code{receive}), but also knows +how to load it with the Guile mechanism. + +@example +(cond-expand (srfi-8 + ) + (guile + (use-modules (srfi srfi-8)))) +@end example + +It should be noted that @code{cond-expand} is separate from the +@code{*features*} mechanism (@pxref{Feature Tracking}), feature +symbols in one are unrelated to those in the other. @node SRFI-1 From 9e5b43bf5759937b3b09a5a1a50c3ac60f40d41d Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 24 Jul 2004 00:14:48 +0000 Subject: [PATCH 42/89] (String Syntax): Add all backslash forms accepted. (Regexp Functions): Use @defvar for regexp/icase etc, to emphasise that they're variables not symbols etc. --- doc/ref/scheme-data.texi | 3544 -------------------------------------- 1 file changed, 3544 deletions(-) diff --git a/doc/ref/scheme-data.texi b/doc/ref/scheme-data.texi index f9bab52a9..e69de29bb 100755 --- a/doc/ref/scheme-data.texi +++ b/doc/ref/scheme-data.texi @@ -1,3544 +0,0 @@ -@c -*-texinfo-*- -@c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 -@c Free Software Foundation, Inc. -@c See the file guile.texi for copying conditions. - -@page -@node Simple Data Types -@section Simple Generic Data Types - -This chapter describes those of Guile's simple data types which are -primarily used for their role as items of generic data. By -@dfn{simple} we mean data types that are not primarily used as -containers to hold other data --- i.e.@: pairs, lists, vectors and so on. -For the documentation of such @dfn{compound} data types, see -@ref{Compound Data Types}. - -@c One of the great strengths of Scheme is that there is no straightforward -@c distinction between ``data'' and ``functionality''. For example, -@c Guile's support for dynamic linking could be described: - -@c @itemize @bullet -@c @item -@c either in a ``data-centric'' way, as the behaviour and properties of the -@c ``dynamically linked object'' data type, and the operations that may be -@c applied to instances of this type - -@c @item -@c or in a ``functionality-centric'' way, as the set of procedures that -@c constitute Guile's support for dynamic linking, in the context of the -@c module system. -@c @end itemize - -@c The contents of this chapter are, therefore, a matter of judgment. By -@c @dfn{generic}, we mean to select those data types whose typical use as -@c @emph{data} in a wide variety of programming contexts is more important -@c than their use in the implementation of a particular piece of -@c @emph{functionality}. The last section of this chapter provides -@c references for all the data types that are documented not here but in a -@c ``functionality-centric'' way elsewhere in the manual. - -@menu -* Booleans:: True/false values. -* Numbers:: Numerical data types. -* Characters:: New character names. -* Strings:: Special things about strings. -* Regular Expressions:: Pattern matching and substitution. -* Symbols:: Symbols. -* Keywords:: Self-quoting, customizable display keywords. -* Other Types:: "Functionality-centric" data types. -@end menu - - -@node Booleans -@subsection Booleans -@tpindex Booleans - -The two boolean values are @code{#t} for true and @code{#f} for false. - -Boolean values are returned by predicate procedures, such as the general -equality predicates @code{eq?}, @code{eqv?} and @code{equal?} -(@pxref{Equality}) and numerical and string comparison operators like -@code{string=?} (@pxref{String Comparison}) and @code{<=} -(@pxref{Comparison}). - -@lisp -(<= 3 8) -@result{} #t - -(<= 3 -3) -@result{} #f - -(equal? "house" "houses") -@result{} #f - -(eq? #f #f) -@result{} -#t -@end lisp - -In test condition contexts like @code{if} and @code{cond} (@pxref{if -cond case}), where a group of subexpressions will be evaluated only if a -@var{condition} expression evaluates to ``true'', ``true'' means any -value at all except @code{#f}. - -@lisp -(if #t "yes" "no") -@result{} "yes" - -(if 0 "yes" "no") -@result{} "yes" - -(if #f "yes" "no") -@result{} "no" -@end lisp - -A result of this asymmetry is that typical Scheme source code more often -uses @code{#f} explicitly than @code{#t}: @code{#f} is necessary to -represent an @code{if} or @code{cond} false value, whereas @code{#t} is -not necessary to represent an @code{if} or @code{cond} true value. - -It is important to note that @code{#f} is @strong{not} equivalent to any -other Scheme value. In particular, @code{#f} is not the same as the -number 0 (like in C and C++), and not the same as the ``empty list'' -(like in some Lisp dialects). - -In C, the two Scheme boolean values are available as the two constants -@code{SCM_BOOL_T} for @code{#t} and @code{SCM_BOOL_F} for @code{#f}. -Care must be taken with the false value @code{SCM_BOOL_F}: it is not -false when used in C conditionals. In order to test for it, use -@code{scm_is_false} or @code{scm_is_true}. - -@rnindex not -@deffn {Scheme Procedure} not x -@deffnx {C Function} scm_not (x) -Return @code{#t} if @var{x} is @code{#f}, else return @code{#f}. -@end deffn - -@rnindex boolean? -@deffn {Scheme Procedure} boolean? obj -@deffnx {C Function} scm_boolean_p (obj) -Return @code{#t} if @var{obj} is either @code{#t} or @code{#f}, else -return @code{#f}. -@end deffn - -@deftypevr {C Macro} SCM SCM_BOOL_T -The @code{SCM} representation of the Scheme object @code{#t}. -@end deftypevr - -@deftypevr {C Macro} SCM SCM_BOOL_F -The @code{SCM} representation of the Scheme object @code{#f}. -@end deftypevr - -@deftypefn {C Function} int scm_is_true (SCM obj) -Return @code{0} if @var{obj} is @code{#f}, else return @code{1}. -@end deftypefn - -@deftypefn {C Function} int scm_is_false (SCM obj) -Return @code{1} if @var{obj} is @code{#f}, else return @code{0}. -@end deftypefn - -@deftypefn {C Function} int scm_is_bool (SCM obj) -Return @code{1} if @var{obj} is either @code{#t} or @code{#f}, else -return @code{0}. -@end deftypefn - -@deftypefn {C Function} SCM scm_from_bool (int val) -Return @code{#f} if @var{val} is @code{0}, else return @code{#t}. -@end deftypefn - -@deftypefn {C Function} int scm_to_bool (SCM val) -Return @code{1} if @var{val} is @code{SCM_BOOL_T}, return @code{0} -when @var{val} is @code{SCM_BOOL_F}, else signal a `wrong type' error. - -You should probably use @code{scm_is_true} instead of this function -when you just want to test a @code{SCM} value for trueness. -@end deftypefn - -@node Numbers -@subsection Numerical data types -@tpindex Numbers - -Guile supports a rich ``tower'' of numerical types --- integer, -rational, real and complex --- and provides an extensive set of -mathematical and scientific functions for operating on numerical -data. This section of the manual documents those types and functions. - -You may also find it illuminating to read R5RS's presentation of numbers -in Scheme, which is particularly clear and accessible: see -@ref{Numbers,,,r5rs,R5RS}. - -@menu -* Numerical Tower:: Scheme's numerical "tower". -* Integers:: Whole numbers. -* Reals and Rationals:: Real and rational numbers. -* Complex Numbers:: Complex numbers. -* Exactness:: Exactness and inexactness. -* Number Syntax:: Read syntax for numerical data. -* Integer Operations:: Operations on integer values. -* Comparison:: Comparison predicates. -* Conversion:: Converting numbers to and from strings. -* Complex:: Complex number operations. -* Arithmetic:: Arithmetic functions. -* Scientific:: Scientific functions. -* Primitive Numerics:: Primitive numeric functions. -* Bitwise Operations:: Logical AND, OR, NOT, and so on. -* Random:: Random number generation. -@end menu - - -@node Numerical Tower -@subsubsection Scheme's Numerical ``Tower'' -@rnindex number? - -Scheme's numerical ``tower'' consists of the following categories of -numbers: - -@table @dfn -@item integers -Whole numbers, positive or negative; e.g.@: --5, 0, 18. - -@item rationals -The set of numbers that can be expressed as @math{@var{p}/@var{q}} -where @var{p} and @var{q} are integers; e.g.@: @math{9/16} works, but -pi (an irrational number) doesn't. These include integers -(@math{@var{n}/1}). - -@item real numbers -The set of numbers that describes all possible positions along a -one-dimensional line. This includes rationals as well as irrational -numbers. - -@item complex numbers -The set of numbers that describes all possible positions in a two -dimensional space. This includes real as well as imaginary numbers -(@math{@var{a}+@var{b}i}, where @var{a} is the @dfn{real part}, -@var{b} is the @dfn{imaginary part}, and @math{i} is the square root of -@minus{}1.) -@end table - -It is called a tower because each category ``sits on'' the one that -follows it, in the sense that every integer is also a rational, every -rational is also real, and every real number is also a complex number -(but with zero imaginary part). - -In addition to the classification into integers, rationals, reals and -complex numbers, Scheme also distinguishes between whether a number is -represented exactly or not. For example, the result of -@m{2\sin(\pi/4),sin(pi/4)} is exactly @m{\sqrt{2},2^(1/2)} but Guile -can neither represent @m{\pi/4,pi/4} nor @m{\sqrt{2},2^(1/2)} exactly. -Instead, it stores an inexact approximation, using the C type -@code{double}. - -Guile can represent exact rationals of any magnitude, inexact -rationals that fit into a C @code{double}, and inexact complex numbers -with @code{double} real and imaginary parts. - -The @code{number?} predicate may be applied to any Scheme value to -discover whether the value is any of the supported numerical types. - -@deffn {Scheme Procedure} number? obj -@deffnx {C Function} scm_number_p (obj) -Return @code{#t} if @var{obj} is any kind of number, else @code{#f}. -@end deffn - -For example: - -@lisp -(number? 3) -@result{} #t - -(number? "hello there!") -@result{} #f - -(define pi 3.141592654) -(number? pi) -@result{} #t -@end lisp - -The next few subsections document each of Guile's numerical data types -in detail. - -@node Integers -@subsubsection Integers - -@tpindex Integer numbers - -@rnindex integer? - -Integers are whole numbers, that is numbers with no fractional part, -such as 2, 83, and @minus{}3789. - -Integers in Guile can be arbitrarily big, as shown by the following -example. - -@lisp -(define (factorial n) - (let loop ((n n) (product 1)) - (if (= n 0) - product - (loop (- n 1) (* product n))))) - -(factorial 3) -@result{} 6 - -(factorial 20) -@result{} 2432902008176640000 - -(- (factorial 45)) -@result{} -119622220865480194561963161495657715064383733760000000000 -@end lisp - -Readers whose background is in programming languages where integers are -limited by the need to fit into just 4 or 8 bytes of memory may find -this surprising, or suspect that Guile's representation of integers is -inefficient. In fact, Guile achieves a near optimal balance of -convenience and efficiency by using the host computer's native -representation of integers where possible, and a more general -representation where the required number does not fit in the native -form. Conversion between these two representations is automatic and -completely invisible to the Scheme level programmer. - -The infinities @samp{+inf.0} and @samp{-inf.0} are considered to be -inexact integers. They are explained in detail in the next section, -together with reals and rationals. - -C has a host of different integer types, and Guile offers a host of -functions to convert between them and the @code{SCM} representation. -For example, a C @code{int} can be handled with @code{scm_to_int} and -@code{scm_from_int}. Guile also defines a few C integer types of its -own, to help with differences between systems. - -C integer types that are not covered can be handled with the generic -@code{scm_to_signed_integer} and @code{scm_from_signed_integer} for -signed types, or with @code{scm_to_unsigned_integer} and -@code{scm_from_unsigned_integer} for unsigned types. - -Scheme integers can be exact and inexact. For example, a number -written as @code{3.0} with an explicit decimal-point is inexact, but -it is also an integer. The functions @code{integer?} and -@code{scm_is_integer} report true for such a number, but the functions -@code{scm_is_signed_integer} and @code{scm_is_unsigned_integer} only -allow exact integers and thus report false. Likewise, the conversion -functions like @code{scm_to_signed_integer} only accept exact -integers. - -The motivation for this behavior is that the inexactness of a number -should not be lost silently. If you want to allow inexact integers, -you can explicitely insert a call to @code{inexact->exact} or to its C -equivalent @code{scm_inexact_to_exact}. (Only inexact integers will -be converted by this call into exact integers; inexact non-integers -will become exact fractions.) - -@deffn {Scheme Procedure} integer? x -@deffnx {C Function} scm_integer_p (x) -Return @code{#t} if @var{x} is an exactor inexact integer number, else -@code{#f}. - -@lisp -(integer? 487) -@result{} #t - -(integer? 3.0) -@result{} #t - -(integer? -3.4) -@result{} #f - -(integer? +inf.0) -@result{} #t -@end lisp -@end deffn - -@deftypefn {C Function} int scm_is_integer (SCM x) -This is equivalent to @code{scm_is_true (scm_integer_p (x))}. -@end deftypefn - -@defvr {C Type} scm_t_int8 -@defvrx {C Type} scm_t_uint8 -@defvrx {C Type} scm_t_int16 -@defvrx {C Type} scm_t_uint16 -@defvrx {C Type} scm_t_int32 -@defvrx {C Type} scm_t_uint32 -@defvrx {C Type} scm_t_int64 -@defvrx {C Type} scm_t_uint64 -@defvrx {C Type} scm_t_intmax -@defvrx {C Type} scm_t_uintmax -The C types are equivalent to the corresponding ISO C types but are -defined on all platforms, with the exception of @code{scm_t_int64} and -@code{scm_t_uint64}, which are only defined when a 64-bit type is -available. For example, @code{scm_t_int8} is equivalent to -@code{int8_t}. - -You can regard these definitions as a stop-gap measure until all -platforms provide these types. If you know that all the platforms -that you are interested in already provide these types, it is better -to use them directly instead of the types provided by Guile. -@end defvr - -@deftypefn {C Function} int scm_is_signed_integer (SCM x, scm_t_intmax min, scm_t_intmax max) -@deftypefnx {C Function} int scm_is_unsigned_integer (SCM x, scm_t_uintmax min, scm_t_uintmax max) -Return @code{1} when @var{x} represents an exact integer that is -between @var{min} and @var{max}, inclusive. - -These functions can be used to check whether a @code{SCM} value will -fit into a given range, such as the range of a given C integer type. -If you just want to convert a @code{SCM} value to a given C integer -type, use one of the conversion functions directly. -@end deftypefn - -@deftypefn {C Function} scm_t_intmax scm_to_signed_integer (SCM x, scm_t_intmax min, scm_t_intmax max) -@deftypefnx {C Function} scm_t_uintmax scm_to_unsigned_integer (SCM x, scm_t_uintmax min, scm_t_uintmax max) -When @var{x} represents an exact integer that is between @var{min} and -@var{max} inclusive, return that integer. Else signal an error, -either a `wrong-type' error when @var{x} is not an exact integer, or -an `out-of-range' error when it doesn't fit the given range. -@end deftypefn - -@deftypefn {C Function} SCM scm_from_signed_integer (scm_t_intmax x) -@deftypefnx {C Function} SCM scm_from_unsigned_integer (scm_t_uintmax x) -Return the @code{SCM} value that represents the integer @var{x}. This -function will always succeed and will always return an exact number. -@end deftypefn - -@deftypefn {C Function} char scm_to_char (SCM x) -@deftypefnx {C Function} {signed char} scm_to_schar (SCM x) -@deftypefnx {C Function} {unsigned char} scm_to_uchar (SCM x) -@deftypefnx {C Function} short scm_to_short (SCM x) -@deftypefnx {C Function} {unsigned short} scm_to_ushort (SCM x) -@deftypefnx {C Function} int scm_to_int (SCM x) -@deftypefnx {C Function} {unsigned int} scm_to_uint (SCM x) -@deftypefnx {C Function} long scm_to_long (SCM x) -@deftypefnx {C Function} {unsigned long} scm_to_ulong (SCM x) -@deftypefnx {C Function} {long long} scm_to_long_long (SCM x) -@deftypefnx {C Function} {unsigned long long} scm_to_ulong_long (SCM x) -@deftypefnx {C Function} size_t scm_to_size_t (SCM x) -@deftypefnx {C Function} ssize_t scm_to_ssize_t (SCM x) -@deftypefnx {C Function} scm_t_int8 scm_to_int8 (SCM x) -@deftypefnx {C Function} scm_t_uint8 scm_to_uint8 (SCM x) -@deftypefnx {C Function} scm_t_int16 scm_to_int16 (SCM x) -@deftypefnx {C Function} scm_t_uint16 scm_to_uint16 (SCM x) -@deftypefnx {C Function} scm_t_int32 scm_to_int32 (SCM x) -@deftypefnx {C Function} scm_t_uint32 scm_to_uint32 (SCM x) -@deftypefnx {C Function} scm_t_int64 scm_to_int64 (SCM x) -@deftypefnx {C Function} scm_t_uint64 scm_to_uint64 (SCM x) -@deftypefnx {C Function} scm_t_intmax scm_to_intmax (SCM x) -@deftypefnx {C Function} scm_t_uintmax scm_to_uintmax (SCM x) -When @var{x} represents an exact integer that fits into the indicated -C type, return that integer. Else signal an error, either a -`wrong-type' error when @var{x} is not an exact integer, or an -`out-of-range' error when it doesn't fit the given range. - -The functions @code{scm_to_long_long}, @code{scm_to_ulong_long}, -@code{scm_to_int64}, and @code{scm_to_uint64} are only available when -the corresponding types are. -@end deftypefn - -@deftypefn {C Function} SCM scm_from_char (char x) -@deftypefnx {C Function} SCM scm_from_schar (signed char x) -@deftypefnx {C Function} SCM scm_from_uchar (unsigned char x) -@deftypefnx {C Function} SCM scm_from_short (short x) -@deftypefnx {C Function} SCM scm_from_ushort (unsigned short x) -@deftypefnx {C Function} SCM scm_from_int (int x) -@deftypefnx {C Function} SCM scm_from_uint (unsigned int x) -@deftypefnx {C Function} SCM scm_from_long (long x) -@deftypefnx {C Function} SCM scm_from_ulong (unsigned long x) -@deftypefnx {C Function} SCM scm_from_long_long (long long x) -@deftypefnx {C Function} SCM scm_from_ulong_long (unsigned long long x) -@deftypefnx {C Function} SCM scm_from_size_t (size_t x) -@deftypefnx {C Function} SCM scm_from_ssize_t (ssize_t x) -@deftypefnx {C Function} SCM scm_from_int8 (scm_t_int8 x) -@deftypefnx {C Function} SCM scm_from_uint8 (scm_t_uint8 x) -@deftypefnx {C Function} SCM scm_from_int16 (scm_t_int16 x) -@deftypefnx {C Function} SCM scm_from_uint16 (scm_t_uint16 x) -@deftypefnx {C Function} SCM scm_from_int32 (scm_t_int32 x) -@deftypefnx {C Function} SCM scm_from_uint32 (scm_t_uint32 x) -@deftypefnx {C Function} SCM scm_from_int64 (scm_t_int64 x) -@deftypefnx {C Function} SCM scm_from_uint64 (scm_t_uint64 x) -@deftypefnx {C Function} SCM scm_from_intmax (scm_t_intmax x) -@deftypefnx {C Function} SCM scm_from_uintmax (scm_t_uintmax x) -Return the @code{SCM} value that represents the integer @var{x}. -These functions will always succeed and will always return an exact -number. -@end deftypefn - -@node Reals and Rationals -@subsubsection Real and Rational Numbers -@tpindex Real numbers -@tpindex Rational numbers - -@rnindex real? -@rnindex rational? - -Mathematically, the real numbers are the set of numbers that describe -all possible points along a continuous, infinite, one-dimensional line. -The rational numbers are the set of all numbers that can be written as -fractions @var{p}/@var{q}, where @var{p} and @var{q} are integers. -All rational numbers are also real, but there are real numbers that -are not rational, for example the square root of 2, and pi. - -Guile can represent both exact and inexact rational numbers, but it -can not represent irrational numbers. Exact rationals are represented -by storing the numerator and denominator as two exact integers. -Inexact rationals are stored as floating point numbers using the C -type @code{double}. - -Exact rationals are written as a fraction of integers. There must be -no whitespace around the slash: - -@lisp -1/2 --22/7 -@end lisp - -Even though the actual encoding of inexact rationals is in binary, it -may be helpful to think of it as a decimal number with a limited -number of significant figures and a decimal point somewhere, since -this corresponds to the standard notation for non-whole numbers. For -example: - -@lisp -0.34 --0.00000142857931198 --5648394822220000000000.0 -4.0 -@end lisp - -The limited precision of Guile's encoding means that any ``real'' number -in Guile can be written in a rational form, by multiplying and then dividing -by sufficient powers of 10 (or in fact, 2). For example, -@samp{-0.00000142857931198} is the same as @minus{}142857931198 divided by -100000000000000000. In Guile's current incarnation, therefore, the -@code{rational?} and @code{real?} predicates are equivalent. - - -Dividing by an exact zero leads to a error message, as one might -expect. However, dividing by an inexact zero does not produce an -error. Instead, the result of the division is either plus or minus -infinity, depending on the sign of the divided number. - -The infinities are written @samp{+inf.0} and @samp{-inf.0}, -respectivly. This syntax is also recognized by @code{read} as an -extension to the usual Scheme syntax. - -Dividing zero by zero yields something that is not a number at all: -@samp{+nan.0}. This is the special `not a number' value. - -On platforms that follow @acronym{IEEE} 754 for their floating point -arithmetic, the @samp{+inf.0}, @samp{-inf.0}, and @samp{+nan.0} values -are implemented using the corresponding @acronym{IEEE} 754 values. -They behave in arithmetic operations like @acronym{IEEE} 754 describes -it, i.e., @code{(= +nan.0 +nan.0)} @result{} @code{#f}. - -The infinities are inexact integers and are considered to be both even -and odd. While @samp{+nan.0} is not @code{=} to itself, it is -@code{eqv?} to itself. - -To test for the special values, use the functions @code{inf?} and -@code{nan?}. - -@deffn {Scheme Procedure} real? obj -@deffnx {C Function} scm_real_p (obj) -Return @code{#t} if @var{obj} is a real number, else @code{#f}. Note -that the sets of integer and rational values form subsets of the set -of real numbers, so the predicate will also be fulfilled if @var{obj} -is an integer number or a rational number. -@end deffn - -@deffn {Scheme Procedure} rational? x -@deffnx {C Function} scm_rational_p (x) -Return @code{#t} if @var{x} is a rational number, @code{#f} otherwise. -Note that the set of integer values forms a subset of the set of -rational numbers, i. e. the predicate will also be fulfilled if -@var{x} is an integer number. - -Since Guile can not represent irrational numbers, every number -satisfying @code{real?} also satisfies @code{rational?} in Guile. -@end deffn - -@deffn {Scheme Procedure} rationalize x eps -@deffnx {C Function} scm_rationalize (x, eps) -Returns the @emph{simplest} rational number differing -from @var{x} by no more than @var{eps}. - -As required by @acronym{R5RS}, @code{rationalize} only returns an -exact result when both its arguments are exact. Thus, you might need -to use @code{inexact->exact} on the arguments. - -@lisp -(rationalize (inexact->exact 1.2) 1/100) -@result{} 6/5 -@end lisp - -@end deffn - -@deffn {Scheme Procedure} inf? x -Return @code{#t} if @var{x} is either @samp{+inf.0} or @samp{-inf.0}, -@code{#f} otherwise. -@end deffn - -@deffn {Scheme Procedure} nan? x -Return @code{#t} if @var{x} is @samp{+nan.0}, @code{#f} otherwise. -@end deffn - -@node Complex Numbers -@subsubsection Complex Numbers -@tpindex Complex numbers - -@rnindex complex? - -Complex numbers are the set of numbers that describe all possible points -in a two-dimensional space. The two coordinates of a particular point -in this space are known as the @dfn{real} and @dfn{imaginary} parts of -the complex number that describes that point. - -In Guile, complex numbers are written in rectangular form as the sum of -their real and imaginary parts, using the symbol @code{i} to indicate -the imaginary part. - -@lisp -3+4i -@result{} -3.0+4.0i - -(* 3-8i 2.3+0.3i) -@result{} -9.3-17.5i -@end lisp - -Guile represents a complex number with a non-zero imaginary part as a -pair of inexact rationals, so the real and imaginary parts of a -complex number have the same properties of inexactness and limited -precision as single inexact rational numbers. Guile can not represent -exact complex numbers with non-zero imaginary parts. - -@deffn {Scheme Procedure} complex? x -@deffnx {C Function} scm_number_p (x) -Return @code{#t} if @var{x} is a complex number, @code{#f} -otherwise. Note that the sets of real, rational and integer -values form subsets of the set of complex numbers, i. e. the -predicate will also be fulfilled if @var{x} is a real, -rational or integer number. -@end deffn - - -@node Exactness -@subsubsection Exact and Inexact Numbers -@tpindex Exact numbers -@tpindex Inexact numbers - -@rnindex exact? -@rnindex inexact? -@rnindex exact->inexact -@rnindex inexact->exact - -R5RS requires that a calculation involving inexact numbers always -produces an inexact result. To meet this requirement, Guile -distinguishes between an exact integer value such as @samp{5} and the -corresponding inexact real value which, to the limited precision -available, has no fractional part, and is printed as @samp{5.0}. Guile -will only convert the latter value to the former when forced to do so by -an invocation of the @code{inexact->exact} procedure. - -@deffn {Scheme Procedure} exact? z -@deffnx {C Function} scm_exact_p (z) -Return @code{#t} if the number @var{z} is exact, @code{#f} -otherwise. - -@lisp -(exact? 2) -@result{} #t - -(exact? 0.5) -@result{} #f - -(exact? (/ 2)) -@result{} #t -@end lisp - -@end deffn - -@deffn {Scheme Procedure} inexact? z -@deffnx {C Function} scm_inexact_p (z) -Return @code{#t} if the number @var{z} is inexact, @code{#f} -else. -@end deffn - -@deffn {Scheme Procedure} inexact->exact z -@deffnx {C Function} scm_inexact_to_exact (z) -Return an exact number that is numerically closest to @var{z}, when -there is one. For inexact rationals, Guile returns the exact rational -that is numerically equal to the inexact rational. Inexact complex -numbers with a non-zero imaginary part can not be made exact. - -@lisp -(inexact->exact 0.5) -@result{} 1/2 -@end lisp - -The following happens because 12/10 is not exactly representable as a -@code{double} (on most platforms). However, when reading a decimal -number that has been marked exact with the ``#e'' prefix, Guile is -able to represent it correctly. - -@lisp -(inexact->exact 1.2) -@result{} 5404319552844595/4503599627370496 - -#e1.2 -@result{} 6/5 -@end lisp - -@end deffn - -@c begin (texi-doc-string "guile" "exact->inexact") -@deffn {Scheme Procedure} exact->inexact z -@deffnx {C Function} scm_exact_to_inexact (z) -Convert the number @var{z} to its inexact representation. -@end deffn - - -@node Number Syntax -@subsubsection Read Syntax for Numerical Data - -The read syntax for integers is a string of digits, optionally -preceded by a minus or plus character, a code indicating the -base in which the integer is encoded, and a code indicating whether -the number is exact or inexact. The supported base codes are: - -@table @code -@item #b -@itemx #B -the integer is written in binary (base 2) - -@item #o -@itemx #O -the integer is written in octal (base 8) - -@item #d -@itemx #D -the integer is written in decimal (base 10) - -@item #x -@itemx #X -the integer is written in hexadecimal (base 16) -@end table - -If the base code is omitted, the integer is assumed to be decimal. The -following examples show how these base codes are used. - -@lisp --13 -@result{} -13 - -#d-13 -@result{} -13 - -#x-13 -@result{} -19 - -#b+1101 -@result{} 13 - -#o377 -@result{} 255 -@end lisp - -The codes for indicating exactness (which can, incidentally, be applied -to all numerical values) are: - -@table @code -@item #e -@itemx #E -the number is exact - -@item #i -@itemx #I -the number is inexact. -@end table - -If the exactness indicator is omitted, the number is exact unless it -contains a radix point. Since Guile can not represent exact complex -numbers, an error is signalled when asking for them. - -@lisp -(exact? 1.2) -@result{} #f - -(exact? #e1.2) -@result{} #t - -(exact? #e+1i) -ERROR: Wrong type argument -@end lisp - -Guile also understands the syntax @samp{+inf.0} and @samp{-inf.0} for -plus and minus infinity, respectively. The value must be written -exactly as shown, that is, they always must have a sign and exactly -one zero digit after the decimal point. It also understands -@samp{+nan.0} and @samp{-nan.0} for the special `not-a-number' value. -The sign is ignored for `not-a-number' and the value is always printed -as @samp{+nan.0}. - -@node Integer Operations -@subsubsection Operations on Integer Values -@rnindex odd? -@rnindex even? -@rnindex quotient -@rnindex remainder -@rnindex modulo -@rnindex gcd -@rnindex lcm - -@deffn {Scheme Procedure} odd? n -@deffnx {C Function} scm_odd_p (n) -Return @code{#t} if @var{n} is an odd number, @code{#f} -otherwise. -@end deffn - -@deffn {Scheme Procedure} even? n -@deffnx {C Function} scm_even_p (n) -Return @code{#t} if @var{n} is an even number, @code{#f} -otherwise. -@end deffn - -@c begin (texi-doc-string "guile" "quotient") -@c begin (texi-doc-string "guile" "remainder") -@deffn {Scheme Procedure} quotient n d -@deffnx {Scheme Procedure} remainder n d -@deffnx {C Function} scm_quotient (n, d) -@deffnx {C Function} scm_remainder (n, d) -Return the quotient or remainder from @var{n} divided by @var{d}. The -quotient is rounded towards zero, and the remainder will have the same -sign as @var{n}. In all cases quotient and remainder satisfy -@math{@var{n} = @var{q}*@var{d} + @var{r}}. - -@lisp -(remainder 13 4) @result{} 1 -(remainder -13 4) @result{} -1 -@end lisp -@end deffn - -@c begin (texi-doc-string "guile" "modulo") -@deffn {Scheme Procedure} modulo n d -@deffnx {C Function} scm_modulo (n, d) -Return the remainder from @var{n} divided by @var{d}, with the same -sign as @var{d}. - -@lisp -(modulo 13 4) @result{} 1 -(modulo -13 4) @result{} 3 -(modulo 13 -4) @result{} -3 -(modulo -13 -4) @result{} -1 -@end lisp -@end deffn - -@c begin (texi-doc-string "guile" "gcd") -@deffn {Scheme Procedure} gcd -@deffnx {C Function} scm_gcd (x, y) -Return the greatest common divisor of all arguments. -If called without arguments, 0 is returned. - -The C function @code{scm_gcd} always takes two arguments, while the -Scheme function can take an arbitrary number. -@end deffn - -@c begin (texi-doc-string "guile" "lcm") -@deffn {Scheme Procedure} lcm -@deffnx {C Function} scm_lcm (x, y) -Return the least common multiple of the arguments. -If called without arguments, 1 is returned. - -The C function @code{scm_lcm} always takes two arguments, while the -Scheme function can take an arbitrary number. -@end deffn - - -@node Comparison -@subsubsection Comparison Predicates -@rnindex zero? -@rnindex positive? -@rnindex negative? - -The C comparison functions below always takes two arguments, while the -Scheme functions can take an arbitrary number. Also keep in mind that -the C functions return one of the Scheme boolean values -@code{SCM_BOOL_T} or @code{SCM_BOOL_F} which are both true as far as C -is concerned. Thus, always write @code{scm_is_true (scm_num_eq_p (x, -y))} when testing the two Scheme numbers @code{x} and @code{y} for -equality, for example. - -@c begin (texi-doc-string "guile" "=") -@deffn {Scheme Procedure} = -@deffnx {C Function} scm_num_eq_p (x, y) -Return @code{#t} if all parameters are numerically equal. -@end deffn - -@c begin (texi-doc-string "guile" "<") -@deffn {Scheme Procedure} < -@deffnx {C Function} scm_less_p (x, y) -Return @code{#t} if the list of parameters is monotonically -increasing. -@end deffn - -@c begin (texi-doc-string "guile" ">") -@deffn {Scheme Procedure} > -@deffnx {C Function} scm_gr_p (x, y) -Return @code{#t} if the list of parameters is monotonically -decreasing. -@end deffn - -@c begin (texi-doc-string "guile" "<=") -@deffn {Scheme Procedure} <= -@deffnx {C Function} scm_leq_p (x, y) -Return @code{#t} if the list of parameters is monotonically -non-decreasing. -@end deffn - -@c begin (texi-doc-string "guile" ">=") -@deffn {Scheme Procedure} >= -@deffnx {C Function} scm_geq_p (x, y) -Return @code{#t} if the list of parameters is monotonically -non-increasing. -@end deffn - -@c begin (texi-doc-string "guile" "zero?") -@deffn {Scheme Procedure} zero? z -@deffnx {C Function} scm_zero_p (z) -Return @code{#t} if @var{z} is an exact or inexact number equal to -zero. -@end deffn - -@c begin (texi-doc-string "guile" "positive?") -@deffn {Scheme Procedure} positive? x -@deffnx {C Function} scm_positive_p (x) -Return @code{#t} if @var{x} is an exact or inexact number greater than -zero. -@end deffn - -@c begin (texi-doc-string "guile" "negative?") -@deffn {Scheme Procedure} negative? x -@deffnx {C Function} scm_negative_p (x) -Return @code{#t} if @var{x} is an exact or inexact number less than -zero. -@end deffn - - -@node Conversion -@subsubsection Converting Numbers To and From Strings -@rnindex number->string -@rnindex string->number - -@deffn {Scheme Procedure} number->string n [radix] -@deffnx {C Function} scm_number_to_string (n, radix) -Return a string holding the external representation of the -number @var{n} in the given @var{radix}. If @var{n} is -inexact, a radix of 10 will be used. -@end deffn - -@deffn {Scheme Procedure} string->number string [radix] -@deffnx {C Function} scm_string_to_number (string, radix) -Return a number of the maximally precise representation -expressed by the given @var{string}. @var{radix} must be an -exact integer, either 2, 8, 10, or 16. If supplied, @var{radix} -is a default radix that may be overridden by an explicit radix -prefix in @var{string} (e.g. "#o177"). If @var{radix} is not -supplied, then the default radix is 10. If string is not a -syntactically valid notation for a number, then -@code{string->number} returns @code{#f}. -@end deffn - - -@node Complex -@subsubsection Complex Number Operations -@rnindex make-rectangular -@rnindex make-polar -@rnindex real-part -@rnindex imag-part -@rnindex magnitude -@rnindex angle - -@deffn {Scheme Procedure} make-rectangular real imaginary -@deffnx {C Function} scm_make_rectangular (real, imaginary) -Return a complex number constructed of the given @var{real} and -@var{imaginary} parts. -@end deffn - -@deffn {Scheme Procedure} make-polar x y -@deffnx {C Function} scm_make_polar (x, y) -Return the complex number @var{x} * e^(i * @var{y}). -@end deffn - -@c begin (texi-doc-string "guile" "real-part") -@deffn {Scheme Procedure} real-part z -@deffnx {C Function} scm_real_part (z) -Return the real part of the number @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "imag-part") -@deffn {Scheme Procedure} imag-part z -@deffnx {C Function} scm_imag_part (z) -Return the imaginary part of the number @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "magnitude") -@deffn {Scheme Procedure} magnitude z -@deffnx {C Function} scm_magnitude (z) -Return the magnitude of the number @var{z}. This is the same as -@code{abs} for real arguments, but also allows complex numbers. -@end deffn - -@c begin (texi-doc-string "guile" "angle") -@deffn {Scheme Procedure} angle z -@deffnx {C Function} scm_angle (z) -Return the angle of the complex number @var{z}. -@end deffn - - -@node Arithmetic -@subsubsection Arithmetic Functions -@rnindex max -@rnindex min -@rnindex + -@rnindex * -@rnindex - -@rnindex / -@rnindex abs -@rnindex floor -@rnindex ceiling -@rnindex truncate -@rnindex round - -The C arithmetic functions below always takes two arguments, while the -Scheme functions can take an arbitrary number. When you need to -invoke them with just one argument, for example to compute the -equivalent od @code{(- x)}, pass @code{SCM_UNDEFINED} as the second -one: @code{scm_difference (x, SCM_UNDEFINED)}. - -@c begin (texi-doc-string "guile" "+") -@deffn {Scheme Procedure} + z1 @dots{} -@deffnx {C Function} scm_sum (z1, z2) -Return the sum of all parameter values. Return 0 if called without any -parameters. -@end deffn - -@c begin (texi-doc-string "guile" "-") -@deffn {Scheme Procedure} - z1 z2 @dots{} -@deffnx {C Function} scm_difference (z1, z2) -If called with one argument @var{z1}, -@var{z1} is returned. Otherwise -the sum of all but the first argument are subtracted from the first -argument. -@end deffn - -@c begin (texi-doc-string "guile" "*") -@deffn {Scheme Procedure} * z1 @dots{} -@deffnx {C Function} scm_product (z1, z2) -Return the product of all arguments. If called without arguments, 1 is -returned. -@end deffn - -@c begin (texi-doc-string "guile" "/") -@deffn {Scheme Procedure} / z1 z2 @dots{} -@deffnx {C Function} scm_divide (z1, z2) -Divide the first argument by the product of the remaining arguments. If -called with one argument @var{z1}, 1/@var{z1} is returned. -@end deffn - -@c begin (texi-doc-string "guile" "abs") -@deffn {Scheme Procedure} abs x -@deffnx {C Function} scm_abs (x) -Return the absolute value of @var{x}. - -@var{x} must be a number with zero imaginary part. To calculate the -magnitude of a complex number, use @code{magnitude} instead. -@end deffn - -@c begin (texi-doc-string "guile" "max") -@deffn {Scheme Procedure} max x1 x2 @dots{} -@deffnx {C Function} scm_max (x1, x2) -Return the maximum of all parameter values. -@end deffn - -@c begin (texi-doc-string "guile" "min") -@deffn {Scheme Procedure} min x1 x2 @dots{} -@deffnx {C Function} scm_min (x1, x2) -Return the minimum of all parameter values. -@end deffn - -@c begin (texi-doc-string "guile" "truncate") -@deffn {Scheme Procedure} truncate -@deffnx {C Function} scm_truncate_number (x) -Round the inexact number @var{x} towards zero. -@end deffn - -@c begin (texi-doc-string "guile" "round") -@deffn {Scheme Procedure} round x -@deffnx {C Function} scm_round_number (x) -Round the inexact number @var{x} to the nearest integer. When exactly -halfway between two integers, round to the even one. -@end deffn - -@c begin (texi-doc-string "guile" "floor") -@deffn {Scheme Procedure} floor x -@deffnx {C Function} scm_floor (x) -Round the number @var{x} towards minus infinity. -@end deffn - -@c begin (texi-doc-string "guile" "ceiling") -@deffn {Scheme Procedure} ceiling x -@deffnx {C Function} scm_ceiling (x) -Round the number @var{x} towards infinity. -@end deffn - - -@node Scientific -@subsubsection Scientific Functions - -The following procedures accept any kind of number as arguments, -including complex numbers. - -@rnindex sqrt -@c begin (texi-doc-string "guile" "sqrt") -@deffn {Scheme Procedure} sqrt z -Return the square root of @var{z}. -@end deffn - -@rnindex expt -@c begin (texi-doc-string "guile" "expt") -@deffn {Scheme Procedure} expt z1 z2 -Return @var{z1} raised to the power of @var{z2}. -@end deffn - -@rnindex sin -@c begin (texi-doc-string "guile" "sin") -@deffn {Scheme Procedure} sin z -Return the sine of @var{z}. -@end deffn - -@rnindex cos -@c begin (texi-doc-string "guile" "cos") -@deffn {Scheme Procedure} cos z -Return the cosine of @var{z}. -@end deffn - -@rnindex tan -@c begin (texi-doc-string "guile" "tan") -@deffn {Scheme Procedure} tan z -Return the tangent of @var{z}. -@end deffn - -@rnindex asin -@c begin (texi-doc-string "guile" "asin") -@deffn {Scheme Procedure} asin z -Return the arcsine of @var{z}. -@end deffn - -@rnindex acos -@c begin (texi-doc-string "guile" "acos") -@deffn {Scheme Procedure} acos z -Return the arccosine of @var{z}. -@end deffn - -@rnindex atan -@c begin (texi-doc-string "guile" "atan") -@deffn {Scheme Procedure} atan z -@deffnx {Scheme Procedure} atan y x -Return the arctangent of @var{z}, or of @math{@var{y}/@var{x}}. -@end deffn - -@rnindex exp -@c begin (texi-doc-string "guile" "exp") -@deffn {Scheme Procedure} exp z -Return e to the power of @var{z}, where e is the base of natural -logarithms (2.71828@dots{}). -@end deffn - -@rnindex log -@c begin (texi-doc-string "guile" "log") -@deffn {Scheme Procedure} log z -Return the natural logarithm of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "log10") -@deffn {Scheme Procedure} log10 z -Return the base 10 logarithm of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "sinh") -@deffn {Scheme Procedure} sinh z -Return the hyperbolic sine of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "cosh") -@deffn {Scheme Procedure} cosh z -Return the hyperbolic cosine of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "tanh") -@deffn {Scheme Procedure} tanh z -Return the hyperbolic tangent of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "asinh") -@deffn {Scheme Procedure} asinh z -Return the hyperbolic arcsine of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "acosh") -@deffn {Scheme Procedure} acosh z -Return the hyperbolic arccosine of @var{z}. -@end deffn - -@c begin (texi-doc-string "guile" "atanh") -@deffn {Scheme Procedure} atanh z -Return the hyperbolic arctangent of @var{z}. -@end deffn - - -@node Primitive Numerics -@subsubsection Primitive Numeric Functions - -Many of Guile's numeric procedures which accept any kind of numbers as -arguments, including complex numbers, are implemented as Scheme -procedures that use the following real number-based primitives. These -primitives signal an error if they are called with complex arguments. - -@c begin (texi-doc-string "guile" "$abs") -@deffn {Scheme Procedure} $abs x -Return the absolute value of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$sqrt") -@deffn {Scheme Procedure} $sqrt x -Return the square root of @var{x}. -@end deffn - -@deffn {Scheme Procedure} $expt x y -@deffnx {C Function} scm_sys_expt (x, y) -Return @var{x} raised to the power of @var{y}. This -procedure does not accept complex arguments. -@end deffn - -@c begin (texi-doc-string "guile" "$sin") -@deffn {Scheme Procedure} $sin x -Return the sine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$cos") -@deffn {Scheme Procedure} $cos x -Return the cosine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$tan") -@deffn {Scheme Procedure} $tan x -Return the tangent of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$asin") -@deffn {Scheme Procedure} $asin x -Return the arcsine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$acos") -@deffn {Scheme Procedure} $acos x -Return the arccosine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$atan") -@deffn {Scheme Procedure} $atan x -Return the arctangent of @var{x} in the range @minus{}@math{PI/2} to -@math{PI/2}. -@end deffn - -@deffn {Scheme Procedure} $atan2 x y -@deffnx {C Function} scm_sys_atan2 (x, y) -Return the arc tangent of the two arguments @var{x} and -@var{y}. This is similar to calculating the arc tangent of -@var{x} / @var{y}, except that the signs of both arguments -are used to determine the quadrant of the result. This -procedure does not accept complex arguments. -@end deffn - -@c begin (texi-doc-string "guile" "$exp") -@deffn {Scheme Procedure} $exp x -Return e to the power of @var{x}, where e is the base of natural -logarithms (2.71828@dots{}). -@end deffn - -@c begin (texi-doc-string "guile" "$log") -@deffn {Scheme Procedure} $log x -Return the natural logarithm of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$sinh") -@deffn {Scheme Procedure} $sinh x -Return the hyperbolic sine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$cosh") -@deffn {Scheme Procedure} $cosh x -Return the hyperbolic cosine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$tanh") -@deffn {Scheme Procedure} $tanh x -Return the hyperbolic tangent of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$asinh") -@deffn {Scheme Procedure} $asinh x -Return the hyperbolic arcsine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$acosh") -@deffn {Scheme Procedure} $acosh x -Return the hyperbolic arccosine of @var{x}. -@end deffn - -@c begin (texi-doc-string "guile" "$atanh") -@deffn {Scheme Procedure} $atanh x -Return the hyperbolic arctangent of @var{x}. -@end deffn - -C functions for the above are provided by the standard mathematics -library. Naturally these expect and return @code{double} arguments -(@pxref{Mathematics,,, libc, GNU C Library Reference Manual}). - -@multitable {xx} {Scheme Procedure} {C Function} -@item @tab Scheme Procedure @tab C Function - -@item @tab @code{$abs} @tab @code{fabs} -@item @tab @code{$sqrt} @tab @code{sqrt} -@item @tab @code{$sin} @tab @code{sin} -@item @tab @code{$cos} @tab @code{cos} -@item @tab @code{$tan} @tab @code{tan} -@item @tab @code{$asin} @tab @code{asin} -@item @tab @code{$acos} @tab @code{acos} -@item @tab @code{$atan} @tab @code{atan} -@item @tab @code{$atan2} @tab @code{atan2} -@item @tab @code{$exp} @tab @code{exp} -@item @tab @code{$expt} @tab @code{pow} -@item @tab @code{$log} @tab @code{log} -@item @tab @code{$sinh} @tab @code{sinh} -@item @tab @code{$cosh} @tab @code{cosh} -@item @tab @code{$tanh} @tab @code{tanh} -@item @tab @code{$asinh} @tab @code{asinh} -@item @tab @code{$acosh} @tab @code{acosh} -@item @tab @code{$atanh} @tab @code{atanh} -@end multitable - -@code{asinh}, @code{acosh} and @code{atanh} are C99 standard but might -not be available on older systems. Guile provides the following -equivalents (on all systems). - -@deftypefn {C Function} double scm_asinh (double x) -@deftypefnx {C Function} double scm_acosh (double x) -@deftypefnx {C Function} double scm_atanh (double x) -Return the hyperbolic arcsine, arccosine or arctangent of @var{x} -respectively. -@end deftypefn - - -@node Bitwise Operations -@subsubsection Bitwise Operations - -For the following bitwise functions, negative numbers are treated as -infinite precision twos-complements. For instance @math{-6} is bits -@math{@dots{}111010}, with infinitely many ones on the left. It can -be seen that adding 6 (binary 110) to such a bit pattern gives all -zeros. - -@deffn {Scheme Procedure} logand n1 n2 @dots{} -@deffnx {C Function} scm_logand (n1, n2) -Return the bitwise @sc{and} of the integer arguments. - -@lisp -(logand) @result{} -1 -(logand 7) @result{} 7 -(logand #b111 #b011 #b001) @result{} 1 -@end lisp -@end deffn - -@deffn {Scheme Procedure} logior n1 n2 @dots{} -@deffnx {C Function} scm_logior (n1, n2) -Return the bitwise @sc{or} of the integer arguments. - -@lisp -(logior) @result{} 0 -(logior 7) @result{} 7 -(logior #b000 #b001 #b011) @result{} 3 -@end lisp -@end deffn - -@deffn {Scheme Procedure} logxor n1 n2 @dots{} -@deffnx {C Function} scm_loxor (n1, n2) -Return the bitwise @sc{xor} of the integer arguments. A bit is -set in the result if it is set in an odd number of arguments. - -@lisp -(logxor) @result{} 0 -(logxor 7) @result{} 7 -(logxor #b000 #b001 #b011) @result{} 2 -(logxor #b000 #b001 #b011 #b011) @result{} 1 -@end lisp -@end deffn - -@deffn {Scheme Procedure} lognot n -@deffnx {C Function} scm_lognot (n) -Return the integer which is the ones-complement of the integer -argument, ie.@: each 0 bit is changed to 1 and each 1 bit to 0. - -@lisp -(number->string (lognot #b10000000) 2) - @result{} "-10000001" -(number->string (lognot #b0) 2) - @result{} "-1" -@end lisp -@end deffn - -@deffn {Scheme Procedure} logtest j k -@deffnx {C Function} scm_logtest (j, k) -@lisp -(logtest j k) @equiv{} (not (zero? (logand j k))) - -(logtest #b0100 #b1011) @result{} #f -(logtest #b0100 #b0111) @result{} #t -@end lisp -@end deffn - -@deffn {Scheme Procedure} logbit? index j -@deffnx {C Function} scm_logbit_p (index, j) -@lisp -(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j) - -(logbit? 0 #b1101) @result{} #t -(logbit? 1 #b1101) @result{} #f -(logbit? 2 #b1101) @result{} #t -(logbit? 3 #b1101) @result{} #t -(logbit? 4 #b1101) @result{} #f -@end lisp -@end deffn - -@deffn {Scheme Procedure} ash n cnt -@deffnx {C Function} scm_ash (n, cnt) -Return @var{n} shifted left by @var{cnt} bits, or shifted right if -@var{cnt} is negative. This is an ``arithmetic'' shift. - -This is effectively a multiplication by @m{2^{cnt}, 2^@var{cnt}}, and -when @var{cnt} is negative it's a division, rounded towards negative -infinity. (Note that this is not the same rounding as @code{quotient} -does.) - -With @var{n} viewed as an infinite precision twos complement, -@code{ash} means a left shift introducing zero bits, or a right shift -dropping bits. - -@lisp -(number->string (ash #b1 3) 2) @result{} "1000" -(number->string (ash #b1010 -1) 2) @result{} "101" - -;; -23 is bits ...11101001, -6 is bits ...111010 -(ash -23 -2) @result{} -6 -@end lisp -@end deffn - -@deffn {Scheme Procedure} logcount n -@deffnx {C Function} scm_logcount (n) -Return the number of bits in integer @var{n}. If integer is -positive, the 1-bits in its binary representation are counted. -If negative, the 0-bits in its two's-complement binary -representation are counted. If 0, 0 is returned. - -@lisp -(logcount #b10101010) - @result{} 4 -(logcount 0) - @result{} 0 -(logcount -2) - @result{} 1 -@end lisp -@end deffn - -@deffn {Scheme Procedure} integer-length n -@deffnx {C Function} scm_integer_length (n) -Return the number of bits necessary to represent @var{n}. - -For positive @var{n} this is how many bits to the most significant one -bit. For negative @var{n} it's how many bits to the most significant -zero bit in twos complement form. - -@lisp -(integer-length #b10101010) @result{} 8 -(integer-length #b1111) @result{} 4 -(integer-length 0) @result{} 0 -(integer-length -1) @result{} 0 -(integer-length -256) @result{} 8 -(integer-length -257) @result{} 9 -@end lisp -@end deffn - -@deffn {Scheme Procedure} integer-expt n k -@deffnx {C Function} scm_integer_expt (n, k) -Return @var{n} raised to the non-negative integer exponent -@var{k}. - -@lisp -(integer-expt 2 5) - @result{} 32 -(integer-expt -3 3) - @result{} -27 -@end lisp -@end deffn - -@deffn {Scheme Procedure} bit-extract n start end -@deffnx {C Function} scm_bit_extract (n, start, end) -Return the integer composed of the @var{start} (inclusive) -through @var{end} (exclusive) bits of @var{n}. The -@var{start}th bit becomes the 0-th bit in the result. - -@lisp -(number->string (bit-extract #b1101101010 0 4) 2) - @result{} "1010" -(number->string (bit-extract #b1101101010 4 9) 2) - @result{} "10110" -@end lisp -@end deffn - - -@node Random -@subsubsection Random Number Generation - -Pseudo-random numbers are generated from a random state object, which -can be created with @code{seed->random-state}. The @var{state} -parameter to the various functions below is optional, it defaults to -the state object in the @code{*random-state*} variable. - -@deffn {Scheme Procedure} copy-random-state [state] -@deffnx {C Function} scm_copy_random_state (state) -Return a copy of the random state @var{state}. -@end deffn - -@deffn {Scheme Procedure} random n [state] -@deffnx {C Function} scm_random (n, state) -Return a number in [0, @var{n}). - -Accepts a positive integer or real n and returns a -number of the same type between zero (inclusive) and -@var{n} (exclusive). The values returned have a uniform -distribution. -@end deffn - -@deffn {Scheme Procedure} random:exp [state] -@deffnx {C Function} scm_random_exp (state) -Return an inexact real in an exponential distribution with mean -1. For an exponential distribution with mean @var{u} use @code{(* -@var{u} (random:exp))}. -@end deffn - -@deffn {Scheme Procedure} random:hollow-sphere! vect [state] -@deffnx {C Function} scm_random_hollow_sphere_x (vect, state) -Fills @var{vect} with inexact real random numbers the sum of whose -squares is equal to 1.0. Thinking of @var{vect} as coordinates in -space of dimension @var{n} @math{=} @code{(vector-length @var{vect})}, -the coordinates are uniformly distributed over the surface of the unit -n-sphere. -@end deffn - -@deffn {Scheme Procedure} random:normal [state] -@deffnx {C Function} scm_random_normal (state) -Return an inexact real in a normal distribution. The distribution -used has mean 0 and standard deviation 1. For a normal distribution -with mean @var{m} and standard deviation @var{d} use @code{(+ @var{m} -(* @var{d} (random:normal)))}. -@end deffn - -@deffn {Scheme Procedure} random:normal-vector! vect [state] -@deffnx {C Function} scm_random_normal_vector_x (vect, state) -Fills @var{vect} with inexact real random numbers that are -independent and standard normally distributed -(i.e., with mean 0 and variance 1). -@end deffn - -@deffn {Scheme Procedure} random:solid-sphere! vect [state] -@deffnx {C Function} scm_random_solid_sphere_x (vect, state) -Fills @var{vect} with inexact real random numbers the sum of whose -squares is less than 1.0. Thinking of @var{vect} as coordinates in -space of dimension @var{n} @math{=} @code{(vector-length @var{vect})}, -the coordinates are uniformly distributed within the unit -@var{n}-sphere. The sum of the squares of the numbers is returned. -@c FIXME: What does this mean, particularly the n-sphere part? -@end deffn - -@deffn {Scheme Procedure} random:uniform [state] -@deffnx {C Function} scm_random_uniform (state) -Return a uniformly distributed inexact real random number in -[0,1). -@end deffn - -@deffn {Scheme Procedure} seed->random-state seed -@deffnx {C Function} scm_seed_to_random_state (seed) -Return a new random state using @var{seed}. -@end deffn - -@defvar *random-state* -The global random state used by the above functions when the -@var{state} parameter is not given. -@end defvar - - -@node Characters -@subsection Characters -@tpindex Characters - -@noindent -[@strong{FIXME}: how do you specify regular (non-control) characters?] - -Most of the ``control characters'' (those below codepoint 32) in the -@acronym{ASCII} character set, as well as the space, may be referred -to by name: for example, @code{#\tab}, @code{#\esc}, @code{#\stx}, and -so on. The following table describes the @acronym{ASCII} names for -each character. - -@multitable @columnfractions .25 .25 .25 .25 -@item 0 = @code{#\nul} - @tab 1 = @code{#\soh} - @tab 2 = @code{#\stx} - @tab 3 = @code{#\etx} -@item 4 = @code{#\eot} - @tab 5 = @code{#\enq} - @tab 6 = @code{#\ack} - @tab 7 = @code{#\bel} -@item 8 = @code{#\bs} - @tab 9 = @code{#\ht} - @tab 10 = @code{#\nl} - @tab 11 = @code{#\vt} -@item 12 = @code{#\np} - @tab 13 = @code{#\cr} - @tab 14 = @code{#\so} - @tab 15 = @code{#\si} -@item 16 = @code{#\dle} - @tab 17 = @code{#\dc1} - @tab 18 = @code{#\dc2} - @tab 19 = @code{#\dc3} -@item 20 = @code{#\dc4} - @tab 21 = @code{#\nak} - @tab 22 = @code{#\syn} - @tab 23 = @code{#\etb} -@item 24 = @code{#\can} - @tab 25 = @code{#\em} - @tab 26 = @code{#\sub} - @tab 27 = @code{#\esc} -@item 28 = @code{#\fs} - @tab 29 = @code{#\gs} - @tab 30 = @code{#\rs} - @tab 31 = @code{#\us} -@item 32 = @code{#\sp} -@end multitable - -The ``delete'' character (octal 177) may be referred to with the name -@code{#\del}. - -Several characters have more than one name: - -@multitable {@code{#\backspace}} {Original} -@item Alias @tab Original -@item @code{#\space} @tab @code{#\sp} -@item @code{#\newline} @tab @code{#\nl} -@item @code{#\tab} @tab @code{#\ht} -@item @code{#\backspace} @tab @code{#\bs} -@item @code{#\return} @tab @code{#\cr} -@item @code{#\page} @tab @code{#\np} -@item @code{#\null} @tab @code{#\nul} -@end multitable - -@rnindex char? -@deffn {Scheme Procedure} char? x -@deffnx {C Function} scm_char_p (x) -Return @code{#t} iff @var{x} is a character, else @code{#f}. -@end deffn - -@rnindex char=? -@deffn {Scheme Procedure} char=? x y -Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}. -@end deffn - -@rnindex char? -@deffn {Scheme Procedure} char>? x y -Return @code{#t} iff @var{x} is greater than @var{y} in the @acronym{ASCII} -sequence, else @code{#f}. -@end deffn - -@rnindex char>=? -@deffn {Scheme Procedure} char>=? x y -Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the -@acronym{ASCII} sequence, else @code{#f}. -@end deffn - -@rnindex char-ci=? -@deffn {Scheme Procedure} char-ci=? x y -Return @code{#t} iff @var{x} is the same character as @var{y} ignoring -case, else @code{#f}. -@end deffn - -@rnindex char-ci? -@deffn {Scheme Procedure} char-ci>? x y -Return @code{#t} iff @var{x} is greater than @var{y} in the @acronym{ASCII} -sequence ignoring case, else @code{#f}. -@end deffn - -@rnindex char-ci>=? -@deffn {Scheme Procedure} char-ci>=? x y -Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the -@acronym{ASCII} sequence ignoring case, else @code{#f}. -@end deffn - -@rnindex char-alphabetic? -@deffn {Scheme Procedure} char-alphabetic? chr -@deffnx {C Function} scm_char_alphabetic_p (chr) -Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}. -Alphabetic means the same thing as the @code{isalpha} C library function. -@end deffn - -@rnindex char-numeric? -@deffn {Scheme Procedure} char-numeric? chr -@deffnx {C Function} scm_char_numeric_p (chr) -Return @code{#t} iff @var{chr} is numeric, else @code{#f}. -Numeric means the same thing as the @code{isdigit} C library function. -@end deffn - -@rnindex char-whitespace? -@deffn {Scheme Procedure} char-whitespace? chr -@deffnx {C Function} scm_char_whitespace_p (chr) -Return @code{#t} iff @var{chr} is whitespace, else @code{#f}. -Whitespace means the same thing as the @code{isspace} C library function. -@end deffn - -@rnindex char-upper-case? -@deffn {Scheme Procedure} char-upper-case? chr -@deffnx {C Function} scm_char_upper_case_p (chr) -Return @code{#t} iff @var{chr} is uppercase, else @code{#f}. -Uppercase means the same thing as the @code{isupper} C library function. -@end deffn - -@rnindex char-lower-case? -@deffn {Scheme Procedure} char-lower-case? chr -@deffnx {C Function} scm_char_lower_case_p (chr) -Return @code{#t} iff @var{chr} is lowercase, else @code{#f}. -Lowercase means the same thing as the @code{islower} C library function. -@end deffn - -@deffn {Scheme Procedure} char-is-both? chr -@deffnx {C Function} scm_char_is_both_p (chr) -Return @code{#t} iff @var{chr} is either uppercase or lowercase, else -@code{#f}. Uppercase and lowercase are as defined by the -@code{isupper} and @code{islower} C library functions. -@end deffn - -@rnindex char->integer -@deffn {Scheme Procedure} char->integer chr -@deffnx {C Function} scm_char_to_integer (chr) -Return the number corresponding to ordinal position of @var{chr} in the -@acronym{ASCII} sequence. -@end deffn - -@rnindex integer->char -@deffn {Scheme Procedure} integer->char n -@deffnx {C Function} scm_integer_to_char (n) -Return the character at position @var{n} in the @acronym{ASCII} sequence. -@end deffn - -@rnindex char-upcase -@deffn {Scheme Procedure} char-upcase chr -@deffnx {C Function} scm_char_upcase (chr) -Return the uppercase character version of @var{chr}. -@end deffn - -@rnindex char-downcase -@deffn {Scheme Procedure} char-downcase chr -@deffnx {C Function} scm_char_downcase (chr) -Return the lowercase character version of @var{chr}. -@end deffn - -@xref{Classification of Characters,,,libc,GNU C Library Reference -Manual}, for information about the @code{is*} Standard C functions -mentioned above. - - -@node Strings -@subsection Strings -@tpindex Strings - -Strings are fixed-length sequences of characters. They can be created -by calling constructor procedures, but they can also literally get -entered at the @acronym{REPL} or in Scheme source files. - -@c Guile provides a rich set of string processing procedures, because text -@c handling is very important when Guile is used as a scripting language. - -Strings always carry the information about how many characters they are -composed of with them, so there is no special end-of-string character, -like in C. That means that Scheme strings can contain any character, -even the @samp{NUL} character @samp{\0}. But note: Since most operating -system calls dealing with strings (such as for file operations) expect -strings to be zero-terminated, they might do unexpected things when -called with string containing unusual characters. - -@menu -* String Syntax:: Read syntax for strings. -* String Predicates:: Testing strings for certain properties. -* String Constructors:: Creating new string objects. -* List/String Conversion:: Converting from/to lists of characters. -* String Selection:: Select portions from strings. -* String Modification:: Modify parts or whole strings. -* String Comparison:: Lexicographic ordering predicates. -* String Searching:: Searching in strings. -* Alphabetic Case Mapping:: Convert the alphabetic case of strings. -* Appending Strings:: Appending strings to form a new string. -@end menu - -@node String Syntax -@subsubsection String Read Syntax - -The read syntax for strings is an arbitrarily long sequence of -characters enclosed in double quotes (@code{"}).@footnote{Actually, -the current implementation restricts strings to a length of -@math{2^24}, or 16,777,216, characters. Sorry.} If you want to -insert a double quote character into a string literal, it must be -prefixed with a backslash @samp{\} character (called an @dfn{escape -character}). - -The following are examples of string literals: - -@lisp -"foo" -"bar plonk" -"Hello World" -"\"Hi\", he said." -@end lisp - -@c FIXME::martin: What about escape sequences like \r, \n etc.? - -@node String Predicates -@subsubsection String Predicates - -The following procedures can be used to check whether a given string -fulfills some specified property. - -@rnindex string? -@deffn {Scheme Procedure} string? obj -@deffnx {C Function} scm_string_p (obj) -Return @code{#t} if @var{obj} is a string, else @code{#f}. -@end deffn - -@deffn {Scheme Procedure} string-null? str -@deffnx {C Function} scm_string_null_p (str) -Return @code{#t} if @var{str}'s length is zero, and -@code{#f} otherwise. -@lisp -(string-null? "") @result{} #t -y @result{} "foo" -(string-null? y) @result{} #f -@end lisp -@end deffn - -@node String Constructors -@subsubsection String Constructors - -The string constructor procedures create new string objects, possibly -initializing them with some specified character data. - -@c FIXME::martin: list->string belongs into `List/String Conversion' - -@rnindex string -@rnindex list->string -@deffn {Scheme Procedure} string . chrs -@deffnx {Scheme Procedure} list->string chrs -@deffnx {C Function} scm_string (chrs) -Return a newly allocated string composed of the arguments, -@var{chrs}. -@end deffn - -@rnindex make-string -@deffn {Scheme Procedure} make-string k [chr] -@deffnx {C Function} scm_make_string (k, chr) -Return a newly allocated string of -length @var{k}. If @var{chr} is given, then all elements of -the string are initialized to @var{chr}, otherwise the contents -of the @var{string} are unspecified. -@end deffn - -@node List/String Conversion -@subsubsection List/String conversion - -When processing strings, it is often convenient to first convert them -into a list representation by using the procedure @code{string->list}, -work with the resulting list, and then convert it back into a string. -These procedures are useful for similar tasks. - -@rnindex string->list -@deffn {Scheme Procedure} string->list str -@deffnx {C Function} scm_string_to_list (str) -Return a newly allocated list of the characters that make up -the given string @var{str}. @code{string->list} and -@code{list->string} are inverses as far as @samp{equal?} is -concerned. -@end deffn - -@deffn {Scheme Procedure} string-split str chr -@deffnx {C Function} scm_string_split (str, chr) -Split the string @var{str} into the a list of the substrings delimited -by appearances of the character @var{chr}. Note that an empty substring -between separator characters will result in an empty string in the -result list. - -@lisp -(string-split "root:x:0:0:root:/root:/bin/bash" #\:) -@result{} -("root" "x" "0" "0" "root" "/root" "/bin/bash") - -(string-split "::" #\:) -@result{} -("" "" "") - -(string-split "" #\:) -@result{} -("") -@end lisp -@end deffn - - -@node String Selection -@subsubsection String Selection - -Portions of strings can be extracted by these procedures. -@code{string-ref} delivers individual characters whereas -@code{substring} can be used to extract substrings from longer strings. - -@rnindex string-length -@deffn {Scheme Procedure} string-length string -@deffnx {C Function} scm_string_length (string) -Return the number of characters in @var{string}. -@end deffn - -@rnindex string-ref -@deffn {Scheme Procedure} string-ref str k -@deffnx {C Function} scm_string_ref (str, k) -Return character @var{k} of @var{str} using zero-origin -indexing. @var{k} must be a valid index of @var{str}. -@end deffn - -@rnindex string-copy -@deffn {Scheme Procedure} string-copy str -@deffnx {C Function} scm_string_copy (str) -Return a newly allocated copy of the given @var{string}. -@end deffn - -@rnindex substring -@deffn {Scheme Procedure} substring str start [end] -@deffnx {C Function} scm_substring (str, start, end) -Return a newly allocated string formed from the characters -of @var{str} beginning with index @var{start} (inclusive) and -ending with index @var{end} (exclusive). -@var{str} must be a string, @var{start} and @var{end} must be -exact integers satisfying: - -0 <= @var{start} <= @var{end} <= @code{(string-length @var{str})}. -@end deffn - -@node String Modification -@subsubsection String Modification - -These procedures are for modifying strings in-place. This means that the -result of the operation is not a new string; instead, the original string's -memory representation is modified. - -@rnindex string-set! -@deffn {Scheme Procedure} string-set! str k chr -@deffnx {C Function} scm_string_set_x (str, k, chr) -Store @var{chr} in element @var{k} of @var{str} and return -an unspecified value. @var{k} must be a valid index of -@var{str}. -@end deffn - -@rnindex string-fill! -@deffn {Scheme Procedure} string-fill! str chr -@deffnx {C Function} scm_string_fill_x (str, chr) -Store @var{char} in every element of the given @var{string} and -return an unspecified value. -@end deffn - -@deffn {Scheme Procedure} substring-fill! str start end fill -@deffnx {C Function} scm_substring_fill_x (str, start, end, fill) -Change every character in @var{str} between @var{start} and -@var{end} to @var{fill}. - -@lisp -(define y "abcdefg") -(substring-fill! y 1 3 #\r) -y -@result{} "arrdefg" -@end lisp -@end deffn - -@deffn {Scheme Procedure} substring-move! str1 start1 end1 str2 start2 -@deffnx {C Function} scm_substring_move_x (str1, start1, end1, str2, start2) -Copy the substring of @var{str1} bounded by @var{start1} and @var{end1} -into @var{str2} beginning at position @var{start2}. -@var{str1} and @var{str2} can be the same string. -@end deffn - - -@node String Comparison -@subsubsection String Comparison - -The procedures in this section are similar to the character ordering -predicates (@pxref{Characters}), but are defined on character sequences. -They all return @code{#t} on success and @code{#f} on failure. The -predicates ending in @code{-ci} ignore the character case when comparing -strings. - - -@rnindex string=? -@deffn {Scheme Procedure} string=? s1 s2 -Lexicographic equality predicate; return @code{#t} if the two -strings are the same length and contain the same characters in -the same positions, otherwise return @code{#f}. - -The procedure @code{string-ci=?} treats upper and lower case -letters as though they were the same character, but -@code{string=?} treats upper and lower case as distinct -characters. -@end deffn - -@rnindex string? -@deffn {Scheme Procedure} string>? s1 s2 -Lexicographic ordering predicate; return @code{#t} if @var{s1} -is lexicographically greater than @var{s2}. -@end deffn - -@rnindex string>=? -@deffn {Scheme Procedure} string>=? s1 s2 -Lexicographic ordering predicate; return @code{#t} if @var{s1} -is lexicographically greater than or equal to @var{s2}. -@end deffn - -@rnindex string-ci=? -@deffn {Scheme Procedure} string-ci=? s1 s2 -Case-insensitive string equality predicate; return @code{#t} if -the two strings are the same length and their component -characters match (ignoring case) at each position; otherwise -return @code{#f}. -@end deffn - -@rnindex string-ci< -@deffn {Scheme Procedure} string-ci? -@deffn {Scheme Procedure} string-ci>? s1 s2 -Case insensitive lexicographic ordering predicate; return -@code{#t} if @var{s1} is lexicographically greater than -@var{s2} regardless of case. -@end deffn - -@rnindex string-ci>=? -@deffn {Scheme Procedure} string-ci>=? s1 s2 -Case insensitive lexicographic ordering predicate; return -@code{#t} if @var{s1} is lexicographically greater than or -equal to @var{s2} regardless of case. -@end deffn - - -@node String Searching -@subsubsection String Searching - -When searching for the index of a character in a string, these -procedures can be used. - -@deffn {Scheme Procedure} string-index str chr [frm [to]] -@deffnx {C Function} scm_string_index (str, chr, frm, to) -Return the index of the first occurrence of @var{chr} in -@var{str}. The optional integer arguments @var{frm} and -@var{to} limit the search to a portion of the string. This -procedure essentially implements the @code{index} or -@code{strchr} functions from the C library. - -@lisp -(string-index "weiner" #\e) -@result{} 1 - -(string-index "weiner" #\e 2) -@result{} 4 - -(string-index "weiner" #\e 2 4) -@result{} #f -@end lisp -@end deffn - -@deffn {Scheme Procedure} string-rindex str chr [frm [to]] -@deffnx {C Function} scm_string_rindex (str, chr, frm, to) -Like @code{string-index}, but search from the right of the -string rather than from the left. This procedure essentially -implements the @code{rindex} or @code{strrchr} functions from -the C library. - -@lisp -(string-rindex "weiner" #\e) -@result{} 4 - -(string-rindex "weiner" #\e 2 4) -@result{} #f - -(string-rindex "weiner" #\e 2 5) -@result{} 4 -@end lisp -@end deffn - -@node Alphabetic Case Mapping -@subsubsection Alphabetic Case Mapping - -These are procedures for mapping strings to their upper- or lower-case -equivalents, respectively, or for capitalizing strings. - -@deffn {Scheme Procedure} string-upcase str -@deffnx {C Function} scm_string_upcase (str) -Return a freshly allocated string containing the characters of -@var{str} in upper case. -@end deffn - -@deffn {Scheme Procedure} string-upcase! str -@deffnx {C Function} scm_string_upcase_x (str) -Destructively upcase every character in @var{str} and return -@var{str}. -@lisp -y @result{} "arrdefg" -(string-upcase! y) @result{} "ARRDEFG" -y @result{} "ARRDEFG" -@end lisp -@end deffn - -@deffn {Scheme Procedure} string-downcase str -@deffnx {C Function} scm_string_downcase (str) -Return a freshly allocation string containing the characters in -@var{str} in lower case. -@end deffn - -@deffn {Scheme Procedure} string-downcase! str -@deffnx {C Function} scm_string_downcase_x (str) -Destructively downcase every character in @var{str} and return -@var{str}. -@lisp -y @result{} "ARRDEFG" -(string-downcase! y) @result{} "arrdefg" -y @result{} "arrdefg" -@end lisp -@end deffn - -@deffn {Scheme Procedure} string-capitalize str -@deffnx {C Function} scm_string_capitalize (str) -Return a freshly allocated string with the characters in -@var{str}, where the first character of every word is -capitalized. -@end deffn - -@deffn {Scheme Procedure} string-capitalize! str -@deffnx {C Function} scm_string_capitalize_x (str) -Upcase the first character of every word in @var{str} -destructively and return @var{str}. - -@lisp -y @result{} "hello world" -(string-capitalize! y) @result{} "Hello World" -y @result{} "Hello World" -@end lisp -@end deffn - - -@node Appending Strings -@subsubsection Appending Strings - -The procedure @code{string-append} appends several strings together to -form a longer result string. - -@rnindex string-append -@deffn {Scheme Procedure} string-append . args -@deffnx {C Function} scm_string_append (args) -Return a newly allocated string whose characters form the -concatenation of the given strings, @var{args}. - -@example -(let ((h "hello ")) - (string-append h "world")) -@result{} "hello world" -@end example -@end deffn - - -@node Regular Expressions -@subsection Regular Expressions -@tpindex Regular expressions - -@cindex regular expressions -@cindex regex -@cindex emacs regexp - -A @dfn{regular expression} (or @dfn{regexp}) is a pattern that -describes a whole class of strings. A full description of regular -expressions and their syntax is beyond the scope of this manual; -an introduction can be found in the Emacs manual (@pxref{Regexps, -, Syntax of Regular Expressions, emacs, The GNU Emacs Manual}), or -in many general Unix reference books. - -If your system does not include a POSIX regular expression library, -and you have not linked Guile with a third-party regexp library such -as Rx, these functions will not be available. You can tell whether -your Guile installation includes regular expression support by -checking whether @code{(provided? 'regex)} returns true. - -The following regexp and string matching features are provided by the -@code{(ice-9 regex)} module. Before using the described functions, -you should load this module by executing @code{(use-modules (ice-9 -regex))}. - -@menu -* Regexp Functions:: Functions that create and match regexps. -* Match Structures:: Finding what was matched by a regexp. -* Backslash Escapes:: Removing the special meaning of regexp - meta-characters. -@end menu - - -@node Regexp Functions -@subsubsection Regexp Functions - -By default, Guile supports POSIX extended regular expressions. -That means that the characters @samp{(}, @samp{)}, @samp{+} and -@samp{?} are special, and must be escaped if you wish to match the -literal characters. - -This regular expression interface was modeled after that -implemented by SCSH, the Scheme Shell. It is intended to be -upwardly compatible with SCSH regular expressions. - -@deffn {Scheme Procedure} string-match pattern str [start] -Compile the string @var{pattern} into a regular expression and compare -it with @var{str}. The optional numeric argument @var{start} specifies -the position of @var{str} at which to begin matching. - -@code{string-match} returns a @dfn{match structure} which -describes what, if anything, was matched by the regular -expression. @xref{Match Structures}. If @var{str} does not match -@var{pattern} at all, @code{string-match} returns @code{#f}. -@end deffn - -Two examples of a match follow. In the first example, the pattern -matches the four digits in the match string. In the second, the pattern -matches nothing. - -@example -(string-match "[0-9][0-9][0-9][0-9]" "blah2002") -@result{} #("blah2002" (4 . 8)) - -(string-match "[A-Za-z]" "123456") -@result{} #f -@end example - -Each time @code{string-match} is called, it must compile its -@var{pattern} argument into a regular expression structure. This -operation is expensive, which makes @code{string-match} inefficient if -the same regular expression is used several times (for example, in a -loop). For better performance, you can compile a regular expression in -advance and then match strings against the compiled regexp. - -@deffn {Scheme Procedure} make-regexp pat . flags -@deffnx {C Function} scm_make_regexp (pat, flags) -Compile the regular expression described by @var{pat}, and -return the compiled regexp structure. If @var{pat} does not -describe a legal regular expression, @code{make-regexp} throws -a @code{regular-expression-syntax} error. - -The @var{flags} arguments change the behavior of the compiled -regular expression. The following flags may be supplied: - -@table @code -@item regexp/icase -Consider uppercase and lowercase letters to be the same when -matching. -@item regexp/newline -If a newline appears in the target string, then permit the -@samp{^} and @samp{$} operators to match immediately after or -immediately before the newline, respectively. Also, the -@samp{.} and @samp{[^...]} operators will never match a newline -character. The intent of this flag is to treat the target -string as a buffer containing many lines of text, and the -regular expression as a pattern that may match a single one of -those lines. -@item regexp/basic -Compile a basic (``obsolete'') regexp instead of the extended -(``modern'') regexps that are the default. Basic regexps do -not consider @samp{|}, @samp{+} or @samp{?} to be special -characters, and require the @samp{@{...@}} and @samp{(...)} -metacharacters to be backslash-escaped (@pxref{Backslash -Escapes}). There are several other differences between basic -and extended regular expressions, but these are the most -significant. -@item regexp/extended -Compile an extended regular expression rather than a basic -regexp. This is the default behavior; this flag will not -usually be needed. If a call to @code{make-regexp} includes -both @code{regexp/basic} and @code{regexp/extended} flags, the -one which comes last will override the earlier one. -@end table -@end deffn - -@deffn {Scheme Procedure} regexp-exec rx str [start [flags]] -@deffnx {C Function} scm_regexp_exec (rx, str, start, flags) -Match the compiled regular expression @var{rx} against -@code{str}. If the optional integer @var{start} argument is -provided, begin matching from that position in the string. -Return a match structure describing the results of the match, -or @code{#f} if no match could be found. - -The @var{flags} arguments change the matching behavior. -The following flags may be supplied: - -@table @code -@item regexp/notbol -Operator @samp{^} always fails (unless @code{regexp/newline} -is used). Use this when the beginning of the string should -not be considered the beginning of a line. -@item regexp/noteol -Operator @samp{$} always fails (unless @code{regexp/newline} -is used). Use this when the end of the string should not be -considered the end of a line. -@end table -@end deffn - -@lisp -;; Regexp to match uppercase letters -(define r (make-regexp "[A-Z]*")) - -;; Regexp to match letters, ignoring case -(define ri (make-regexp "[A-Z]*" regexp/icase)) - -;; Search for bob using regexp r -(match:substring (regexp-exec r "bob")) -@result{} "" ; no match - -;; Search for bob using regexp ri -(match:substring (regexp-exec ri "Bob")) -@result{} "Bob" ; matched case insensitive -@end lisp - -@deffn {Scheme Procedure} regexp? obj -@deffnx {C Function} scm_regexp_p (obj) -Return @code{#t} if @var{obj} is a compiled regular expression, -or @code{#f} otherwise. -@end deffn - -Regular expressions are commonly used to find patterns in one string and -replace them with the contents of another string. - -@c begin (scm-doc-string "regex.scm" "regexp-substitute") -@deffn {Scheme Procedure} regexp-substitute port match [item@dots{}] -Write to the output port @var{port} selected contents of the match -structure @var{match}. Each @var{item} specifies what should be -written, and may be one of the following arguments: - -@itemize @bullet -@item -A string. String arguments are written out verbatim. - -@item -An integer. The submatch with that number is written. - -@item -The symbol @samp{pre}. The portion of the matched string preceding -the regexp match is written. - -@item -The symbol @samp{post}. The portion of the matched string following -the regexp match is written. -@end itemize - -The @var{port} argument may be @code{#f}, in which case nothing is -written; instead, @code{regexp-substitute} constructs a string from the -specified @var{item}s and returns that. -@end deffn - -The following example takes a regular expression that matches a standard -@sc{yyyymmdd}-format date such as @code{"20020828"}. The -@code{regexp-substitute} call returns a string computed from the -information in the match structure, consisting of the fields and text -from the original string reordered and reformatted. - -@lisp -(define date-regex "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])") -(define s "Date 20020429 12am.") -(define sm (string-match date-regex s)) -(regexp-substitute #f sm 'pre 2 "-" 3 "-" 1 'post " (" 0 ")") -@result{} "Date 04-29-2002 12am. (20020429)" -@end lisp - -@c begin (scm-doc-string "regex.scm" "regexp-substitute") -@deffn {Scheme Procedure} regexp-substitute/global port regexp target [item@dots{}] -Similar to @code{regexp-substitute}, but can be used to perform global -substitutions on @var{str}. Instead of taking a match structure as an -argument, @code{regexp-substitute/global} takes two string arguments: a -@var{regexp} string describing a regular expression, and a @var{target} -string which should be matched against this regular expression. - -Each @var{item} behaves as in @code{regexp-substitute}, with the -following exceptions: - -@itemize @bullet -@item -A function may be supplied. When this function is called, it will be -passed one argument: a match structure for a given regular expression -match. It should return a string to be written out to @var{port}. - -@item -The @samp{post} symbol causes @code{regexp-substitute/global} to recurse -on the unmatched portion of @var{str}. This @emph{must} be supplied in -order to perform global search-and-replace on @var{str}; if it is not -present among the @var{item}s, then @code{regexp-substitute/global} will -return after processing a single match. -@end itemize -@end deffn - -The example above for @code{regexp-substitute} could be rewritten as -follows to remove the @code{string-match} stage: - -@lisp -(define date-regex "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])") -(define s "Date 20020429 12am.") -(regexp-substitute/global #f date-regex s - 'pre 2 "-" 3 "-" 1 'post " (" 0 ")") -@result{} "Date 04-29-2002 12am. (20020429)" -@end lisp - - -@node Match Structures -@subsubsection Match Structures - -@cindex match structures - -A @dfn{match structure} is the object returned by @code{string-match} and -@code{regexp-exec}. It describes which portion of a string, if any, -matched the given regular expression. Match structures include: a -reference to the string that was checked for matches; the starting and -ending positions of the regexp match; and, if the regexp included any -parenthesized subexpressions, the starting and ending positions of each -submatch. - -In each of the regexp match functions described below, the @code{match} -argument must be a match structure returned by a previous call to -@code{string-match} or @code{regexp-exec}. Most of these functions -return some information about the original target string that was -matched against a regular expression; we will call that string -@var{target} for easy reference. - -@c begin (scm-doc-string "regex.scm" "regexp-match?") -@deffn {Scheme Procedure} regexp-match? obj -Return @code{#t} if @var{obj} is a match structure returned by a -previous call to @code{regexp-exec}, or @code{#f} otherwise. -@end deffn - -@c begin (scm-doc-string "regex.scm" "match:substring") -@deffn {Scheme Procedure} match:substring match [n] -Return the portion of @var{target} matched by subexpression number -@var{n}. Submatch 0 (the default) represents the entire regexp match. -If the regular expression as a whole matched, but the subexpression -number @var{n} did not match, return @code{#f}. -@end deffn - -@lisp -(define s (string-match "[0-9][0-9][0-9][0-9]" "blah2002foo")) -(match:substring s) -@result{} "2002" - -;; match starting at offset 6 in the string -(match:substring - (string-match "[0-9][0-9][0-9][0-9]" "blah987654" 6)) -@result{} "7654" -@end lisp - -@c begin (scm-doc-string "regex.scm" "match:start") -@deffn {Scheme Procedure} match:start match [n] -Return the starting position of submatch number @var{n}. -@end deffn - -In the following example, the result is 4, since the match starts at -character index 4: - -@lisp -(define s (string-match "[0-9][0-9][0-9][0-9]" "blah2002foo")) -(match:start s) -@result{} 4 -@end lisp - -@c begin (scm-doc-string "regex.scm" "match:end") -@deffn {Scheme Procedure} match:end match [n] -Return the ending position of submatch number @var{n}. -@end deffn - -In the following example, the result is 8, since the match runs between -characters 4 and 8 (i.e. the ``2002''). - -@lisp -(define s (string-match "[0-9][0-9][0-9][0-9]" "blah2002foo")) -(match:end s) -@result{} 8 -@end lisp - -@c begin (scm-doc-string "regex.scm" "match:prefix") -@deffn {Scheme Procedure} match:prefix match -Return the unmatched portion of @var{target} preceding the regexp match. - -@lisp -(define s (string-match "[0-9][0-9][0-9][0-9]" "blah2002foo")) -(match:prefix s) -@result{} "blah" -@end lisp -@end deffn - -@c begin (scm-doc-string "regex.scm" "match:suffix") -@deffn {Scheme Procedure} match:suffix match -Return the unmatched portion of @var{target} following the regexp match. -@end deffn - -@lisp -(define s (string-match "[0-9][0-9][0-9][0-9]" "blah2002foo")) -(match:suffix s) -@result{} "foo" -@end lisp - -@c begin (scm-doc-string "regex.scm" "match:count") -@deffn {Scheme Procedure} match:count match -Return the number of parenthesized subexpressions from @var{match}. -Note that the entire regular expression match itself counts as a -subexpression, and failed submatches are included in the count. -@end deffn - -@c begin (scm-doc-string "regex.scm" "match:string") -@deffn {Scheme Procedure} match:string match -Return the original @var{target} string. -@end deffn - -@lisp -(define s (string-match "[0-9][0-9][0-9][0-9]" "blah2002foo")) -(match:string s) -@result{} "blah2002foo" -@end lisp - - -@node Backslash Escapes -@subsubsection Backslash Escapes - -Sometimes you will want a regexp to match characters like @samp{*} or -@samp{$} exactly. For example, to check whether a particular string -represents a menu entry from an Info node, it would be useful to match -it against a regexp like @samp{^* [^:]*::}. However, this won't work; -because the asterisk is a metacharacter, it won't match the @samp{*} at -the beginning of the string. In this case, we want to make the first -asterisk un-magic. - -You can do this by preceding the metacharacter with a backslash -character @samp{\}. (This is also called @dfn{quoting} the -metacharacter, and is known as a @dfn{backslash escape}.) When Guile -sees a backslash in a regular expression, it considers the following -glyph to be an ordinary character, no matter what special meaning it -would ordinarily have. Therefore, we can make the above example work by -changing the regexp to @samp{^\* [^:]*::}. The @samp{\*} sequence tells -the regular expression engine to match only a single asterisk in the -target string. - -Since the backslash is itself a metacharacter, you may force a regexp to -match a backslash in the target string by preceding the backslash with -itself. For example, to find variable references in a @TeX{} program, -you might want to find occurrences of the string @samp{\let\} followed -by any number of alphabetic characters. The regular expression -@samp{\\let\\[A-Za-z]*} would do this: the double backslashes in the -regexp each match a single backslash in the target string. - -@c begin (scm-doc-string "regex.scm" "regexp-quote") -@deffn {Scheme Procedure} regexp-quote str -Quote each special character found in @var{str} with a backslash, and -return the resulting string. -@end deffn - -@strong{Very important:} Using backslash escapes in Guile source code -(as in Emacs Lisp or C) can be tricky, because the backslash character -has special meaning for the Guile reader. For example, if Guile -encounters the character sequence @samp{\n} in the middle of a string -while processing Scheme code, it replaces those characters with a -newline character. Similarly, the character sequence @samp{\t} is -replaced by a horizontal tab. Several of these @dfn{escape sequences} -are processed by the Guile reader before your code is executed. -Unrecognized escape sequences are ignored: if the characters @samp{\*} -appear in a string, they will be translated to the single character -@samp{*}. - -This translation is obviously undesirable for regular expressions, since -we want to be able to include backslashes in a string in order to -escape regexp metacharacters. Therefore, to make sure that a backslash -is preserved in a string in your Guile program, you must use @emph{two} -consecutive backslashes: - -@lisp -(define Info-menu-entry-pattern (make-regexp "^\\* [^:]*")) -@end lisp - -The string in this example is preprocessed by the Guile reader before -any code is executed. The resulting argument to @code{make-regexp} is -the string @samp{^\* [^:]*}, which is what we really want. - -This also means that in order to write a regular expression that matches -a single backslash character, the regular expression string in the -source code must include @emph{four} backslashes. Each consecutive pair -of backslashes gets translated by the Guile reader to a single -backslash, and the resulting double-backslash is interpreted by the -regexp engine as matching a single backslash character. Hence: - -@lisp -(define tex-variable-pattern (make-regexp "\\\\let\\\\=[A-Za-z]*")) -@end lisp - -The reason for the unwieldiness of this syntax is historical. Both -regular expression pattern matchers and Unix string processing systems -have traditionally used backslashes with the special meanings -described above. The POSIX regular expression specification and ANSI C -standard both require these semantics. Attempting to abandon either -convention would cause other kinds of compatibility problems, possibly -more severe ones. Therefore, without extending the Scheme reader to -support strings with different quoting conventions (an ungainly and -confusing extension when implemented in other languages), we must adhere -to this cumbersome escape syntax. - - -@node Symbols -@subsection Symbols -@tpindex Symbols - -Symbols in Scheme are widely used in three ways: as items of discrete -data, as lookup keys for alists and hash tables, and to denote variable -references. - -A @dfn{symbol} is similar to a string in that it is defined by a -sequence of characters. The sequence of characters is known as the -symbol's @dfn{name}. In the usual case --- that is, where the symbol's -name doesn't include any characters that could be confused with other -elements of Scheme syntax --- a symbol is written in a Scheme program by -writing the sequence of characters that make up the name, @emph{without} -any quotation marks or other special syntax. For example, the symbol -whose name is ``multiply-by-2'' is written, simply: - -@lisp -multiply-by-2 -@end lisp - -Notice how this differs from a @emph{string} with contents -``multiply-by-2'', which is written with double quotation marks, like -this: - -@lisp -"multiply-by-2" -@end lisp - -Looking beyond how they are written, symbols are different from strings -in two important respects. - -The first important difference is uniqueness. If the same-looking -string is read twice from two different places in a program, the result -is two @emph{different} string objects whose contents just happen to be -the same. If, on the other hand, the same-looking symbol is read twice -from two different places in a program, the result is the @emph{same} -symbol object both times. - -Given two read symbols, you can use @code{eq?} to test whether they are -the same (that is, have the same name). @code{eq?} is the most -efficient comparison operator in Scheme, and comparing two symbols like -this is as fast as comparing, for example, two numbers. Given two -strings, on the other hand, you must use @code{equal?} or -@code{string=?}, which are much slower comparison operators, to -determine whether the strings have the same contents. - -@lisp -(define sym1 (quote hello)) -(define sym2 (quote hello)) -(eq? sym1 sym2) @result{} #t - -(define str1 "hello") -(define str2 "hello") -(eq? str1 str2) @result{} #f -(equal? str1 str2) @result{} #t -@end lisp - -The second important difference is that symbols, unlike strings, are not -self-evaluating. This is why we need the @code{(quote @dots{})}s in the -example above: @code{(quote hello)} evaluates to the symbol named -"hello" itself, whereas an unquoted @code{hello} is @emph{read} as the -symbol named "hello" and evaluated as a variable reference @dots{} about -which more below (@pxref{Symbol Variables}). - -@menu -* Symbol Data:: Symbols as discrete data. -* Symbol Keys:: Symbols as lookup keys. -* Symbol Variables:: Symbols as denoting variables. -* Symbol Primitives:: Operations related to symbols. -* Symbol Props:: Function slots and property lists. -* Symbol Read Syntax:: Extended read syntax for symbols. -* Symbol Uninterned:: Uninterned symbols. -@end menu - - -@node Symbol Data -@subsubsection Symbols as Discrete Data - -Numbers and symbols are similar to the extent that they both lend -themselves to @code{eq?} comparison. But symbols are more descriptive -than numbers, because a symbol's name can be used directly to describe -the concept for which that symbol stands. - -For example, imagine that you need to represent some colours in a -computer program. Using numbers, you would have to choose arbitrarily -some mapping between numbers and colours, and then take care to use that -mapping consistently: - -@lisp -;; 1=red, 2=green, 3=purple - -(if (eq? (colour-of car) 1) - ...) -@end lisp - -@noindent -You can make the mapping more explicit and the code more readable by -defining constants: - -@lisp -(define red 1) -(define green 2) -(define purple 3) - -(if (eq? (colour-of car) red) - ...) -@end lisp - -@noindent -But the simplest and clearest approach is not to use numbers at all, but -symbols whose names specify the colours that they refer to: - -@lisp -(if (eq? (colour-of car) 'red) - ...) -@end lisp - -The descriptive advantages of symbols over numbers increase as the set -of concepts that you want to describe grows. Suppose that a car object -can have other properties as well, such as whether it has or uses: - -@itemize @bullet -@item -automatic or manual transmission -@item -leaded or unleaded fuel -@item -power steering (or not). -@end itemize - -@noindent -Then a car's combined property set could be naturally represented and -manipulated as a list of symbols: - -@lisp -(properties-of car1) -@result{} -(red manual unleaded power-steering) - -(if (memq 'power-steering (properties-of car1)) - (display "Unfit people can drive this car.\n") - (display "You'll need strong arms to drive this car!\n")) -@print{} -Unfit people can drive this car. -@end lisp - -Remember, the fundamental property of symbols that we are relying on -here is that an occurrence of @code{'red} in one part of a program is an -@emph{indistinguishable} symbol from an occurrence of @code{'red} in -another part of a program; this means that symbols can usefully be -compared using @code{eq?}. At the same time, symbols have naturally -descriptive names. This combination of efficiency and descriptive power -makes them ideal for use as discrete data. - - -@node Symbol Keys -@subsubsection Symbols as Lookup Keys - -Given their efficiency and descriptive power, it is natural to use -symbols as the keys in an association list or hash table. - -To illustrate this, consider a more structured representation of the car -properties example from the preceding subsection. Rather than -mixing all the properties up together in a flat list, we could use an -association list like this: - -@lisp -(define car1-properties '((colour . red) - (transmission . manual) - (fuel . unleaded) - (steering . power-assisted))) -@end lisp - -Notice how this structure is more explicit and extensible than the flat -list. For example it makes clear that @code{manual} refers to the -transmission rather than, say, the windows or the locking of the car. -It also allows further properties to use the same symbols among their -possible values without becoming ambiguous: - -@lisp -(define car1-properties '((colour . red) - (transmission . manual) - (fuel . unleaded) - (steering . power-assisted) - (seat-colour . red) - (locking . manual))) -@end lisp - -With a representation like this, it is easy to use the efficient -@code{assq-XXX} family of procedures (@pxref{Association Lists}) to -extract or change individual pieces of information: - -@lisp -(assq-ref car1-properties 'fuel) @result{} unleaded -(assq-ref car1-properties 'transmission) @result{} manual - -(assq-set! car1-properties 'seat-colour 'black) -@result{} -((colour . red) - (transmission . manual) - (fuel . unleaded) - (steering . power-assisted) - (seat-colour . black) - (locking . manual))) -@end lisp - -Hash tables also have keys, and exactly the same arguments apply to the -use of symbols in hash tables as in association lists. The hash value -that Guile uses to decide where to add a symbol-keyed entry to a hash -table can be obtained by calling the @code{symbol-hash} procedure: - -@deffn {Scheme Procedure} symbol-hash symbol -@deffnx {C Function} scm_symbol_hash (symbol) -Return a hash value for @var{symbol}. -@end deffn - -See @ref{Hash Tables} for information about hash tables in general, and -for why you might choose to use a hash table rather than an association -list. - - -@node Symbol Variables -@subsubsection Symbols as Denoting Variables - -When an unquoted symbol in a Scheme program is evaluated, it is -interpreted as a variable reference, and the result of the evaluation is -the appropriate variable's value. - -For example, when the expression @code{(string-length "abcd")} is read -and evaluated, the sequence of characters @code{string-length} is read -as the symbol whose name is "string-length". This symbol is associated -with a variable whose value is the procedure that implements string -length calculation. Therefore evaluation of the @code{string-length} -symbol results in that procedure. - -The details of the connection between an unquoted symbol and the -variable to which it refers are explained elsewhere. See @ref{Binding -Constructs}, for how associations between symbols and variables are -created, and @ref{Modules}, for how those associations are affected by -Guile's module system. - - -@node Symbol Primitives -@subsubsection Operations Related to Symbols - -Given any Scheme value, you can determine whether it is a symbol using -the @code{symbol?} primitive: - -@rnindex symbol? -@deffn {Scheme Procedure} symbol? obj -@deffnx {C Function} scm_symbol_p (obj) -Return @code{#t} if @var{obj} is a symbol, otherwise return -@code{#f}. -@end deffn - -Once you know that you have a symbol, you can obtain its name as a -string by calling @code{symbol->string}. Note that Guile differs by -default from R5RS on the details of @code{symbol->string} as regards -case-sensitivity: - -@rnindex symbol->string -@deffn {Scheme Procedure} symbol->string s -@deffnx {C Function} scm_symbol_to_string (s) -Return the name of symbol @var{s} as a string. By default, Guile reads -symbols case-sensitively, so the string returned will have the same case -variation as the sequence of characters that caused @var{s} to be -created. - -If Guile is set to read symbols case-insensitively (as specified by -R5RS), and @var{s} comes into being as part of a literal expression -(@pxref{Literal expressions,,,r5rs, The Revised^5 Report on Scheme}) or -by a call to the @code{read} or @code{string-ci->symbol} procedures, -Guile converts any alphabetic characters in the symbol's name to -lower case before creating the symbol object, so the string returned -here will be in lower case. - -If @var{s} was created by @code{string->symbol}, the case of characters -in the string returned will be the same as that in the string that was -passed to @code{string->symbol}, regardless of Guile's case-sensitivity -setting at the time @var{s} was created. - -It is an error to apply mutation procedures like @code{string-set!} to -strings returned by this procedure. -@end deffn - -Most symbols are created by writing them literally in code. However it -is also possible to create symbols programmatically using the following -@code{string->symbol} and @code{string-ci->symbol} procedures: - -@rnindex string->symbol -@deffn {Scheme Procedure} string->symbol string -@deffnx {C Function} scm_string_to_symbol (string) -Return the symbol whose name is @var{string}. This procedure can create -symbols with names containing special characters or letters in the -non-standard case, but it is usually a bad idea to create such symbols -because in some implementations of Scheme they cannot be read as -themselves. -@end deffn - -@deffn {Scheme Procedure} string-ci->symbol str -@deffnx {C Function} scm_string_ci_to_symbol (str) -Return the symbol whose name is @var{str}. If Guile is currently -reading symbols case-insensitively, @var{str} is converted to lowercase -before the returned symbol is looked up or created. -@end deffn - -The following examples illustrate Guile's detailed behaviour as regards -the case-sensitivity of symbols: - -@lisp -(read-enable 'case-insensitive) ; R5RS compliant behaviour - -(symbol->string 'flying-fish) @result{} "flying-fish" -(symbol->string 'Martin) @result{} "martin" -(symbol->string - (string->symbol "Malvina")) @result{} "Malvina" - -(eq? 'mISSISSIppi 'mississippi) @result{} #t -(string->symbol "mISSISSIppi") @result{} mISSISSIppi -(eq? 'bitBlt (string->symbol "bitBlt")) @result{} #f -(eq? 'LolliPop - (string->symbol (symbol->string 'LolliPop))) @result{} #t -(string=? "K. Harper, M.D." - (symbol->string - (string->symbol "K. Harper, M.D."))) @result{} #t - -(read-disable 'case-insensitive) ; Guile default behaviour - -(symbol->string 'flying-fish) @result{} "flying-fish" -(symbol->string 'Martin) @result{} "Martin" -(symbol->string - (string->symbol "Malvina")) @result{} "Malvina" - -(eq? 'mISSISSIppi 'mississippi) @result{} #f -(string->symbol "mISSISSIppi") @result{} mISSISSIppi -(eq? 'bitBlt (string->symbol "bitBlt")) @result{} #t -(eq? 'LolliPop - (string->symbol (symbol->string 'LolliPop))) @result{} #t -(string=? "K. Harper, M.D." - (symbol->string - (string->symbol "K. Harper, M.D."))) @result{} #t -@end lisp - -From C, there are lower level functions that construct a Scheme symbol -from a null terminated C string or from a sequence of bytes whose length -is specified explicitly. - -@deffn {C Function} scm_str2symbol (const char * name) -@deffnx {C Function} scm_mem2symbol (const char * name, size_t len) -Construct and return a Scheme symbol whose name is specified by -@var{name}. For @code{scm_str2symbol} @var{name} must be null -terminated; For @code{scm_mem2symbol} the length of @var{name} is -specified explicitly by @var{len}. -@end deffn - -Finally, some applications, especially those that generate new Scheme -code dynamically, need to generate symbols for use in the generated -code. The @code{gensym} primitive meets this need: - -@deffn {Scheme Procedure} gensym [prefix] -@deffnx {C Function} scm_gensym (prefix) -Create a new symbol with a name constructed from a prefix and a counter -value. The string @var{prefix} can be specified as an optional -argument. Default prefix is @samp{@w{ g}}. The counter is increased by 1 -at each call. There is no provision for resetting the counter. -@end deffn - -The symbols generated by @code{gensym} are @emph{likely} to be unique, -since their names begin with a space and it is only otherwise possible -to generate such symbols if a programmer goes out of their way to do -so. Uniqueness can be guaranteed by instead using uninterned symbols -(@pxref{Symbol Uninterned}), though they can't be usefully written out -and read back in. - - -@node Symbol Props -@subsubsection Function Slots and Property Lists - -In traditional Lisp dialects, symbols are often understood as having -three kinds of value at once: - -@itemize @bullet -@item -a @dfn{variable} value, which is used when the symbol appears in -code in a variable reference context - -@item -a @dfn{function} value, which is used when the symbol appears in -code in a function name position (i.e. as the first element in an -unquoted list) - -@item -a @dfn{property list} value, which is used when the symbol is given as -the first argument to Lisp's @code{put} or @code{get} functions. -@end itemize - -Although Scheme (as one of its simplifications with respect to Lisp) -does away with the distinction between variable and function namespaces, -Guile currently retains some elements of the traditional structure in -case they turn out to be useful when implementing translators for other -languages, in particular Emacs Lisp. - -Specifically, Guile symbols have two extra slots. for a symbol's -property list, and for its ``function value.'' The following procedures -are provided to access these slots. - -@deffn {Scheme Procedure} symbol-fref symbol -@deffnx {C Function} scm_symbol_fref (symbol) -Return the contents of @var{symbol}'s @dfn{function slot}. -@end deffn - -@deffn {Scheme Procedure} symbol-fset! symbol value -@deffnx {C Function} scm_symbol_fset_x (symbol, value) -Set the contents of @var{symbol}'s function slot to @var{value}. -@end deffn - -@deffn {Scheme Procedure} symbol-pref symbol -@deffnx {C Function} scm_symbol_pref (symbol) -Return the @dfn{property list} currently associated with @var{symbol}. -@end deffn - -@deffn {Scheme Procedure} symbol-pset! symbol value -@deffnx {C Function} scm_symbol_pset_x (symbol, value) -Set @var{symbol}'s property list to @var{value}. -@end deffn - -@deffn {Scheme Procedure} symbol-property sym prop -From @var{sym}'s property list, return the value for property -@var{prop}. The assumption is that @var{sym}'s property list is an -association list whose keys are distinguished from each other using -@code{equal?}; @var{prop} should be one of the keys in that list. If -the property list has no entry for @var{prop}, @code{symbol-property} -returns @code{#f}. -@end deffn - -@deffn {Scheme Procedure} set-symbol-property! sym prop val -In @var{sym}'s property list, set the value for property @var{prop} to -@var{val}, or add a new entry for @var{prop}, with value @var{val}, if -none already exists. For the structure of the property list, see -@code{symbol-property}. -@end deffn - -@deffn {Scheme Procedure} symbol-property-remove! sym prop -From @var{sym}'s property list, remove the entry for property -@var{prop}, if there is one. For the structure of the property list, -see @code{symbol-property}. -@end deffn - -Support for these extra slots may be removed in a future release, and it -is probably better to avoid using them. (In release 1.6, Guile itself -uses the property list slot sparingly, and the function slot not at -all.) For a more modern and Schemely approach to properties, see -@ref{Object Properties}. - - -@node Symbol Read Syntax -@subsubsection Extended Read Syntax for Symbols - -The read syntax for a symbol is a sequence of letters, digits, and -@dfn{extended alphabetic characters}, beginning with a character that -cannot begin a number. In addition, the special cases of @code{+}, -@code{-}, and @code{...} are read as symbols even though numbers can -begin with @code{+}, @code{-} or @code{.}. - -Extended alphabetic characters may be used within identifiers as if -they were letters. The set of extended alphabetic characters is: - -@example -! $ % & * + - . / : < = > ? @@ ^ _ ~ -@end example - -In addition to the standard read syntax defined above (which is taken -from R5RS (@pxref{Formal syntax,,,r5rs,The Revised^5 Report on -Scheme})), Guile provides an extended symbol read syntax that allows the -inclusion of unusual characters such as space characters, newlines and -parentheses. If (for whatever reason) you need to write a symbol -containing characters not mentioned above, you can do so as follows. - -@itemize @bullet -@item -Begin the symbol with the characters @code{#@{}, - -@item -write the characters of the symbol and - -@item -finish the symbol with the characters @code{@}#}. -@end itemize - -Here are a few examples of this form of read syntax. The first symbol -needs to use extended syntax because it contains a space character, the -second because it contains a line break, and the last because it looks -like a number. - -@lisp -#@{foo bar@}# - -#@{what -ever@}# - -#@{4242@}# -@end lisp - -Although Guile provides this extended read syntax for symbols, -widespread usage of it is discouraged because it is not portable and not -very readable. - - -@node Symbol Uninterned -@subsubsection 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 up to 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 people's code. - -The simplest way to arrange for this is to create a new symbol but -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 differently 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 -@subsection Keywords -@tpindex Keywords - -Keywords are self-evaluating objects with a convenient read syntax that -makes them easy to type. - -Guile's keyword support conforms to R5RS, and adds a (switchable) read -syntax extension to permit keywords to begin with @code{:} as well as -@code{#:}. - -@menu -* Why Use Keywords?:: Motivation for keyword usage. -* Coding With Keywords:: How to use keywords. -* Keyword Read Syntax:: Read syntax for keywords. -* Keyword Procedures:: Procedures for dealing with keywords. -* Keyword Primitives:: The underlying primitive procedures. -@end menu - -@node Why Use Keywords? -@subsubsection Why Use Keywords? - -Keywords are useful in contexts where a program or procedure wants to be -able to accept a large number of optional arguments without making its -interface unmanageable. - -To illustrate this, consider a hypothetical @code{make-window} -procedure, which creates a new window on the screen for drawing into -using some graphical toolkit. There are many parameters that the caller -might like to specify, but which could also be sensibly defaulted, for -example: - -@itemize @bullet -@item -color depth -- Default: the color depth for the screen - -@item -background color -- Default: white - -@item -width -- Default: 600 - -@item -height -- Default: 400 -@end itemize - -If @code{make-window} did not use keywords, the caller would have to -pass in a value for each possible argument, remembering the correct -argument order and using a special value to indicate the default value -for that argument: - -@lisp -(make-window 'default ;; Color depth - 'default ;; Background color - 800 ;; Width - 100 ;; Height - @dots{}) ;; More make-window arguments -@end lisp - -With keywords, on the other hand, defaulted arguments are omitted, and -non-default arguments are clearly tagged by the appropriate keyword. As -a result, the invocation becomes much clearer: - -@lisp -(make-window #:width 800 #:height 100) -@end lisp - -On the other hand, for a simpler procedure with few arguments, the use -of keywords would be a hindrance rather than a help. The primitive -procedure @code{cons}, for example, would not be improved if it had to -be invoked as - -@lisp -(cons #:car x #:cdr y) -@end lisp - -So the decision whether to use keywords or not is purely pragmatic: use -them if they will clarify the procedure invocation at point of call. - -@node Coding With Keywords -@subsubsection Coding With Keywords - -If a procedure wants to support keywords, it should take a rest argument -and then use whatever means is convenient to extract keywords and their -corresponding arguments from the contents of that rest argument. - -The following example illustrates the principle: the code for -@code{make-window} uses a helper procedure called -@code{get-keyword-value} to extract individual keyword arguments from -the rest argument. - -@lisp -(define (get-keyword-value args keyword default) - (let ((kv (memq keyword args))) - (if (and kv (>= (length kv) 2)) - (cadr kv) - default))) - -(define (make-window . args) - (let ((depth (get-keyword-value args #:depth screen-depth)) - (bg (get-keyword-value args #:bg "white")) - (width (get-keyword-value args #:width 800)) - (height (get-keyword-value args #:height 100)) - @dots{}) - @dots{})) -@end lisp - -But you don't need to write @code{get-keyword-value}. The @code{(ice-9 -optargs)} module provides a set of powerful macros that you can use to -implement keyword-supporting procedures like this: - -@lisp -(use-modules (ice-9 optargs)) - -(define (make-window . args) - (let-keywords args #f ((depth screen-depth) - (bg "white") - (width 800) - (height 100)) - ...)) -@end lisp - -@noindent -Or, even more economically, like this: - -@lisp -(use-modules (ice-9 optargs)) - -(define* (make-window #:key (depth screen-depth) - (bg "white") - (width 800) - (height 100)) - ...) -@end lisp - -For further details on @code{let-keywords}, @code{define*} and other -facilities provided by the @code{(ice-9 optargs)} module, see -@ref{Optional Arguments}. - - -@node Keyword Read Syntax -@subsubsection Keyword Read Syntax - -Guile, by default, only recognizes the keyword syntax specified by R5RS. -A token of the form @code{#:NAME}, where @code{NAME} has the same syntax -as a Scheme symbol (@pxref{Symbol Read Syntax}), is the external -representation of the keyword named @code{NAME}. Keyword objects print -using this syntax as well, so values containing keyword objects can be -read back into Guile. When used in an expression, keywords are -self-quoting objects. - -If the @code{keyword} read option is set to @code{'prefix}, Guile also -recognizes the alternative read syntax @code{:NAME}. Otherwise, tokens -of the form @code{:NAME} are read as symbols, as required by R5RS. - -To enable and disable the alternative non-R5RS keyword syntax, you use -the @code{read-set!} procedure documented in @ref{User level options -interfaces} and @ref{Reader options}. - -@smalllisp -(read-set! keywords 'prefix) - -#:type -@result{} -#:type - -:type -@result{} -#:type - -(read-set! keywords #f) - -#:type -@result{} -#:type - -:type -@print{} -ERROR: In expression :type: -ERROR: Unbound variable: :type -ABORT: (unbound-variable) -@end smalllisp - -@node Keyword Procedures -@subsubsection Keyword Procedures - -The following procedures can be used for converting symbols to keywords -and back. - -@deffn {Scheme Procedure} symbol->keyword sym -Return a keyword with the same characters as in @var{sym}. -@end deffn - -@deffn {Scheme Procedure} keyword->symbol kw -Return a symbol with the same characters as in @var{kw}. -@end deffn - - -@node Keyword Primitives -@subsubsection Keyword Primitives - -Internally, a keyword is implemented as something like a tagged symbol, -where the tag identifies the keyword as being self-evaluating, and the -symbol, known as the keyword's @dfn{dash symbol} has the same name as -the keyword name but prefixed by a single dash. For example, the -keyword @code{#:name} has the corresponding dash symbol @code{-name}. - -Most keyword objects are constructed automatically by the reader when it -reads a token beginning with @code{#:}. However, if you need to -construct a keyword object programmatically, you can do so by calling -@code{make-keyword-from-dash-symbol} with the corresponding dash symbol -(as the reader does). The dash symbol for a keyword object can be -retrieved using the @code{keyword-dash-symbol} procedure. - -@deffn {Scheme Procedure} make-keyword-from-dash-symbol symbol -@deffnx {C Function} scm_make_keyword_from_dash_symbol (symbol) -Make a keyword object from a @var{symbol} that starts with a dash. -For example, - -@example -(make-keyword-from-dash-symbol '-foo) -@result{} #:foo -@end example -@end deffn - -@deffn {Scheme Procedure} keyword? obj -@deffnx {C Function} scm_keyword_p (obj) -Return @code{#t} if the argument @var{obj} is a keyword, else -@code{#f}. -@end deffn - -@deffn {Scheme Procedure} keyword-dash-symbol keyword -@deffnx {C Function} scm_keyword_dash_symbol (keyword) -Return the dash symbol for @var{keyword}. -This is the inverse of @code{make-keyword-from-dash-symbol}. -For example, - -@example -(keyword-dash-symbol #:foo) -@result{} -foo -@end example -@end deffn - -@deftypefn {C Function} SCM scm_c_make_keyword (char *@var{str}) -Make a keyword object from a string. For example, - -@example -scm_c_make_keyword ("foo") -@result{} #:foo -@end example -@c -@c FIXME: What can be said about the string argument? Currently it's -@c not used after creation, but should that be documented? -@end deftypefn - - -@node Other Types -@subsection ``Functionality-Centric'' Data Types - -Procedures and macros are documented in their own chapter: see -@ref{Procedures and Macros}. - -Variable objects are documented as part of the description of Guile's -module system: see @ref{Variables}. - -Asyncs, dynamic roots and fluids are described in the chapter on -scheduling: see @ref{Scheduling}. - -Hooks are documented in the chapter on general utility functions: see -@ref{Hooks}. - -Ports are described in the chapter on I/O: see @ref{Input and Output}. - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: From 34111015842eea10db6faeebea9eb100d06f188e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 24 Jul 2004 00:15:15 +0000 Subject: [PATCH 43/89] *** empty log message *** --- doc/ref/ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 9ae359e23..9360da2f1 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,12 @@ +2004-07-24 Kevin Ryde + + * scheme-data.texi (String Syntax): Add all backslash forms accepted. + (Regexp Functions): Use @defvar for regexp/icase etc, to emphasise + that they're variables not symbols etc. + + * srfi-modules.texi (SRFI-0): Revise for clarity, drop BNF in favour + of plain description, emphasise this is just for portable programs. + 2004-07-10 Marius Vollmer * scheme-data.texi (Integers): Talk more about inexact and exact From 30a80af9f554338a2a95e90b613cfcc7174c6a63 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 24 Jul 2004 00:17:50 +0000 Subject: [PATCH 44/89] (Frames): Add @findex for SCM_F_WIND_EXPLICITLY. --- doc/ref/scheme-control.texi | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/ref/scheme-control.texi b/doc/ref/scheme-control.texi index 20ea8dfa1..52aaa0d11 100644 --- a/doc/ref/scheme-control.texi +++ b/doc/ref/scheme-control.texi @@ -1167,6 +1167,7 @@ flags are listed in the following table. @table @code @item SCM_F_WIND_EXPLICITLY +@findex SCM_F_WIND_EXPLICITLY The registered action is also carried out when the frame is entered or left locally. @end table From 46b66e1a06dbb080072c645c9d5c6942a6376100 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 24 Jul 2004 00:19:27 +0000 Subject: [PATCH 45/89] Make it vindex instead: (Frames): Add @vindex for SCM_F_WIND_EXPLICITLY. --- doc/ref/scheme-control.texi | 1337 ----------------------------------- 1 file changed, 1337 deletions(-) diff --git a/doc/ref/scheme-control.texi b/doc/ref/scheme-control.texi index 52aaa0d11..e69de29bb 100644 --- a/doc/ref/scheme-control.texi +++ b/doc/ref/scheme-control.texi @@ -1,1337 +0,0 @@ -@c -*-texinfo-*- -@c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 -@c Free Software Foundation, Inc. -@c See the file guile.texi for copying conditions. - -@page -@node Control Mechanisms -@section Controlling the Flow of Program Execution - -See @ref{Control Flow} for a discussion of how the more general control -flow of Scheme affects C code. - -@menu -* begin:: Evaluating a sequence of expressions. -* if cond case:: Simple conditional evaluation. -* and or:: Conditional evaluation of a sequence. -* while do:: Iteration mechanisms. -* Continuations:: Continuations. -* Multiple Values:: Returning and accepting multiple values. -* Exceptions:: Throwing and catching exceptions. -* Error Reporting:: Procedures for signaling errors. -* Dynamic Wind:: Guarding against non-local entrance/exit. -* Frames:: Another way to handle non-localness -* Handling Errors:: How to handle errors in C code. -@end menu - -@node begin -@subsection Evaluating a Sequence of Expressions - -@cindex begin -@cindex sequencing -@cindex expression sequencing - -The @code{begin} syntax is used for grouping several expressions -together so that they are treated as if they were one expression. -This is particularly important when syntactic expressions are used -which only allow one expression, but the programmer wants to use more -than one expression in that place. As an example, consider the -conditional expression below: - -@lisp -(if (> x 0) - (begin (display "greater") (newline))) -@end lisp - -If the two calls to @code{display} and @code{newline} were not embedded -in a @code{begin}-statement, the call to @code{newline} would get -misinterpreted as the else-branch of the @code{if}-expression. - -@deffn syntax begin expr1 expr2 @dots{} -The expression(s) are evaluated in left-to-right order and the value -of the last expression is returned as the value of the -@code{begin}-expression. This expression type is used when the -expressions before the last one are evaluated for their side effects. - -Guile also allows the expression @code{(begin)}, a @code{begin} with no -sub-expressions. Such an expression returns the `unspecified' value. -@end deffn - -@node if cond case -@subsection Simple Conditional Evaluation - -@cindex conditional evaluation -@cindex if -@cindex case -@cindex cond - -Guile provides three syntactic constructs for conditional evaluation. -@code{if} is the normal if-then-else expression (with an optional else -branch), @code{cond} is a conditional expression with multiple branches -and @code{case} branches if an expression has one of a set of constant -values. - -@deffn syntax if test consequent [alternate] -All arguments may be arbitrary expressions. First, @var{test} is -evaluated. If it returns a true value, the expression @var{consequent} -is evaluated and @var{alternate} is ignored. If @var{test} evaluates to -@code{#f}, @var{alternate} is evaluated instead. The value of the -evaluated branch (@var{consequent} or @var{alternate}) is returned as -the value of the @code{if} expression. - -When @var{alternate} is omitted and the @var{test} evaluates to -@code{#f}, the value of the expression is not specified. -@end deffn - -@deffn syntax cond clause1 clause2 @dots{} -Each @code{cond}-clause must look like this: - -@lisp -(@var{test} @var{expression} @dots{}) -@end lisp - -where @var{test} and @var{expression} are arbitrary expression, or like -this - -@lisp -(@var{test} => @var{expression}) -@end lisp - -where @var{expression} must evaluate to a procedure. - -The @var{test}s of the clauses are evaluated in order and as soon as one -of them evaluates to a true values, the corresponding @var{expression}s -are evaluated in order and the last value is returned as the value of -the @code{cond}-expression. For the @code{=>} clause type, -@var{expression} is evaluated and the resulting procedure is applied to -the value of @var{test}. The result of this procedure application is -then the result of the @code{cond}-expression. - -The @var{test} of the last @var{clause} may be the symbol @code{else}. -Then, if none of the preceding @var{test}s is true, the -@var{expression}s following the @code{else} are evaluated to produce the -result of the @code{cond}-expression. -@end deffn - -@deffn syntax case key clause1 clause2 @dots{} -@var{key} may be any expression, the @var{clause}s must have the form - -@lisp -((@var{datum1} @dots{}) @var{expr1} @var{expr2} @dots{}) -@end lisp - -and the last @var{clause} may have the form - -@lisp -(else @var{expr1} @var{expr2} @dots{}) -@end lisp - -All @var{datum}s must be distinct. First, @var{key} is evaluated. The -the result of this evaluation is compared against all @var{datum}s using -@code{eqv?}. When this comparison succeeds, the expression(s) following -the @var{datum} are evaluated from left to right, returning the value of -the last expression as the result of the @code{case} expression. - -If the @var{key} matches no @var{datum} and there is an -@code{else}-clause, the expressions following the @code{else} are -evaluated. If there is no such clause, the result of the expression is -unspecified. -@end deffn - - -@node and or -@subsection Conditional Evaluation of a Sequence of Expressions - -@code{and} and @code{or} evaluate all their arguments in order, similar -to @code{begin}, but evaluation stops as soon as one of the expressions -evaluates to false or true, respectively. - -@deffn syntax and expr @dots{} -Evaluate the @var{expr}s from left to right and stop evaluation as soon -as one expression evaluates to @code{#f}; the remaining expressions are -not evaluated. The value of the last evaluated expression is returned. -If no expression evaluates to @code{#f}, the value of the last -expression is returned. - -If used without expressions, @code{#t} is returned. -@end deffn - -@deffn syntax or expr @dots{} -Evaluate the @var{expr}s from left to right and stop evaluation as soon -as one expression evaluates to a true value (that is, a value different -from @code{#f}); the remaining expressions are not evaluated. The value -of the last evaluated expression is returned. If all expressions -evaluate to @code{#f}, @code{#f} is returned. - -If used without expressions, @code{#f} is returned. -@end deffn - - -@node while do -@subsection Iteration mechanisms - -@cindex iteration -@cindex looping -@cindex named let - -Scheme has only few iteration mechanisms, mainly because iteration in -Scheme programs is normally expressed using recursion. Nevertheless, -R5RS defines a construct for programming loops, calling @code{do}. In -addition, Guile has an explicit looping syntax called @code{while}. - -@deffn syntax do ((variable init [step]) @dots{}) (test [expr @dots{}]) body @dots{} -Bind @var{variable}s and evaluate @var{body} until @var{test} is true. -The return value is the last @var{expr} after @var{test}, if given. A -simple example will illustrate the basic form, - -@example -(do ((i 1 (1+ i))) - ((> i 4)) - (display i)) -@print{} 1234 -@end example - -@noindent -Or with two variables and a final return value, - -@example -(do ((i 1 (1+ i)) - (p 3 (* 3 p))) - ((> i 4) - p) - (format #t "3**~s is ~s\n" i p)) -@print{} -3**1 is 3 -3**2 is 9 -3**3 is 27 -3**4 is 81 -@result{} -789 -@end example - -The @var{variable} bindings are established like a @code{let}, in that -the expressions are all evaluated and then all bindings made. When -iterating, the optional @var{step} expressions are evaluated with the -previous bindings in scope, then new bindings all made. - -The @var{test} expression is a termination condition. Looping stops -when the @var{test} is true. It's evaluated before running the -@var{body} each time, so if it's true the first time then @var{body} -is not run at all. - -The optional @var{expr}s after the @var{test} are evaluated at the end -of looping, with the final @var{variable} bindings available. The -last @var{expr} gives the return value, or if there are no @var{expr}s -the return value is unspecified. - -Each iteration establishes bindings to fresh locations for the -@var{variable}s, like a new @code{let} for each iteration. This is -done for @var{variable}s without @var{step} expressions too. The -following illustrates this, showing how a new @code{i} is captured by -the @code{lambda} in each iteration (@pxref{About Closure,, The -Concept of Closure}). - -@example -(define lst '()) -(do ((i 1 (1+ i))) - ((> i 4)) - (set! lst (cons (lambda () i) lst))) -(map (lambda (proc) (proc)) lst) -@result{} -(4 3 2 1) -@end example -@end deffn - -@deffn syntax while cond body @dots{} -Run a loop executing the @var{body} forms while @var{cond} is true. -@var{cond} is tested at the start of each iteration, so if it's -@code{#f} the first time then @var{body} is not executed at all. The -return value is unspecified. - -Within @code{while}, two extra bindings are provided, they can be used -from both @var{cond} and @var{body}. - -@deffn {Scheme Procedure} break -Break out of the @code{while} form. -@end deffn - -@deffn {Scheme Procedure} continue -Abandon the current iteration, go back to the start and test -@var{cond} again, etc. -@end deffn - -Each @code{while} form gets its own @code{break} and @code{continue} -procedures, operating on that @code{while}. This means when loops are -nested the outer @code{break} can be used to escape all the way out. -For example, - -@example -(while (test1) - (let ((outer-break break)) - (while (test2) - (if (something) - (outer-break #f)) - ...))) -@end example - -Note that each @code{break} and @code{continue} procedure can only be -used within the dynamic extent of its @code{while}. Outside the -@code{while} their behaviour is unspecified. -@end deffn - -@cindex named let -Another very common way of expressing iteration in Scheme programs is -the use of the so-called @dfn{named let}. - -Named let is a variant of @code{let} which creates a procedure and calls -it in one step. Because of the newly created procedure, named let is -more powerful than @code{do}--it can be used for iteration, but also -for arbitrary recursion. - -@deffn syntax let variable bindings body -For the definition of @var{bindings} see the documentation about -@code{let} (@pxref{Local Bindings}). - -Named @code{let} works as follows: - -@itemize @bullet -@item -A new procedure which accepts as many arguments as are in @var{bindings} -is created and bound locally (using @code{let}) to @var{variable}. The -new procedure's formal argument names are the name of the -@var{variables}. - -@item -The @var{body} expressions are inserted into the newly created procedure. - -@item -The procedure is called with the @var{init} expressions as the formal -arguments. -@end itemize - -The next example implements a loop which iterates (by recursion) 1000 -times. - -@lisp -(let lp ((x 1000)) - (if (positive? x) - (lp (- x 1)) - x)) -@result{} -0 -@end lisp -@end deffn - - -@node Continuations -@subsection Continuations -@cindex continuations - -A ``continuation'' is the code that will execute when a given function -or expression returns. For example, consider - -@example -(define (foo) - (display "hello\n") - (display (bar)) (newline) - (exit)) -@end example - -The continuation from the call to @code{bar} comprises a -@code{display} of the value returned, a @code{newline} and an -@code{exit}. This can be expressed as a function of one argument. - -@example -(lambda (r) - (display r) (newline) - (exit)) -@end example - -In Scheme, continuations are represented as special procedures just -like this. The special property is that when a continuation is called -it abandons the current program location and jumps directly to that -represented by the continuation. - -A continuation is like a dynamic label, capturing at run-time a point -in program execution, including all the nested calls that have lead to -it (or rather the code that will execute when those calls return). - -Continuations are created with the following functions. - -@deffn {Scheme Procedure} call-with-current-continuation proc -@deffnx {Scheme Procedure} call/cc proc -@rnindex call-with-current-continuation -Capture the current continuation and call @code{(@var{proc} -@var{cont})} with it. The return value is the value returned by -@var{proc}, or when @code{(@var{cont} @var{value})} is later invoked, -the return is the @var{value} passed. - -Normally @var{cont} should be called with one argument, but when the -location resumed is expecting multiple values (@pxref{Multiple -Values}) then they should be passed as multiple arguments, for -instance @code{(@var{cont} @var{x} @var{y} @var{z})}. - -@var{cont} may only be used from the dynamic root in which it was -created (@pxref{Dynamic Roots}), and in a multi-threaded program only -from the thread in which it was created, since each thread is a -separate dynamic root. - -The call to @var{proc} is not part of the continuation captured, it runs -only when the continuation is created. Often a program will want to -store @var{cont} somewhere for later use; this can be done in -@var{proc}. - -The @code{call} in the name @code{call-with-current-continuation} -refers to the way a call to @var{proc} gives the newly created -continuation. It's not related to the way a call is used later to -invoke that continuation. - -@code{call/cc} is an alias for @code{call-with-current-continuation}. -This is in common use since the latter is rather long. -@end deffn - -@deftypefn {C Function} SCM scm_make_continuation (int *first) -Capture the current continuation as described above. The return value -is the new continuation, and @var{*first} is set to 1. - -When the continuation is invoked, @code{scm_make_continuation} will -return again, this time returning the value (or set of multiple -values) passed in that invocation, and with @var{*first} set to 0. -@end deftypefn - -@sp 1 -@noindent -Here is a simple example, - -@example -(define kont #f) -(format #t "the return is ~a\n" - (call/cc (lambda (k) - (set! kont k) - 1))) -@result{} the return is 1 - -(kont 2) -@result{} the return is 2 -@end example - -@code{call/cc} captures a continuation in which the value returned is -going to be displayed by @code{format}. The @code{lambda} stores this -in @code{kont} and gives an initial return @code{1} which is -displayed. The later invocation of @code{kont} resumes the captured -point, but this time returning @code{2}, which is displayed. - -When Guile is run interactively, a call to @code{format} like this has -an implicit return back to the read-eval-print loop. @code{call/cc} -captures that like any other return, which is why interactively -@code{kont} will come back to read more input. - -@sp 1 -C programmers may note that @code{call/cc} is like @code{setjmp} in -the way it records at runtime a point in program execution. A call to -a continuation is like a @code{longjmp} in that it abandons the -present location and goes to the recorded one. Like @code{longjmp}, -the value passed to the continuation is the value returned by -@code{call/cc} on resuming there. However @code{longjmp} can only go -up the program stack, but the continuation mechanism can go anywhere. - -When a continuation is invoked, @code{call/cc} and subsequent code -effectively ``returns'' a second time. It can be confusing to imagine -a function returning more times than it was called. It may help -instead to think of it being stealthily re-entered and then program -flow going on as normal. - -@code{dynamic-wind} (@pxref{Dynamic Wind}) can be used to ensure setup -and cleanup code is run when a program locus is resumed or abandoned -through the continuation mechanism. C code can use @dfn{frames} -(@pxref{Frames}). - -@sp 1 -Continuations are a powerful mechanism, and can be used to implement -almost any sort of control structure, such as loops, coroutines, or -exception handlers. - -However the implementation of continuations in Guile is not as -efficient as one might hope, because Guile is designed to cooperate -with programs written in other languages, such as C, which do not know -about continuations. Basically continuations are captured by a block -copy of the stack, and resumed by copying back. - -For this reason, generally continuations should be used only when -there is no other simple way to achieve the desired result, or when -the elegance of the continuation mechanism outweighs the need for -performance. - -Escapes upwards from loops or nested functions are generally best -handled with exceptions (@pxref{Exceptions}). Coroutines can be -efficiently implemented with cooperating threads (a thread holds a -full program stack but doesn't copy it around the way continuations -do). - - -@node Multiple Values -@subsection Returning and Accepting Multiple Values - -@cindex multiple values -@cindex receive - -Scheme allows a procedure to return more than one value to its caller. -This is quite different to other languages which only allow -single-value returns. Returning multiple values is different from -returning a list (or pair or vector) of values to the caller, because -conceptually not @emph{one} compound object is returned, but several -distinct values. - -The primitive procedures for handling multiple values are @code{values} -and @code{call-with-values}. @code{values} is used for returning -multiple values from a procedure. This is done by placing a call to -@code{values} with zero or more arguments in tail position in a -procedure body. @code{call-with-values} combines a procedure returning -multiple values with a procedure which accepts these values as -parameters. - -@rnindex values -@deffn {Scheme Procedure} values arg1 @dots{} argN -@deffnx {C Function} scm_values (args) -Delivers all of its arguments to its continuation. Except for -continuations created by the @code{call-with-values} procedure, -all continuations take exactly one value. The effect of -passing no value or more than one value to continuations that -were not created by @code{call-with-values} is unspecified. - -For @code{scm_values}, @var{args} is a list of arguments and the -return is a multiple-values object which the caller can return. In -the current implementation that object shares structure with -@var{args}, so @var{args} should not be modified subsequently. -@end deffn - -@rnindex call-with-values -@deffn {Scheme Procedure} call-with-values producer consumer -Calls its @var{producer} argument with no values and a -continuation that, when passed some values, calls the -@var{consumer} procedure with those values as arguments. The -continuation for the call to @var{consumer} is the continuation -of the call to @code{call-with-values}. - -@example -(call-with-values (lambda () (values 4 5)) - (lambda (a b) b)) -@result{} 5 - -@end example -@example -(call-with-values * -) -@result{} -1 -@end example -@end deffn - -In addition to the fundamental procedures described above, Guile has a -module which exports a syntax called @code{receive}, which is much more -convenient. If you want to use it in your programs, you have to load -the module @code{(ice-9 receive)} with the statement - -@lisp -(use-modules (ice-9 receive)) -@end lisp - -@deffn {library syntax} receive formals expr body @dots{} -Evaluate the expression @var{expr}, and bind the result values (zero or -more) to the formal arguments in the formal argument list @var{formals}. -@var{formals} must have the same syntax like the formal argument list -used in @code{lambda} (@pxref{Lambda}). After binding the variables, -the expressions in @var{body} @dots{} are evaluated in order. -@end deffn - - -@node Exceptions -@subsection Exceptions -@cindex error handling -@cindex exception handling - -A common requirement in applications is to want to jump -@dfn{non-locally} from the depths of a computation back to, say, the -application's main processing loop. Usually, the place that is the -target of the jump is somewhere in the calling stack of procedures that -called the procedure that wants to jump back. For example, typical -logic for a key press driven application might look something like this: - -@example -main-loop: - read the next key press and call dispatch-key - -dispatch-key: - lookup the key in a keymap and call an appropriate procedure, - say find-file - -find-file: - interactively read the required file name, then call - find-specified-file - -find-specified-file: - check whether file exists; if not, jump back to main-loop - @dots{} -@end example - -The jump back to @code{main-loop} could be achieved by returning through -the stack one procedure at a time, using the return value of each -procedure to indicate the error condition, but Guile (like most modern -programming languages) provides an additional mechanism called -@dfn{exception handling} that can be used to implement such jumps much -more conveniently. - -@menu -* Exception Terminology:: Different ways to say the same thing. -* Catch:: Setting up to catch exceptions. -* Throw:: Throwing an exception. -* Lazy Catch:: Catch without unwinding the stack. -* Exception Implementation:: How Guile implements exceptions. -@end menu - - -@node Exception Terminology -@subsubsection Exception Terminology - -There are several variations on the terminology for dealing with -non-local jumps. It is useful to be aware of them, and to realize -that they all refer to the same basic mechanism. - -@itemize @bullet -@item -Actually making a non-local jump may be called @dfn{raising an -exception}, @dfn{raising a signal}, @dfn{throwing an exception} or -@dfn{doing a long jump}. When the jump indicates an error condition, -people may talk about @dfn{signalling}, @dfn{raising} or @dfn{throwing} -@dfn{an error}. - -@item -Handling the jump at its target may be referred to as @dfn{catching} or -@dfn{handling} the @dfn{exception}, @dfn{signal} or, where an error -condition is involved, @dfn{error}. -@end itemize - -Where @dfn{signal} and @dfn{signalling} are used, special care is needed -to avoid the risk of confusion with POSIX signals. - -This manual prefers to speak of throwing and catching exceptions, since -this terminology matches the corresponding Guile primitives. - - -@node Catch -@subsubsection Catching Exceptions - -@code{catch} is used to set up a target for a possible non-local jump. -The arguments of a @code{catch} expression are a @dfn{key}, which -restricts the set of exceptions to which this @code{catch} applies, a -thunk that specifies the code to execute and a @dfn{handler} procedure -that says what to do if an exception is thrown while executing the code. -Note that if the execution thunk executes @dfn{normally}, which means -without throwing any exceptions, the handler procedure is not called at -all. - -When an exception is thrown using the @code{throw} function, the first -argument of the @code{throw} is a symbol that indicates the type of the -exception. For example, Guile throws an exception using the symbol -@code{numerical-overflow} to indicate numerical overflow errors such as -division by zero: - -@lisp -(/ 1 0) -@result{} -ABORT: (numerical-overflow) -@end lisp - -The @var{key} argument in a @code{catch} expression corresponds to this -symbol. @var{key} may be a specific symbol, such as -@code{numerical-overflow}, in which case the @code{catch} applies -specifically to exceptions of that type; or it may be @code{#t}, which -means that the @code{catch} applies to all exceptions, irrespective of -their type. - -The second argument of a @code{catch} expression should be a thunk -(i.e. a procedure that accepts no arguments) that specifies the normal -case code. The @code{catch} is active for the execution of this thunk, -including any code called directly or indirectly by the thunk's body. -Evaluation of the @code{catch} expression activates the catch and then -calls this thunk. - -The third argument of a @code{catch} expression is a handler procedure. -If an exception is thrown, this procedure is called with exactly the -arguments specified by the @code{throw}. Therefore, the handler -procedure must be designed to accept a number of arguments that -corresponds to the number of arguments in all @code{throw} expressions -that can be caught by this @code{catch}. - -@deffn {Scheme Procedure} catch key thunk handler -@deffnx {C Function} scm_catch (key, thunk, handler) -Invoke @var{thunk} in the dynamic context of @var{handler} for -exceptions matching @var{key}. If thunk throws to the symbol -@var{key}, then @var{handler} is invoked this way: -@lisp -(handler key args ...) -@end lisp - -@var{key} is a symbol or @code{#t}. - -@var{thunk} takes no arguments. If @var{thunk} returns -normally, that is the return value of @code{catch}. - -Handler is invoked outside the scope of its own @code{catch}. -If @var{handler} again throws to the same key, a new handler -from further up the call chain is invoked. - -If the key is @code{#t}, then a throw to @emph{any} symbol will -match this call to @code{catch}. -@end deffn - -If the handler procedure needs to match a variety of @code{throw} -expressions with varying numbers of arguments, you should write it like -this: - -@lisp -(lambda (key . args) - @dots{}) -@end lisp - -@noindent -The @var{key} argument is guaranteed always to be present, because a -@code{throw} without a @var{key} is not valid. The number and -interpretation of the @var{args} varies from one type of exception to -another, but should be specified by the documentation for each exception -type. - -Note that, once the handler procedure is invoked, the catch that led to -the handler procedure being called is no longer active. Therefore, if -the handler procedure itself throws an exception, that exception can -only be caught by another active catch higher up the call stack, if -there is one. - -@sp 1 -@deftypefn {C Function} SCM scm_internal_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data) -The above @code{scm_catch} takes Scheme procedures as body and handler -arguments. @code{scm_internal_catch} is an equivalent taking C -functions. - -@var{body} is called as @code{@var{body} (@var{body_data})} with a -catch on exceptions of the given @var{tag} type. If an exception is -caught, @var{handler} is called @code{@var{handler} -(@var{handler_data}, @var{key}, @var{args})}. @var{key} and -@var{args} are the @code{SCM} key and argument list from the -@code{throw}. - -@tpindex scm_t_catch_body -@tpindex scm_t_catch_handler -@var{body} and @var{handler} should have the following prototypes. -@code{scm_t_catch_body} and @code{scm_t_catch_handler} are pointer -typedefs for these. - -@example -SCM body (void *data); -SCM handler (void *data, SCM key, SCM args); -@end example - -The @var{body_data} and @var{handler_data} parameters are passed to -the respective calls so an application can communicate extra -information to those functions. - -If the data consists of an @code{SCM} object, care should be taken -that it isn't garbage collected while still required. If the -@code{SCM} is a local C variable, one way to protect it is to pass a -pointer to that variable as the data parameter, since the C compiler -will then know the value must be held on the stack. Another way is to -use @code{scm_remember_upto_here_1} (@pxref{Remembering During -Operations}). -@end deftypefn - - -@node Throw -@subsubsection Throwing Exceptions - -The @code{throw} primitive is used to throw an exception. One argument, -the @var{key}, is mandatory, and must be a symbol; it indicates the type -of exception that is being thrown. Following the @var{key}, -@code{throw} accepts any number of additional arguments, whose meaning -depends on the exception type. The documentation for each possible type -of exception should specify the additional arguments that are expected -for that kind of exception. - -@deffn {Scheme Procedure} throw key . args -@deffnx {C Function} scm_throw (key, args) -Invoke the catch form matching @var{key}, passing @var{args} to the -@var{handler}. - -@var{key} is a symbol. It will match catches of the same symbol or of -@code{#t}. - -If there is no handler at all, Guile prints an error and then exits. -@end deffn - -When an exception is thrown, it will be caught by the innermost -@code{catch} expression that applies to the type of the thrown -exception; in other words, the innermost @code{catch} whose @var{key} is -@code{#t} or is the same symbol as that used in the @code{throw} -expression. Once Guile has identified the appropriate @code{catch}, it -handles the exception by applying that @code{catch} expression's handler -procedure to the arguments of the @code{throw}. - -If there is no appropriate @code{catch} for a thrown exception, Guile -prints an error to the current error port indicating an uncaught -exception, and then exits. In practice, it is quite difficult to -observe this behaviour, because Guile when used interactively installs a -top level @code{catch} handler that will catch all exceptions and print -an appropriate error message @emph{without} exiting. For example, this -is what happens if you try to throw an unhandled exception in the -standard Guile REPL; note that Guile's command loop continues after the -error message: - -@lisp -guile> (throw 'badex) -:3:1: In procedure gsubr-apply @dots{} -:3:1: unhandled-exception: badex -ABORT: (misc-error) -guile> -@end lisp - -The default uncaught exception behaviour can be observed by evaluating a -@code{throw} expression from the shell command line: - -@example -$ guile -c "(begin (throw 'badex) (display \"here\\n\"))" -guile: uncaught throw to badex: () -$ -@end example - -@noindent -That Guile exits immediately following the uncaught exception -is shown by the absence of any output from the @code{display} -expression, because Guile never gets to the point of evaluating that -expression. - - -@node Lazy Catch -@subsubsection Catch Without Unwinding - -A @dfn{lazy catch} is used in the same way as a normal @code{catch}, -with @var{key}, @var{thunk} and @var{handler} arguments specifying the -exception type, normal case code and handler procedure, but differs in -one important respect: the handler procedure is executed without -unwinding the call stack from the context of the @code{throw} expression -that caused the handler to be invoked. - -@deffn {Scheme Procedure} lazy-catch key thunk handler -@deffnx {C Function} scm_lazy_catch (key, thunk, handler) -This behaves exactly like @code{catch}, except that it does -not unwind the stack before invoking @var{handler}. -The @var{handler} procedure is not allowed to return: -it must throw to another catch, or otherwise exit non-locally. -@end deffn - -@deftypefn {C Function} SCM scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data) -The above @code{scm_lazy_catch} takes Scheme procedures as body and -handler arguments. @code{scm_internal_lazy_catch} is an equivalent -taking C functions. See @code{scm_internal_catch} (@pxref{Catch}) for -a description of the parameters, the behaviour however of course -follows @code{lazy-catch}. -@end deftypefn - -Typically, @var{handler} should save any desired state associated with -the stack at the point where the corresponding @code{throw} occurred, -and then throw an exception itself --- usually the same exception as the -one it caught. If @var{handler} is invoked and does @emph{not} throw an -exception, Guile itself throws an exception with key @code{misc-error}. - -Not unwinding the stack means that throwing an exception that is caught -by a @code{lazy-catch} is @emph{almost} equivalent to calling the -@code{lazy-catch}'s handler inline instead of each @code{throw}, and -then omitting the surrounding @code{lazy-catch}. In other words, - -@lisp -(lazy-catch 'key - (lambda () @dots{} (throw 'key args @dots{}) @dots{}) - handler) -@end lisp - -@noindent -is @emph{almost} equivalent to - -@lisp -((lambda () @dots{} (handler 'key args @dots{}) @dots{})) -@end lisp - -@noindent -But why only @emph{almost}? The difference is that with -@code{lazy-catch} (as with normal @code{catch}), the dynamic context is -unwound back to just outside the @code{lazy-catch} expression before -invoking the handler. (For an introduction to what is meant by dynamic -context, @xref{Dynamic Wind}.) - -Then, when the handler @emph{itself} throws an exception, that exception -must be caught by some kind of @code{catch} (including perhaps another -@code{lazy-catch}) higher up the call stack. - -The dynamic context also includes @code{with-fluids} blocks (REFFIXME), -so the effect of unwinding the dynamic context can also be seen in fluid -variable values. This is illustrated by the following code, in which -the normal case thunk uses @code{with-fluids} to temporarily change the -value of a fluid: - -@lisp -(define f (make-fluid)) -(fluid-set! f "top level value") - -(define (handler . args) - (cons (fluid-ref f) args)) - -(lazy-catch 'foo - (lambda () - (with-fluids ((f "local value")) - (throw 'foo))) - handler) -@result{} -("top level value" foo) - -((lambda () - (with-fluids ((f "local value")) - (handler 'foo)))) -@result{} -("local value" foo) -@end lisp - -@noindent -In the @code{lazy-catch} version, the unwinding of dynamic context -restores @code{f} to its value outside the @code{with-fluids} block -before the handler is invoked, so the handler's @code{(fluid-ref f)} -returns the external value. - -@code{lazy-catch} is useful because it permits the implementation of -debuggers and other reflective programming tools that need to access the -state of the call stack at the exact point where an exception or an -error is thrown. For an example of this, see REFFIXME:stack-catch. - - -@node Exception Implementation -@subsubsection How Guile Implements Exceptions - -It is traditional in Scheme to implement exception systems using -@code{call-with-current-continuation}. Continuations -(@pxref{Continuations}) are such a powerful concept that any other -control mechanism --- including @code{catch} and @code{throw} --- can be -implemented in terms of them. - -Guile does not implement @code{catch} and @code{throw} like this, -though. Why not? Because Guile is specifically designed to be easy to -integrate with applications written in C. In a mixed Scheme/C -environment, the concept of @dfn{continuation} must logically include -``what happens next'' in the C parts of the application as well as the -Scheme parts, and it turns out that the only reasonable way of -implementing continuations like this is to save and restore the complete -C stack. - -So Guile's implementation of @code{call-with-current-continuation} is a -stack copying one. This allows it to interact well with ordinary C -code, but means that creating and calling a continuation is slowed down -by the time that it takes to copy the C stack. - -The more targeted mechanism provided by @code{catch} and @code{throw} -does not need to save and restore the C stack because the @code{throw} -always jumps to a location higher up the stack of the code that executes -the @code{throw}. Therefore Guile implements the @code{catch} and -@code{throw} primitives independently of -@code{call-with-current-continuation}, in a way that takes advantage of -this @emph{upwards only} nature of exceptions. - - -@node Error Reporting -@subsection Procedures for Signaling Errors - -Guile provides a set of convenience procedures for signaling error -conditions that are implemented on top of the exception primitives just -described. - -@deffn {Scheme Procedure} error msg args @dots{} -Raise an error with key @code{misc-error} and a message constructed by -displaying @var{msg} and writing @var{args}. -@end deffn - -@deffn {Scheme Procedure} scm-error key subr message args data -@deffnx {C Function} scm_error_scm (key, subr, message, args, data) -Raise an error with key @var{key}. @var{subr} can be a string -naming the procedure associated with the error, or @code{#f}. -@var{message} is the error message string, possibly containing -@code{~S} and @code{~A} escapes. When an error is reported, -these are replaced by formatting the corresponding members of -@var{args}: @code{~A} (was @code{%s} in older versions of -Guile) formats using @code{display} and @code{~S} (was -@code{%S}) formats using @code{write}. @var{data} is a list or -@code{#f} depending on @var{key}: if @var{key} is -@code{system-error} then it should be a list containing the -Unix @code{errno} value; If @var{key} is @code{signal} then it -should be a list containing the Unix signal number; otherwise -it will usually be @code{#f}. -@end deffn - -@deffn {Scheme Procedure} strerror err -@deffnx {C Function} scm_strerror (err) -Return the Unix error message corresponding to @var{err}, which -must be an integer value. -@end deffn - -@c begin (scm-doc-string "boot-9.scm" "false-if-exception") -@deffn syntax false-if-exception expr -Returns the result of evaluating its argument; however -if an exception occurs then @code{#f} is returned instead. -@end deffn -@c end - - -@node Dynamic Wind -@subsection Dynamic Wind - -@rnindex dynamic-wind -@deffn {Scheme Procedure} dynamic-wind in_guard thunk out_guard -@deffnx {C Function} scm_dynamic_wind (in_guard, thunk, out_guard) -All three arguments must be 0-argument procedures. -@var{in_guard} is called, then @var{thunk}, then -@var{out_guard}. - -If, any time during the execution of @var{thunk}, the -dynamic extent of the @code{dynamic-wind} expression is escaped -non-locally, @var{out_guard} is called. If the dynamic extent of -the dynamic-wind is re-entered, @var{in_guard} is called. Thus -@var{in_guard} and @var{out_guard} may be called any number of -times. -@lisp -(define x 'normal-binding) -@result{} x -(define a-cont (call-with-current-continuation - (lambda (escape) - (let ((old-x x)) - (dynamic-wind - ;; in-guard: - ;; - (lambda () (set! x 'special-binding)) - - ;; thunk - ;; - (lambda () (display x) (newline) - (call-with-current-continuation escape) - (display x) (newline) - x) - - ;; out-guard: - ;; - (lambda () (set! x old-x))))))) - -;; Prints: -special-binding -;; Evaluates to: -@result{} a-cont -x -@result{} normal-binding -(a-cont #f) -;; Prints: -special-binding -;; Evaluates to: -@result{} a-cont ;; the value of the (define a-cont...) -x -@result{} normal-binding -a-cont -@result{} special-binding -@end lisp -@end deffn - -@node Frames -@subsection Frames - -For Scheme code, the fundamental procedure to react to non-local entry -and exits of dynamic contexts is @code{dynamic-wind}. C code could use -@code{scm_internal_dynamic_wind}, but since C does not allow the -convenient construction of anonymous procedures that close over lexical -variables, this will be, well, inconvenient. Instead, C code can use -@dfn{frames}. - -Guile offers the functions @code{scm_frame_begin} and -@code{scm_frame_end} to delimit a dynamic extent. Within this dynamic -extent, which is called a @dfn{frame}, you can perform various -@dfn{frame actions} that control what happens when the frame is entered -or left. For example, you can register a cleanup routine with -@code{scm_frame_unwind} that is executed when the frame is left. There are -several other more specialized frame actions as well, for example to -temporarily block the execution of asyncs or to temporarily change the -current output port. They are described elsewhere in this manual. - -Here is an example that shows how to prevent memory leaks. - -@example - -/* Suppose there is a function called FOO in some library that you - would like to make available to Scheme code (or to C code that - follows the Scheme conventions). - - FOO takes two C strings and returns a new string. When an error has - occurred in FOO, it returns NULL. -*/ - -char *foo (char *s1, char *s2); - -/* SCM_FOO interfaces the C function FOO to the Scheme way of life. - It takes care to free up all temporary strings in the case of - non-local exits. - - It uses SCM_TO_STRING as a helper procedure. - */ - -char * -scm_to_string (SCM obj) -@{ - if (SCM_STRINGP (obj)) - @{ - char *res = scm_malloc (SCM_STRING_LENGTH (obj)+1); - strcpy (res, SCM_STRING_CHARS (obj)); - scm_remember_upto_here_1 (obj); - return res; - @} - else - scm_wrong_type_arg ("scm_to_string", 1, obj); -@} - -SCM -scm_foo (SCM s1, SCM s2) -@{ - char *c_s1, *c_s2, *c_res; - - scm_frame_begin (0); - - c_s1 = scm_to_string (s1); - scm_frame_unwind_handler (free, c_s1, SCM_F_WIND_EXPLICITLY); - - c_s2 = scm_to_string (s2); - scm_frame_unwind_handler (free, c_s2, SCM_F_WIND_EXPLICITLY); - - c_res = foo (c_s1, c_s2); - if (c_res == NULL) - scm_memory_error ("foo"); - - scm_frame_end (); - - return scm_take0str (res); -@} -@end example - -@deftp {C Type} scm_t_frame_flags -This is an enumeration of several flags that modify the behavior of -@code{scm_begin_frame}. The flags are listed in the following table. - -@table @code -@item SCM_F_FRAME_REWINDABLE -The frame is @dfn{rewindable}. This means that it can be reentered -non-locally (via the invokation of a continuation). The default is that -a frame can not be reentered non-locally. -@end table - -@end deftp - -@deftypefn {C Function} void scm_frame_begin (scm_t_frame_flags flags) -The function @code{scm_begin_frame} starts a new frame and makes it the -`current' one. - -The @var{flags} argument determines the default behavior of the frame. -For normal frames, use 0. This will result in a frame that can not be -reentered with a captured continuation. When you are prepared to handle -reentries, include @code{SCM_F_FRAME_REWINDABLE} in @var{flags}. - -Being prepared for reentry means that the effects of unwind handlers -can be undone on reentry. In the example above, we want to prevent a -memory leak on non-local exit and thus register an unwind handler that -frees the memory. But once the memory is freed, we can not get it -back on reentry. Thus reentry can not be allowed. - -The consequence is that continuations become less useful when -non-reenterable frames are captured, but you don't need to worry about -that too much. - -The frame is ended either implicitly when a non-local exit happens, or -explicitly with @code{scm_end_frame}. You must make sure that a frame -is indeed ended properly. If you fail to call @code{scm_end_frame} -for each @code{scm_begin_frame}, the behavior is undefined. -@end deftypefn - -@deftypefn {C Function} void scm_frame_end () -End the current frame explicitly and make the previous frame current. -@end deftypefn - -@deftp {C Type} scm_t_wind_flags -This is an enumeration of several flags that modify the behavior of -@code{scm_on_unwind_handler} and @code{scm_on_rewind_handler}. The -flags are listed in the following table. - -@table @code -@item SCM_F_WIND_EXPLICITLY -@findex SCM_F_WIND_EXPLICITLY -The registered action is also carried out when the frame is entered or -left locally. -@end table -@end deftp - -@deftypefn {C Function} void scm_frame_unwind_handler (void (*func)(void *), void *data, scm_t_wind_flags flags) -@deftypefnx {C Function} void scm_frame_unwind_handler_with_scm (void (*func)(SCM), SCM data, scm_t_wind_flags flags) -Arranges for @var{func} to be called with @var{data} as its arguments -when the current frame ends implicitly. If @var{flags} contains -@code{SCM_F_WIND_EXPLICITLY}, @var{func} is also called when the frame -ends explicitly with @code{scm_frame_end}. - -The function @code{scm_frame_unwind_handler_with_scm} takes care that -@var{data} is protected from garbage collection. -@end deftypefn - -@deftypefn {C Function} void scm_frame_rewind_handler (void (*func)(void *), void *data, scm_t_wind_flags flags) -@deftypefnx {C Function} void scm_frame_rewind_handler_with_scm (void (*func)(SCM), SCM data, scm_t_wind_flags flags) -Arrange for @var{func} to be called with @var{data} as its argument when -the current frame is restarted by rewinding the stack. When @var{flags} -contains @code{SCM_F_WIND_EXPLICITLY}, @var{func} is called immediately -as well. - -The function @code{scm_frame_rewind_handler_with_scm} takes care that -@var{data} is protected from garbage collection. -@end deftypefn - - -@node Handling Errors -@subsection How to Handle Errors - -Error handling is based on @code{catch} and @code{throw}. Errors are -always thrown with a @var{key} and four arguments: - -@itemize @bullet -@item -@var{key}: a symbol which indicates the type of error. The symbols used -by libguile are listed below. - -@item -@var{subr}: the name of the procedure from which the error is thrown, or -@code{#f}. - -@item -@var{message}: a string (possibly language and system dependent) -describing the error. The tokens @code{~A} and @code{~S} can be -embedded within the message: they will be replaced with members of the -@var{args} list when the message is printed. @code{~A} indicates an -argument printed using @code{display}, while @code{~S} indicates an -argument printed using @code{write}. @var{message} can also be -@code{#f}, to allow it to be derived from the @var{key} by the error -handler (may be useful if the @var{key} is to be thrown from both C and -Scheme). - -@item -@var{args}: a list of arguments to be used to expand @code{~A} and -@code{~S} tokens in @var{message}. Can also be @code{#f} if no -arguments are required. - -@item -@var{rest}: a list of any additional objects required. e.g., when the -key is @code{'system-error}, this contains the C errno value. Can also -be @code{#f} if no additional objects are required. -@end itemize - -In addition to @code{catch} and @code{throw}, the following Scheme -facilities are available: - -@deffn {Scheme Procedure} display-error stack port subr message args rest -@deffnx {C Function} scm_display_error (stack, port, subr, message, args, rest) -Display an error message to the output port @var{port}. -@var{stack} is the saved stack for the error, @var{subr} is -the name of the procedure in which the error occurred and -@var{message} is the actual error message, which may contain -formatting instructions. These will format the arguments in -the list @var{args} accordingly. @var{rest} is currently -ignored. -@end deffn - -The following are the error keys defined by libguile and the situations -in which they are used: - -@itemize @bullet -@item -@cindex @code{error-signal} -@code{error-signal}: thrown after receiving an unhandled fatal signal -such as SIGSEGV, SIGBUS, SIGFPE etc. The @var{rest} argument in the throw -contains the coded signal number (at present this is not the same as the -usual Unix signal number). - -@item -@cindex @code{system-error} -@code{system-error}: thrown after the operating system indicates an -error condition. The @var{rest} argument in the throw contains the -errno value. - -@item -@cindex @code{numerical-overflow} -@code{numerical-overflow}: numerical overflow. - -@item -@cindex @code{out-of-range} -@code{out-of-range}: the arguments to a procedure do not fall within the -accepted domain. - -@item -@cindex @code{wrong-type-arg} -@code{wrong-type-arg}: an argument to a procedure has the wrong type. - -@item -@cindex @code{wrong-number-of-args} -@code{wrong-number-of-args}: a procedure was called with the wrong number -of arguments. - -@item -@cindex @code{memory-allocation-error} -@code{memory-allocation-error}: memory allocation error. - -@item -@cindex @code{stack-overflow} -@code{stack-overflow}: stack overflow error. - -@item -@cindex @code{regular-expression-syntax} -@code{regular-expression-syntax}: errors generated by the regular -expression library. - -@item -@cindex @code{misc-error} -@code{misc-error}: other errors. -@end itemize - - -@subsubsection C Support - -In the following C functions, @var{SUBR} and @var{MESSAGE} parameters -can be @code{NULL} to give the effect of @code{#f} described above. - -@deftypefn {C Function} SCM scm_error (SCM @var{key}, char *@var{subr}, char *@var{message}, SCM @var{args}, SCM @var{rest}) -Throw an error, as per @code{scm-error} above. -@end deftypefn - -@deftypefn {C Function} void scm_syserror (char *@var{subr}) -@deftypefnx {C Function} void scm_syserror_msg (char *@var{subr}, char *@var{message}, SCM @var{args}) -Throw an error with key @code{system-error} and supply @code{errno} in -the @var{rest} argument. For @code{scm_syserror} the message is -generated using @code{strerror}. - -Care should be taken that any code in between the failing operation -and the call to these routines doesn't change @code{errno}. -@end deftypefn - -@deftypefn {C Function} void scm_num_overflow (char *@var{subr}) -@deftypefnx {C Function} void scm_out_of_range (char *@var{subr}, SCM @var{bad_value}) -@deftypefnx {C Function} void scm_wrong_num_args (SCM @var{proc}) -@deftypefnx {C Function} void scm_wrong_type_arg (char *@var{subr}, int @var{argnum}, SCM @var{bad_value}) -@deftypefnx {C Function} void scm_memory_error (char *@var{subr}) -Throw an error with the various keys described above. - -For @code{scm_wrong_num_args}, @var{proc} should be a Scheme symbol -which is the name of the procedure incorrectly invoked. -@end deftypefn - - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: From 6df2ef3bafe45598e3100cd86a88b3251034b5c3 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 24 Jul 2004 00:21:43 +0000 Subject: [PATCH 46/89] (Smobs): In SCM_SMOB_OBJECT_LOC, SCM_SMOB_OBJECT_2_LOC, SCM_SMOB_OBJECT_3_LOC, use {} to avoid "*" getting into the index as part of the macro name. --- doc/ref/scheme-smobs.texi | 185 -------------------------------------- 1 file changed, 185 deletions(-) diff --git a/doc/ref/scheme-smobs.texi b/doc/ref/scheme-smobs.texi index 61e9b0e4a..e69de29bb 100644 --- a/doc/ref/scheme-smobs.texi +++ b/doc/ref/scheme-smobs.texi @@ -1,185 +0,0 @@ -@c -*-texinfo-*- -@c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 -@c Free Software Foundation, Inc. -@c See the file guile.texi for copying conditions. - -@page -@node Smobs -@section Smobs - -This chapter contains reference information related to defining and -working with smobs. See @ref{Defining New Types (Smobs)} for a -tutorial-like introduction to smobs. - -@deftypefun scm_t_bits scm_make_smob_type (const char *name, size_t size) -This function adds a new smob type, named @var{name}, with instance size -@var{size}, to the system. The return value is a tag that is used in -creating instances of the type. - -If @var{size} is 0, the default @emph{free} function will do nothing. - -If @var{size} is not 0, the default @emph{free} function will -deallocate the memory block pointed to by @code{SCM_SMOB_DATA} with -@code{scm_gc_free}. The @var{WHAT} parameter in the call to -@code{scm_gc_free} will be @var{NAME}. - -Default values are provided for the @emph{mark}, @emph{free}, -@emph{print}, and @emph{equalp} functions, as described in -@ref{Defining New Types (Smobs)}. If you want to customize any of -these functions, the call to @code{scm_make_smob_type} should be -immediately followed by calls to one or several of -@code{scm_set_smob_mark}, @code{scm_set_smob_free}, -@code{scm_set_smob_print}, and/or @code{scm_set_smob_equalp}. -@end deftypefun - -@deftypefn {C Function} void scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM obj)) -This function sets the smob marking procedure for the smob type specified by -the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}. - -The @var{mark} procedure must cause @code{scm_gc_mark} to be called -for every @code{SCM} value that is directly referenced by the smob -instance @var{obj}. One of these @code{SCM} values can be returned -from the procedure and Guile will call @code{scm_gc_mark} for it. -This can be used to avoid deep recursions for smob instances that form -a list. -@end deftypefn - -@deftypefn {C Function} void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM obj)) -This function sets the smob freeing procedure for the smob type -specified by the tag @var{tc}. @var{tc} is the tag returned by -@code{scm_make_smob_type}. - -The @var{free} procedure must deallocate all resources that are -directly associated with the smob instance @var{OBJ}. It must assume -that all @code{SCM} values that it references have already been freed -and are thus invalid. - -The @var{free} procedure must return 0. -@end deftypefn - -@deftypefn {C Function} void scm_set_smob_print (scm_t_bits tc, int (*print) (SCM obj, SCM port, scm_print_state* pstate)) -This function sets the smob printing procedure for the smob type -specified by the tag @var{tc}. @var{tc} is the tag returned by -@code{scm_make_smob_type}. - -The @var{print} procedure should output a textual representation of -the smob instance @var{obj} to @var{port}, using information in -@var{pstate}. - -The textual representation should be of the form @code{#}. -This ensures that @code{read} will not interpret it as some other -Scheme value. - -It is often best to ignore @var{pstate} and just print to @var{port} -with @code{scm_display}, @code{scm_write}, @code{scm_simple_format}, -and @code{scm_puts}. -@end deftypefn - -@deftypefn {C Function} void scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM obj1, SCM obj1)) -This function sets the smob equality-testing predicate for the smob -type specified by the tag @var{tc}. @var{tc} is the tag returned by -@code{scm_make_smob_type}. - -The @var{equalp} procedure should return @code{SCM_BOOL_T} when -@var{obj1} is @code{equal?} to @var{obj2}. Else it should return -@var{SCM_BOOL_F}. Both @var{obj1} and @var{obj2} are instances of the -smob type @var{tc}. -@end deftypefn - -@deftypefn {C Macro} int SCM_SMOB_PREDICATE (scm_t_bits tag, SCM exp) -Return true iff @var{exp} is a smob instance of the type indicated by -@var{tag}. The expression @var{exp} can be evaluated more than once, -so it shouldn't contain any side effects. -@end deftypefn - -@deftypefn {C Macro} void SCM_NEWSMOB (SCM value, scm_t_bits tag, void *data) -@deftypefnx {C Macro} void SCM_NEWSMOB2 (SCM value, scm_t_bits tag, void *data, void *data2) -@deftypefnx {C Macro} void SCM_NEWSMOB3 (SCM value, scm_t_bits tag, void *data, void *data2, void *data3) -Make @var{value} contain a smob instance of the type with tag -@var{tag} and smob data @var{data}, @var{data2}, and @var{data3}, as -appropriate. - -The @var{tag} is what has been returned by @code{scm_make_smob_type}. -The initial values @var{data}, @var{data2}, and @var{data3} are of -type @code{scm_t_bits}; when you want to use them for @code{SCM} -values, these values need to be converted to a @code{scm_t_bits} first -by using @code{SCM_UNPACK}. - -The flags of the smob instance start out as zero. -@end deftypefn - -Since it is often the case (e.g., in smob constructors) that you will -create a smob instance and return it, there is also a slightly specialized -macro for this situation: - -@deftypefn {C Macro} {} SCM_RETURN_NEWSMOB (scm_t_bits tag, void *data) -@deftypefnx {C Macro} {} SCM_RETURN_NEWSMOB2 (scm_t_bits tag, void *data1, void *data2) -@deftypefnx {C Macro} {} SCM_RETURN_NEWSMOB3 (scm_t_bits tag, void *data1, void *data2, void *data3) -This macro expands to a block of code that creates a smob instance of -the type with tag @var{tag} and smob data @var{data}, @var{data2}, and -@var{data3}, as with @code{SCM_NEWSMOB}, etc., and causes the -surrounding function to return that @code{SCM} value. It should be -the last piece of code in a block. -@end deftypefn - -@deftypefn {C Macro} scm_t_bits SCM_SMOB_FLAGS (SCM obj) -Return the 16 extra bits of the smob @var{obj}. No meaning is -predefined for these bits, you can use them freely. -@end deftypefn - -@deftypefn {C Macro} scm_t_bits SCM_SET_SMOB_FLAGS (SCM obj, scm_t_bits flags) -Set the 16 extra bits of the smob @var{obj} to @var{flags}. No -meaning is predefined for these bits, you can use them freely. -@end deftypefn - -@deftypefn {C Macro} scm_t_bits SCM_SMOB_DATA (SCM obj) -@deftypefnx {C Macro} scm_t_bits SCM_SMOB_DATA_2 (SCM obj) -@deftypefnx {C Macro} scm_t_bits SCM_SMOB_DATA_3 (SCM obj) -Return the first (second, third) immediate word of the smob @var{obj} -as a @code{scm_t_bits} value. When the word contains a @code{SCM} -value, use @code{SCM_SMOB_OBJECT} (etc.) instead. -@end deftypefn - -@deftypefn {C Macro} void SCM_SET_SMOB_DATA (SCM obj, scm_t_bits val) -@deftypefnx {C Macro} void SCM_SET_SMOB_DATA_2 (SCM obj, scm_t_bits val) -@deftypefnx {C Macro} void SCM_SET_SMOB_DATA_3 (SCM obj, scm_t_bits val) -Set the first (second, third) immediate word of the smob @var{obj} to -@var{val}. When the word should be set to a @code{SCM} value, use -@code{SCM_SMOB_SET_OBJECT} (etc.) instead. -@end deftypefn - -@deftypefn {C Macro} SCM SCM_SMOB_OBJECT (SCM obj) -@deftypefnx {C Macro} SCM SCM_SMOB_OBJECT_2 (SCM obj) -@deftypefnx {C Macro} SCM SCM_SMOB_OBJECT_3 (SCM obj) -Return the first (second, third) immediate word of the smob @var{obj} -as a @code{SCM} value. When the word contains a @code{scm_t_bits} -value, use @code{SCM_SMOB_DATA} (etc.) instead. -@end deftypefn - -@deftypefn {C Macro} void SCM_SET_SMOB_OBJECT (SCM obj, SCM val) -@deftypefnx {C Macro} void SCM_SET_SMOB_OBJECT_2 (SCM obj, SCM val) -@deftypefnx {C Macro} void SCM_SET_SMOB_OBJECT_3 (SCM obj, SCM val) -Set the first (second, third) immediate word of the smob @var{obj} to -@var{val}. When the word should be set to a @code{scm_t_bits} value, use -@code{SCM_SMOB_SET_DATA} (etc.) instead. -@end deftypefn - -@deftypefn {C Macro} SCM *SCM_SMOB_OBJECT_LOC (SCM obj) -@deftypefnx {C Macro} SCM *SCM_SMOB_OBJECT_2_LOC (SCM obj) -@deftypefnx {C Macro} SCM *SCM_SMOB_OBJECT_3_LOC (SCM obj) -Return a pointer to the first (second, third) immediate word of the -smob @var{obj}. Note that this is a pointer to @code{SCM}. If you -need to work with @code{scm_t_bits} values, use @code{SCM_PACK} and -@code{SCM_UNPACK}, as appropriate. -@end deftypefn - -@deftypefun SCM scm_markcdr (SCM @var{x}) -Mark the references in the smob @var{x}, assuming that @var{x}'s first -data word contains an ordinary Scheme object, and @var{x} refers to no -other objects. This function simply returns @var{x}'s first data word. -@end deftypefun - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: From 317b4c4ac177276f693304be45ae154e73f3e305 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 24 Jul 2004 00:26:09 +0000 Subject: [PATCH 47/89] *** empty log message *** --- doc/ref/ChangeLog | 6 ++++++ libguile/ChangeLog | 5 +++++ 2 files changed, 11 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 9360da2f1..e5a2fabea 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,9 +1,15 @@ 2004-07-24 Kevin Ryde + * scheme-control.texi (Frames): Add @vindex for SCM_F_WIND_EXPLICITLY. + * scheme-data.texi (String Syntax): Add all backslash forms accepted. (Regexp Functions): Use @defvar for regexp/icase etc, to emphasise that they're variables not symbols etc. + * scheme-smobs.texi (Smobs): In SCM_SMOB_OBJECT_LOC, + SCM_SMOB_OBJECT_2_LOC, SCM_SMOB_OBJECT_3_LOC, use {} to avoid "*" + getting into the index as part of the macro name. + * srfi-modules.texi (SRFI-0): Revise for clarity, drop BNF in favour of plain description, emphasise this is just for portable programs. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 650dbb8b4..5e33bf4c0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2004-07-24 Kevin Ryde + + * threads.c, threads.h (scm_i_misc_mutex): New SCM_GLOBAL_MUTEX. + * posix.c (scm_crypt): Use it to protect static data in crypt(). + 2004-07-23 Marius Vollmer * deprecated.h, deprecated.c, numbers.h (SCM_INUMP, SCM_NINUMP, From 7ac44f03c6238e319836197d5fb524fc8176a25a Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 24 Jul 2004 00:45:02 +0000 Subject: [PATCH 48/89] (@nicode): Use @alias instead of @macro, for correct handling of backslashes. --- doc/ref/guile.texi | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index ae79bdca9..0d14998a4 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -97,18 +97,15 @@ x @end macro @end ifnottex -@c @nicode{S} is plain S in info, or @code{S} elsewhere. This can be -@c used when the quotes that @code{} gives in info aren't wanted, but -@c the fontification in tex or html is wanted. +@c @nicode{S} is plain S in info, or @code{S} elsewhere. This can be used +@c when the quotes that @code{} gives in info aren't wanted, but the +@c fontification in tex or html is wanted. @alias is used rather +@c than @macro because backslashes don't work properly in an @macro. @ifinfo -@macro nicode {S} -\S\ -@end macro +@alias nicode=asis @end ifinfo @ifnotinfo -@macro nicode {S} -@code{\S\} -@end macro +@alias nicode=code @end ifnotinfo @@ -128,7 +125,7 @@ x @comment The title is printed in a large font. @title Guile Reference Manual @subtitle Edition @value{MANUAL-EDITION}, for use with Guile @value{VERSION} -@c @subtitle $Id: guile.texi,v 1.31 2004-06-28 13:24:53 mvo Exp $ +@c @subtitle $Id: guile.texi,v 1.32 2004-07-24 00:45:02 kryde Exp $ @c See preface.texi for the list of authors @author The Guile Developers From e759bc7c331a19d0389aa9471febb39746680011 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 24 Jul 2004 00:45:53 +0000 Subject: [PATCH 49/89] *** empty log message *** --- doc/ref/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index e5a2fabea..bf2a4f2ec 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,5 +1,8 @@ 2004-07-24 Kevin Ryde + * guile.texi (@nicode): Use @alias instead of @macro, for correct + handling of backslashes. + * scheme-control.texi (Frames): Add @vindex for SCM_F_WIND_EXPLICITLY. * scheme-data.texi (String Syntax): Add all backslash forms accepted. From 2ad58b2a89598490f27813caa5a6da66cc1593a0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 27 Jul 2004 15:39:25 +0000 Subject: [PATCH 50/89] * deprecated.h (SCM_FALSEP, SCM_NFALSEP, SCM_BOOLP, SCM_BOOL): Reimplement using scm_is_false, scm_is_true, scm_is_bool, and scm_from_bool, respectively. (SCM_NINUMP): Added. * tags.h, deprecated.h (SCM_EQ_P): Deprecated by moving it into deprecated.h. Replaced all uses with scm_is_eq. --- libguile/deprecated.h | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 8b89fec78..2794a50b8 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -77,7 +77,7 @@ SCM_API const char scm_s_formals[]; /* From eval.h: Helper macros for evaluation and application. These were * deprecated in guile 1.7.0 on 2003-06-02. */ #define SCM_EVALIM2(x) \ - ((SCM_EQ_P ((x), SCM_EOL) \ + ((scm_is_eq ((x), SCM_EOL) \ ? scm_misc_error (NULL, scm_s_expression, SCM_EOL), 0 \ : 0), \ (x)) @@ -305,16 +305,22 @@ SCM_API SCM scm_gentemp (SCM prefix, SCM obarray); #define SCM_CELL_WORD_LOC(x, n) ((scm_t_bits*)SCM_CELL_OBJECT_LOC((x),(n))) -#define SCM_FALSEP(x) (SCM_EQ_P ((x), SCM_BOOL_F)) -#define SCM_NFALSEP(x) (!SCM_FALSEP (x)) +/* Deprecated because they do not follow the naming convention. that + is, they endiin "P" but return a C boolean. Also, SCM_BOOLP + evaluates its argument twice. +*/ + +#define SCM_FALSEP scm_is_false +#define SCM_NFALSEP scm_is_true +#define SCM_BOOLP scm_is_bool +#define SCM_EQ_P scm_is_eq -#define SCM_BOOLP(x) (SCM_EQ_P ((x), SCM_BOOL_F) || SCM_EQ_P ((x), SCM_BOOL_T)) /* Convert from a C boolean to a SCM boolean value */ -#define SCM_BOOL(f) ((f) ? SCM_BOOL_T : SCM_BOOL_F) +#define SCM_BOOL scm_from_bool /* Convert from a C boolean to a SCM boolean value and negate it */ -#define SCM_NEGATE_BOOL(f) ((f) ? SCM_BOOL_F : SCM_BOOL_T) +#define SCM_NEGATE_BOOL(f) scm_from_bool(!(f)) /* SCM_BOOL_NOT returns the other boolean. * The order of ^s here is important for Borland C++ (!?!?!) @@ -328,6 +334,7 @@ SCM_API SCM scm_gentemp (SCM prefix, SCM obarray); SCM_API SCM SCM_MAKINUM (scm_t_signed_bits val); SCM_API int SCM_INUMP (SCM obj); +#define SCM_NINUMP(x) (!SCM_INUMP(x)) SCM_API scm_t_signed_bits SCM_INUM (SCM obj); #define SCM_VALIDATE_INUM(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, INUMP, "exact integer") From 68fb32d29c5500bdebde6e26ef40928967af77f0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 27 Jul 2004 15:39:46 +0000 Subject: [PATCH 51/89] (SCM_EQ_P): Deprecated by moving it into deprecated.h. Replaced all uses with scm_is_eq. --- libguile/tags.h | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/libguile/tags.h b/libguile/tags.h index 614d9e83f..08e33a735 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -137,7 +137,6 @@ typedef unsigned long scm_t_bits; * macro instead, which is the equivalent of the scheme predicate 'eq?'. */ #define scm_is_eq(x, y) (SCM_UNPACK (x) == SCM_UNPACK (y)) -#define SCM_EQ_P scm_is_eq @@ -532,7 +531,7 @@ enum scm_tc8_tags #define SCM_ELISP_NIL SCM_MAKIFLAG (7) -#define SCM_UNBNDP(x) (SCM_EQ_P ((x), SCM_UNDEFINED)) +#define SCM_UNBNDP(x) (scm_is_eq ((x), SCM_UNDEFINED)) From c82f8ed66ca55da796cb6289f380aaed2e5e34bb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 27 Jul 2004 15:40:07 +0000 Subject: [PATCH 52/89] *** empty log message *** --- libguile/ChangeLog | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5e33bf4c0..ab136308a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2004-07-27 Marius Vollmer + + * deprecated.h (SCM_FALSEP, SCM_NFALSEP, SCM_BOOLP, SCM_BOOL): + Reimplement using scm_is_false, scm_is_true, scm_is_bool, and + scm_from_bool, respectively. + (SCM_NINUMP): Added. + + * tags.h, deprecated.h (SCM_EQ_P): Deprecated by moving it into + deprecated.h. Replaced all uses with scm_is_eq. + 2004-07-24 Kevin Ryde * threads.c, threads.h (scm_i_misc_mutex): New SCM_GLOBAL_MUTEX. @@ -6,7 +16,7 @@ 2004-07-23 Marius Vollmer * deprecated.h, deprecated.c, numbers.h (SCM_INUMP, SCM_NINUMP, - SCM_INUM): Deprecated by reenaming them to SCM_I_INUMP, + SCM_INUM): Deprecated by renaming them to SCM_I_INUMP, SCM_I_NINUMP and SCM_I_INUM, respectively and adding deprecated versions to deprecated.h and deprecated.c. Changed all uses to either use the SCM_I_ variants or scm_is_*, scm_to_*, or From bc36d0502b9b2ac7e43ded2e1fbeed2f1499bb1d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 27 Jul 2004 15:41:49 +0000 Subject: [PATCH 53/89] * tags.h, deprecated.h (SCM_EQ_P): Deprecated by moving it into deprecated.h. Replaced all uses with scm_is_eq. --- libguile/alist.c | 4 +-- libguile/backtrace.c | 8 ++--- libguile/chars.c | 2 +- libguile/debug.c | 4 +-- libguile/deprecated.c | 16 +++++----- libguile/dynwind.c | 2 +- libguile/environments.c | 44 +++++++++++++------------- libguile/eq.c | 6 ++-- libguile/eval.c | 69 +++++++++++++++++++++-------------------- libguile/evalext.c | 4 +-- libguile/gc.c | 6 ++-- libguile/goops.c | 4 +-- libguile/guardians.c | 6 ++-- libguile/lang.h | 2 +- libguile/list.c | 12 +++---- libguile/load.c | 4 +-- libguile/numbers.c | 22 ++++++------- libguile/objects.c | 4 +-- libguile/options.c | 2 +- libguile/pairs.h | 2 +- libguile/ports.h | 2 +- libguile/print.c | 20 ++++++------ libguile/print.h | 4 +-- libguile/procprop.c | 6 ++-- libguile/procs.c | 2 +- libguile/procs.h | 2 +- libguile/ramap.c | 22 ++++++------- libguile/read.c | 18 +++++------ libguile/scmsigs.c | 4 +-- libguile/srcprop.c | 20 ++++++------ libguile/stacks.c | 14 ++++----- libguile/stacks.h | 2 +- libguile/threads.c | 6 ++-- libguile/throw.c | 8 ++--- libguile/unif.c | 24 +++++++------- libguile/validate.h | 4 +-- libguile/values.h | 2 +- srfi/srfi-1.c | 10 +++--- srfi/srfi-13.c | 8 ++--- 39 files changed, 201 insertions(+), 200 deletions(-) diff --git a/libguile/alist.c b/libguile/alist.c index b876ae59d..9a1f4d090 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -52,7 +52,7 @@ SCM_DEFINE (scm_sloppy_assq, "sloppy-assq", 2, 0, 0, for (; SCM_CONSP (alist); alist = SCM_CDR (alist)) { SCM tmp = SCM_CAR (alist); - if (SCM_CONSP (tmp) && SCM_EQ_P (SCM_CAR (tmp), key)) + if (SCM_CONSP (tmp) && scm_is_eq (SCM_CAR (tmp), key)) return tmp; } return SCM_BOOL_F; @@ -118,7 +118,7 @@ SCM_DEFINE (scm_assq, "assq", 2, 0, 0, SCM tmp = SCM_CAR (ls); SCM_ASSERT_TYPE (SCM_CONSP (tmp), alist, SCM_ARG2, FUNC_NAME, "association list"); - if (SCM_EQ_P (SCM_CAR (tmp), key)) + if (scm_is_eq (SCM_CAR (tmp), key)) return tmp; } SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME, diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 591108d14..3f6efac2f 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -228,7 +228,7 @@ display_error_body (struct display_error_args *a) if (!SCM_MEMOIZEDP (source) && scm_is_true (prev_frame)) source = SCM_FRAME_SOURCE (prev_frame); if (!SCM_SYMBOLP (pname) && !SCM_STRINGP (pname) && SCM_FRAME_PROC_P (current_frame) - && SCM_EQ_P (scm_procedure_p (SCM_FRAME_PROC (current_frame)), SCM_BOOL_T)) + && scm_is_true (scm_procedure_p (SCM_FRAME_PROC (current_frame)))) pname = scm_procedure_name (SCM_FRAME_PROC (current_frame)); } if (SCM_SYMBOLP (pname) || SCM_STRINGP (pname) || SCM_MEMOIZEDP (source)) @@ -490,7 +490,7 @@ display_backtrace_file (frame, last_file, port, pstate) display_backtrace_get_file_line (frame, &file, &line); - if (SCM_EQ_P (file, *last_file)) + if (scm_is_eq (file, *last_file)) return; *last_file = file; @@ -517,7 +517,7 @@ display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate) display_backtrace_get_file_line (frame, &file, &line); - if (SCM_EQ_P (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base)) + if (scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base)) { if (scm_is_false (file)) { @@ -718,7 +718,7 @@ display_backtrace_body (struct display_backtrace_args *a) last_file = SCM_UNDEFINED; for (i = 0; i < n; ++i) { - if (!SCM_EQ_P (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base)) + if (!scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base)) display_backtrace_file (frame, &last_file, a->port, pstate); display_frame (frame, nfield, indentation, sport, a->port, pstate); diff --git a/libguile/chars.c b/libguile/chars.c index ea44ccfdc..d205cf6e4 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -42,7 +42,7 @@ SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr, { SCM_VALIDATE_CHAR (1, x); SCM_VALIDATE_CHAR (2, y); - return scm_from_bool (SCM_EQ_P (x, y)); + return scm_from_bool (scm_is_eq (x, y)); } #undef FUNC_NAME diff --git a/libguile/debug.c b/libguile/debug.c index 52e507ae6..0f4734e82 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -428,12 +428,12 @@ scm_reverse_lookup (SCM env, SCM data) SCM values = SCM_CDAR (env); while (SCM_CONSP (names)) { - if (SCM_EQ_P (SCM_CAR (values), data)) + if (scm_is_eq (SCM_CAR (values), data)) return SCM_CAR (names); names = SCM_CDR (names); values = SCM_CDR (values); } - if (!SCM_NULLP (names) && SCM_EQ_P (values, data)) + if (!SCM_NULLP (names) && scm_is_eq (values, data)) return names; env = SCM_CDR (env); } diff --git a/libguile/deprecated.c b/libguile/deprecated.c index eb1150456..32286146d 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -271,7 +271,7 @@ static SCM scm_module_full_name (SCM name) { init_module_stuff (); - if (SCM_EQ_P (SCM_CAR (name), scm_sym_app)) + if (scm_is_eq (SCM_CAR (name), scm_sym_app)) return name; else return scm_append (scm_list_2 (module_prefix, name)); @@ -320,7 +320,7 @@ maybe_close_port (void *data, SCM port) while (!SCM_NULLP (except)) { SCM p = SCM_COERCE_OUTPORT (SCM_CAR (except)); - if (SCM_EQ_P (p, port)) + if (scm_is_eq (p, port)) return; except = SCM_CDR (except); } @@ -447,7 +447,7 @@ SCM_DEFINE (scm_sloppy_memq, "sloppy-memq", 2, 0, 0, for(; SCM_CONSP (lst); lst = SCM_CDR(lst)) { - if (SCM_EQ_P (SCM_CAR (lst), x)) + if (scm_is_eq (SCM_CAR (lst), x)) return lst; } return lst; @@ -691,7 +691,7 @@ scm_sym2ovcell_soft (SCM sym, SCM obarray) lsym = SCM_CDR (lsym)) { z = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (z), sym)) + if (scm_is_eq (SCM_CAR (z), sym)) { SCM_REALLOW_INTS; return z; @@ -766,7 +766,7 @@ scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int so { SCM a = SCM_CAR (lsym); SCM z = SCM_CAR (a); - if (SCM_EQ_P (z, symbol)) + if (scm_is_eq (z, symbol)) return a; } @@ -838,7 +838,7 @@ SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, /* nothing interesting to do here. */ return scm_string_to_symbol (s); } - else if (SCM_EQ_P (o, SCM_BOOL_T)) + else if (scm_is_eq (o, SCM_BOOL_T)) o = SCM_BOOL_F; vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), @@ -879,7 +879,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, lsym = SCM_CDR (lsym)) { sym = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (sym), s)) + if (scm_is_eq (SCM_CAR (sym), s)) { SCM_REALLOW_INTS; return SCM_UNSPECIFIED; @@ -921,7 +921,7 @@ SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, lsym_follow = lsym, lsym = SCM_CDR (lsym)) { sym = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (sym), s)) + if (scm_is_eq (SCM_CAR (sym), s)) { /* Found the symbol to unintern. */ if (scm_is_false (lsym_follow)) diff --git a/libguile/dynwind.c b/libguile/dynwind.c index ff46c1720..e8059be27 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -271,7 +271,7 @@ void scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data) { tail: - if (SCM_EQ_P (to, scm_dynwinds)) + if (scm_is_eq (to, scm_dynwinds)) { if (turn_func) turn_func (data); diff --git a/libguile/environments.c b/libguile/environments.c index 70e7dbc0a..6ad9d51d2 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -203,7 +203,7 @@ SCM_DEFINE (scm_environment_fold, "environment-fold", 3, 0, 0, #define FUNC_NAME s_scm_environment_fold { SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); - SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T), + SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, SCM_ARG2, FUNC_NAME); return SCM_ENVIRONMENT_FOLD (env, environment_default_folder, proc, init); @@ -244,9 +244,9 @@ SCM_DEFINE (scm_environment_define, "environment-define", 3, 0, 0, status = SCM_ENVIRONMENT_DEFINE (env, sym, val); - if (SCM_EQ_P (status, SCM_ENVIRONMENT_SUCCESS)) + if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS)) return SCM_UNSPECIFIED; - else if (SCM_EQ_P (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE)) + else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE)) scm_error_environment_immutable_binding (FUNC_NAME, env, sym); else abort(); @@ -270,9 +270,9 @@ SCM_DEFINE (scm_environment_undefine, "environment-undefine", 2, 0, 0, status = SCM_ENVIRONMENT_UNDEFINE (env, sym); - if (SCM_EQ_P (status, SCM_ENVIRONMENT_SUCCESS)) + if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS)) return SCM_UNSPECIFIED; - else if (SCM_EQ_P (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE)) + else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE)) scm_error_environment_immutable_binding (FUNC_NAME, env, sym); else abort(); @@ -298,11 +298,11 @@ SCM_DEFINE (scm_environment_set_x, "environment-set!", 3, 0, 0, status = SCM_ENVIRONMENT_SET (env, sym, val); - if (SCM_EQ_P (status, SCM_ENVIRONMENT_SUCCESS)) + if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS)) return SCM_UNSPECIFIED; else if (SCM_UNBNDP (status)) scm_error_environment_unbound (FUNC_NAME, env, sym); - else if (SCM_EQ_P (status, SCM_ENVIRONMENT_LOCATION_IMMUTABLE)) + else if (scm_is_eq (status, SCM_ENVIRONMENT_LOCATION_IMMUTABLE)) scm_error_environment_immutable_binding (FUNC_NAME, env, sym); else abort(); @@ -337,7 +337,7 @@ SCM_DEFINE (scm_environment_cell, "environment-cell", 3, 0, 0, return location; else if (SCM_UNBNDP (location)) scm_error_environment_unbound (FUNC_NAME, env, sym); - else if (SCM_EQ_P (location, SCM_ENVIRONMENT_LOCATION_IMMUTABLE)) + else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_IMMUTABLE)) scm_error_environment_immutable_location (FUNC_NAME, env, sym); else /* no cell */ return location; @@ -535,7 +535,7 @@ obarray_replace (SCM obarray, SCM symbol, SCM data) lsym = SCM_CDR (lsym)) { SCM old_entry = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (old_entry), symbol)) + if (scm_is_eq (SCM_CAR (old_entry), symbol)) { SCM_SETCAR (lsym, new_entry); return old_entry; @@ -565,7 +565,7 @@ obarray_retrieve (SCM obarray, SCM sym) lsym = SCM_CDR (lsym)) { SCM entry = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (entry), sym)) + if (scm_is_eq (SCM_CAR (entry), sym)) return entry; } @@ -682,7 +682,7 @@ core_environments_unobserve (SCM env, SCM observer) ? SCM_CDAR (l) : SCM_CAR (l); - if (SCM_EQ_P (first, observer)) + if (scm_is_eq (first, observer)) { /* Remove the first observer */ handling_weaks @@ -700,7 +700,7 @@ core_environments_unobserve (SCM env, SCM observer) ? SCM_CDAR (l) : SCM_CAR (l); - if (SCM_EQ_P (next, observer)) + if (scm_is_eq (next, observer)) { SCM_SETCDR (l, SCM_CDR (rest)); return; @@ -1124,10 +1124,10 @@ eval_environment_lookup (SCM env, SCM sym, int for_write) return location; mutability = CACHED_MUTABILITY (entry); - if (SCM_EQ_P (mutability, MUTABLE)) + if (scm_is_eq (mutability, MUTABLE)) return location; - if (SCM_EQ_P (mutability, UNKNOWN)) + if (scm_is_eq (mutability, UNKNOWN)) { SCM source_env = CACHED_SOURCE_ENVIRONMENT (entry); SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, 1); @@ -1179,7 +1179,7 @@ eval_environment_lookup (SCM env, SCM sym, int for_write) obarray_enter (obarray, sym, entry); return location; } - else if (SCM_EQ_P (location, SCM_ENVIRONMENT_LOCATION_NO_CELL)) + else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_NO_CELL)) { obarray_enter (obarray, sym, source_env); return source_env; @@ -1281,7 +1281,7 @@ eval_environment_set_x (SCM env, SCM sym, SCM val) { return SCM_ENVIRONMENT_SET (location, sym, val); } - else if (SCM_EQ_P (location, IMMUTABLE)) + else if (scm_is_eq (location, IMMUTABLE)) { return SCM_ENVIRONMENT_LOCATION_IMMUTABLE; } @@ -1303,7 +1303,7 @@ eval_environment_cell (SCM env, SCM sym, int for_write) return location; else if (SCM_ENVIRONMENT_P (location)) return SCM_ENVIRONMENT_LOCATION_NO_CELL; - else if (SCM_EQ_P (location, IMMUTABLE)) + else if (scm_is_eq (location, IMMUTABLE)) return SCM_ENVIRONMENT_LOCATION_IMMUTABLE; else return SCM_UNDEFINED; @@ -1629,7 +1629,7 @@ import_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail) scm_environment_folder proc = (scm_environment_folder) proc_as_ul; SCM data = SCM_CDDDR (extended_data); - if (SCM_CONSP (owner) && SCM_EQ_P (SCM_CAR (owner), imported_env)) + if (SCM_CONSP (owner) && scm_is_eq (SCM_CAR (owner), imported_env)) owner = import_environment_conflict (import_env, symbol, owner); if (SCM_ENVIRONMENT_P (owner)) @@ -2005,7 +2005,7 @@ export_environment_set_x (SCM env, SCM sym, SCM val) } else { - if (SCM_EQ_P (SCM_CADR (entry), symbol_mutable_location)) + if (scm_is_eq (SCM_CADR (entry), symbol_mutable_location)) return SCM_ENVIRONMENT_SET (body->private, sym, val); else return SCM_ENVIRONMENT_LOCATION_IMMUTABLE; @@ -2027,7 +2027,7 @@ export_environment_cell (SCM env, SCM sym, int for_write) } else { - if (!for_write || SCM_EQ_P (SCM_CADR (entry), symbol_mutable_location)) + if (!for_write || scm_is_eq (SCM_CADR (entry), symbol_mutable_location)) return SCM_ENVIRONMENT_CELL (body->private, sym, for_write); else return SCM_ENVIRONMENT_LOCATION_IMMUTABLE; @@ -2260,9 +2260,9 @@ export_environment_parse_signature (SCM signature, const char* caller) for (l2 = SCM_CDR (entry); SCM_CONSP (l2); l2 = SCM_CDR (l2)) { SCM attribute = SCM_CAR (l2); - if (SCM_EQ_P (attribute, symbol_immutable_location)) + if (scm_is_eq (attribute, symbol_immutable_location)) immutable = 1; - else if (SCM_EQ_P (attribute, symbol_mutable_location)) + else if (scm_is_eq (attribute, symbol_mutable_location)) mutable = 1; else SCM_ASSERT (0, entry, SCM_ARGn, caller); diff --git a/libguile/eq.c b/libguile/eq.c index 7f368ed1a..fa9dcdebc 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -47,7 +47,7 @@ SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr, "@code{eqv?}.") #define FUNC_NAME s_scm_eq_p { - return scm_from_bool (SCM_EQ_P (x, y)); + return scm_from_bool (scm_is_eq (x, y)); } #undef FUNC_NAME @@ -71,7 +71,7 @@ SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, "and inexact numbers.") #define FUNC_NAME s_scm_eqv_p { - if (SCM_EQ_P (x, y)) + if (scm_is_eq (x, y)) return SCM_BOOL_T; if (SCM_IMP (x)) return SCM_BOOL_F; @@ -141,7 +141,7 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, SCM_CHECK_STACK; tailrecurse: SCM_TICK; - if (SCM_EQ_P (x, y)) + if (scm_is_eq (x, y)) return SCM_BOOL_T; if (SCM_IMP (x)) return SCM_BOOL_F; diff --git a/libguile/eval.c b/libguile/eval.c index 8f7d89540..e8c27e952 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -479,11 +479,11 @@ lookup_symbol (const SCM symbol, const SCM env) SCM_CONSP (symbol_idx); symbol_idx = SCM_CDR (symbol_idx), ++symbol_nr) { - if (SCM_EQ_P (SCM_CAR (symbol_idx), symbol)) + if (scm_is_eq (SCM_CAR (symbol_idx), symbol)) /* found the symbol, therefore return the iloc */ return SCM_MAKE_ILOC (frame_nr, symbol_nr, 0); } - if (SCM_EQ_P (symbol_idx, symbol)) + if (scm_is_eq (symbol_idx, symbol)) /* found the symbol as the last element of the current frame */ return SCM_MAKE_ILOC (frame_nr, symbol_nr, 1); } @@ -709,7 +709,7 @@ is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env) if (SCM_BUILTIN_MACRO_P (value)) { const SCM macro_name = scm_macro_name (value); - return SCM_EQ_P (macro_name, syntactic_keyword); + return scm_is_eq (macro_name, syntactic_keyword); } } @@ -980,14 +980,14 @@ scm_m_case (SCM expr, SCM env) } else { - ASSERT_SYNTAX_2 (SCM_EQ_P (labels, scm_sym_else) && else_literal_p, + ASSERT_SYNTAX_2 (scm_is_eq (labels, scm_sym_else) && else_literal_p, s_bad_case_labels, labels, expr); ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses)), s_misplaced_else_clause, clause, expr); } /* build the new clause */ - if (SCM_EQ_P (labels, scm_sym_else)) + if (scm_is_eq (labels, scm_sym_else)) SCM_SETCAR (clause, SCM_IM_ELSE); clauses = SCM_CDR (clauses); @@ -1021,7 +1021,7 @@ unmemoize_case (const SCM expr, const SCM env) const SCM exprs = SCM_CDR (clause); const SCM um_exprs = unmemoize_exprs (exprs, env); - const SCM um_labels = (SCM_EQ_P (labels, SCM_IM_ELSE)) + const SCM um_labels = (scm_is_eq (labels, SCM_IM_ELSE)) ? scm_sym_else : scm_i_finite_list_copy (labels); const SCM um_clause = scm_cons (um_labels, um_exprs); @@ -1062,7 +1062,7 @@ scm_m_cond (SCM expr, SCM env) ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr); test = SCM_CAR (clause); - if (SCM_EQ_P (test, scm_sym_else) && else_literal_p) + if (scm_is_eq (test, scm_sym_else) && else_literal_p) { const int last_clause_p = SCM_NULLP (SCM_CDR (clause_idx)); ASSERT_SYNTAX_2 (length >= 2, @@ -1072,7 +1072,7 @@ scm_m_cond (SCM expr, SCM env) SCM_SETCAR (clause, SCM_IM_ELSE); } else if (length >= 2 - && SCM_EQ_P (SCM_CADR (clause), scm_sym_arrow) + && scm_is_eq (SCM_CADR (clause), scm_sym_arrow) && arrow_literal_p) { ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr); @@ -1102,12 +1102,13 @@ unmemoize_cond (const SCM expr, const SCM env) SCM um_sequence; SCM um_clause; - if (SCM_EQ_P (test, SCM_IM_ELSE)) + if (scm_is_eq (test, SCM_IM_ELSE)) um_test = scm_sym_else; else um_test = unmemoize_expression (test, env); - if (!SCM_NULLP (sequence) && SCM_EQ_P (SCM_CAR (sequence), SCM_IM_ARROW)) + if (!SCM_NULLP (sequence) && scm_is_eq (SCM_CAR (sequence), + SCM_IM_ARROW)) { const SCM target = SCM_CADR (sequence); const SCM um_target = unmemoize_expression (target, env); @@ -1361,7 +1362,7 @@ unmemoize_do (const SCM expr, const SCM env) const SCM name = SCM_CAR (um_names); const SCM init = SCM_CAR (um_inits); SCM step = SCM_CAR (um_steps); - step = SCM_EQ_P (step, name) ? SCM_EOL : scm_list_1 (step); + step = scm_is_eq (step, name) ? SCM_EOL : scm_list_1 (step); um_bindings = scm_cons (scm_cons2 (name, init, step), um_bindings); @@ -1423,10 +1424,10 @@ c_improper_memq (SCM obj, SCM list) { for (; SCM_CONSP (list); list = SCM_CDR (list)) { - if (SCM_EQ_P (SCM_CAR (list), obj)) + if (scm_is_eq (SCM_CAR (list), obj)) return 1; } - return SCM_EQ_P (list, obj); + return scm_is_eq (list, obj); } SCM @@ -1839,13 +1840,13 @@ iqq (SCM form, SCM env, unsigned long int depth) if (SCM_CONSP (form)) { const SCM tmp = SCM_CAR (form); - if (SCM_EQ_P (tmp, scm_sym_quasiquote)) + if (scm_is_eq (tmp, scm_sym_quasiquote)) { const SCM args = SCM_CDR (form); ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form); return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1)); } - else if (SCM_EQ_P (tmp, scm_sym_unquote)) + else if (scm_is_eq (tmp, scm_sym_unquote)) { const SCM args = SCM_CDR (form); ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form); @@ -1855,7 +1856,7 @@ iqq (SCM form, SCM env, unsigned long int depth) return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1)); } else if (SCM_CONSP (tmp) - && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing)) + && scm_is_eq (SCM_CAR (tmp), scm_sym_uq_splicing)) { const SCM args = SCM_CDR (tmp); ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form); @@ -2134,7 +2135,7 @@ scm_m_generalized_set_x (SCM expr, SCM env) variable and we memoize to (set! ...). */ exp_target = macroexp (target, env); - if (SCM_EQ_P (SCM_CAR (exp_target), SCM_IM_BEGIN) + if (scm_is_eq (SCM_CAR (exp_target), SCM_IM_BEGIN) && !SCM_NULLP (SCM_CDR (exp_target)) && SCM_NULLP (SCM_CDDR (exp_target))) { @@ -2592,7 +2593,7 @@ static SCM deval (SCM x, SCM env); #define SCM_EVALIM2(x) \ - ((SCM_EQ_P ((x), SCM_EOL) \ + ((scm_is_eq ((x), SCM_EOL) \ ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \ : 0), \ (x)) @@ -2776,9 +2777,9 @@ scm_lookupcar1 (SCM vloc, SCM genv, int check) { if (!SCM_CONSP (fl)) { - if (SCM_EQ_P (fl, var)) + if (scm_is_eq (fl, var)) { - if (! SCM_EQ_P (SCM_CAR (vloc), var)) + if (!scm_is_eq (SCM_CAR (vloc), var)) goto race; SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (iloc) + SCM_ICDR); return SCM_CDRLOC (*al); @@ -2787,14 +2788,14 @@ scm_lookupcar1 (SCM vloc, SCM genv, int check) break; } al = SCM_CDRLOC (*al); - if (SCM_EQ_P (SCM_CAR (fl), var)) + if (scm_is_eq (SCM_CAR (fl), var)) { if (SCM_UNBNDP (SCM_CAR (*al))) { env = SCM_EOL; goto errout; } - if (!SCM_EQ_P (SCM_CAR (vloc), var)) + if (!scm_is_eq (SCM_CAR (vloc), var)) goto race; SCM_SETCAR (vloc, iloc); return SCM_CARLOC (*al); @@ -2837,7 +2838,7 @@ scm_lookupcar1 (SCM vloc, SCM genv, int check) } } - if (!SCM_EQ_P (SCM_CAR (vloc), var)) + if (!scm_is_eq (SCM_CAR (vloc), var)) { /* Some other thread has changed the very cell we are working on. In effect, it must have done our job or messed it up @@ -3137,7 +3138,7 @@ deval_args (SCM l, SCM env, SCM proc, SCM *lloc) #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ - ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x) + ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x) /* This is the evaluator. Like any real monster, it has three heads: @@ -3360,7 +3361,7 @@ dispatch: { const SCM clause = SCM_CAR (x); SCM labels = SCM_CAR (clause); - if (SCM_EQ_P (labels, SCM_IM_ELSE)) + if (scm_is_eq (labels, SCM_IM_ELSE)) { x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); @@ -3369,7 +3370,7 @@ dispatch: while (!SCM_NULLP (labels)) { const SCM label = SCM_CAR (labels); - if (SCM_EQ_P (label, key) + if (scm_is_eq (label, key) || scm_is_true (scm_eqv_p (label, key))) { x = SCM_CDR (clause); @@ -3389,7 +3390,7 @@ dispatch: while (!SCM_NULLP (x)) { const SCM clause = SCM_CAR (x); - if (SCM_EQ_P (SCM_CAR (clause), SCM_IM_ELSE)) + if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE)) { x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); @@ -3403,7 +3404,7 @@ dispatch: x = SCM_CDR (clause); if (SCM_NULLP (x)) RETURN (arg1); - else if (!SCM_EQ_P (SCM_CAR (x), SCM_IM_ARROW)) + else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW)) { PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; @@ -3800,7 +3801,7 @@ dispatch: { /* More arguments than specifiers => CLASS != ENV */ SCM class_of_arg = scm_class_of (SCM_CAR (args)); - if (!SCM_EQ_P (class_of_arg, SCM_CAR (z))) + if (!scm_is_eq (class_of_arg, SCM_CAR (z))) goto next_method; args = SCM_CDR (args); z = SCM_CDR (z); @@ -3858,7 +3859,7 @@ dispatch: if (!(scm_is_false (test_result) || SCM_NULL_OR_NIL_P (test_result))) { - if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED)) + if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED)) RETURN (test_result); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; @@ -3979,8 +3980,8 @@ dispatch: if (!SCM_CONSP (arg1)) arg1 = scm_list_2 (SCM_IM_BEGIN, arg1); - assert (!SCM_EQ_P (x, SCM_CAR (arg1)) - && !SCM_EQ_P (x, SCM_CDR (arg1))); + assert (!scm_is_eq (x, SCM_CAR (arg1)) + && !scm_is_eq (x, SCM_CDR (arg1))); #ifdef DEVAL if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc))) @@ -5711,7 +5712,7 @@ copy_tree ( { tortoise_delay = 1; tortoise = tortoise->trace; - ASSERT_SYNTAX (!SCM_EQ_P (hare->obj, tortoise->obj), + ASSERT_SYNTAX (!scm_is_eq (hare->obj, tortoise->obj), s_bad_expression, hare->obj); } else @@ -5775,7 +5776,7 @@ copy_tree ( rabbit = SCM_CDR (rabbit); turtle = SCM_CDR (turtle); - ASSERT_SYNTAX (!SCM_EQ_P (rabbit, turtle), + ASSERT_SYNTAX (!scm_is_eq (rabbit, turtle), s_bad_expression, rabbit); } } diff --git a/libguile/evalext.c b/libguile/evalext.c index c6e6dea76..a18d965b6 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -56,12 +56,12 @@ SCM_DEFINE (scm_defined_p, "defined?", 1, 1, 0, { if (!SCM_CONSP (b)) { - if (SCM_EQ_P (b, sym)) + if (scm_is_eq (b, sym)) return SCM_BOOL_T; else break; } - if (SCM_EQ_P (SCM_CAR (b), sym)) + if (scm_is_eq (SCM_CAR (b), sym)) return SCM_BOOL_T; } } diff --git a/libguile/gc.c b/libguile/gc.c index 21657dc24..d87e88d2f 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -185,7 +185,7 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, { scm_debug_cell_accesses_p = 0; } - else if (SCM_EQ_P (flag, SCM_BOOL_T)) + else if (scm_is_eq (flag, SCM_BOOL_T)) { scm_debug_cells_gc_interval = 0; scm_debug_cell_accesses_p = 1; @@ -746,7 +746,7 @@ scm_gc_unprotect_object (SCM obj) else { SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1)); - if (SCM_EQ_P (count, scm_from_int (0))) + if (scm_is_eq (count, scm_from_int (0))) scm_hashq_remove_x (scm_protects, obj); else SCM_SETCDR (handle, count); @@ -793,7 +793,7 @@ scm_gc_unregister_root (SCM *p) else { SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1)); - if (SCM_EQ_P (count, scm_from_int (0))) + if (scm_is_eq (count, scm_from_int (0))) scm_hashv_remove_x (scm_gc_registered_roots, key); else SCM_SETCDR (handle, count); diff --git a/libguile/goops.c b/libguile/goops.c index bf6c03a51..cc4c98e04 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -335,7 +335,7 @@ scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr if (!SCM_KEYWORDP (obj)) scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj)); - else if (SCM_EQ_P (obj, key)) + else if (scm_is_eq (obj, key)) return SCM_CADR (l); else l = SCM_CDDR (l); @@ -1212,7 +1212,7 @@ test_slot_existence (SCM class SCM_UNUSED, SCM obj, SCM slot_name) register SCM l; for (l = SCM_ACCESSORS_OF (obj); !SCM_NULLP (l); l = SCM_CDR (l)) - if (SCM_EQ_P (SCM_CAAR (l), slot_name)) + if (scm_is_eq (SCM_CAAR (l), slot_name)) return SCM_BOOL_T; return SCM_BOOL_F; diff --git a/libguile/guardians.c b/libguile/guardians.c index 706fbcb47..a28657aab 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -57,7 +57,7 @@ typedef struct t_tconc SCM tail; } t_tconc; -#define TCONC_EMPTYP(tc) (SCM_EQ_P ((tc).head, (tc).tail)) +#define TCONC_EMPTYP(tc) (scm_is_eq ((tc).head, (tc).tail)) #define TCONC_IN(tc, obj, pair) \ do { \ @@ -417,7 +417,7 @@ mark_dependencies_in_tconc (t_tconc *tc) /* scan the list for unmarked objects, and mark their dependencies */ for (pair = tc->head, prev_ptr = &tc->head; - ! SCM_EQ_P (pair, tc->tail); + !scm_is_eq (pair, tc->tail); pair = next_pair) { SCM obj = SCM_CAR (pair); @@ -466,7 +466,7 @@ mark_and_zombify (t_guardian *g) SCM *prev_ptr = &g->live.head; SCM pair = g->live.head; - while (! SCM_EQ_P (pair, tconc_tail)) + while (!scm_is_eq (pair, tconc_tail)) { SCM next_pair = SCM_CDR (pair); diff --git a/libguile/lang.h b/libguile/lang.h index c22655699..bb2ce6235 100644 --- a/libguile/lang.h +++ b/libguile/lang.h @@ -28,7 +28,7 @@ #if SCM_ENABLE_ELISP -#define SCM_NILP(x) (SCM_EQ_P ((x), SCM_ELISP_NIL)) +#define SCM_NILP(x) (scm_is_eq ((x), SCM_ELISP_NIL)) SCM_API void scm_init_lang (void); diff --git a/libguile/list.c b/libguile/list.c index 18a0f70e7..26b774be1 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -181,7 +181,7 @@ scm_ilength(SCM sx) /* For every two steps the hare takes, the tortoise takes one. */ tortoise = SCM_CDR(tortoise); } - while (! SCM_EQ_P (hare, tortoise)); + while (!scm_is_eq (hare, tortoise)); /* If the tortoise ever catches the hare, then the list must contain a cycle. */ @@ -307,7 +307,7 @@ SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0, hare = ahead; tortoise = SCM_CDR(tortoise); } - while (! SCM_EQ_P (hare, tortoise)); + while (!scm_is_eq (hare, tortoise)); SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst)); } #undef FUNC_NAME @@ -336,7 +336,7 @@ SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0, hare = SCM_CDR (hare); tortoise = SCM_CDR (tortoise); } - while (! SCM_EQ_P (hare, tortoise)); + while (!scm_is_eq (hare, tortoise)); SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst)); } #undef FUNC_NAME @@ -567,7 +567,7 @@ scm_c_memq (SCM obj, SCM list) { for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR (list)) { - if (SCM_EQ_P (SCM_CAR (list), obj)) + if (scm_is_eq (SCM_CAR (list), obj)) return list; } return SCM_BOOL_F; @@ -653,7 +653,7 @@ SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0, SCM_CONSP (walk); walk = SCM_CDR (walk)) { - if (SCM_EQ_P (SCM_CAR (walk), item)) + if (scm_is_eq (SCM_CAR (walk), item)) *prev = SCM_CDR (walk); else prev = SCM_CDRLOC (walk); @@ -770,7 +770,7 @@ SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0, SCM_CONSP (walk); walk = SCM_CDR (walk)) { - if (SCM_EQ_P (SCM_CAR (walk), item)) + if (scm_is_eq (SCM_CAR (walk), item)) { *prev = SCM_CDR (walk); break; diff --git a/libguile/load.c b/libguile/load.c index 74eaaca9b..00ec130a1 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -93,11 +93,11 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, { SCM hook = *scm_loc_load_hook; SCM_VALIDATE_STRING (1, filename); - if (scm_is_true (hook) && !SCM_EQ_P (scm_procedure_p (hook), SCM_BOOL_T)) + if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook))) SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f", SCM_EOL); - if (! scm_is_false (hook)) + if (!scm_is_false (hook)) scm_call_1 (hook, filename); { /* scope */ diff --git a/libguile/numbers.c b/libguile/numbers.c index a6e5c69e5..f57ed0805 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -331,9 +331,9 @@ scm_make_ratio (SCM numerator, SCM denominator) */ if (SCM_I_INUMP (denominator)) { - if (SCM_EQ_P (denominator, SCM_INUM0)) + if (scm_is_eq (denominator, SCM_INUM0)) scm_num_overflow ("make-ratio"); - if (SCM_EQ_P (denominator, SCM_I_MAKINUM(1))) + if (scm_is_eq (denominator, SCM_I_MAKINUM(1))) return numerator; } else @@ -358,7 +358,7 @@ scm_make_ratio (SCM numerator, SCM denominator) if (SCM_I_INUMP (numerator)) { long x = SCM_I_INUM (numerator); - if (SCM_EQ_P (numerator, SCM_INUM0)) + if (scm_is_eq (numerator, SCM_INUM0)) return SCM_INUM0; if (SCM_I_INUMP (denominator)) { @@ -391,7 +391,7 @@ scm_make_ratio (SCM numerator, SCM denominator) } else { - if (SCM_EQ_P (numerator, denominator)) + if (scm_is_eq (numerator, denominator)) return SCM_I_MAKINUM(1); if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator), SCM_I_BIG_MPZ (denominator))) @@ -413,7 +413,7 @@ static void scm_i_fraction_reduce (SCM z) { SCM divisor; divisor = scm_gcd (SCM_FRACTION_NUMERATOR (z), SCM_FRACTION_DENOMINATOR (z)); - if (!(SCM_EQ_P (divisor, SCM_I_MAKINUM(1)))) + if (!(scm_is_eq (divisor, SCM_I_MAKINUM(1)))) { /* is this safe? */ SCM_FRACTION_SET_NUMERATOR (z, scm_divide (SCM_FRACTION_NUMERATOR (z), divisor)); @@ -1090,7 +1090,7 @@ scm_lcm (SCM n1, SCM n2) if (SCM_I_INUMP (n2)) { SCM d = scm_gcd (n1, n2); - if (SCM_EQ_P (d, SCM_INUM0)) + if (scm_is_eq (d, SCM_INUM0)) return d; else return scm_abs (scm_product (n1, scm_quotient (n2, d))); @@ -1580,7 +1580,7 @@ SCM_DEFINE (scm_modulo_expt, "modulo-expt", 3, 0, 0, mpz_init (k_tmp); mpz_init (m_tmp); - if (SCM_EQ_P (m, SCM_INUM0)) + if (scm_is_eq (m, SCM_INUM0)) { report_overflow = 1; goto cleanup; @@ -1667,9 +1667,9 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, SCM acc = SCM_I_MAKINUM (1L); /* 0^0 == 1 according to R5RS */ - if (SCM_EQ_P (n, SCM_INUM0) || SCM_EQ_P (n, acc)) + if (scm_is_eq (n, SCM_INUM0) || scm_is_eq (n, acc)) return scm_is_false (scm_zero_p(k)) ? n : acc; - else if (SCM_EQ_P (n, SCM_I_MAKINUM (-1L))) + else if (scm_is_eq (n, SCM_I_MAKINUM (-1L))) return scm_is_false (scm_even_p (k)) ? n : acc; if (SCM_I_INUMP (k)) @@ -2690,7 +2690,7 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, /* When returning an inexact zero, make sure it is represented as a floating point value so that we can change its sign. */ - if (SCM_EQ_P (result, SCM_I_MAKINUM(0)) && *p_exactness == INEXACT) + if (scm_is_eq (result, SCM_I_MAKINUM(0)) && *p_exactness == INEXACT) result = scm_make_real (0.0); return result; @@ -3492,7 +3492,7 @@ SCM scm_zero_p (SCM z) { if (SCM_I_INUMP (z)) - return scm_from_bool (SCM_EQ_P (z, SCM_INUM0)); + return scm_from_bool (scm_is_eq (z, SCM_INUM0)); else if (SCM_BIGP (z)) return SCM_BOOL_F; else if (SCM_REALP (z)) diff --git a/libguile/objects.c b/libguile/objects.c index ca5c2c29f..519a7ecf5 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -278,7 +278,7 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) do { /* More arguments than specifiers => CLASS != ENV */ - if (! SCM_EQ_P (scm_class_of (SCM_CAR (ls)), SCM_CAR (z))) + if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z))) goto next_method; ls = SCM_CDR (ls); z = SCM_CDR (z); @@ -452,7 +452,7 @@ SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0, unsigned long flags = 0; SCM_VALIDATE_STRUCT (1, metaclass); SCM_VALIDATE_STRING (2, layout); - if (SCM_EQ_P (metaclass, scm_metaclass_operator)) + if (scm_is_eq (metaclass, scm_metaclass_operator)) flags = SCM_CLASSF_OPERATOR; return scm_i_make_class_object (metaclass, layout, flags); } diff --git a/libguile/options.c b/libguile/options.c index 41cadc7b5..4c53611a3 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -178,7 +178,7 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c for (i = 0; i != n && !found; ++i) { - if (SCM_EQ_P (name, SCM_PACK (options[i].name))) + if (scm_is_eq (name, SCM_PACK (options[i].name))) { switch (options[i].type) { diff --git a/libguile/pairs.h b/libguile/pairs.h index 1dd409cfc..c03495b3e 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -33,7 +33,7 @@ # define SCM_VALIDATE_PAIR(cell, expr) (expr) #endif -#define SCM_NULLP(x) (SCM_EQ_P ((x), SCM_EOL)) +#define SCM_NULLP(x) (scm_is_eq ((x), SCM_EOL)) #define SCM_NNULLP(x) (!SCM_NULLP (x)) #define SCM_CAR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (x))) diff --git a/libguile/ports.h b/libguile/ports.h index 8dffade07..ee53d3773 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -117,7 +117,7 @@ SCM_API scm_t_mutex scm_i_port_table_mutex; -#define SCM_EOF_OBJECT_P(x) (SCM_EQ_P ((x), SCM_EOF_VAL)) +#define SCM_EOF_OBJECT_P(x) (scm_is_eq ((x), SCM_EOF_VAL)) /* PORT FLAGS * A set of flags characterizes a port. diff --git a/libguile/print.c b/libguile/print.c index e43462a51..a2fe9785f 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -112,7 +112,7 @@ do { \ do { \ register unsigned long i; \ for (i = 0; i < pstate->top; ++i) \ - if (SCM_EQ_P (pstate->ref_stack[i], (obj))) \ + if (scm_is_eq (pstate->ref_stack[i], (obj))) \ goto label; \ if (pstate->fancyp) \ { \ @@ -244,15 +244,15 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref) while (i > 0) { if (!SCM_CONSP (pstate->ref_stack[i - 1]) - || !SCM_EQ_P (SCM_CDR (pstate->ref_stack[i - 1]), - pstate->ref_stack[i])) + || !scm_is_eq (SCM_CDR (pstate->ref_stack[i - 1]), + pstate->ref_stack[i])) break; --i; } self = i; } for (i = pstate->top - 1; 1; --i) - if (SCM_EQ_P (pstate->ref_stack[i], ref)) + if (scm_is_eq (pstate->ref_stack[i], ref)) break; scm_putc ('#', port); scm_intprint (i - self, 10, port); @@ -598,7 +598,7 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_cclo: { SCM proc = SCM_CCLO_SUBR (exp); - if (SCM_EQ_P (proc, scm_f_gsubr_apply)) + if (scm_is_eq (proc, scm_f_gsubr_apply)) { /* Print gsubrs as primitives */ SCM name = scm_procedure_name (exp); @@ -760,7 +760,7 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) tortoise = exp; while (SCM_CONSP (hare)) { - if (SCM_EQ_P (hare, tortoise)) + if (scm_is_eq (hare, tortoise)) goto fancy_printing; hare = SCM_CDR (hare); if (!SCM_CONSP (hare)) @@ -776,7 +776,7 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) register long i; for (i = floor; i >= 0; --i) - if (SCM_EQ_P (pstate->ref_stack[i], exp)) + if (scm_is_eq (pstate->ref_stack[i], exp)) goto circref; PUSH_REF (pstate, exp); scm_putc (' ', port); @@ -805,7 +805,7 @@ fancy_printing: register unsigned long i; for (i = 0; i < pstate->top; ++i) - if (SCM_EQ_P (pstate->ref_stack[i], exp)) + if (scm_is_eq (pstate->ref_stack[i], exp)) goto fancy_circref; if (pstate->fancyp) { @@ -916,7 +916,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, char *end; char *p; - if (SCM_EQ_P (destination, SCM_BOOL_T)) + if (scm_is_eq (destination, SCM_BOOL_T)) { destination = port = scm_cur_outp; } @@ -981,7 +981,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, } scm_lfwrite (start, p - start, port); - if (!SCM_EQ_P (args, SCM_EOL)) + if (!scm_is_eq (args, SCM_EOL)) SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments", scm_list_1 (scm_length (args))); diff --git a/libguile/print.h b/libguile/print.h index b4e8292c4..6d9c47c31 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -35,8 +35,8 @@ SCM_API scm_t_option scm_print_opts[]; /* State information passed around during printing. */ #define SCM_PRINT_STATE_P(obj) (SCM_STRUCTP(obj) \ - && (SCM_EQ_P (SCM_STRUCT_VTABLE(obj), \ - scm_print_state_vtable))) + && (scm_is_eq (SCM_STRUCT_VTABLE(obj), \ + scm_print_state_vtable))) #define SCM_PRINT_STATE(obj) ((scm_print_state *) SCM_STRUCT_DATA (obj)) #define RESET_PRINT_STATE(pstate) \ diff --git a/libguile/procprop.c b/libguile/procprop.c index 1c6727e0f..d91c72904 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -85,7 +85,7 @@ scm_i_procedure_arity (SCM proc) return SCM_BOOL_F; } case scm_tc7_cclo: - if (SCM_EQ_P (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply)) + if (scm_is_eq (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply)) { int type = scm_to_int (SCM_GSUBR_TYPE (proc)); a += SCM_GSUBR_REQ (type); @@ -180,7 +180,7 @@ SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0, #define FUNC_NAME s_scm_procedure_property { SCM assoc; - if (SCM_EQ_P (k, scm_sym_arity)) + if (scm_is_eq (k, scm_sym_arity)) { SCM arity; SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (p)), @@ -206,7 +206,7 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, if (!SCM_CLOSUREP (p)) p = scm_stand_in_scm_proc(p); SCM_VALIDATE_CLOSURE (1, p); - if (SCM_EQ_P (k, scm_sym_arity)) + if (scm_is_eq (k, scm_sym_arity)) SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL); assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p)); if (SCM_NIMP (assoc)) diff --git a/libguile/procs.c b/libguile/procs.c index 42869182c..a03ef8bb3 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -249,7 +249,7 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, #define FUNC_NAME s_scm_procedure_documentation { SCM code; - SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T), + SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, SCM_ARG1, FUNC_NAME); switch (SCM_TYP7 (proc)) { diff --git a/libguile/procs.h b/libguile/procs.h index ad9f6ae9c..d9621a8e4 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -77,7 +77,7 @@ typedef struct + scm_tc3_closure)) #define SCM_ENV(x) SCM_CELL_OBJECT_1 (x) #define SCM_SETENV(x, e) SCM_SET_CELL_OBJECT_1 ((x), (e)) -#define SCM_TOP_LEVEL(ENV) (SCM_NULLP (ENV) || (SCM_EQ_P (scm_procedure_p (SCM_CAR (ENV)), SCM_BOOL_T))) +#define SCM_TOP_LEVEL(ENV) (SCM_NULLP (ENV) || (scm_is_true (scm_procedure_p (SCM_CAR (ENV))))) /* Procedure-with-setter diff --git a/libguile/ramap.c b/libguile/ramap.c index 62b04d62c..b85a3ae67 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -495,7 +495,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) if ((base + n) % SCM_LONG_BIT) /* trailing partial word */ ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT)); } - else if (SCM_EQ_P (fill, SCM_BOOL_T)) + else if (scm_is_eq (fill, SCM_BOOL_T)) { if (base % SCM_LONG_BIT) ve[i++] |= ~0L << (base % SCM_LONG_BIT); @@ -512,7 +512,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) if (scm_is_false (fill)) for (i = base; n--; i += inc) ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT)); - else if (SCM_EQ_P (fill, SCM_BOOL_T)) + else if (scm_is_eq (fill, SCM_BOOL_T)) for (i = base; n--; i += inc) ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT)); else @@ -1521,7 +1521,7 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, goto gencase; scm_array_fill_x (ra0, SCM_BOOL_T); for (p = ra_rpsubrs; p->name; p++) - if (SCM_EQ_P (proc, p->sproc)) + if (scm_is_eq (proc, p->sproc)) { while (!SCM_NULLP (lra) && !SCM_NULLP (SCM_CDR (lra))) { @@ -1558,22 +1558,22 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, /* Check to see if order might matter. This might be an argument for a separate SERIAL-ARRAY-MAP! */ - if (SCM_EQ_P (v0, ra1) - || (SCM_ARRAYP (ra1) && SCM_EQ_P (v0, SCM_ARRAY_V (ra1)))) - if (!SCM_EQ_P (ra0, ra1) + if (scm_is_eq (v0, ra1) + || (SCM_ARRAYP (ra1) && scm_is_eq (v0, SCM_ARRAY_V (ra1)))) + if (!scm_is_eq (ra0, ra1) || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0))) goto gencase; for (tail = SCM_CDR (lra); !SCM_NULLP (tail); tail = SCM_CDR (tail)) { ra1 = SCM_CAR (tail); - if (SCM_EQ_P (v0, ra1) - || (SCM_ARRAYP (ra1) && SCM_EQ_P (v0, SCM_ARRAY_V (ra1)))) + if (scm_is_eq (v0, ra1) + || (SCM_ARRAYP (ra1) && scm_is_eq (v0, SCM_ARRAY_V (ra1)))) goto gencase; } for (p = ra_asubrs; p->name; p++) - if (SCM_EQ_P (proc, p->sproc)) + if (scm_is_eq (proc, p->sproc)) { - if (!SCM_EQ_P (ra0, SCM_CAR (lra))) + if (!scm_is_eq (ra0, SCM_CAR (lra))) scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME); lra = SCM_CDR (lra); while (1) @@ -1932,7 +1932,7 @@ raeql (SCM ra0, SCM as_equal, SCM ra1) vlen *= s0[k].ubnd - s1[k].lbnd + 1; } } - if (unroll && bas0 == bas1 && SCM_EQ_P (v0, v1)) + if (unroll && bas0 == bas1 && scm_is_eq (v0, v1)) return 1; return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), ""); } diff --git a/libguile/read.c b/libguile/read.c index 7f301531b..b412cf6e4 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -388,7 +388,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) SCM got; got = scm_call_2 (sharp, SCM_MAKE_CHAR (c), port); - if (SCM_EQ_P (got, SCM_UNSPECIFIED)) + if (scm_is_eq (got, SCM_UNSPECIFIED)) goto handle_sharp; if (SCM_RECORD_POSITIONS_P) return *copy = recsexpr (got, line, column, @@ -489,7 +489,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) SCM got; got = scm_call_2 (sharp, SCM_MAKE_CHAR (c), port); - if (SCM_EQ_P (got, SCM_UNSPECIFIED)) + if (scm_is_eq (got, SCM_UNSPECIFIED)) goto unkshrp; if (SCM_RECORD_POSITIONS_P) return *copy = recsexpr (got, line, column, @@ -610,7 +610,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) goto tok; case ':': - if (SCM_EQ_P (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) + if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) { j = scm_read_token ('-', tok_buf, port, 0); p = scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); @@ -742,7 +742,7 @@ scm_i_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy, char term_char) if (term_char == c) return SCM_EOL; scm_ungetc (c, port); - if (SCM_EQ_P (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) + if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) { ans = scm_lreadr (tok_buf, port, copy); closeit: @@ -754,7 +754,7 @@ scm_i_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy, char term_char) while (term_char != (c = scm_flush_ws (port, name))) { scm_ungetc (c, port); - if (SCM_EQ_P (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) + if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) { SCM_SETCDR (tl, scm_lreadr (tok_buf, port, copy)); goto closeit; @@ -783,7 +783,7 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy) if (')' == c) return SCM_EOL; scm_ungetc (c, port); - if (SCM_EQ_P (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) + if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) { ans = scm_lreadr (tok_buf, port, copy); if (')' != (c = scm_flush_ws (port, name))) @@ -802,7 +802,7 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy) SCM new_tail; scm_ungetc (c, port); - if (SCM_EQ_P (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) + if (scm_is_eq (scm_sym_dot, (tmp = scm_lreadr (tok_buf, port, copy)))) { SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, copy)); if (SCM_COPY_SOURCE_P) @@ -859,7 +859,7 @@ SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0, SCM_VALIDATE_CHAR (1, chr); SCM_ASSERT (scm_is_false (proc) - || SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T), + || scm_is_eq (scm_procedure_p (proc), SCM_BOOL_T), proc, SCM_ARG2, FUNC_NAME); /* Check if chr is already in the alist. */ @@ -877,7 +877,7 @@ SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0, } break; } - if (SCM_EQ_P (chr, SCM_CAAR (this))) + if (scm_is_eq (chr, SCM_CAAR (this))) { /* already in the alist. */ if (scm_is_false (proc)) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index fba285d24..3591f3a63 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -146,7 +146,7 @@ scm_delq_spine_x (SCM cell, SCM list) { SCM s = list, prev = SCM_BOOL_F; - while (!SCM_EQ_P (cell, s)) + while (!scm_is_eq (cell, s)) { if (SCM_NULLP (s)) return list; @@ -192,7 +192,7 @@ really_install_handler (void *data) /* Make sure it is queued for the right thread. */ old_thread = SCM_VECTOR_REF (signal_handler_threads, signum); - if (!SCM_EQ_P (thread, old_thread)) + if (!scm_is_eq (thread, old_thread)) { scm_root_state *r; if (scm_is_true (old_thread)) diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 72f2db490..f48df9f51 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -202,11 +202,11 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); if (!SRCPROPSP (p)) goto plist; - if (SCM_EQ_P (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p)); - else if (SCM_EQ_P (scm_sym_line, key)) p = scm_from_int (SRCPROPLINE (p)); - else if (SCM_EQ_P (scm_sym_column, key)) p = scm_from_int (SRCPROPCOL (p)); - else if (SCM_EQ_P (scm_sym_filename, key)) p = SRCPROPFNAME (p); - else if (SCM_EQ_P (scm_sym_copy, key)) p = SRCPROPCOPY (p); + if (scm_is_eq (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p)); + else if (scm_is_eq (scm_sym_line, key)) p = scm_from_int (SRCPROPLINE (p)); + else if (scm_is_eq (scm_sym_column, key)) p = scm_from_int (SRCPROPCOL (p)); + else if (scm_is_eq (scm_sym_filename, key)) p = SRCPROPFNAME (p); + else if (scm_is_eq (scm_sym_copy, key)) p = SRCPROPCOPY (p); else { p = SRCPROPPLIST (p); @@ -239,7 +239,7 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, h = scm_whash_create_handle (scm_source_whash, obj); p = SCM_EOL; } - if (SCM_EQ_P (scm_sym_breakpoint, key)) + if (scm_is_eq (scm_sym_breakpoint, key)) { if (SRCPROPSP (p)) { @@ -258,7 +258,7 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, SETSRCPROPBRK (sp); } } - else if (SCM_EQ_P (scm_sym_line, key)) + else if (scm_is_eq (scm_sym_line, key)) { if (SRCPROPSP (p)) SETSRCPROPLINE (p, scm_to_int (datum)); @@ -267,7 +267,7 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, scm_make_srcprops (scm_to_int (datum), 0, SCM_UNDEFINED, SCM_UNDEFINED, p)); } - else if (SCM_EQ_P (scm_sym_column, key)) + else if (scm_is_eq (scm_sym_column, key)) { if (SRCPROPSP (p)) SETSRCPROPCOL (p, scm_to_int (datum)); @@ -276,14 +276,14 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, scm_make_srcprops (0, scm_to_int (datum), SCM_UNDEFINED, SCM_UNDEFINED, p)); } - else if (SCM_EQ_P (scm_sym_filename, key)) + else if (scm_is_eq (scm_sym_filename, key)) { if (SRCPROPSP (p)) SRCPROPFNAME (p) = datum; else SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p)); } - else if (SCM_EQ_P (scm_sym_copy, key)) + else if (scm_is_eq (scm_sym_copy, key)) { if (SRCPROPSP (p)) SRCPROPCOPY (p) = datum; diff --git a/libguile/stacks.c b/libguile/stacks.c index 8fd4dc8cc..387fc57fd 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -202,7 +202,7 @@ get_applybody () #define NEXT_FRAME(iframe, n, quit) \ do { \ if (SCM_MEMOIZEDP (iframe->source) \ - && SCM_EQ_P (SCM_MEMOIZED_EXP (iframe->source), applybody)) \ + && scm_is_eq (SCM_MEMOIZED_EXP (iframe->source), applybody)) \ { \ iframe->source = SCM_BOOL_F; \ if (scm_is_false (iframe->proc)) \ @@ -281,7 +281,7 @@ read_frames (scm_t_debug_frame *dframe, long offset, long n, scm_t_info_frame *i NEXT_FRAME (iframe, n, quit); } } - else if (SCM_EQ_P (iframe->proc, scm_f_gsubr_apply)) + else if (scm_is_eq (iframe->proc, scm_f_gsubr_apply)) /* Skip gsubr apply frames. */ continue; else @@ -324,7 +324,7 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key) long n = s->length; /* Cut inner part. */ - if (SCM_EQ_P (inner_key, SCM_BOOL_T)) + if (scm_is_eq (inner_key, SCM_BOOL_T)) { /* Cut all frames up to user module code */ for (i = 0; inner; ++i, --inner) @@ -358,7 +358,7 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key) /* Use standard cutting procedure. */ { for (i = 0; inner; --inner) - if (SCM_EQ_P (s->frames[i++].proc, inner_key)) + if (scm_is_eq (s->frames[i++].proc, inner_key)) break; } s->frames = &s->frames[i]; @@ -366,7 +366,7 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key) /* Cut outer part. */ for (; n && outer; --outer) - if (SCM_EQ_P (s->frames[--n].proc, outer_key)) + if (scm_is_eq (s->frames[--n].proc, outer_key)) break; s->length = n; @@ -425,7 +425,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, /* Extract a pointer to the innermost frame of whatever object scm_make_stack was given. */ - if (SCM_EQ_P (obj, SCM_BOOL_T)) + if (scm_is_eq (obj, SCM_BOOL_T)) { dframe = scm_last_debug_frame; } @@ -509,7 +509,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, { scm_t_debug_frame *dframe; long offset = 0; - if (SCM_EQ_P (stack, SCM_BOOL_T)) + if (scm_is_eq (stack, SCM_BOOL_T)) { dframe = scm_last_debug_frame; } diff --git a/libguile/stacks.h b/libguile/stacks.h index 4e68a67a5..568587c4c 100644 --- a/libguile/stacks.h +++ b/libguile/stacks.h @@ -48,7 +48,7 @@ typedef struct scm_t_stack { SCM_API SCM scm_stack_type; -#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && SCM_EQ_P (SCM_STRUCT_VTABLE (obj), scm_stack_type)) +#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && scm_is_eq (SCM_STRUCT_VTABLE (obj), scm_stack_type)) #define SCM_STACK_LENGTH(stack) (SCM_STACK (stack) -> length) #define SCM_FRAMEP(obj) \ diff --git a/libguile/threads.c b/libguile/threads.c index a94e0698d..25f06d6d4 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -68,9 +68,9 @@ remqueue (SCM q, SCM c) SCM p, prev = q; for (p = SCM_CDR (q); !SCM_NULLP (p); p = SCM_CDR (p)) { - if (SCM_EQ_P (p, c)) + if (scm_is_eq (p, c)) { - if (SCM_EQ_P (c, SCM_CAR (q))) + if (scm_is_eq (c, SCM_CAR (q))) SCM_SETCAR (q, SCM_CDR (c)); SCM_SETCDR (prev, SCM_CDR (c)); return; @@ -457,7 +457,7 @@ SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0, SCM res; SCM_VALIDATE_THREAD (1, thread); - if (SCM_EQ_P (cur_thread, thread)) + if (scm_is_eq (cur_thread, thread)) SCM_MISC_ERROR ("can not join the current thread", SCM_EOL); t = SCM_THREAD_DATA (thread); diff --git a/libguile/throw.c b/libguile/throw.c index 0f27e93a1..94affdeb4 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -502,7 +502,7 @@ SCM_DEFINE (scm_catch, "catch", 3, 0, 0, { struct scm_body_thunk_data c; - SCM_ASSERT (SCM_SYMBOLP (key) || SCM_EQ_P (key, SCM_BOOL_T), + SCM_ASSERT (SCM_SYMBOLP (key) || scm_is_eq (key, SCM_BOOL_T), key, SCM_ARG1, FUNC_NAME); c.tag = key; @@ -530,7 +530,7 @@ SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0, { struct scm_body_thunk_data c; - SCM_ASSERT (SCM_SYMBOLP (key) || SCM_EQ_P (key, SCM_BOOL_T), + SCM_ASSERT (SCM_SYMBOLP (key) || scm_is_eq (key, SCM_BOOL_T), key, SCM_ARG1, FUNC_NAME); c.tag = key; @@ -584,7 +584,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED) { SCM this_key = SCM_CAR (dynpair); - if (SCM_EQ_P (this_key, SCM_BOOL_T) || SCM_EQ_P (this_key, key)) + if (scm_is_eq (this_key, SCM_BOOL_T) || scm_is_eq (this_key, key)) break; } } @@ -605,7 +605,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED) jmpbuf = SCM_CDR (dynpair); for (wind_goal = scm_dynwinds; - !SCM_EQ_P (SCM_CDAR (wind_goal), jmpbuf); + !scm_is_eq (SCM_CDAR (wind_goal), jmpbuf); wind_goal = SCM_CDR (wind_goal)) ; diff --git a/libguile/unif.c b/libguile/unif.c index 3d81b95c4..3abc8c7d9 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -152,7 +152,7 @@ SCM scm_make_uve (long k, SCM prot) #define FUNC_NAME "scm_make_uve" { - if (SCM_EQ_P (prot, SCM_BOOL_T)) + if (scm_is_eq (prot, SCM_BOOL_T)) { if (k > 0) { @@ -271,13 +271,13 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, switch (SCM_TYP7 (v)) { case scm_tc7_bvect: - protp = (SCM_EQ_P (prot, SCM_BOOL_T)); + protp = (scm_is_eq (prot, SCM_BOOL_T)); break; case scm_tc7_string: protp = SCM_CHARP(prot) && (SCM_CHAR (prot) != '\0'); break; case scm_tc7_byvect: - protp = SCM_EQ_P (prot, SCM_MAKE_CHAR ('\0')); + protp = scm_is_eq (prot, SCM_MAKE_CHAR ('\0')); break; case scm_tc7_uvect: protp = SCM_I_INUMP(prot) && SCM_I_INUM(prot)>0; @@ -1169,14 +1169,14 @@ scm_cvref (SCM v, unsigned long pos, SCM last) return scm_from_long_long (((long long *) SCM_CELL_WORD_1 (v))[pos]); #endif case scm_tc7_fvect: - if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0)) + if (SCM_REALP (last) && !scm_is_eq (last, scm_flo0)) { SCM_REAL_VALUE (last) = ((float *) SCM_CELL_WORD_1 (v))[pos]; return last; } return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]); case scm_tc7_dvect: - if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0)) + if (SCM_REALP (last) && !scm_is_eq (last, scm_flo0)) { SCM_REAL_VALUE (last) = ((double *) SCM_CELL_WORD_1 (v))[pos]; return last; @@ -1262,7 +1262,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, case scm_tc7_bvect: if (scm_is_false (obj)) SCM_BITVEC_CLR(v, pos); - else if (SCM_EQ_P (obj, SCM_BOOL_T)) + else if (scm_is_eq (obj, SCM_BOOL_T)) SCM_BITVEC_SET(v, pos); else badobj:SCM_WRONG_TYPE_ARG (2, obj); @@ -1595,7 +1595,7 @@ loop: if (SCM_TYP7 (v) == scm_tc7_bvect) ans *= SCM_LONG_BIT; - if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra)) + if (!scm_is_eq (v, ra) && !scm_is_eq (cra, ra)) scm_array_copy_x (cra, ra); return scm_from_long (ans); @@ -1891,7 +1891,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, scm_out_of_range (FUNC_NAME, scm_from_long (k)); SCM_BITVEC_CLR(v, k); } - else if (SCM_EQ_P (obj, SCM_BOOL_T)) + else if (scm_is_eq (obj, SCM_BOOL_T)) for (i = SCM_UVECTOR_LENGTH (kv); i;) { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); @@ -1907,7 +1907,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, if (scm_is_false (obj)) for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) SCM_BITVECTOR_BASE (v) [k] &= ~SCM_BITVECTOR_BASE (kv) [k]; - else if (SCM_EQ_P (obj, SCM_BOOL_T)) + else if (scm_is_eq (obj, SCM_BOOL_T)) for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) SCM_BITVECTOR_BASE (v) [k] |= SCM_BITVECTOR_BASE (kv) [k]; else @@ -1962,7 +1962,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, if (!SCM_BITVEC_REF(v, k)) count++; } - else if (SCM_EQ_P (obj, SCM_BOOL_T)) + else if (scm_is_eq (obj, SCM_BOOL_T)) for (i = SCM_UVECTOR_LENGTH (kv); i;) { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); @@ -1979,7 +1979,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, if (0 == SCM_BITVECTOR_LENGTH (v)) return SCM_INUM0; SCM_ASRTGO (scm_is_bool (obj), badarg3); - fObj = SCM_EQ_P (obj, SCM_BOOL_T); + fObj = scm_is_eq (obj, SCM_BOOL_T); i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK (SCM_VELTS (v)[i]) : ~ SCM_UNPACK (SCM_VELTS (v)[i])); k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT); @@ -2465,7 +2465,7 @@ tail: } } case scm_tc7_bvect: - if (SCM_EQ_P (exp, v)) + if (scm_is_eq (exp, v)) { /* a uve, not an scm_array */ register long i, j, w; scm_putc ('*', port); diff --git a/libguile/validate.h b/libguile/validate.h index 3da0d0500..18a671e61 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -143,7 +143,7 @@ #define SCM_VALIDATE_BOOL_COPY(pos, flag, cvar) \ do { \ SCM_ASSERT (scm_is_bool (flag), flag, pos, FUNC_NAME); \ - cvar = SCM_EQ_P (flag, SCM_BOOL_T) ? 1 : 0; \ + cvar = scm_to_bool (flag); \ } while (0) #define SCM_VALIDATE_CHAR(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, CHARP, "character") @@ -306,7 +306,7 @@ #define SCM_VALIDATE_PROC(pos, proc) \ do { \ - SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T), proc, pos, FUNC_NAME); \ + SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, pos, FUNC_NAME); \ } while (0) #define SCM_VALIDATE_NULLORCONS(pos, env) \ diff --git a/libguile/values.h b/libguile/values.h index 5ddcadf47..7653e3583 100644 --- a/libguile/values.h +++ b/libguile/values.h @@ -27,7 +27,7 @@ SCM_API SCM scm_values_vtable; #define SCM_VALUESP(x) (SCM_STRUCTP (x)\ - && SCM_EQ_P (scm_struct_vtable (x), scm_values_vtable)) + && scm_is_eq (scm_struct_vtable (x), scm_values_vtable)) SCM_API SCM scm_values (SCM args); SCM_API void scm_init_values (void); diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index eef97d7ef..c194f66b5 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -49,7 +49,7 @@ srfi1_ilength (SCM sx) /* For every two steps the hare takes, the tortoise takes one. */ tortoise = SCM_CDR(tortoise); } - while (! SCM_EQ_P (hare, tortoise)); + while (! scm_is_eq (hare, tortoise)); /* If the tortoise ever catches the hare, then the list must contain a cycle. */ @@ -222,7 +222,7 @@ SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0, { /* delete this element, so copy from keeplst (inclusive) to lst (exclusive) onto ret */ - while (! SCM_EQ_P (keeplst, lst)) + while (! scm_is_eq (keeplst, lst)) { SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL); *p = c; @@ -360,13 +360,13 @@ SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0, item = SCM_CAR (lst); /* loop searching ret upto lst */ - for (l = ret; ! SCM_EQ_P (l, lst); l = SCM_CDR (l)) + for (l = ret; ! scm_is_eq (l, lst); l = SCM_CDR (l)) { if (scm_is_true (equal_p (pred, SCM_CAR (l), item))) { /* duplicate, don't want this element, so copy keeplst (inclusive) to lst (exclusive) onto ret */ - while (! SCM_EQ_P (keeplst, lst)) + while (! scm_is_eq (keeplst, lst)) { SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL); *p = c; @@ -450,7 +450,7 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0, if (scm_is_true (equal_p (pred, SCM_CAR (l), item))) break; /* equal, forget this element */ - if (SCM_EQ_P (l, endret)) + if (scm_is_eq (l, endret)) { /* not equal to any, so append this pair */ SCM_SETCDR (endret, lst); diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index 0efd24abb..bbb20faab 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -236,13 +236,13 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, /* Validate the grammar symbol and remember the grammar. */ if (SCM_UNBNDP (grammar)) gram = GRAM_INFIX; - else if (SCM_EQ_P (grammar, scm_sym_infix)) + else if (scm_is_eq (grammar, scm_sym_infix)) gram = GRAM_INFIX; - else if (SCM_EQ_P (grammar, scm_sym_strict_infix)) + else if (scm_is_eq (grammar, scm_sym_strict_infix)) gram = GRAM_STRICT_INFIX; - else if (SCM_EQ_P (grammar, scm_sym_suffix)) + else if (scm_is_eq (grammar, scm_sym_suffix)) gram = GRAM_SUFFIX; - else if (SCM_EQ_P (grammar, scm_sym_prefix)) + else if (scm_is_eq (grammar, scm_sym_prefix)) gram = GRAM_PREFIX; else SCM_WRONG_TYPE_ARG (3, grammar); From 710491c564b18366e775ebafa4b2d153e1800737 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 27 Jul 2004 22:49:52 +0000 Subject: [PATCH 54/89] (make-regexp): Exercise flags args validation. --- test-suite/tests/regexp.test | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test index 0358354ba..c7e9f0715 100644 --- a/test-suite/tests/regexp.test +++ b/test-suite/tests/regexp.test @@ -1,7 +1,7 @@ ;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*- ;;;; Jim Blandy --- September 1999 ;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2004 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 @@ -39,6 +39,29 @@ (lambda (port) (write obj port)))) +;;; +;;; make-regexp +;;; + +(with-test-prefix "make-regexp" + + (pass-if-exception "no args" exception:wrong-num-args + (make-regexp)) + + (pass-if-exception "bad pat arg" exception:wrong-type-arg + (make-regexp 'blah)) + + ;; in guile prior to 1.6.5 make-regex didn't validate its flags args + (pass-if-exception "bad arg 2" exception:wrong-type-arg + (make-regexp "xyz" 'abc)) + + (pass-if-exception "bad arg 3" exception:wrong-type-arg + (make-regexp "xyz" regexp/icase 'abc))) + +;;; +;;; regexp-substitute +;;; + (with-test-prefix "regexp-substitute" (let ((match (string-match "patleft(sub1)patmid(sub2)patright" From 081c1b24fadbe74e59a739f98b4721dbe1ecebd9 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 27 Jul 2004 22:55:55 +0000 Subject: [PATCH 55/89] *** empty log message *** --- test-suite/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 259f62a17..d8565e473 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2004-07-28 Kevin Ryde + + * tests/regexp.test (make-regexp): Exercise flags args validation. + 2004-07-24 Kevin Ryde * tests/common-list.test: Use define-module, to as not to import From 0a9d83b0f490a7df942a39f3d6b57e819be0d42d Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 27 Jul 2004 23:10:35 +0000 Subject: [PATCH 56/89] (scm_ctermid): Use an L_ctermid buf on the stack, for thread safety. --- libguile/posix.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/libguile/posix.c b/libguile/posix.c index 1bc5d6ccd..f4035e8a0 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -792,6 +792,11 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0, #undef FUNC_NAME #endif /* HAVE_TTYNAME */ +/* For thread safety "buf" is used instead of NULL for the ctermid static + buffer. Actually it's unlikely the controlling terminal will change + during program execution, and indeed on glibc (2.3.2) it's always just + "/dev/tty", but L_ctermid on the stack is easy and fast and guarantees + safety everywhere. */ #ifdef HAVE_CTERMID SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0, (), @@ -799,7 +804,8 @@ SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0, "terminal for the current process.") #define FUNC_NAME s_scm_ctermid { - char *result = ctermid (NULL); + char buf[L_ctermid]; + char *result = ctermid (buf); if (*result == '\0') SCM_SYSERROR; return scm_makfrom0str (result); From 48360eb3eea56a59ee418547a544e90686ed784b Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 27 Jul 2004 23:11:33 +0000 Subject: [PATCH 57/89] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index ab136308a..e14495cca 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2004-07-28 Kevin Ryde + + * posix.c (scm_ctermid): Use an L_ctermid buf on the stack, for thread + safety. + 2004-07-27 Marius Vollmer * deprecated.h (SCM_FALSEP, SCM_NFALSEP, SCM_BOOLP, SCM_BOOL): From a1f3180a9295ca7d48a69636dbd078abef932ab7 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 27 Jul 2004 23:27:51 +0000 Subject: [PATCH 58/89] (array-set!): Exercise svect value range check. --- test-suite/tests/unif.test | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test index bbe02e063..3915fe232 100644 --- a/test-suite/tests/unif.test +++ b/test-suite/tests/unif.test @@ -348,6 +348,36 @@ (pass-if "scm" (eq? '() (array-prototype (make-uniform-array '() '(5 6))))))) +;;; +;;; array-set! +;;; + +(with-test-prefix "array-set!" + + (with-test-prefix "short" + + (let ((a (make-uniform-array 's 1))) + ;; true if n can be array-set! into a + (define (fits? n) + (false-if-exception (begin (array-set! a n 0) #t))) + + (with-test-prefix "store/fetch" + ;; Check array-ref gives back what was put with array-set!. + ;; In Guile 1.6.4 and earlier, array-set! only demanded an inum and + ;; would silently truncate to a short. + + (do ((n 1 (1+ (* 2 n)))) ;; n=2^k-1 + ((not (fits? n))) + (array-set! a n 0) + (pass-if n + (= n (array-ref a 0)))) + + (do ((n -1 (* 2 n))) ;; -n=2^k + ((not (fits? n))) + (array-set! a n 0) + (pass-if n + (= n (array-ref a 0)))))))) + ;;; ;;; uniform-array-set1! ;;; From eb16734d62757c958c6652018d16511a750b7f0c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 27 Jul 2004 23:36:35 +0000 Subject: [PATCH 59/89] (scm_array_set_x): For svect, use scm_num2short for consistency with other vector types and to get arg and func name into error message. --- libguile/unif.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/unif.c b/libguile/unif.c index 3abc8c7d9..34b707f7b 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1285,7 +1285,8 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, = scm_num2long (obj, SCM_ARG2, FUNC_NAME); break; case scm_tc7_svect: - ((short *) SCM_UVECTOR_BASE (v))[pos] = scm_to_short (obj); + ((short *) SCM_UVECTOR_BASE (v))[pos] + = scm_num2short (obj, SCM_ARG2, FUNC_NAME); break; #if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: From c3f3c841f072c87d0311d7f8aa943a2c2e5a47b2 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 27 Jul 2004 23:38:20 +0000 Subject: [PATCH 60/89] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e14495cca..52a18d036 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -3,6 +3,10 @@ * posix.c (scm_ctermid): Use an L_ctermid buf on the stack, for thread safety. + * unif.c (scm_array_set_x): For svect, use scm_num2short for + consistency with other vector types and to get arg and func name into + error message. + 2004-07-27 Marius Vollmer * deprecated.h (SCM_FALSEP, SCM_NFALSEP, SCM_BOOLP, SCM_BOOL): From 32b435f20190db5f8130285b78cdd6aee77bbafb Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 27 Jul 2004 23:47:16 +0000 Subject: [PATCH 61/89] *** empty log message *** --- test-suite/ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d8565e473..dc9f85831 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -2,6 +2,8 @@ * tests/regexp.test (make-regexp): Exercise flags args validation. + * tests/unif.test (array-set!): Exercise svect value range check. + 2004-07-24 Kevin Ryde * tests/common-list.test: Use define-module, to as not to import From 17bf4bfa2139e7921227c9c653723dbb2cbf5aa6 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 28 Jul 2004 00:53:09 +0000 Subject: [PATCH 62/89] (@le, @ge): New macros for ifnottex. --- doc/ref/guile.texi | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 0d14998a4..bea77dbd4 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -73,6 +73,18 @@ section entitled "GNU Free Documentation License". @end macro +@c The following, @le{} and @ge{}, are standard tex directives, given +@c definitions for use in non-tex. +@c +@ifnottex +@macro ge +>= +@end macro +@macro le +<= +@end macro +@end ifnottex + @c @cross{} is a \times symbol in tex, or an "x" in info. In tex it works @c inside or outside $ $. @tex @@ -125,7 +137,7 @@ x @comment The title is printed in a large font. @title Guile Reference Manual @subtitle Edition @value{MANUAL-EDITION}, for use with Guile @value{VERSION} -@c @subtitle $Id: guile.texi,v 1.32 2004-07-24 00:45:02 kryde Exp $ +@c @subtitle $Id: guile.texi,v 1.33 2004-07-28 00:53:09 kryde Exp $ @c See preface.texi for the list of authors @author The Guile Developers From 76d3f3d47f14d8c85921574ba6c3f7e5dcd2d61c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 28 Jul 2004 00:54:04 +0000 Subject: [PATCH 63/89] (Formatted Output): Rewrite, describing escapes and parameters in detail. --- doc/ref/misc-modules.texi | 1062 +++++++++++++++++++++++++++++++------ 1 file changed, 889 insertions(+), 173 deletions(-) diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index 0d8bfdcaf..c22aa4d9c 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -82,232 +82,948 @@ used by @code{write}, but not by @code{pretty-print}. @page @node Formatted Output @section Formatted Output - -@c FIXME::martin: Review me! - -@cindex format @cindex formatted output -Outputting messages or other texts which are composed of literal -strings, variable contents, newlines and other formatting can be -cumbersome, when only the standard procedures like @code{display}, -@code{write} and @code{newline} are available. Additionally, one -often wants to collect the output in strings. With the standard -routines, the user is required to set up a string port, add this port -as a parameter to the output procedure calls and then retrieve the -resulting string from the string port. -The @code{format} procedure, to be found in module @code{(ice-9 -format)}, can do all this, and even more. If you are a C programmer, -you can think of this procedure as Guile's @code{fprintf}. +@c For reference, in this section escapes like ~a are given in +@c @nicode, to give code font in TeX etc, but leave them unadorned in +@c Info. +@c +@c The idea is to reduce clutter around what's shown, and avoid any +@c possible confusion over whether the ` ' quotes are part of what +@c should be entered. (In particular for instance of course ' is +@c meaningful in a format string, introducing a char parameter). -@deffn {Scheme Procedure} format destination format-string args @dots{} -The first parameter is the @var{destination}, it determines where the -output of @code{format} will go. +The @code{format} function is a powerful way to print numbers, strings +and other objects together with literal text under the control of a +format string. This function is available from + +@example +(use-modules (ice-9 format)) +@end example + +A format string is generally more compact and easier than using just +the standard procedures like @code{display}, @code{write} and +@code{newline}. Parameters in the output string allow various output +styles, and parameters can be taken from the arguments for runtime +flexibility. + +@code{format} is similar to the Common Lisp procedure of the same +name, but it's not identical and doesn't have quite all the features +found in Common Lisp. + +C programmers will note the similarity between @code{format} and +@code{printf}, though escape sequences are marked with @nicode{~} +instead of @nicode{%}, and are more powerful. + +@sp 1 +@deffn {Scheme Procedure} format dest fmt [args@dots{}] +Write output specified by the @var{fmt} string to @var{dest}. +@var{dest} can be an output port, @code{#t} for +@code{current-output-port} (@pxref{Default Ports}), a number for +@code{current-error-port}, or @code{#f} to return the output as a +string. + +@var{fmt} can contain literal text to be output, and @nicode{~} +escapes. Each escape has the form + +@example +~ [param [, param@dots{}] [:] [@@] code +@end example + +@nicode{code} is a character determining the escape sequence. The +@nicode{:} and @nicode{@@} characters are optional modifiers, one or +both of which change the way various codes operate. Optional +parameters are accepted by some codes too. Parameters have the +following forms, @table @asis -@item @code{#t} -Send the formatted output to the current output port and return -@code{#t}. - -@item @code{#f} -Return the formatted output as a string. - -@item Any number value -Send the formatted output to the current error port and return -@code{#t}. - -@item A valid output port -Send the formatted output to the port @var{destination} and return -@code{#t}. +@item @nicode{[+/-] number} +An integer, with optional @nicode{+} or @nicode{-}. +@item @nicode{'} (apostrophe) +The following character in the format string, for instance @nicode{'z} +for @nicode{z}. +@item @nicode{v} +The next function argument as the parameter. @nicode{v} stands for +``variable'', a parameter can be calculated at runtime and included in +the arguments. Upper case @nicode{V} can be used too. +@item @nicode{#} +The number of arguments remaining. (See @nicode{~*} below for some +usages.) @end table -The second parameter is the format string. It has a similar function -to the format string in calls to @code{printf} or @code{fprintf} in C. -It is output to the specified destination, but all escape sequences -are replaced by the results of formatting the corresponding sequence. +Parameters are separated by commas (@nicode{,}). A parameter can be +left empty to keep its default value when supplying later parameters. -Note that escape sequences are marked with the character @code{~} -(tilde), and not with a @code{%} (percent sign), as in C. +@sp 1 +The following escapes are available. The code letters are not +case-sensitive, upper and lower case are the same. -The escape sequences in the following table are supported. When there -appears ``corresponding @var{arg}', that means any of the additional -arguments, after dropping all arguments which have been used up by -escape sequences which have been processed earlier. Some of the -format characters (the characters following the tilde) can be prefixed -by @code{:}, @code{@@}, or @code{:@@}, to modify the behaviour of the -format character. How the modified behaviour differs from the default -behaviour is described for every character in the table where -appropriate. +@table @asis +@item @nicode{~a} +@itemx @nicode{~s} +Object output. Parameters: @var{minwidth}, @var{padinc}, +@var{minpad}, @var{padchar}. -@table @code -@item ~~ -Output a single @code{~} (tilde) character. +@nicode{~a} outputs an argument like @code{display}, @nicode{~s} +outputs an argument like @code{write} (@pxref{Writing}). -@item ~% -Output a newline character, thus advancing to the next output line. +@example +(format #t "~a" "foo") @print{} foo +(format #t "~s" "foo") @print{} "foo" +@end example -@item ~& -Start a new line, that is, output a newline character if not already -at the start of a line. +With the @nicode{:} modifier, objects which don't have an external +representation are put in quotes like a string. -@item ~_ -Output a single space character. +@example +(format #t "~:a" car) @print{} "#" +@end example -@item ~/ -Output a single tabulator character. +If the output is less than @var{minwidth} characters (default 0), it's +padded on the right with @var{padchar} (default space). The +@nicode{@@} modifier puts the padding on the left instead. -@item ~| -Output a page separator (formfeed) character. +@example +(format #f "~5a" 'abc) @result{} "abc " +(format #f "~5,,,'-@@a" 'abc) @result{} "--abc" +@end example -@item ~t -Advance to the next tabulator position. +@var{minpad} is a minimum for the padding then plus a multiple of +@var{padinc}. Ie.@: the padding is @math{@var{minpad} + @var{N} * +@var{padinc}}, where @var{n} is the smallest integer making the total +object plus padding greater than or equal to @var{minwidth}. The +default @var{minpad} is 0 and the default @var{padinc} is 1 (imposing +no minimum or multiple). -@item ~y -Pretty-print the corresponding @var{arg}. +@example +(format #f "~5,1,4a" 'abc) @result{} "abc " +@end example -@item ~a -Output the corresponding @var{arg} like @code{display}. +@item @nicode{~c} +Character. Parameter: @var{charnum}. -@item ~s -Output the corresponding @var{arg} like @code{write}. +Output a character. The default is to simply output, as per +@code{write-char} (@pxref{Writing}). With the @nicode{@@} modifier +output is in @code{write} style. Or with the @nicode{:} modifier +control characters (ASCII 0 to 31) are printed in @nicode{^X} form. -@item ~d -Output the corresponding @var{arg} as a decimal number. +@example +(format #t "~c" #\z) @print{} z +(format #t "~@@c" #\z) @print{} #\z +(format #t "~:c" #\newline) @print{} ^J +@end example -@item ~x -Output the corresponding @var{arg} as a hexadecimal number. +If the @var{charnum} parameter is given then an argument is not taken +but instead the character is @code{(integer->char @var{charnum})} +(@pxref{Characters}). This can be used for instance to output +characters given by their ASCII code. -@item ~o -Output the corresponding @var{arg} as an octal number. +@example +(format #t "~65c") @print{} A +@end example -@item ~b -Output the corresponding @var{arg} as a binary number. +@item @nicode{~d} +@itemx @nicode{~x} +@itemx @nicode{~o} +@itemx @nicode{~b} +Integer. Parameters: @var{minwidth}, @var{padchar}, @var{commachar}, +@var{commawidth}. -@item ~r -Output the corresponding @var{arg} as a number word, e.g. 10 prints as -@code{ten}. If prefixed with @code{:}, @code{tenth} is printed, if -prefixed with @code{:@@}, Roman numbers are printed. +Output an integer argument as a decimal, hexadecimal, octal or binary +integer (respectively). -@item ~f -Output the corresponding @var{arg} as a fixed format floating point -number, such as @code{1.34}. +@example +(format #t "~d" 123) @print{} 123 +@end example -@item ~e -Output the corresponding @var{arg} in exponential notation, such as -@code{1.34E+0}. +With the @nicode{@@} modifier, a @nicode{+} sign is shown on positive +numbers. -@item ~g -This works either like @code{~f} or like @code{~e}, whichever produces -less characters to be written. +@c FIXME: "+" is not shown on zero, unlike in Common Lisp. Should +@c that be changed in the code, or is it too late and should just be +@c documented that way? -@item ~$ -Like @code{~f}, but only with two digits after the decimal point. +@example +(format #t "~@@b" 12) @print{} +1100 +@end example -@item ~i -Output the corresponding @var{arg} as a complex number. +If the output is less than the @var{minwidth} parameter (default no +minimum), it's padded on the left with the @var{padchar} parameter +(default space). -@item ~c -Output the corresponding @var{arg} as a character. If prefixed with -@code{@@}, it is printed like with @code{write}. If prefixed with -@code{:}, control characters are treated specially, for example -@code{#\newline} will be printed as @code{^J}. +@example +(format #t "~5,'*d" 12) @print{} ***12 +(format #t "~5,'0d" 12) @print{} 00012 +(format #t "~3d" 1234) @print{} 1234 +@end example -@item ~p -``Plural''. If the corresponding @var{arg} is 1, nothing is printed -(or @code{y} if prefixed with @code{@@} or @code{:@@}), otherwise -@code{s} is printed (or @code{ies} if prefixed with @code{@@} or -@code{:@@}). +The @nicode{:} modifier adds commas (or the @var{commachar} parameter) +every three digits (or the @var{commawidth} parameter many). -@item ~?, ~k -Take the corresponding argument as a format string, and the following -argument as a list of values. Then format the values with respect to -the format string. +@example +(format #t "~:d" 1234567) @print{} 1,234,567 +(format #t "~10,'*,'/,2:d" 12345) @print{} ***1/23/45 +@end example -@item ~! -Flush the output to the output port. +Hexadecimal @nicode{~x} output is in lower case, but the @nicode{~(} +and @nicode{~)} case conversion directives described below can be used +to get upper case. -@item ~#\newline (tilde-newline) -@c FIXME::martin: I don't understand this from the source. -Continuation lines. +@example +(format #t "~x" 65261) @print{} feed +(format #t "~:@@(~x~)" 65261) @print{} FEED +@end example -@item ~* -Argument jumping. Navigate in the argument list as specified by the -corresponding argument. If prefixed with @code{:}, jump backwards in -the argument list, if prefixed by @code{:@@}, jump to the parameter -with the absolute index, otherwise jump forward in the argument list. +@item @nicode{~r} +Integer in words, roman numerals, or a specified radix. Parameters: +@var{radix}, @var{minwidth}, @var{padchar}, @var{commachar}, +@var{commawidth}. -@item ~( -Case conversion begin. If prefixed by @code{:}, the following output -string will be capitalized, if prefixed by @code{@@}, the first -character will be capitalized, if prefixed by @code{:@@} it will be -upcased and otherwise it will be downcased. Conversion stops when the -``Case conversion end'' @code{~)}sequence is encountered. +With no parameters output is in words as a cardinal like ``ten'', or +with the @nicode{:} modifier as an ordinal like ``tenth''. -@item ~) -Case conversion end. Stop any case conversion currently in effect. +@example +(format #t "~r" 9) @print{} nine ;; cardinal +(format #t "~r" -9) @print{} minus nine ;; cardinal +(format #t "~:r" 9) @print{} ninth ;; ordinal +@end example -@item ~[ -@c FIXME::martin: I don't understand this from the source. -Conditional begin. +And also with no parameters, the @nicode{@@} modifier gives roman +numerals and @nicode{@@} and @nicode{:} together give old roman +numerals. In old roman numerals there's no ``subtraction'', so 9 is +@nicode{VIIII} instead of @nicode{IX}. In both cases only positive +numbers can be output. -@item ~; -@c FIXME::martin: I don't understand this from the source. -Conditional separator. +@example +(format #t "~@@r" 89) @print{} LXXXIX ;; roman +(format #t "~@@:r" 89) @print{} LXXXVIIII ;; old roman +@end example -@item ~] -@c FIXME::martin: I don't understand this from the source. -Conditional end. +When a parameter is given it means numeric output in the specified +@var{radix}. The modifiers and parameters following the radix are the +same as described for @nicode{~d} etc above. -@item ~@{ -@c FIXME::martin: I don't understand this from the source. -Iteration begin. +@example +(format #f "~3r" 27) @result{} "1000" ;; base 3 +(format #f "~3,5r" 26) @result{} " 222" ;; base 3 width 5 +@end example -@item ~@} -@c FIXME::martin: I don't understand this from the source. -Iteration end. +@item @nicode{~f} +Fixed-point float. Parameters: @var{width}, @var{decimals}, +@var{scale}, @var{overflowchar}, @var{padchar}. -@item ~^ -@c FIXME::martin: I don't understand this from the source. -Up and out. +Output a number or number string in fixed-point format, ie.@: with a +decimal point. -@item ~' -@c FIXME::martin: I don't understand this from the source. -Character parameter. +@example +(format #t "~f" 5) @print{} 5.0 +(format #t "~f" "123") @print{} 123.0 +(format #t "~f" "1e-1") @print{} 0.1 +@end example -@item ~0 @dots{} ~9, ~-, ~+ -@c FIXME::martin: I don't understand this from the source. -Numeric parameter. +With the @nicode{@@} modifier a @nicode{+} sign is shown on positive +numbers (including zero). -@item ~v -@c FIXME::martin: I don't understand this from the source. -Variable parameter from next argument. +@example +(format #t "~@@f" 0) @print{} +0.0 +@end example -@item ~# -Parameter is number of remaining args. The number of the remaining -arguments is prepended to the list of unprocessed arguments. +If the output is less than @var{width} characters it's padded on the +left with @var{padchar} (space by default). If the output equals or +exceeds @var{width} then there's no padding. The default for +@var{width} is no padding. -@item ~, -@c FIXME::martin: I don't understand this from the source. -Parameter separators. +@example +(format #f "~6f" -1.5) @result{} " -1.5" +(format #f "~6,,,,'*f" 23) @result{} "**23.0" +(format #f "~6f" 1234567.0) @result{} "1234567.0" +@end example -@item ~q -Inquiry message. Insert a copyright message into the output. +@var{decimals} is how many digits to print after the decimal point, +with the value rounded or padded with zeros as necessary. (The +default is to output as many decimals as required.) + +@example +(format #t "~1,2f" 3.125) @print{} 3.13 +(format #t "~1,2f" 1.5) @print{} 1.50 +@end example + +@var{scale} is a power of 10 applied to the value, moving the decimal +point that many places. A positive @var{scale} increases the value +shown, a negative decreases it. + +@example +(format #t "~,,2f" 1234) @print{} 123400.0 +(format #t "~,,-2f" 1234) @print{} 12.34 +@end example + +If @var{overflowchar} and @var{width} are both given and if the output +would exceed @var{width}, then that many @var{overflowchar}s are +printed instead of the value. + +@example +(format #t "~5,,,'xf" 12345) @print{} 12345 +(format #t "~4,,,'xf" 12345) @print{} xxxx +@end example + +@item @nicode{~e} +Exponential float. Parameters: @var{width}, @var{mantdigits}, +@var{expdigits}, @var{intdigits}, @var{overflowchar}, @var{padchar}, +@var{expchar}. + +Output a number or number string in exponential notation. + +@example +(format #t "~e" 5000.25) @print{} 5.00025E+3 +(format #t "~e" "123.4") @print{} 1.234E+2 +(format #t "~e" "1e4") @print{} 1.0E+4 +@end example + +With the @nicode{@@} modifier a @nicode{+} sign is shown on positive +numbers (including zero). (This is for the mantissa, a @nicode{+} or +@nicode{-} sign is always shown on the exponent.) + +@example +(format #t "~@@e" 5000.0) @print{} +5.0E+3 +@end example + +If the output is less than @var{width} characters it's padded on the +left with @var{padchar} (space by default). The default for +@var{width} is to output with no padding. + +@example +(format #f "~10e" 1234.0) @result{} " 1.234E+3" +(format #f "~10,,,,,'*e" 0.5) @result{} "****5.0E-1" +@end example + +@c FIXME: Describe what happens when the number is bigger than WIDTH. +@c There seems to be a bit of dodginess about this, or some deviation +@c from Common Lisp. + +@var{mantdigits} is the number of digits shown in the mantissa after +the decimal point. The value is rounded or trailing zeros are added +as necessary. The default @var{mantdigits} is to show as much as +needed by the value. + +@example +(format #f "~,3e" 11111.0) @result{} "1.111E+4" +(format #f "~,8e" 123.0) @result{} "1.23000000E+2" +@end example + +@var{expdigits} is the minimum number of digits shown for the +exponent, with leading zeros added if necessary. The default for +@var{expdigits} is to show only as many digits as required. At least +1 digit is always shown. + +@example +(format #f "~,,1e" 1.0e99) @result{} "1.0E+99" +(format #f "~,,6e" 1.0e99) @result{} "1.0E+000099" +@end example + +@var{intdigits} (default 1) is the number of digits to show before the +decimal point in the mantissa. @var{intdigits} can be zero, in which +case the integer part is a single @nicode{0}, or it can be negative, +in which case leading zeros are shown after the decimal point. + +@c FIXME: When INTDIGITS is 0, Common Lisp format apparently only +@c shows the single 0 digit if it fits in WIDTH. format.scm seems to +@c show it always. Is it meant to? + +@example +(format #t "~,,,3e" 12345.0) @print{} 123.45E+2 +(format #t "~,,,0e" 12345.0) @print{} 0.12345E+5 +(format #t "~,,,-3e" 12345.0) @print{} 0.00012345E+8 +@end example + +@c FIXME: MANTDIGITS with negative INTDIGITS doesn't match CL spec, +@c believe the spec says it ought to still show mantdigits+1 sig +@c figures, ie. leading zeros don't count towards MANTDIGITS, but it +@c seems to just treat MANTDIGITS as how many digits after the +@c decimal point. + +If @var{overflowchar} is given then @var{width} is a hard limit. If +the output would exceed @var{width} then instead that many +@var{overflowchar}s are printed. + +@example +(format #f "~6,,,,'xe" 100.0) @result{} "1.0E+2" +(format #f "~3,,,,'xe" 100.0) @result{} "xxx" +@end example + +@var{expchar} is the exponent marker character (default @nicode{E}). + +@example +(format #t "~,,,,,,'ee" 100.0) @print{} 1.0e+2 +@end example + +@item @nicode{~g} +General float. Parameters: @var{width}, @var{mantdigits}, +@var{expdigits}, @var{intdigits}, @var{overflowchar}, @var{padchar}, +@var{expchar}. + +Output a number or number string in either exponential format the same +as @nicode{~e}, or fixed-point format like @nicode{~f} but aligned +where the mantissa would have been and followed by padding where the +exponent would have been. + +@c FIXME: The default MANTDIGITS is apparently max(needed,min(n,7)) +@c where 10^(n-1)<=abs(x)<=10^n. But the Common Lisp spec seems to +@c ask for "needed" to be without leading or trailing zeros, whereas +@c format.scm seems to include trailing zeros, ending up with it +@c using fixed format for bigger values than it should. + +Fixed-point is used when the absolute value is 0.1 or more and it +takes no more space than the mantissa in exponential format, ie.@: +basically up to @var{mantdigits} digits. + +@example +(format #f "~12,4,2g" 999.0) @result{} " 999.0 " +(format #f "~12,4,2g" "100000") @result{} " 1.0000E+05" +@end example + +The parameters are interpreted as per @nicode{~e} above. When +fixed-point is used, the @var{decimals} parameter to @nicode{~f} is +established from @var{mantdigits}, so as to give a total +@math{@var{mantdigits}+1} figures. + +@item @nicode{~$} +Monetary style fixed-point float. Parameters: @var{decimals}, +@var{intdigits}, @var{width}, @var{padchar}. + +@c For reference, fmtdoc.txi from past versions of slib showed the +@c INTDIGITS parameter as SCALE. That looks like a typo, in the code +@c and in the Common Lisp spec it's a minimum digits for the integer +@c part, it isn't a power of 10 like in ~f. + +Output a number or number string in fixed-point format, ie.@: with a +decimal point. @var{decimals} is the number of decimal places to +show, default 2. + +@example +(format #t "~$" 5) @print{} 5.00 +(format #t "~4$" "2.25") @print{} 2.2500 +(format #t "~4$" "1e-2") @print{} 0.0100 +@end example + +With the @nicode{@@} modifier a @nicode{+} sign is shown on positive +numbers (including zero). + +@example +(format #t "~@@$" 0) @print{} +0.00 +@end example + +@var{intdigits} is a minimum number of digits to show in the integer +part of the value (default 1). + +@example +(format #t "~,3$" 9.5) @print{} 009.50 +(format #t "~,0$" 0.125) @print{} .13 +@end example + +If the output is less than @var{width} characters (default 0), it's +padded on the left with @var{padchar} (default space). With the +@nicode{:} modifier the padding is output after the sign. + +@example +(format #f "~,,8$" -1.5) @result{} " -1.50" +(format #f "~,,8:$" -1.5) @result{} "- 1.50" +(format #f "~,,8,'.@@:$" 3) @result{} "+...3.00" +@end example + +Note that floating point for dollar amounts is generally not a good +idea, because a cent @math{0.01} cannot be represented exactly in the +binary floating point Guile uses, which leads to slowly accumulating +rounding errors. Keeping values as cents (or fractions of a cent) in +integers then printing with the scale option in @nicode{~f} may be a +better approach. + +@c For reference, fractions don't work with ~$ (or any of the float +@c conversions) currently. If they did work then we could perhaps +@c suggest keeping dollar amounts as rationals, which would of course +@c give exact cents. An integer as cents is probably still a better +@c recommendation though, since it forces one to think about where +@c and when rounding can or should occur. + +@item @nicode{~i} +Complex fixed-point float. Parameters: @var{width}, @var{decimals}, +@var{scale}, @var{overflowchar}, @var{padchar}. + +@c For reference, in Common Lisp ~i is an indent, but slib fmtdoc.txi +@c described it as complex number output, so we keep that. + +Output the argument as a complex number, with both real and imaginary +part shown (even if one or both are zero). + +The parameters and modifiers are the same as for fixed-point +@nicode{~f} described above. The real and imaginary parts are both +output with the same given parameters and modifiers, except that for +the imaginary part the @nicode{@@} modifier is always enabled, so as +to print a @nicode{+} sign between the real and imaginary parts. + +@example +(format #t "~i" 1) @print{} 1.0+0.0i +@end example + +@item @nicode{~p} +Plural. No parameters. + +Output nothing if the argument is 1, or @samp{s} for any other +value. + +@example +(format #t "enter name~p" 1) @print{} enter name +(format #t "enter name~p" 2) @print{} enter names +@end example + +With the @nicode{@@} modifier, the output is @samp{y} for 1 or +@samp{ies} otherwise. + +@example +(format #t "pupp~@@p" 1) @print{} puppy +(format #t "pupp~@@p" 2) @print{} puppies +@end example + +The @nicode{:} modifier means re-use the preceding argument instead of +taking a new one, which can be convenient when printing some sort of +count. + +@example +(format #t "~d cat~:p" 9) @print{} 9 cats +@end example + +@item @nicode{~y} +Pretty print. No parameters. + +Output an argument with @code{pretty-print} (@pxref{Pretty Printing}). + +@item @nicode{~?} +@itemx @nicode{~k} +Sub-format. No parameters. + +Take a format string argument and a second argument which is a list of +arguments for it, and output the result. With the @nicode{@@} +modifier, the arguments for the sub-format are taken directly rather +than from a list. + +@example +(format #t "~?" "~d ~d" '(1 2)) @print{} 1 2 +(format #t "~@@? ~s" "~d ~d" 1 2 "foo") @print{} 1 2 "foo" +@end example + +@nicode{~?} and @nicode{~k} are the same, @nicode{~k} is provided for +T-Scheme compatibility. + +@item @nicode{~*} +Argument jumping. Parameter: @var{N}. + +Move forward @var{N} arguments (default 1) in the argument list. With +the @nicode{:} modifier move backwards. @var{N} can be negative to +move backwards too. + +@example +(format #f "~d ~:*~d" 6) @result{} "6 6" +@end example + +With the @nicode{@@} modifier, move to argument number @var{N}. The +first argument is number 0 (and that's the default for @var{N}). + +@example +(format #f "~d~d again ~@@*~d~d" 1 2) @result{} "12 again 12" +(format #f "~d~d~d ~1@@*~d~d" 1 2 3) @result{} "123 23" +@end example + +At the end of the format string the last argument must have been +consumed, or a ``too many arguments'' error results. If the last +argument is not the last to be printed, then a move to skip the +remaining must be given. This can be done with the @nicode{#} +parameter (count of remaining arguments). + +@example +(format #t "~2*~d" 1 2 3 4) ;; error +(format #t "~2*~d~#*" 1 2 3 4) @result{} 3 +@end example + +A @nicode{#} move to the end followed by a @nicode{:} modifier move +back can be used for an absolute position relative to the end of the +argument list, a reverse of what the @nicode{@@} modifier does. + +@item @nicode{~t} +Advance to a column position. Parameters: @var{colnum}, @var{colinc}, +@var{padchar}. + +Output @var{padchar} (space by default) to move to the given +@var{colnum} column. The start of the line is column 0, the default +for @var{colnum} is 1. + +@example +(format #f "~tX") @result{} " X" +(format #f "~3tX") @result{} " X" +@end example + +If the current column is already past @var{colnum}, then the move is +to there plus a multiple of @var{colinc}, ie.@: column +@math{@var{colnum} + @var{N} * @var{colinc}} for the smallest @var{N} +which makes that value greater than or equal to the current column. +The default @var{colinc} is 1 (which means no further move). + +@example +(format #f "abcd~2,5,'.tx") @result{} "abcd...x" +@end example + +With the @nicode{@@} modifier, @var{colnum} is relative to the current +column. @var{colnum} many padding characters are output, then further +padding to make the current column a multiple of @var{colinc}, if it +isn't already so. + +@example +(format #f "a~3,5'*@@tx") @result{} "a****x" +@end example + +@item @nicode{~~} +Tilde character. Parameter: @var{n}. + +Output a tilde character @nicode{~}, or @var{n} many if a parameter is +given. Normally @nicode{~} introduces an escape sequence, @nicode{~~} +is the way to output a literal tilde. + +@item @nicode{~%} +Newline. Parameter: @var{n}. + +Output a newline character, or @var{n} many if a parameter is given. +A newline (or a few newlines) can of course be output just by +including them in the format string. + +@item @nicode{~&} +Start a new line. Parameter: @var{n}. + +Output a newline if not already at the start of a line. With a +parameter, output that many newlines, but with the first only if not +already at the start of a line. So for instance 3 would be a newline +if not already at the start of a line, and 2 further newlines. + +@item @nicode{~_} +Space character. Parameter: @var{n}. + +@c For reference, in Common Lisp ~_ is a conditional newline, but +@c slib fmtdoc.txi described it as a space, so we keep that. + +Output a space character, or @var{n} many if a parameter is given. + +With a variable parameter this is one way to insert runtime calculated +padding (@nicode{~t} or the various field widths can do similar +things). + +@example +(format #f "~v_foo" 4) @result{} " foo" +@end example + +@item @nicode{~/} +Tab character. Parameter: @var{n}. + +Output a tab character, or @var{n} many if a parameter is given. + +@item @nicode{~|} +Formfeed character. Parameter: @var{n}. + +Output a formfeed character, or @var{n} many if a parameter is given. + +@item @nicode{~!} +Force output. No parameters. + +At the end of output, call @code{force-output} to flush any buffers on +the destination (@pxref{Writing}). @nicode{~!} can occur anywhere in +the format string, but the force is done at the end of output. + +When output is to a string (destination @code{#f}), @nicode{~!} does +nothing. + +@item @nicode{~newline} (ie.@: newline character) +Continuation line. No parameters. + +Skip this newline and any following whitespace in the format string, +don't send it to the output. With the @nicode{:} modifier the newline +is not output but any further following whitespace is. With the +@nicode{@@} modifier the newline is output but not any following +whitespace. + +This escape can be used to break up a long format string into multiple +lines for readability, but supress that extra whitespace. + +@example +(format #f "abc~ + ~d def~ + ~d" 1 2) @result{} "abc1 def2" +@end example + +@item @nicode{~(} @nicode{~)} +Case conversion. Between @nicode{~(} and @nicode{~)} the case of all +output is changed. The modifiers on @nicode{~(} control the +conversion. + +@itemize @w +@item +no modifiers --- lower case. +@c +@c FIXME: The : and @ modifiers are not yet documented because the +@c code applies string-capitalize and string-capitalize-first to each +@c separate format:out-str call, which has various subtly doubtful +@c effects. And worse they're applied to individual characters, +@c including literal characters in the format string, which has the +@c silly effect of being always an upcase. +@c +@c The Common Lisp spec is apparently for the capitalization to be +@c applied in one hit to the whole of the output between ~( and ~). +@c (This can no doubt be implemented without accumulating all that +@c text, just by keeping a state or the previous char to tell whether +@c within a word.) +@c +@c @item +@c @nicode{:} --- first letter of each word upper case, the rest lower +@c case, as per the @code{string-capitalize} function (@pxref{Alphabetic +@c Case Mapping}). +@c @item +@c @nicode{@@} --- first letter of just the first word upper case, the +@c rest lower case. +@c +@item +@nicode{:} and @nicode{@@} together --- upper case. +@end itemize + +For example, + +@example +(format #t "~(Hello~)") @print{} hello +(format #t "~@@:(Hello~)") @print{} HELLO +@end example + +In the future it's intended the modifiers @nicode{:} and @nicode{@@} +alone will capitalize the first letters of words, as per Common Lisp +@code{format}, but the current implementation of this is flawed and +not recommended for use. + +Case conversions do not nest, currently. This might change in the +future, but if it does then it will be to Common Lisp style where the +outermost conversion has priority, overriding inner ones (making those +fairly pointless). + +@item @nicode{~@{} @nicode{~@}} +Iteration. Parameter: @var{maxreps} (for @nicode{~@{}). + +The format between @nicode{~@{} and @nicode{~@}} is iterated. The +modifiers to @nicode{~@{} determine how arguments are taken. The +default is a list argument with each iteration successively consuming +elements from it. This is a convenient way to output a whole list. + +@example +(format #t "~@{~d~@}" '(1 2 3)) @print{} 123 +(format #t "~@{~s=~d ~@}" '("x" 1 "y" 2)) @print{} "x"=1 "y"=2 +@end example + +With the @nicode{:} modifier a list of lists argument is taken, each +of those lists gives the arguments for the iterated format. + +@example +(format #t "~:@{~dx~d ~@}" '((1 2) (3 4) (5 6))) @print{} 1x2 3x4 5x6 +@end example + +With the @nicode{@@} modifier, the remaining arguments are used, each +iteration successively consuming elements. + +@example +(format #t "~@@@{~d~@}" 1 2 3) @print{} 123 +(format #t "~@@@{~s=~d ~@}" "x" 1 "y" 2) @print{} "x"=1 "y"=2 +@end example + +With both @nicode{:} and @nicode{@@} modifiers, the remaining +arguments are used, each is a list of arguments for the format. + +@example +(format #t "~:@@@{~dx~d ~@}" '(1 2) '(3 4) '(5 6)) @print{} 1x2 3x4 5x6 +@end example + +Iterating stops when there are no more arguments or when the +@var{maxreps} parameter to @nicode{~@{} is reached (default no +maximum). + +@example +(format #t "~2@{~d~@}" '(1 2 3 4)) @print{} 12 +@end example + +If the format between @nicode{~@{} and @nicode{~@}} is empty, then a +format string argument is taken (before iteration argument(s)) and +used instead. This allows a sub-format (like @nicode{~?} above) to be +iterated. + +@example +(format #t "~@{~@}" "~d" '(1 2 3)) @print{} 123 +@end example + +@c FIXME: What is the @nicode{:} modifier to ~} meant to do? The +@c Common Lisp spec says it's a minimum of 1 iteration, but the +@c format.scm code seems to merely make it have MAXREPS default to 1. + +Iterations can be nested, an inner iteration operates in the same way +as described, but of course on the arguments the outer iteration +provides it. This can be used to work into nested list structures. +For example in the following the inner @nicode{~@{~d~@}x} is applied +to @code{(1 2)} then @code{(3 4 5)} etc. + +@example +(format #t "~@{~@{~d~@}x~@}" '((1 2) (3 4 5))) @print{} 12x345x +@end example + +@item @nicode{~[} @nicode{~;} @nicode{~]} +Conditional. Parameter: @var{selector}. + +A conditional block is delimited by @nicode{~[} and @nicode{~]}, and +@nicode{~;} separates clauses within the block. @nicode{~[} takes an +integer argument and that number clause is used. The first clause is +number 0. + +@example +(format #f "~[peach~;banana~;mango~]" 1) @result{} "banana" +@end example + +The @var{selector} parameter can be used for the clause number, +instead of taking an argument. + +@example +(format #f "~2[peach~;banana~;mango~]") @result{} "mango" +@end example + +If the clause number is out of range then nothing is output. Or the +last @nicode{~;} can have a @nicode{:} modifier to make it the default +for a number out of range. + +@example +(format #f "~[banana~;mango~]" 99) @result{} "" +(format #f "~[banana~;mango~:;fruit~]" 99) @result{} "fruit" +@end example + +The @nicode{:} modifier to @nicode{~[} treats the argument as a flag, +and expects two clauses. The first used if the argument is @code{#f} +or the second otherwise. + +@example +(format #f "~:[false~;not false~]" #f) @result{} "false" +(format #f "~:[false~;not false~]" 'abc) @result{} "not false" + +(let ((n 3)) + (format #t "~d gnu~:[s are~; is~] here" n (= 1 n))) +@print{} 3 gnus are here +@end example + +The @nicode{@@} modifier to @nicode{~[} also treats the argument as a +flag, and expects one clause. If the argument is @code{#f} then no +output is produced and the argument is consumed, otherwise the clause +is used and the argument is not consumed by @nicode{~[}, it's left for +the clause. This can be used for instance to suppress output if +@code{#f} means something not available. + +@example +(format #f "~@@[temperature=~d~]" 27) @result{} "temperature=27" +(format #f "~@@[temperature=~d~]" #f) @result{} "" +@end example + +@item @nicode{~^} +Escape. Parameters: @var{val1}, @var{val2}, @var{val3}. + +Stop formatting if there are no more arguments. This can be used for +instance to let a format string adapt to a variable number of +arguments. + +@example +(format #t "~d~^ ~d" 1) @print{} 1 +(format #t "~d~^ ~d" 1 2) @print{} 1 2 +@end example + +Within a @nicode{~@{} @nicode{~@}} iteration, @nicode{~^} stops the +current iteration step if there are no more arguments to that step, +continuing with possible further steps (for instance in the case of +the @nicode{:} modifier to @nicode{~@{}) and the rest of the format. + +@example +(format #f "~@{~d~^/~@} go" '(1 2 3)) @result{} "1/2/3 go" +(format #f "~:@{ ~d~^~d~@} go" '((1) (2 3))) @result{} " 1 23 go" +@end example + +@c For reference, format.scm doesn't implement that Common Lisp ~:^ +@c modifier which stops the entire iterating of ~:{ or ~@:{. + +@c FIXME: Believe the Common Lisp spec is for ~^ within ~[ ~] +@c conditional to terminate the whole format (or iteration step if in +@c an iteration). But format.scm seems to terminate just the +@c conditional form. +@c +@c (format #f "~[abc~^def~;ghi~] blah" 0) +@c @result{} "abc blah" ;; looks wrong + +@c FIXME: Believe the Common Lisp spec is for ~^ within ~( ~) to end +@c that case conversion and then also terminate the whole format (or +@c iteration step if in an iteration). But format.scm doesn't seem +@c to do that quite right. +@c +@c (format #f "~d ~^ ~d" 1) @result{} "1 " +@c (format #f "~(~d ~^ ~d~)" 1) @result{} ERROR + +Within a @nicode{~?} sub-format, @nicode{~^} operates just on that +sub-format. If it terminates the sub-format then the originating +format will still continue. + +@example +(format #t "~? items" "~d~^ ~d" '(1)) @print{} 1 items +(format #t "~? items" "~d~^ ~d" '(1 2)) @print{} 1 2 items +@end example + +The parameters to @nicode{~^} (which are numbers) change the condition +used to terminate. For a single parameter, termination is when that +value is zero (notice this makes plain @nicode{~^} equivalent to +@nicode{~#^}). For two parameters, termination is when those two are +equal. For three parameters, termination is when @math{@var{val1} +@le{} @var{val2}} and @math{@var{val2} @le{} @var{val3}}. + +@c FIXME: Good examples of these? + +@item @nicode{~q} +Inquiry message. Insert a copyright message into the output. With +the @nicode{:} modifier insert the format implementation version. @end table -If any type conversions should fail (for example when using an escape -sequence for number output, but the argument is a string), an error -will be signalled. +@sp 1 +It's an error if there are too many or not enough arguments for the +escapes in the format string. (Unwanted arguments can be skipped with +an argument jump @nicode{~#*} described above if desired.) + +Iterations @nicode{~@{} @nicode{~@}} and conditionals @nicode{~[} +@nicode{~;} @nicode{~]} can be nested, but must be properly nested, +meaning the inner form must be entirely within the outer form. So +it's not possible, for instance, to try to conditionalize the endpoint +of an iteration. + +@example +(format #t "~@{ ~[ ... ~] ~@}" ...) ;; good +(format #t "~@{ ~[ ... ~@} ... ~]" ...) ;; bad +@end example + +The same applies to case conversions @nicode{~(} @nicode{~)}, they +must properly nest with respect to iterations and conditionals (though +currently a case conversion cannot nest within another case +conversion). + +When a sub-format (@nicode{~?}) is used, that sub-format string must +be self-contained. It cannot for instance give a @nicode{~@{} to +begin an iteration form and have the @nicode{~@}} up in the +originating format, or similar. @end deffn -You may have noticed that Guile contains a @code{format} procedure -even when the module @code{(ice-9 format)} is not loaded. The default -@code{format} procedure does not support all escape sequences -documented in this chapter, and will signal an error if you try to use -one of them. The reason for providing two versions of @code{format} -is that the full-featured module is fairly large and requires some -time to get loaded. So the Guile maintainers decided not to load the -large version of @code{format} by default, so that the start-up time -of the interpreter is not unnecessarily increased. +@sp 1 +Guile contains a @code{format} procedure even when the module +@code{(ice-9 format)} is not loaded. The default @code{format} is +@code{simple-format} (@pxref{Writing}), it doesn't support all escape +sequences documented in this section, and will signal an error if you +try to use one of them. The reason for two versions is that the full +@code{format} is fairly large and requires some time to load. +@code{simple-format} is often adequate too. @page From eab8f8b2084b30eeebbb6372962cdc13149bfd7f Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 28 Jul 2004 00:54:29 +0000 Subject: [PATCH 64/89] *** empty log message *** --- doc/ref/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index bf2a4f2ec..0bedeceac 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,9 @@ +2004-07-28 Kevin Ryde + + * misc-modules.texi (Formatted Output): Rewrite, describing escapes + and parameters in detail. + * guile.texi (@le, @ge): New macros for ifnottex. + 2004-07-24 Kevin Ryde * guile.texi (@nicode): Use @alias instead of @macro, for correct From 8d20b7af9e4789d9dacfffcf706b65fe39d06bf5 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 28 Jul 2004 23:52:17 +0000 Subject: [PATCH 65/89] (What is libguile): Correction to reference manual "Data representation" cross reference. --- doc/tutorial/guile-tut.texi | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/tutorial/guile-tut.texi b/doc/tutorial/guile-tut.texi index cbbf46965..f904c7d61 100644 --- a/doc/tutorial/guile-tut.texi +++ b/doc/tutorial/guile-tut.texi @@ -34,7 +34,7 @@ @page @vskip 0pt plus 1filll -Copyright @copyright{} 1997, 1998 Free Software Foundation +Copyright @copyright{} 1997, 1998, 2004 Free Software Foundation Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice @@ -60,7 +60,7 @@ by the author. @ifinfo This file gives a tutorial introduction to Guile. -Copyright (C) 1997 Free Software Foundation +Copyright (C) 1997, 2004 Free Software Foundation Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice @@ -941,8 +941,8 @@ more stable, because it is simpler. The @code{scm_} interface is necessary if you want to poke into the innards of Scheme data structures, or do anything else that is not offered by the @code{gh_} interface. It is not covered in this -tutorial, but is covered extensively in @ref{Scheme data representation, -Guile Reference Manual, guile-ref, Guile Reference Manual}. +tutorial, but is covered extensively in @ref{Data representation,, Data +Representation in Guile, guile, Guile Reference Manual}. This chapter gives a gentle introduction to the @code{gh_} interface, presenting some @emph{hello world}-style programs which I wrote while From e8a590639c9365cd80d87707b89a9123c84b12cd Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 29 Jul 2004 00:12:25 +0000 Subject: [PATCH 66/89] (scm_ttyname): Use scm_i_misc_mutex for thread safety. --- libguile/posix.c | 27 +++++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index f4035e8a0..cba143bb0 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -768,6 +768,15 @@ SCM_DEFINE (scm_setsid, "setsid", 0, 0, 0, #undef FUNC_NAME #endif /* HAVE_SETSID */ + +/* ttyname returns its result in a single static buffer, hence + scm_i_misc_mutex for thread safety. In glibc 2.3.2 two threads + continuously calling ttyname will otherwise get an overwrite quite + easily. + + ttyname_r (when available) could be used instead of scm_i_misc_mutex, but + there's probably little to be gained in either speed or parallelism. */ + #ifdef HAVE_TTYNAME SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0, (SCM port), @@ -776,22 +785,32 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0, #define FUNC_NAME s_scm_ttyname { char *result; - int fd; + int fd, err; + SCM ret; port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPPORT (1, port); if (!SCM_FPORTP (port)) return SCM_BOOL_F; fd = SCM_FPORT_FDES (port); + + scm_mutex_lock (&scm_i_misc_mutex); SCM_SYSCALL (result = ttyname (fd)); + err = errno; + ret = scm_makfrom0str (result); + scm_mutex_unlock (&scm_i_misc_mutex); + if (!result) - SCM_SYSERROR; - /* result could be overwritten by another call to ttyname */ - return (scm_makfrom0str (result)); + { + errno = err; + SCM_SYSERROR; + } + return ret; } #undef FUNC_NAME #endif /* HAVE_TTYNAME */ + /* For thread safety "buf" is used instead of NULL for the ctermid static buffer. Actually it's unlikely the controlling terminal will change during program execution, and indeed on glibc (2.3.2) it's always just From 1f15779e06a0397bc7d99da930ca543706863a27 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 29 Jul 2004 00:13:22 +0000 Subject: [PATCH 67/89] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 52a18d036..e31350496 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2004-07-29 Kevin Ryde + + * posix.c (scm_ttyname): Use scm_i_misc_mutex for thread safety. + 2004-07-28 Kevin Ryde * posix.c (scm_ctermid): Use an L_ctermid buf on the stack, for thread From 3bfd202a72b19758b291219d7ef20c319ada2978 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 29 Jul 2004 00:19:17 +0000 Subject: [PATCH 68/89] *** empty log message *** --- doc/tutorial/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/tutorial/ChangeLog b/doc/tutorial/ChangeLog index 6ab62fd1c..9b78ed77c 100644 --- a/doc/tutorial/ChangeLog +++ b/doc/tutorial/ChangeLog @@ -1,3 +1,8 @@ +2004-07-29 Kevin Ryde + + * doc/tutorial/guile-tut.texi (What is libguile): Correction to + reference manual "Data representation" cross reference. + 2004-06-28 Marius Vollmer * Makefile.am: Removed home-grown code for HTML generation. From bfd7932e6644c91004c6e863ecc5db580eda12f6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 13:42:50 +0000 Subject: [PATCH 69/89] * conv-integer.i.c, conv-uinteger.i.c: New files, used to generate the functions below. * numbers.c, numbers.h (scm_to_int8, scm_to_uint8, scm_to_int16, scm_to_uint16, scm_to_int32, scm_to_uint32, scm_to_int64, scm_to_uint64, scm_from_int8, scm_from_uint8, scm_from_int16, scm_from_uint16, scm_from_int32, scm_from_uint32, scm_from_int64, scm_from_uint64): Turned from macros into proper functions. (scm_to_signed_integer, scm_to_unsigned_integer, scm_from_signed_integer, scm_from_unsigned_integer): Generate via conv-integer.i.c and conv-uinteger.i.c, as well. --- libguile/conv-integer.i.c | 126 +++++++++++++++++++ libguile/conv-uinteger.i.c | 95 +++++++++++++++ libguile/numbers.c | 243 +++++++++++-------------------------- libguile/numbers.h | 68 +++++------ 4 files changed, 325 insertions(+), 207 deletions(-) create mode 100644 libguile/conv-integer.i.c create mode 100644 libguile/conv-uinteger.i.c diff --git a/libguile/conv-integer.i.c b/libguile/conv-integer.i.c new file mode 100644 index 000000000..4a6095fc1 --- /dev/null +++ b/libguile/conv-integer.i.c @@ -0,0 +1,126 @@ +TYPE +SCM_TO_TYPE_PROTO (SCM val) +{ + if (SCM_I_INUMP (val)) + { + scm_t_signed_bits n = SCM_I_INUM (val); +#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SIZEOF_SCM_T_BITS + return n; +#else + if (n >= TYPE_MIN && n <= TYPE_MAX) + return n; + else + { + goto out_of_range; + } +#endif + } + else if (SCM_BIGP (val)) + { + if (TYPE_MIN >= SCM_MOST_NEGATIVE_FIXNUM + && TYPE_MAX <= SCM_MOST_POSITIVE_FIXNUM) + goto out_of_range; + else if (TYPE_MIN >= LONG_MIN && TYPE_MAX <= LONG_MAX) + { + if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val))) + { + long n = mpz_get_si (SCM_I_BIG_MPZ (val)); +#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SCM_SIZEOF_LONG + return n; +#else + if (n >= TYPE_MIN && n <= TYPE_MAX) + return n; + else + goto out_of_range; +#endif + } + else + goto out_of_range; + } + else + { + scm_t_intmax n; + size_t count; + + if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2) + > CHAR_BIT*sizeof (scm_t_uintmax)) + goto out_of_range; + + mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0, + SCM_I_BIG_MPZ (val)); + + if (mpz_sgn (SCM_I_BIG_MPZ (val)) >= 0) + { + if (n < 0) + goto out_of_range; + } + else + { + n = -n; + if (n >= 0) + goto out_of_range; + } + + if (n >= TYPE_MIN && n <= TYPE_MAX) + return n; + else + { + out_of_range: + scm_out_of_range (NULL, val); + return 0; + } + } + } + else + { + scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); + return 0; + } +} + +SCM +SCM_FROM_TYPE_PROTO (TYPE val) +{ +#if SIZEOF_TYPE != 0 && SIZEOF_TYPE < SIZEOF_SCM_T_BITS + return SCM_I_MAKINUM (val); +#else + if (SCM_FIXABLE (val)) + return SCM_I_MAKINUM (val); + else if (val >= LONG_MIN && val <= LONG_MAX) + { + SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + mpz_init_set_si (SCM_I_BIG_MPZ (z), val); + return z; + } + else + { + SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + mpz_init (SCM_I_BIG_MPZ (z)); + if (val < 0) + { + val = -val; + mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (TYPE), 0, 0, + &val); + mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z)); + } + else + mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (TYPE), 0, 0, + &val); + return z; + } +#endif +} + +/* clean up */ +#undef TYPE +#undef TYPE_MIN +#undef TYPE_MAX +#undef SIZEOF_TYPE +#undef SCM_TO_TYPE_PROTO +#undef SCM_FROM_TYPE_PROTO + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/conv-uinteger.i.c b/libguile/conv-uinteger.i.c new file mode 100644 index 000000000..961000449 --- /dev/null +++ b/libguile/conv-uinteger.i.c @@ -0,0 +1,95 @@ +TYPE +SCM_TO_TYPE_PROTO (SCM val) +{ + if (SCM_I_INUMP (val)) + { + scm_t_signed_bits n = SCM_I_INUM (val); + if (n >= 0 + && ((scm_t_uintmax)n) >= TYPE_MIN && ((scm_t_uintmax)n) <= TYPE_MAX) + return n; + else + { + out_of_range: + scm_out_of_range (NULL, val); + return 0; + } + } + else if (SCM_BIGP (val)) + { + if (TYPE_MAX <= SCM_MOST_POSITIVE_FIXNUM) + goto out_of_range; + else if (TYPE_MAX <= ULONG_MAX) + { + if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val))) + { + unsigned long n = mpz_get_ui (SCM_I_BIG_MPZ (val)); +#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SCM_SIZEOF_LONG + return n; +#else + if (n >= TYPE_MIN && n <= TYPE_MAX) + return n; + else + goto out_of_range; +#endif + } + else + goto out_of_range; + } + else + { + scm_t_uintmax n; + size_t count; + + if (mpz_sgn (SCM_I_BIG_MPZ (val)) < 0) + goto out_of_range; + + if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2) + > CHAR_BIT*sizeof (TYPE)) + goto out_of_range; + + mpz_export (&n, &count, 1, sizeof (TYPE), 0, 0, SCM_I_BIG_MPZ (val)); + + if (n >= TYPE_MIN && n <= TYPE_MAX) + return n; + else + goto out_of_range; + } + } + else + { + scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); + return 0; + } +} + +SCM +SCM_FROM_TYPE_PROTO (TYPE val) +{ +#if SIZEOF_TYPE != 0 && SIZEOF_TYPE < SIZEOF_SCM_T_BITS + return SCM_I_MAKINUM (val); +#else + if (SCM_POSFIXABLE (val)) + return SCM_I_MAKINUM (val); + else if (val <= ULONG_MAX) + { + SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + mpz_init_set_ui (SCM_I_BIG_MPZ (z), val); + return z; + } + else + { + SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + mpz_init (SCM_I_BIG_MPZ (z)); + mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (TYPE), 0, 0, &val); + return z; + } +#endif +} + +#undef TYPE +#undef TYPE_MIN +#undef TYPE_MAX +#undef SIZEOF_TYPE +#undef SCM_TO_TYPE_PROTO +#undef SCM_FROM_TYPE_PROTO + diff --git a/libguile/numbers.c b/libguile/numbers.c index f57ed0805..6ca389c95 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5750,184 +5750,89 @@ scm_is_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max) return 0; } -scm_t_intmax -scm_to_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max) -{ - if (SCM_I_INUMP (val)) - { - scm_t_signed_bits n = SCM_I_INUM (val); - if (n >= min && n <= max) - return n; - else - { - out_of_range: - scm_out_of_range (NULL, val); - return 0; - } - } - else if (SCM_BIGP (val)) - { - if (min >= SCM_MOST_NEGATIVE_FIXNUM && max <= SCM_MOST_POSITIVE_FIXNUM) - goto out_of_range; - else if (min >= LONG_MIN && max <= LONG_MAX) - { - if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val))) - { - long n = mpz_get_si (SCM_I_BIG_MPZ (val)); - if (n >= min && n <= max) - return n; - else - goto out_of_range; - } - else - goto out_of_range; - } - else - { - scm_t_intmax n; - size_t count; +#define TYPE scm_t_intmax +#define TYPE_MIN min +#define TYPE_MAX max +#define SIZEOF_TYPE 0 +#define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg) +#include "libguile/conv-integer.i.c" - if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2) - > CHAR_BIT*sizeof (scm_t_uintmax)) - goto out_of_range; - - mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0, - SCM_I_BIG_MPZ (val)); +#define TYPE scm_t_uintmax +#define TYPE_MIN min +#define TYPE_MAX max +#define SIZEOF_TYPE 0 +#define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg) +#include "libguile/conv-uinteger.i.c" - if (mpz_sgn (SCM_I_BIG_MPZ (val)) >= 0) - { - if (n < 0) - goto out_of_range; - } - else - { - n = -n; - if (n >= 0) - goto out_of_range; - } +#define TYPE scm_t_int8 +#define TYPE_MIN SCM_T_INT8_MIN +#define TYPE_MAX SCM_T_INT8_MAX +#define SIZEOF_TYPE 1 +#define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg) +#include "libguile/conv-integer.i.c" - if (n >= min && n <= max) - return n; - else - goto out_of_range; - } - } - else - { - scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); - return 0; - } -} +#define TYPE scm_t_uint8 +#define TYPE_MIN 0 +#define TYPE_MAX SCM_T_UINT8_MAX +#define SIZEOF_TYPE 1 +#define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg) +#include "libguile/conv-uinteger.i.c" -scm_t_uintmax -scm_to_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max) -{ - if (SCM_I_INUMP (val)) - { - scm_t_signed_bits n = SCM_I_INUM (val); - if (n >= 0 && ((scm_t_uintmax)n) >= min && ((scm_t_uintmax)n) <= max) - return n; - else - { - out_of_range: - scm_out_of_range (NULL, val); - return 0; - } - } - else if (SCM_BIGP (val)) - { - if (max <= SCM_MOST_POSITIVE_FIXNUM) - goto out_of_range; - else if (max <= ULONG_MAX) - { - if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val))) - { - unsigned long n = mpz_get_ui (SCM_I_BIG_MPZ (val)); - if (n >= min && n <= max) - return n; - else - goto out_of_range; - } - else - goto out_of_range; - } - else - { - scm_t_uintmax n; - size_t count; +#define TYPE scm_t_int16 +#define TYPE_MIN SCM_T_INT16_MIN +#define TYPE_MAX SCM_T_INT16_MAX +#define SIZEOF_TYPE 2 +#define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg) +#include "libguile/conv-integer.i.c" - if (mpz_sgn (SCM_I_BIG_MPZ (val)) < 0) - goto out_of_range; +#define TYPE scm_t_uint16 +#define TYPE_MIN 0 +#define TYPE_MAX SCM_T_UINT16_MAX +#define SIZEOF_TYPE 2 +#define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg) +#include "libguile/conv-uinteger.i.c" - if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2) - > CHAR_BIT*sizeof (scm_t_uintmax)) - goto out_of_range; - - mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0, - SCM_I_BIG_MPZ (val)); +#define TYPE scm_t_int32 +#define TYPE_MIN SCM_T_INT32_MIN +#define TYPE_MAX SCM_T_INT32_MAX +#define SIZEOF_TYPE 4 +#define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg) +#include "libguile/conv-integer.i.c" - if (n >= min && n <= max) - return n; - else - goto out_of_range; - } - } - else - { - scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); - return 0; - } -} +#define TYPE scm_t_uint32 +#define TYPE_MIN 0 +#define TYPE_MAX SCM_T_UINT32_MAX +#define SIZEOF_TYPE 4 +#define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg) +#include "libguile/conv-uinteger.i.c" -SCM -scm_from_signed_integer (scm_t_intmax val) -{ - if (SCM_FIXABLE (val)) - return SCM_I_MAKINUM (val); - else if (val >= LONG_MIN && val <= LONG_MAX) - { - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); - mpz_init_set_si (SCM_I_BIG_MPZ (z), val); - return z; - } - else - { - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); - mpz_init (SCM_I_BIG_MPZ (z)); - if (val < 0) - { - val = -val; - mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (scm_t_intmax), 0, 0, - &val); - mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z)); - } - else - mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (scm_t_intmax), 0, 0, - &val); - return z; - } -} +#if SCM_HAVE_T_INT64 -SCM -scm_from_unsigned_integer (scm_t_uintmax val) -{ - if (SCM_POSFIXABLE (val)) - return SCM_I_MAKINUM (val); - else if (val <= ULONG_MAX) - { - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); - mpz_init_set_ui (SCM_I_BIG_MPZ (z), val); - return z; - } - else - { - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); - mpz_init (SCM_I_BIG_MPZ (z)); - mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (scm_t_uintmax), 0, 0, - &val); - return z; - } -} +#define TYPE scm_t_int64 +#define TYPE_MIN SCM_T_INT64_MIN +#define TYPE_MAX SCM_T_INT64_MAX +#define SIZEOF_TYPE 8 +#define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg) +#include "libguile/conv-integer.i.c" + +#define TYPE scm_t_uint64 +#define TYPE_MIN 0 +#define TYPE_MAX SCM_T_UINT64_MAX +#define SIZEOF_TYPE 8 +#define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg) +#include "libguile/conv-uinteger.i.c" + +#endif int scm_is_real (SCM val) diff --git a/libguile/numbers.h b/libguile/numbers.h index 405b80bf0..8e4d82c28 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -356,6 +356,34 @@ SCM_API scm_t_uintmax scm_to_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max); +SCM_API scm_t_int8 scm_to_int8 (SCM x); +SCM_API SCM scm_from_int8 (scm_t_int8 x); + +SCM_API scm_t_uint8 scm_to_uint8 (SCM x); +SCM_API SCM scm_from_uint8 (scm_t_uint8 x); + +SCM_API scm_t_int16 scm_to_int16 (SCM x); +SCM_API SCM scm_from_int16 (scm_t_int16 x); + +SCM_API scm_t_uint16 scm_to_uint16 (SCM x); +SCM_API SCM scm_from_uint16 (scm_t_uint16 x); + +SCM_API scm_t_int32 scm_to_int32 (SCM x); +SCM_API SCM scm_from_int32 (scm_t_int32 x); + +SCM_API scm_t_uint32 scm_to_uint32 (SCM x); +SCM_API SCM scm_from_uint32 (scm_t_uint32 x); + +#if SCM_HAVE_T_INT64 + +SCM_API scm_t_int64 scm_to_int64 (SCM x); +SCM_API SCM scm_from_int64 (scm_t_int64 x); + +SCM_API scm_t_uint64 scm_to_uint64 (SCM x); +SCM_API SCM scm_from_uint64 (scm_t_uint64 x); + +#endif + #define scm_to_schar(x) \ ((signed char)scm_to_signed_integer ((x), SCHAR_MIN, SCHAR_MAX)) #define scm_to_uchar(x) \ @@ -382,9 +410,9 @@ SCM_API scm_t_uintmax scm_to_unsigned_integer (SCM val, ((unsigned long)scm_to_unsigned_integer ((x), 0, ULONG_MAX)) #define scm_to_ssize_t(x) \ - ((ssize_t)scm_to_signed_integer ((x), -SSIZE_MAX-1, SSIZE_MAX)) + ((ssize_t)scm_to_signed_integer ((x), SCM_I_SSIZE_MIN, SCM_I_SSIZE_MAX)) #define scm_to_size_t(x) \ - ((unsigned long)scm_to_unsigned_integer ((x), 0, SIZE_MAX)) + ((unsigned long)scm_to_unsigned_integer ((x), 0, SCM_I_SIZE_MAX)) #if SCM_SIZEOF_LONG_LONG != 0 #define scm_to_long_long(x) \ @@ -393,28 +421,6 @@ SCM_API scm_t_uintmax scm_to_unsigned_integer (SCM val, ((unsigned long long)scm_to_unsigned_integer ((x), 0, SCM_I_ULLONG_MAX)) #endif -#define scm_to_int8(x) \ - ((scm_t_int8)scm_to_signed_integer ((x), SCM_T_INT8_MIN, SCM_T_INT8_MAX)) -#define scm_to_uint8(x) \ - ((scm_t_uint8)scm_to_unsigned_integer ((x), 0, SCM_T_UINT8_MAX)) - -#define scm_to_int16(x) \ - ((scm_t_int16)scm_to_signed_integer ((x), SCM_T_INT16_MIN, SCM_T_INT16_MAX)) -#define scm_to_uint16(x) \ - ((scm_t_uint16)scm_to_unsigned_integer ((x), 0, SCM_T_UINT16_MAX)) - -#define scm_to_int32(x) \ - ((scm_t_int32)scm_to_signed_integer ((x), SCM_T_INT32_MIN, SCM_T_INT32_MAX)) -#define scm_to_uint32(x) \ - ((scm_t_uint32)scm_to_unsigned_integer ((x), 0, SCM_T_UINT32_MAX)) - -#if SCM_HAVE_T_INT64 -#define scm_to_int64(x) \ - ((scm_t_int64)scm_to_signed_integer ((x), SCM_T_INT64_MIN, SCM_T_INT64_MAX)) -#define scm_to_uint64(x) \ - ((scm_t_uint64)scm_to_unsigned_integer ((x), 0, SCM_T_UINT64_MAX)) -#endif - #define scm_to_intmax(x) \ ((scm_t_intmax)scm_to_signed_integer ((x),SCM_T_INTMAX_MIN,SCM_T_INTMAX_MAX)) #define scm_to_uintmax(x) \ @@ -445,20 +451,6 @@ SCM_API scm_t_uintmax scm_to_unsigned_integer (SCM val, #define scm_from_ulong_long(x) scm_from_unsigned_integer ((unsigned long long)(x)) #endif -#define scm_from_int8(x) scm_from_signed_integer ((scm_t_int8)(x)) -#define scm_from_uint8(x) scm_from_unsigned_integer ((scm_t_uint8)(x)) - -#define scm_from_int16(x) scm_from_signed_integer ((scm_t_int16)(x)) -#define scm_from_uint16(x) scm_from_unsigned_integer ((scm_t_uint16)(x)) - -#define scm_from_int32(x) scm_from_signed_integer ((scm_t_int32)(x)) -#define scm_from_uint32(x) scm_from_unsigned_integer ((scm_t_uint32)(x)) - -#if SCM_HAVE_T_INT64 -#define scm_from_int64(x) scm_from_signed_integer ((scm_t_int64)(x)) -#define scm_from_uint64(x) scm_from_unsigned_integer ((scm_t_uint64)(x)) -#endif - #define scm_from_intmax(x) scm_from_signed_integer ((scm_t_intmax)(x)) #define scm_from_uintmax(x) scm_from_unsigned_integer ((scm_t_uintmax)(x)) From 7ff8176bdb22bfa1960d8ab2da6fa46b7071fd4b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 13:43:49 +0000 Subject: [PATCH 70/89] (noinst_HEADERS): Added conv-integer.i.c and conv-uinteger.i.c. --- libguile/Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index c0f7e0102..568ff0daa 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -163,6 +163,7 @@ install-exec-hook: ## Perhaps we can deal with them normally once the merge seems to be ## working. noinst_HEADERS = num2integral.i.c num2float.i.c convert.i.c \ + conv-integer.i.c conv-uinteger.i.c \ win32-uname.h win32-dirent.h win32-socket.h \ private-gc.h From 9d3ebce49327fa2c2bc3cf2318d3619c672e2ac0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 13:54:15 +0000 Subject: [PATCH 71/89] Added docs. --- libguile/conv-integer.i.c | 25 +++++++++++++++++++++++++ libguile/conv-uinteger.i.c | 25 +++++++++++++++++++++++++ 2 files changed, 50 insertions(+) diff --git a/libguile/conv-integer.i.c b/libguile/conv-integer.i.c index 4a6095fc1..16ec2348b 100644 --- a/libguile/conv-integer.i.c +++ b/libguile/conv-integer.i.c @@ -1,3 +1,28 @@ +/* This code in included by number.s.c to generate integer conversion + functions like scm_to_int and scm_from_int. It is only for signed + types, see conv-uinteger.i.c for the unsigned variant. +*/ + +/* You need to define the following macros before including this + template. They are undefined at the end of this file to giove a + clean slate for the next inclusion. + + TYPE - the integral type to be converted + TYPE_MIN - the smallest representable number of TYPE + TYPE_MAX - the largest representable number of TYPE + SIZEOF_TYPE - the size of TYPE, equal to "sizeof (TYPE)" but + in a form that can be computed by the preprocessor. + When this number is 0, the preprocessor is not used + to select which code to compile; the most general + code is always used. + + SCM_TO_TYPE_PROTO(arg), SCM_FROM_TYPE_PROTO(arg) + - These two macros should expand into the prototype + for the two defined functions, without the return + type. + +*/ + TYPE SCM_TO_TYPE_PROTO (SCM val) { diff --git a/libguile/conv-uinteger.i.c b/libguile/conv-uinteger.i.c index 961000449..7f1e0dc3a 100644 --- a/libguile/conv-uinteger.i.c +++ b/libguile/conv-uinteger.i.c @@ -1,3 +1,28 @@ +/* This code in included by number.s.c to generate integer conversion + functions like scm_to_int and scm_from_int. It is only for + unsigned types, see conv-integer.i.c for the signed variant. +*/ + +/* You need to define the following macros before including this + template. They are undefined at the end of this file to giove a + clean slate for the next inclusion. + + TYPE - the integral type to be converted + TYPE_MIN - the smallest representable number of TYPE, typically 0. + TYPE_MAX - the largest representable number of TYPE + SIZEOF_TYPE - the size of TYPE, equal to "sizeof (TYPE)" but + in a form that can be computed by the preprocessor. + When this number is 0, the preprocessor is not used + to select which code to compile; the most general + code is always used. + + SCM_TO_TYPE_PROTO(arg), SCM_FROM_TYPE_PROTO(arg) + - These two macros should expand into the prototype + for the two defined functions, without the return + type. + +*/ + TYPE SCM_TO_TYPE_PROTO (SCM val) { From d0fefc7de59be16cdc6b08c08e76adbb0bc34a26 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 14:03:30 +0000 Subject: [PATCH 72/89] Removed SCM_I_GSC_*_LIMITS macros, they are no longer used. --- libguile/gen-scmconfig.h.in | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/libguile/gen-scmconfig.h.in b/libguile/gen-scmconfig.h.in index 9f6fbdb92..f48288672 100644 --- a/libguile/gen-scmconfig.h.in +++ b/libguile/gen-scmconfig.h.in @@ -16,25 +16,15 @@ #define SCM_I_GSC_NEEDS_STDINT_H @SCM_I_GSC_NEEDS_STDINT_H@ #define SCM_I_GSC_NEEDS_INTTYPES_H @SCM_I_GSC_NEEDS_INTTYPES_H@ #define SCM_I_GSC_T_INT8 @SCM_I_GSC_T_INT8@ -#define SCM_I_GSC_T_INT8_LIMITS @SCM_I_GSC_T_INT8_LIMITS@ #define SCM_I_GSC_T_UINT8 @SCM_I_GSC_T_UINT8@ -#define SCM_I_GSC_T_UINT8_LIMITS @SCM_I_GSC_T_UINT8_LIMITS@ #define SCM_I_GSC_T_INT16 @SCM_I_GSC_T_INT16@ -#define SCM_I_GSC_T_INT16_LIMITS @SCM_I_GSC_T_INT16_LIMITS@ #define SCM_I_GSC_T_UINT16 @SCM_I_GSC_T_UINT16@ -#define SCM_I_GSC_T_UINT16_LIMITS @SCM_I_GSC_T_UINT16_LIMITS@ #define SCM_I_GSC_T_INT32 @SCM_I_GSC_T_INT32@ -#define SCM_I_GSC_T_INT32_LIMITS @SCM_I_GSC_T_INT32_LIMITS@ #define SCM_I_GSC_T_UINT32 @SCM_I_GSC_T_UINT32@ -#define SCM_I_GSC_T_UINT32_LIMITS @SCM_I_GSC_T_UINT32_LIMITS@ #define SCM_I_GSC_T_INT64 @SCM_I_GSC_T_INT64@ -#define SCM_I_GSC_T_INT64_LIMITS @SCM_I_GSC_T_INT64_LIMITS@ #define SCM_I_GSC_T_UINT64 @SCM_I_GSC_T_UINT64@ -#define SCM_I_GSC_T_UINT64_LIMITS @SCM_I_GSC_T_UINT64_LIMITS@ #define SCM_I_GSC_T_INTMAX @SCM_I_GSC_T_INTMAX@ -#define SCM_I_GSC_T_INTMAX_LIMITS @SCM_I_GSC_T_INTMAX_LIMITS@ #define SCM_I_GSC_T_UINTMAX @SCM_I_GSC_T_UINTMAX@ -#define SCM_I_GSC_T_UINTMAX_LIMITS @SCM_I_GSC_T_UINTMAX_LIMITS@ #define SCM_I_GSC_T_PTRDIFF @SCM_I_GSC_T_PTRDIFF@ #define SCM_I_GSC_USE_PTHREAD_THREADS @SCM_I_GSC_USE_PTHREAD_THREADS@ #define SCM_I_GSC_USE_NULL_THREADS @SCM_I_GSC_USE_NULL_THREADS@ From e88d45aa731eae1c5742f100fdf0731202f7b434 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 14:03:40 +0000 Subject: [PATCH 73/89] * __scm.h (SCM_I_UTYPE_MAX, SCM_I_TYPE_MAX, SCM_I_TYPE_MIN, SCM_I_SIZE_MAX, SCM_I_SSIZE_MIN, SCM_I_SSIZE_MAX): New. * __scm.h, gen-scmconfig.c (SCM_I_LLONG_MAX, SCM_I_LLONG_MIN, SCM_I_ULLONG_MAX, SCM_T_INT8_MIN, SCM_T_INT8_MAX, SCM_T_UINT8_MAX, SCM_T_INT16_MIN, SCM_T_INT16_MAX, SCM_T_UINT16_MAX, SCM_T_INT32_MIN, SCM_T_INT32_MAX, SCM_T_UINT32_MAX, SCM_T_INT64_MIN, SCM_T_INT64_MAX, SCM_T_UINT64_MAX, SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX, SCM_T_UINTMAX_MAX): Moved definition into __scm.h, using new SCM_I_TYPE_MIN, etc. --- libguile/__scm.h | 36 ++++++++++++++++++++++++++++++++++++ libguile/gen-scmconfig.c | 30 ------------------------------ 2 files changed, 36 insertions(+), 30 deletions(-) diff --git a/libguile/__scm.h b/libguile/__scm.h index 5448ff4fd..5581c8a4b 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -353,6 +353,42 @@ # define SCM_CHAR_CODE_LIMIT 256L #endif +#define SCM_I_UTYPE_MAX(type) ((type)-1) +#define SCM_I_TYPE_MAX(type,umax) ((type)((umax)/2)) +#define SCM_I_TYPE_MIN(type,umax) (-((type)((umax)/2))-1) + +#define SCM_T_UINT8_MAX SCM_I_UTYPE_MAX(scm_t_uint8) +#define SCM_T_INT8_MIN SCM_I_TYPE_MIN(scm_t_int8,SCM_T_UINT8_MAX) +#define SCM_T_INT8_MAX SCM_I_TYPE_MAX(scm_t_int8,SCM_T_UINT8_MAX) + +#define SCM_T_UINT16_MAX SCM_I_UTYPE_MAX(scm_t_uint16) +#define SCM_T_INT16_MIN SCM_I_TYPE_MIN(scm_t_int16,SCM_T_UINT16_MAX) +#define SCM_T_INT16_MAX SCM_I_TYPE_MAX(scm_t_int16,SCM_T_UINT16_MAX) + +#define SCM_T_UINT32_MAX SCM_I_UTYPE_MAX(scm_t_uint32) +#define SCM_T_INT32_MIN SCM_I_TYPE_MIN(scm_t_int32,SCM_T_UINT32_MAX) +#define SCM_T_INT32_MAX SCM_I_TYPE_MAX(scm_t_int32,SCM_T_UINT32_MAX) + +#if SCM_HAVE_T_INT64 +#define SCM_T_UINT64_MAX SCM_I_UTYPE_MAX(scm_t_uint64) +#define SCM_T_INT64_MIN SCM_I_TYPE_MIN(scm_t_int64,SCM_T_UINT64_MAX) +#define SCM_T_INT64_MAX SCM_I_TYPE_MAX(scm_t_int64,SCM_T_UINT64_MAX) +#endif + +#if SCM_SIZEOF_LONG_LONG +#define SCM_I_ULLONG_MAX SCM_I_UTYPE_MAX(unsigned long long) +#define SCM_I_LLONG_MIN SCM_I_TYPE_MIN(long long,SCM_I_ULLONG_MAX) +#define SCM_I_LLONG_MAX SCM_I_TYPE_MAX(long long,SCM_I_ULLONG_MAX) +#endif + +#define SCM_T_UINTMAX_MAX SCM_I_UTYPE_MAX(scm_t_uintmax) +#define SCM_T_INTMAX_MIN SCM_I_TYPE_MIN(scm_t_intmax,SCM_T_UINTMAX_MAX) +#define SCM_T_INTMAX_MAX SCM_I_TYPE_MAX(scm_t_intmax,SCM_T_UINTMAX_MAX) + +#define SCM_I_SIZE_MAX SCM_I_UTYPE_MAX(size_t) +#define SCM_I_SSIZE_MIN SCM_I_TYPE_MIN(ssize_t,SCM_I_SIZE_MAX) +#define SCM_I_SSIZE_MAX SCM_I_TYPE_MAX(ssize_t,SCM_I_SIZE_MAX) + #include "libguile/tags.h" diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 1dd87b844..3fd2df569 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -277,19 +277,6 @@ main (int argc, char *argv[]) pf ("#define SCM_SIZEOF_LONG_LONG %d\n", SIZEOF_LONG_LONG); pf ("#define SCM_SIZEOF_UNSIGNED_LONG_LONG %d\n", SIZEOF_UNSIGNED_LONG_LONG); - if (SIZEOF_LONG_LONG != 0) - { - pf ("\n"); - pf ("/* The limits of long long are not readily available without\n"); - pf (" defining _GNU_SOURCE (which we can't do in a header) or\n"); - pf (" being on a C99 system (which we can't rely on yet). Thus,\n"); - pf (" we define the limits on our own, assuming twos-complement.\n"); - pf ("*/\n"); - pf ("#define SCM_I_LLONG_MAX ((long long) (SCM_I_ULLONG_MAX >> 1))\n"); - pf ("#define SCM_I_LLONG_MIN (~SCM_I_LLONG_MAX)\n"); - pf ("#define SCM_I_ULLONG_MAX ((unsigned long long) (-1))\n"); - } - pf("\n"); pf("/* handling for the deprecated long_long and ulong_long types */\n"); pf("/* If anything suitable is available, it'll be defined here. */\n"); @@ -316,16 +303,6 @@ main (int argc, char *argv[]) pf ("typedef %s scm_t_intmax;\n", SCM_I_GSC_T_INTMAX); pf ("typedef %s scm_t_uintmax;\n", SCM_I_GSC_T_UINTMAX); - pf ("#define SCM_T_INT8_MIN %s_MIN\n", SCM_I_GSC_T_INT8_LIMITS); - pf ("#define SCM_T_INT8_MAX %s_MAX\n", SCM_I_GSC_T_INT8_LIMITS); - pf ("#define SCM_T_UINT8_MAX %s_MAX\n", SCM_I_GSC_T_UINT8_LIMITS); - pf ("#define SCM_T_INT16_MIN %s_MIN\n", SCM_I_GSC_T_INT16_LIMITS); - pf ("#define SCM_T_INT16_MAX %s_MAX\n", SCM_I_GSC_T_INT16_LIMITS); - pf ("#define SCM_T_UINT16_MAX %s_MAX\n", SCM_I_GSC_T_UINT16_LIMITS); - pf ("#define SCM_T_INT32_MIN %s_MIN\n", SCM_I_GSC_T_INT32_LIMITS); - pf ("#define SCM_T_INT32_MAX %s_MAX\n", SCM_I_GSC_T_INT32_LIMITS); - pf ("#define SCM_T_UINT32_MAX %s_MAX\n", SCM_I_GSC_T_UINT32_LIMITS); - pf ("\n"); pf ("/* 64-bit integer -- if available SCM_HAVE_T_INT64 will be 1 and\n" " scm_t_int64 will be a suitable type, otherwise SCM_HAVE_T_INT64\n" @@ -334,8 +311,6 @@ main (int argc, char *argv[]) { pf ("#define SCM_HAVE_T_INT64 1 /* 0 or 1 */\n"); pf ("typedef %s scm_t_int64;\n", SCM_I_GSC_T_INT64); - pf ("#define SCM_T_INT64_MIN %s_MIN\n", SCM_I_GSC_T_INT64_LIMITS); - pf ("#define SCM_T_INT64_MAX %s_MAX\n", SCM_I_GSC_T_INT64_LIMITS); } else pf ("#define SCM_HAVE_T_INT64 0 /* 0 or 1 */\n"); @@ -348,15 +323,10 @@ main (int argc, char *argv[]) { pf ("#define SCM_HAVE_T_UINT64 1 /* 0 or 1 */\n"); pf ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64); - pf ("#define SCM_T_UINT64_MAX %s_MAX\n", SCM_I_GSC_T_UINT64_LIMITS); } else pf ("#define SCM_HAVE_T_UINT64 0 /* 0 or 1 */\n"); - pf ("#define SCM_T_INTMAX_MIN %s_MIN\n", SCM_I_GSC_T_INTMAX_LIMITS); - pf ("#define SCM_T_INTMAX_MAX %s_MAX\n", SCM_I_GSC_T_INTMAX_LIMITS); - pf ("#define SCM_T_UINTMAX_MAX %s_MAX\n", SCM_I_GSC_T_UINTMAX_LIMITS); - pf ("\n"); pf ("/* scm_t_ptrdiff_t and size, always defined -- defined to long if\n" " platform doesn't have ptrdiff_t. */\n"); From 03696aab8cdb16118fffd382ac0dc738bb47ae0c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 14:04:02 +0000 Subject: [PATCH 74/89] *** empty log message *** --- libguile/ChangeLog | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e31350496..e52f62699 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,38 @@ +2004-07-29 Marius Vollmer + + * gen-scmconfig.h.in: Removed SCM_I_GSC_*_LIMITS macros, they are + no longer used. + + * __scm.h (SCM_I_UTYPE_MAX, SCM_I_TYPE_MAX, SCM_I_TYPE_MIN, + SCM_I_SIZE_MAX, SCM_I_SSIZE_MIN, SCM_I_SSIZE_MAX): New. + + * __scm.h, gen-scmconfig.c (SCM_I_LLONG_MAX, SCM_I_LLONG_MIN, + SCM_I_ULLONG_MAX, SCM_T_INT8_MIN, SCM_T_INT8_MAX, SCM_T_UINT8_MAX, + SCM_T_INT16_MIN, SCM_T_INT16_MAX, SCM_T_UINT16_MAX, + SCM_T_INT32_MIN, SCM_T_INT32_MAX, SCM_T_UINT32_MAX, + SCM_T_INT64_MIN, SCM_T_INT64_MAX, SCM_T_UINT64_MAX, + SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX, SCM_T_UINTMAX_MAX): Moved + definition into __scm.h, using new SCM_I_TYPE_MIN, etc. + + * conv-integer.i.c, conv-uinteger.i.c: New files, used to generate + the functions below. + + * Makefile.am (noinst_HEADERS): Added conv-integer.i.c and + conv-uinteger.i.c. + + * numbers.c, numbers.h (scm_to_int8, scm_to_uint8, scm_to_int16, + scm_to_uint16, scm_to_int32, scm_to_uint32, scm_to_int64, + scm_to_uint64, scm_from_int8, scm_from_uint8, scm_from_int16, + scm_from_uint16, scm_from_int32, scm_from_uint32, scm_from_int64, + scm_from_uint64): Turned from macros into proper functions. + (scm_to_signed_integer, scm_to_unsigned_integer, + scm_from_signed_integer, scm_from_unsigned_integer): Generate via + conv-integer.i.c and conv-uinteger.i.c, as well. + + * number.h (scm_to_ssize_t, scm_to_size_t): Use the new + SCM_I_SSIZE_MIN, SCM_I_SSIZE_MAX, and SCM_I_SIZE_MAX macros for + the limits. Those are always defined. + 2004-07-29 Kevin Ryde * posix.c (scm_ttyname): Use scm_i_misc_mutex for thread safety. From c134fe9dab2f6e96849902f373ff022687dd6150 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 14:13:20 +0000 Subject: [PATCH 75/89] Bugfix: logic in detecting ptrdiff_t was inverted; assume ptrdiff_t is available when its size is non-zero, not when it is zero. Do no longer define SCM_I_GSC_*_LIMITS macros. --- configure.in | 60 +--------------------------------------------------- 1 file changed, 1 insertion(+), 59 deletions(-) diff --git a/configure.in b/configure.in index 4d9aefb7f..4a38ed2be 100644 --- a/configure.in +++ b/configure.in @@ -245,7 +245,7 @@ if test "$ac_cv_sizeof_long" -ne "$ac_cv_sizeof_void_p"; then AC_MSG_ERROR(sizes of long and void* are not identical) fi -if test "$ac_cv_sizeof_ptrdiff_t" -eq 0; then +if test "$ac_cv_sizeof_ptrdiff_t" -ne 0; then SCM_I_GSC_T_PTRDIFF='"ptrdiff_t"' else SCM_I_GSC_T_PTRDIFF='"long"' @@ -323,161 +323,123 @@ fi ### Required type scm_t_int8 if test "$scm_stdint_has_int8"; then SCM_I_GSC_T_INT8='"int8_t"' - SCM_I_GSC_T_INT8_LIMITS='"INT8"' SCM_I_GSC_NEEDS_STDINT_H=1 elif test "$scm_inttypes_has_int8"; then SCM_I_GSC_T_INT8='"int8_t"' - SCM_I_GSC_T_INT8_LIMITS='"INT8"' SCM_I_GSC_NEEDS_INTTYPES_H=1 elif test "$ac_cv_sizeof_char" -eq 1; then SCM_I_GSC_T_INT8='"signed char"' - SCM_I_GSC_T_INT8_LIMITS='"SCHAR"' else AC_MSG_ERROR([Can't find appropriate type for scm_t_int8.]) fi AC_SUBST([SCM_I_GSC_T_INT8]) -AC_SUBST([SCM_I_GSC_T_INT8_LIMITS]) ### Required type scm_t_uint8 if test "$scm_stdint_has_uint8"; then SCM_I_GSC_T_UINT8='"uint8_t"' - SCM_I_GSC_T_UINT8_LIMITS='"UINT8"' SCM_I_GSC_NEEDS_STDINT_H=1 elif test "$scm_inttypes_has_uint8"; then SCM_I_GSC_T_UINT8='"uint8_t"' - SCM_I_GSC_T_UINT8_LIMITS='"UINT8"' SCM_I_GSC_NEEDS_INTTYPES_H=1 elif test "$ac_cv_sizeof_unsigned_char" -eq 1; then SCM_I_GSC_T_UINT8='"unsigned char"' - SCM_I_GSC_T_UINT8_LIMITS='"UCHAR"' else AC_MSG_ERROR([Can't find appropriate type for scm_t_uint8.]) fi AC_SUBST([SCM_I_GSC_T_UINT8]) -AC_SUBST([SCM_I_GSC_T_UINT8_LIMITS]) ### Required type scm_t_int16 (ANSI C says int or short might work) if test "$scm_stdint_has_int16"; then SCM_I_GSC_T_INT16='"int16_t"' - SCM_I_GSC_T_INT16_LIMITS='"INT16"' SCM_I_GSC_NEEDS_STDINT_H=1 elif test "$scm_inttypes_has_int16"; then SCM_I_GSC_T_INT16='"int16_t"' - SCM_I_GSC_T_INT16_LIMITS='"INT16"' SCM_I_GSC_NEEDS_INTTYPES_H=1 elif test "$ac_cv_sizeof_int" -eq 2; then SCM_I_GSC_T_INT16='"int"' - SCM_I_GSC_T_INT16_LIMITS='"INT"' elif test "$ac_cv_sizeof_short" -eq 2; then SCM_I_GSC_T_INT16='"short"' - SCM_I_GSC_T_INT16_LIMITS='"SHRT"' else AC_MSG_ERROR([Can't find appropriate type for scm_t_int16.]) fi AC_SUBST([SCM_I_GSC_T_INT16]) -AC_SUBST([SCM_I_GSC_T_INT16_LIMITS]) ### Required type scm_t_uint16 (ANSI C says int or short might work) if test "$scm_stdint_has_uint16"; then SCM_I_GSC_T_UINT16='"uint16_t"' - SCM_I_GSC_T_UINT16_LIMITS='"UINT16"' SCM_I_GSC_NEEDS_STDINT_H=1 elif test "$scm_inttypes_has_uint16"; then SCM_I_GSC_T_UINT16='"uint16_t"' - SCM_I_GSC_T_UINT16_LIMITS='"UINT16"' SCM_I_GSC_NEEDS_INTTYPES_H=1 elif test "$ac_cv_sizeof_unsigned_int" -eq 2; then SCM_I_GSC_T_UINT16='"unsigned int"' - SCM_I_GSC_T_UINT16_LIMITS='"UINT"' elif test "$ac_cv_sizeof_unsigned_short" -eq 2; then SCM_I_GSC_T_UINT16='"unsigned short"' - SCM_I_GSC_T_UINT16_LIMITS='"USHRT"' else AC_MSG_ERROR([Can't find appropriate type for scm_t_uint16.]) fi AC_SUBST([SCM_I_GSC_T_UINT16]) -AC_SUBST([SCM_I_GSC_T_UINT16_LIMITS]) ### Required type scm_t_int32 (ANSI C says int, short, or long might work) if test "$scm_stdint_has_int32"; then SCM_I_GSC_T_INT32='"int32_t"' - SCM_I_GSC_T_INT32_LIMITS='"INT32"' SCM_I_GSC_NEEDS_STDINT_H=1 elif test "$scm_inttypes_has_int32"; then SCM_I_GSC_T_INT32='"int32_t"' - SCM_I_GSC_T_INT32_LIMITS='"INT32"' SCM_I_GSC_NEEDS_INTTYPES_H=1 elif test "$ac_cv_sizeof_int" -eq 4; then SCM_I_GSC_T_INT32='"int"' - SCM_I_GSC_T_INT32_LIMITS='"INT"' elif test "$ac_cv_sizeof_long" -eq 4; then SCM_I_GSC_T_INT32='"long"' - SCM_I_GSC_T_INT32_LIMITS='"LONG"' elif test "$ac_cv_sizeof_short" -eq 4; then SCM_I_GSC_T_INT32='"short"' - SCM_I_GSC_T_INT32_LIMITS='"SHRT"' else AC_MSG_ERROR([Can't find appropriate type for scm_t_int32.]) fi AC_SUBST([SCM_I_GSC_T_INT32]) -AC_SUBST([SCM_I_GSC_T_INT32_LIMITS]) ### Required type scm_t_uint32 (ANSI C says int, short, or long might work) if test "$scm_stdint_has_uint32"; then SCM_I_GSC_T_UINT32='"uint32_t"' - SCM_I_GSC_T_UINT32_LIMITS='"UINT32"' SCM_I_GSC_NEEDS_STDINT_H=1 elif test "$scm_inttypes_has_uint32"; then SCM_I_GSC_T_UINT32='"uint32_t"' - SCM_I_GSC_T_UINT32_LIMITS='"UINT32"' SCM_I_GSC_NEEDS_INTTYPES_H=1 elif test "$ac_cv_sizeof_unsigned_int" -eq 4; then SCM_I_GSC_T_UINT32='"unsigned int"' - SCM_I_GSC_T_UINT32_LIMITS='"UINT"' elif test "$ac_cv_sizeof_unsigned_long" -eq 4; then SCM_I_GSC_T_UINT32='"unsigned long"' - SCM_I_GSC_T_UINT32_LIMITS='"ULONG"' elif test "$ac_cv_sizeof_unsigned_short" -eq 4; then SCM_I_GSC_T_UINT32='"unsigned short"' - SCM_I_GSC_T_UINT32_LIMITS='"USHRT"' else AC_MSG_ERROR([Can't find appropriate type for scm_t_uint32.]) fi AC_SUBST([SCM_I_GSC_T_UINT32]) -AC_SUBST([SCM_I_GSC_T_UINT32_LIMITS]) ### Optional type scm_t_int64 (ANSI C says int, short, or long might work) ### Also try 'long long' and '__int64' if we have it. SCM_I_GSC_T_INT64=0 if test "$scm_stdint_has_int64"; then SCM_I_GSC_T_INT64='"int64_t"' - SCM_I_GSC_T_INT64_LIMITS='"INT64"' SCM_I_GSC_NEEDS_STDINT_H=1 elif test "$scm_inttypes_has_int64"; then SCM_I_GSC_T_INT64='"int64_t"' - SCM_I_GSC_T_INT64_LIMITS='"INT64"' SCM_I_GSC_NEEDS_INTTYPES_H=1 elif test "$ac_cv_sizeof_int" -eq 8; then SCM_I_GSC_T_INT64='"int"' - SCM_I_GSC_T_INT64_LIMITS='"INT"' elif test "$ac_cv_sizeof_long" -eq 8; then SCM_I_GSC_T_INT64='"long"' - SCM_I_GSC_T_INT64_LIMITS='"LONG"' elif test "$ac_cv_sizeof_short" -eq 8; then SCM_I_GSC_T_INT64='"short"' - SCM_I_GSC_T_INT64_LIMITS='"SHRT"' elif test "$ac_cv_sizeof_long_long" -eq 8; then SCM_I_GSC_T_INT64='"long long"' - SCM_I_GSC_T_INT64_LIMITS='"SCM_I_LLONG"' elif test "$ac_cv_sizeof___int64" -eq 8; then SCM_I_GSC_T_INT64='"__int64"' - SCM_I_GSC_T_INT64_LIMITS='"unknown"' else AC_MSG_ERROR([Can't find appropriate type for scm_t_int64.]) fi AC_SUBST([SCM_I_GSC_T_INT64]) -AC_SUBST([SCM_I_GSC_T_INT64_LIMITS]) ### Optional type scm_t_uint64 (ANSI C says int, short, or long might work) @@ -485,32 +447,24 @@ AC_SUBST([SCM_I_GSC_T_INT64_LIMITS]) SCM_I_GSC_T_UINT64=0 if test "$scm_stdint_has_uint64"; then SCM_I_GSC_T_UINT64='"uint64_t"' - SCM_I_GSC_T_UINT64_LIMITS='"UINT64"' SCM_I_GSC_NEEDS_STDINT_H=1 elif test "$scm_inttypes_has_uint64"; then SCM_I_GSC_T_UINT64='"uint64_t"' - SCM_I_GSC_T_UINT64_LIMITS='"UINT64"' SCM_I_GSC_NEEDS_INTTYPES_H=1 elif test "$ac_cv_sizeof_unsigned_int" -eq 8; then SCM_I_GSC_T_UINT64='"unsigned int"' - SCM_I_GSC_T_UINT64_LIMITS='"UINT"' elif test "$ac_cv_sizeof_unsigned_long" -eq 8; then SCM_I_GSC_T_UINT64='"unsigned long"' - SCM_I_GSC_T_UINT64_LIMITS='"ULONG"' elif test "$ac_cv_sizeof_unsigned_short" -eq 8; then SCM_I_GSC_T_UINT64='"unsigned short"' - SCM_I_GSC_T_UINT64_LIMITS='"USHRT"' elif test "$ac_cv_sizeof_unsigned_long_long" -eq 8; then SCM_I_GSC_T_UINT64='"unsigned long long"' - SCM_I_GSC_T_UINT64_LIMITS='"SCM_I_ULLONG"' elif test "$ac_cv_sizeof_unsigned___int64" -eq 8; then SCM_I_GSC_T_UINT64='"unsigned __int64"' - SCM_I_GSC_T_UINT64_LIMITS='"unknown"' else AC_MSG_ERROR([Can't find appropriate type for scm_t_uint64.]) fi AC_SUBST([SCM_I_GSC_T_UINT64]) -AC_SUBST([SCM_I_GSC_T_UINT64_LIMITS]) ### Required type scm_t_intmax ### @@ -520,24 +474,18 @@ AC_SUBST([SCM_I_GSC_T_UINT64_LIMITS]) SCM_I_GSC_T_INTMAX=0 if test "$scm_stdint_has_intmax"; then SCM_I_GSC_T_INTMAX='"intmax_t"' - SCM_I_GSC_T_INTMAX_LIMITS='"INTMAX"' SCM_I_GSC_NEEDS_STDINT_H=1 elif test "$scm_inttypes_has_intmax"; then SCM_I_GSC_T_INTMAX='"intmax_t"' - SCM_I_GSC_T_INTMAX_LIMITS='"INTMAX"' SCM_I_GSC_NEEDS_INTTYPES_H=1 elif test "$ac_cv_sizeof___int64" -ne 0; then SCM_I_GSC_T_INTMAX='"__int64"' - SCM_I_GSC_T_INTMAX_LIMITS='"unknown"' elif test "$ac_cv_sizeof_long_long" -ne 0; then SCM_I_GSC_T_INTMAX='"long long"' - SCM_I_GSC_T_INTMAX_LIMITS='"SCM_I_LLONG"' else SCM_I_GSC_T_INTMAX='"long"' - SCM_I_GSC_T_INTMAX_LIMITS='"LONG"' fi AC_SUBST([SCM_I_GSC_T_INTMAX]) -AC_SUBST([SCM_I_GSC_T_INTMAX_LIMITS]) ### Required type scm_t_uintmax ### @@ -547,24 +495,18 @@ AC_SUBST([SCM_I_GSC_T_INTMAX_LIMITS]) SCM_I_GSC_T_UINTMAX=0 if test "$scm_stdint_has_uintmax"; then SCM_I_GSC_T_UINTMAX='"uintmax_t"' - SCM_I_GSC_T_UINTMAX_LIMITS='"UINTMAX"' SCM_I_GSC_NEEDS_STDINT_H=1 elif test "$scm_inttypes_has_uintmax"; then SCM_I_GSC_T_UINTMAX='"uintmax_t"' - SCM_I_GSC_T_UINTMAX_LIMITS='"UINTMAX"' SCM_I_GSC_NEEDS_INTTYPES_H=1 elif test "$ac_cv_sizeof_unsigned___int64" -ne 0; then SCM_I_GSC_T_UINTMAX='"unsigned __int64"' - SCM_I_GSC_T_UINTMAX_LIMITS='"unknown"' elif test "$ac_cv_sizeof_unsigned_long_long" -ne 0; then SCM_I_GSC_T_UINTMAX='"unsigned long long"' - SCM_I_GSC_T_UINTMAX_LIMITS='"SCM_I_ULLONG"' else SCM_I_GSC_T_UINTMAX='"unsigned long"' - SCM_I_GSC_T_UINTMAX_LIMITS='"ULONG"' fi AC_SUBST([SCM_I_GSC_T_UINTMAX]) -AC_SUBST([SCM_I_GSC_T_UINTMAX_LIMITS]) AC_SUBST([SCM_I_GSC_NEEDS_STDINT_H]) From 3838c384d12e0b0871a5f659c0a96b7980de0c6f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 14:13:59 +0000 Subject: [PATCH 76/89] Many more tests for the integer conversion functions. --- test-suite/standalone/test-conversion.c | 305 ++++++++++++++++++++---- 1 file changed, 264 insertions(+), 41 deletions(-) diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c index 7dc792de9..897293b55 100644 --- a/test-suite/standalone/test-conversion.c +++ b/test-suite/standalone/test-conversion.c @@ -493,58 +493,281 @@ test_from_unsigned_integer () test_6 (SCM_MOST_POSITIVE_FIXNUM+1, "(+ most-positive-fixnum 1)"); } +static void +test_7s (SCM n, scm_t_intmax c_n, const char *result, const char *func) +{ + SCM r = scm_c_eval_string (result); + + if (scm_is_false (scm_equal_p (n, r))) + { + fprintf (stderr, "fail: %s (%Ld) == %s\n", func, c_n, result); + exit (1); + } +} + +#define TEST_7S(func,arg,res) test_7s (func(arg), arg, res, #func) + +static void +test_7u (SCM n, scm_t_uintmax c_n, const char *result, const char *func) +{ + SCM r = scm_c_eval_string (result); + + if (scm_is_false (scm_equal_p (n, r))) + { + fprintf (stderr, "fail: %s (%Lu) == %s\n", func, c_n, result); + exit (1); + } +} + +#define TEST_7U(func,arg,res) test_7u (func(arg), arg, res, #func) + +typedef struct { + SCM val; + scm_t_intmax (*func) (SCM); + scm_t_intmax result; +} to_signed_func_data; + +static SCM +to_signed_func_body (void *data) +{ + to_signed_func_data *d = (to_signed_func_data *)data; + d->result = d->func (d->val); + return SCM_BOOL_F; +} + +static void +test_8s (const char *str, scm_t_intmax (*func) (SCM), const char *func_name, + scm_t_intmax result, int range_error, int type_error) +{ + to_signed_func_data data; + data.val = scm_c_eval_string (str); + data.func = func; + + if (range_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_signed_func_body, &data, + out_of_range_handler, NULL))) + { + fprintf (stderr, + "fail: %s (%s) -> out of range\n", func_name, str); + exit (1); + } + } + else if (type_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_signed_func_body, &data, + wrong_type_handler, NULL))) + { + fprintf (stderr, + "fail: %s (%s) -> wrong type\n", func_name, str); + exit (1); + } + } + else + { + if (scm_is_true (scm_internal_catch (SCM_BOOL_T, + to_signed_func_body, &data, + any_handler, NULL)) + || data.result != result) + { + fprintf (stderr, + "fail: %s (%s) = %Ld\n", func_name, str, result); + exit (1); + } + } +} + +typedef struct { + SCM val; + scm_t_uintmax (*func) (SCM); + scm_t_uintmax result; +} to_unsigned_func_data; + +static SCM +to_unsigned_func_body (void *data) +{ + to_unsigned_func_data *d = (to_unsigned_func_data *)data; + d->result = d->func (d->val); + return SCM_BOOL_F; +} + +static void +test_8u (const char *str, scm_t_uintmax (*func) (SCM), const char *func_name, + scm_t_uintmax result, int range_error, int type_error) +{ + to_unsigned_func_data data; + data.val = scm_c_eval_string (str); + data.func = func; + + if (range_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_unsigned_func_body, &data, + out_of_range_handler, NULL))) + { + fprintf (stderr, + "fail: %s (%s) -> out of range\n", func_name, str); + exit (1); + } + } + else if (type_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_unsigned_func_body, &data, + wrong_type_handler, NULL))) + { + fprintf (stderr, + "fail: %s (%s) -> wrong type\n", func_name, str); + exit (1); + } + } + else + { + if (scm_is_true (scm_internal_catch (SCM_BOOL_T, + to_unsigned_func_body, &data, + any_handler, NULL)) + || data.result != result) + { + fprintf (stderr, + "fail: %s (%s) = %Ld\n", func_name, str, result); + exit (1); + } + } +} + +/* We can't rely on the scm_to functions being proper functions but we + want to pass them to test_8s and test_8u, so we wrap'em. Also, we + need to give them a common return type. +*/ + +#define DEFSTST(f) static scm_t_intmax tst_##f (SCM x) { return f(x); } +#define DEFUTST(f) static scm_t_uintmax tst_##f (SCM x) { return f(x); } + +DEFSTST (scm_to_schar); +DEFUTST (scm_to_uchar); +DEFSTST (scm_to_char); +DEFSTST (scm_to_short); +DEFUTST (scm_to_ushort); +DEFSTST (scm_to_int); +DEFUTST (scm_to_uint); +DEFSTST (scm_to_long); +DEFUTST (scm_to_ulong); +#if SCM_SIZEOF_LONG_LONG != 0 +DEFSTST (scm_to_long_long); +DEFUTST (scm_to_ulong_long); +#endif +DEFSTST (scm_to_ssize_t); +DEFUTST (scm_to_size_t); + +DEFSTST (scm_to_int8); +DEFUTST (scm_to_uint8); +DEFSTST (scm_to_int16); +DEFUTST (scm_to_uint16); +DEFSTST (scm_to_int32); +DEFUTST (scm_to_uint32); +#ifdef SCM_HAVE_T_INT64 +DEFSTST (scm_to_int64); +DEFUTST (scm_to_uint64); +#endif + +#define TEST_8S(v,f,r,re,te) test_8s (v, tst_##f, #f, r, re, te) +#define TEST_8U(v,f,r,re,te) test_8u (v, tst_##f, #f, r, re, te) + + static void test_int_sizes () { - SCM n = scm_from_int (91); - - /* Just list them here to check whether the macros expand to correct - code. */ - - scm_from_schar (91); - scm_from_uchar (91); - scm_from_char (91); - scm_from_short (91); - scm_from_int (91); - scm_from_long (91); + TEST_7U (scm_from_uchar, 91, "91"); + TEST_7S (scm_from_schar, 91, "91"); + TEST_7S (scm_from_char, 91, "91"); + TEST_7S (scm_from_short, -911, "-911"); + TEST_7U (scm_from_ushort, 911, "911"); + TEST_7S (scm_from_int, 911, "911"); + TEST_7U (scm_from_uint, 911, "911"); + TEST_7S (scm_from_long, 911, "911"); + TEST_7U (scm_from_ulong, 911, "911"); #if SCM_SIZEOF_LONG_LONG != 0 - scm_from_long_long (91); - scm_from_ulong_long (91); + TEST_7S (scm_from_long_long, 911, "911"); + TEST_7U (scm_from_ulong_long, 911, "911"); #endif - scm_from_size_t (91); - scm_from_ssize_t (91); - scm_from_int8 (91); - scm_from_uint8 (91); - scm_from_int16 (91); - scm_from_uint16 (91); - scm_from_int32 (91); - scm_from_uint32 (91); + TEST_7U (scm_from_size_t, 911, "911"); + TEST_7S (scm_from_ssize_t, 911, "911"); + + TEST_7S (scm_from_int8, -128, "-128"); + TEST_7S (scm_from_int8, 127, "127"); + TEST_7S (scm_from_int8, 128, "-128"); + TEST_7U (scm_from_uint8, 255, "255"); + + TEST_7S (scm_from_int16, -32768, "-32768"); + TEST_7S (scm_from_int16, 32767, "32767"); + TEST_7S (scm_from_int16, 32768, "-32768"); + TEST_7U (scm_from_uint16, 65535, "65535"); + + TEST_7S (scm_from_int32, SCM_T_INT32_MIN, "-2147483648"); + TEST_7S (scm_from_int32, SCM_T_INT32_MAX, "2147483647"); + TEST_7S (scm_from_int32, SCM_T_INT32_MAX+1LL, "-2147483648"); + TEST_7U (scm_from_uint32, SCM_T_UINT32_MAX, "4294967295"); + #if SCM_HAVE_T_INT64 - scm_from_int64 (91); - scm_from_uint64 (91); + TEST_7S (scm_from_int64, SCM_T_INT64_MIN, "-9223372036854775808"); + TEST_7S (scm_from_int64, SCM_T_INT64_MAX, "9223372036854775807"); + TEST_7U (scm_from_uint64, SCM_T_UINT64_MAX, "18446744073709551615"); #endif - scm_to_schar (n); - scm_to_uchar (n); - scm_to_char (n); - scm_to_short (n); - scm_to_int (n); - scm_to_long (n); + TEST_8S ("91", scm_to_schar, 91, 0, 0); + TEST_8U ("91", scm_to_uchar, 91, 0, 0); + TEST_8S ("91", scm_to_char, 91, 0, 0); + TEST_8S ("-911", scm_to_short, -911, 0, 0); + TEST_8U ("911", scm_to_ushort, 911, 0, 0); + TEST_8S ("-911", scm_to_int, -911, 0, 0); + TEST_8U ("911", scm_to_uint, 911, 0, 0); + TEST_8S ("-911", scm_to_long, -911, 0, 0); + TEST_8U ("911", scm_to_ulong, 911, 0, 0); #if SCM_SIZEOF_LONG_LONG != 0 - scm_to_long_long (n); - scm_to_ulong_long (n); + TEST_8S ("-911", scm_to_long_long, -911, 0, 0); + TEST_8U ("911", scm_to_ulong_long, 911, 0, 0); #endif - scm_to_size_t (n); - scm_to_ssize_t (n); - scm_to_int8 (n); - scm_to_uint8 (n); - scm_to_int16 (n); - scm_to_uint16 (n); - scm_to_int32 (n); - scm_to_uint32 (n); + TEST_8U ("911", scm_to_size_t, 911, 0, 0); + TEST_8S ("911", scm_to_ssize_t, 911, 0, 0); + + TEST_8S ("-128", scm_to_int8, SCM_T_INT8_MIN, 0, 0); + TEST_8S ("127", scm_to_int8, SCM_T_INT8_MAX, 0, 0); + TEST_8S ("128", scm_to_int8, 0, 1, 0); + TEST_8S ("#f", scm_to_int8, 0, 0, 1); + TEST_8U ("255", scm_to_uint8, SCM_T_UINT8_MAX, 0, 0); + TEST_8U ("256", scm_to_uint8, 0, 1, 0); + TEST_8U ("-1", scm_to_uint8, 0, 1, 0); + TEST_8U ("#f", scm_to_uint8, 0, 0, 1); + + TEST_8S ("-32768", scm_to_int16, SCM_T_INT16_MIN, 0, 0); + TEST_8S ("32767", scm_to_int16, SCM_T_INT16_MAX, 0, 0); + TEST_8S ("32768", scm_to_int16, 0, 1, 0); + TEST_8S ("#f", scm_to_int16, 0, 0, 1); + TEST_8U ("65535", scm_to_uint16, SCM_T_UINT16_MAX, 0, 0); + TEST_8U ("65536", scm_to_uint16, 0, 1, 0); + TEST_8U ("-1", scm_to_uint16, 0, 1, 0); + TEST_8U ("#f", scm_to_uint16, 0, 0, 1); + + TEST_8S ("-2147483648", scm_to_int32, SCM_T_INT32_MIN, 0, 0); + TEST_8S ("2147483647", scm_to_int32, SCM_T_INT32_MAX, 0, 0); + TEST_8S ("2147483648", scm_to_int32, 0, 1, 0); + TEST_8S ("#f", scm_to_int32, 0, 0, 1); + TEST_8U ("4294967295", scm_to_uint32, SCM_T_UINT32_MAX, 0, 0); + TEST_8U ("4294967296", scm_to_uint32, 0, 1, 0); + TEST_8U ("-1", scm_to_uint32, 0, 1, 0); + TEST_8U ("#f", scm_to_uint32, 0, 0, 1); + #if SCM_HAVE_T_INT64 - scm_to_int64 (n); - scm_to_uint64 (n); + TEST_8S ("-9223372036854775808", scm_to_int64, SCM_T_INT64_MIN, 0, 0); + TEST_8S ("9223372036854775807", scm_to_int64, SCM_T_INT64_MAX, 0, 0); + TEST_8S ("9223372036854775808", scm_to_int64, 0, 1, 0); + TEST_8S ("#f", scm_to_int64, 0, 0, 1); + TEST_8U ("18446744073709551615", scm_to_uint64, SCM_T_UINT64_MAX, 0, 0); + TEST_8U ("18446744073709551616", scm_to_uint64, 0, 1, 0); + TEST_8U ("-1", scm_to_uint64, 0, 1, 0); + TEST_8U ("#f", scm_to_uint64, 0, 0, 1); #endif } From 315158a8ac1af1c4aa565c44448b93112670eacf Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 14:14:18 +0000 Subject: [PATCH 77/89] *** empty log message *** --- ChangeLog | 6 ++++++ test-suite/ChangeLog | 5 +++++ 2 files changed, 11 insertions(+) diff --git a/ChangeLog b/ChangeLog index ba89a8a3f..0f8459ef0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2004-07-29 Marius Vollmer + + * configure.in: Bugfix: logic in detecting ptrdiff_t was inverted; + assume ptrdiff_t is available when its size is non-zero, not when + it is zero. Do no longer define SCM_I_GSC_*_LIMITS macros. + 2004-07-09 Marius Vollmer * configure.in: Bugfix: set SCM_I_GSC_T_UINTMAX, not diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index dc9f85831..b672f5622 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-07-29 Marius Vollmer + + * standalone/test-conversion.c: Many more tests for the integer + conversion functions. + 2004-07-28 Kevin Ryde * tests/regexp.test (make-regexp): Exercise flags args validation. From d20008c0abb9ab978a3406442ac15474504a014b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 15:44:01 +0000 Subject: [PATCH 78/89] Check for sizes of size_t and intmax_t. --- configure.in | 3 +++ 1 file changed, 3 insertions(+) diff --git a/configure.in b/configure.in index 4a38ed2be..e47c76dad 100644 --- a/configure.in +++ b/configure.in @@ -240,6 +240,7 @@ AC_CHECK_SIZEOF(void *) AC_CHECK_SIZEOF(intptr_t) AC_CHECK_SIZEOF(uintptr_t) AC_CHECK_SIZEOF(ptrdiff_t) +AC_CHECK_SIZEOF(size_t) if test "$ac_cv_sizeof_long" -ne "$ac_cv_sizeof_void_p"; then AC_MSG_ERROR(sizes of long and void* are not identical) @@ -255,6 +256,8 @@ AC_SUBST([SCM_I_GSC_T_PTRDIFF]) AC_CHECK_HEADERS([stdint.h]) AC_CHECK_HEADERS([inttypes.h]) +AC_CHECK_SIZEOF(intmax_t) + SCM_I_GSC_NEEDS_STDINT_H=0 SCM_I_GSC_NEEDS_INTTYPES_H=0 From d1b5b4001ee658d978182eb67a43dc648f0a9e2f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 15:48:44 +0000 Subject: [PATCH 79/89] * numbers.h (scm_to_schar, scm_to_uchar, scm_to_char, scm_to_short, scm_to_ushort, scm_to_int, scm_to_uint, scm_to_long, scm_to_ulong, scm_to_long_long, scm_to_ulong_long, scm_to_intmax, scm_to_uintmax, scm_to_size_t, scm_to_ssize_t scm_from_schar, scm_from_uchar, scm_from_char, scm_from_short, scm_from_ushort, scm_from_int, scm_from_uint, scm_from_long, scm_from_ulong, scm_from_long_long, scm_from_ulong_long, scm_from_intmax, scm_from_uintmax, scm_from_size_t, scm_from_ssize_t): No longer defined in terms of scm_to_signed_integer, etc, but in terms of scm_to_int8, etc. --- libguile/numbers.h | 182 ++++++++++++++++++++++++++++++--------------- 1 file changed, 120 insertions(+), 62 deletions(-) diff --git a/libguile/numbers.h b/libguile/numbers.h index 8e4d82c28..19bd356d1 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -338,7 +338,7 @@ SCM_API int scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate); SCM_API SCM scm_sys_check_number_conversions (void); #endif -/* conversion functions */ +/* conversion functions for integers */ SCM_API int scm_is_integer (SCM val); SCM_API int scm_is_signed_integer (SCM val, @@ -384,75 +384,133 @@ SCM_API SCM scm_from_uint64 (scm_t_uint64 x); #endif -#define scm_to_schar(x) \ - ((signed char)scm_to_signed_integer ((x), SCHAR_MIN, SCHAR_MAX)) -#define scm_to_uchar(x) \ - ((unsigned char)scm_to_unsigned_integer ((x), 0, UCHAR_MAX)) +/* The conversion functions for other types are aliased to the + appropriate ones from above. We pick the right one based on the + size of the type. + + Not each and every possibility is covered by the code below, and + while it is trivial to complete the tests, it might be better to + just test for the 'sane' possibilities. When one of the tests + below fails, chances are good that some silent assumption somewhere + else will also fail. +*/ + +#if SCM_SIZEOF_CHAR == 1 +#define scm_to_schar scm_to_int8 +#define scm_from_schar scm_from_int8 +#define scm_to_uchar scm_to_uint8 +#define scm_from_uchar scm_from_uint8 #if CHAR_MIN == 0 -#define scm_to_char scm_to_uchar +#define scm_to_char scm_to_uint8 +#define scm_from_char scm_from_uint8 #else -#define scm_to_char scm_to_schar +#define scm_to_char scm_to_int8 +#define scm_from_char scm_from_int8 #endif - -#define scm_to_short(x) \ - ((short)scm_to_signed_integer ((x), SHRT_MIN, SHRT_MAX)) -#define scm_to_ushort(x) \ - ((unsigned short)scm_to_unsigned_integer ((x), 0, SHRT_MAX)) - -#define scm_to_int(x) \ - ((int)scm_to_signed_integer ((x), INT_MIN, INT_MAX)) -#define scm_to_uint(x) \ - ((unsigned int)scm_to_unsigned_integer ((x), 0, UINT_MAX)) - -#define scm_to_long(x) \ - ((long)scm_to_signed_integer ((x), LONG_MIN, LONG_MAX)) -#define scm_to_ulong(x) \ - ((unsigned long)scm_to_unsigned_integer ((x), 0, ULONG_MAX)) - -#define scm_to_ssize_t(x) \ - ((ssize_t)scm_to_signed_integer ((x), SCM_I_SSIZE_MIN, SCM_I_SSIZE_MAX)) -#define scm_to_size_t(x) \ - ((unsigned long)scm_to_unsigned_integer ((x), 0, SCM_I_SIZE_MAX)) - -#if SCM_SIZEOF_LONG_LONG != 0 -#define scm_to_long_long(x) \ - ((long long)scm_to_signed_integer ((x), SCM_I_LLONG_MIN, SCM_I_LLONG_MAX)) -#define scm_to_ulong_long(x) \ - ((unsigned long long)scm_to_unsigned_integer ((x), 0, SCM_I_ULLONG_MAX)) -#endif - -#define scm_to_intmax(x) \ - ((scm_t_intmax)scm_to_signed_integer ((x),SCM_T_INTMAX_MIN,SCM_T_INTMAX_MAX)) -#define scm_to_uintmax(x) \ - ((scm_t_uintmax)scm_to_unsigned_integer ((x), 0, SCM_T_UINTMAX_MAX)) - -#define scm_from_schar(x) scm_from_signed_integer ((signed char)(x)) -#define scm_from_uchar(x) scm_from_unsigned_integer ((unsigned char)(x)) -#if CHAR_MIN == 0 -#define scm_from_char scm_from_uchar #else -#define scm_from_char scm_from_schar +#error sizeof(char) is not 1. #endif -#define scm_from_short(x) scm_from_signed_integer ((short)(x)) -#define scm_from_ushort(x) scm_from_unsigned_integer ((unsigned short)(x)) - -#define scm_from_int(x) scm_from_signed_integer ((int)(x)) -#define scm_from_uint(x) scm_from_unsigned_integer ((unsigned int)(x)) - -#define scm_from_long(x) scm_from_signed_integer ((long)(x)) -#define scm_from_ulong(x) scm_from_unsigned_integer ((unsigned long)(x)) - -#define scm_from_ssize_t(x) scm_from_signed_integer ((ssize_t)(x)) -#define scm_from_size_t(x) scm_from_unsigned_integer ((size_t)(x)) - -#if SCM_SIZEOF_LONG_LONG != 0 -#define scm_from_long_long(x) scm_from_signed_integer ((long long)(x)) -#define scm_from_ulong_long(x) scm_from_unsigned_integer ((unsigned long long)(x)) +#if SCM_SIZEOF_SHORT == 1 +#define scm_to_short scm_to_int8 +#define scm_from_short scm_from_int8 +#define scm_to_ushort scm_to_uint8 +#define scm_from_ushort scm_from_uint8 +#else +#if SCM_SIZEOF_SHORT == 2 +#define scm_to_short scm_to_int16 +#define scm_from_short scm_from_int16 +#define scm_to_ushort scm_to_uint16 +#define scm_from_ushort scm_from_uint16 +#else +#if SCM_SIZEOF_SHORT == 4 +#define scm_to_short scm_to_int32 +#define scm_from_short scm_from_int32 +#define scm_to_ushort scm_to_uint32 +#define scm_from_ushort scm_from_uint32 +#else +#error sizeof(short) is not 1, 2, or 4. +#endif +#endif #endif -#define scm_from_intmax(x) scm_from_signed_integer ((scm_t_intmax)(x)) -#define scm_from_uintmax(x) scm_from_unsigned_integer ((scm_t_uintmax)(x)) +#if SCM_SIZEOF_INT == 4 +#define scm_to_int scm_to_int32 +#define scm_from_int scm_from_int32 +#define scm_to_uint scm_to_uint32 +#define scm_from_uint scm_from_uint32 +#else +#if SCM_SIZEOF_INT == 8 +#define scm_to_int scm_to_int64 +#define scm_from_int scm_from_int64 +#define scm_to_uint scm_to_uint64 +#define scm_from_uint scm_from_uint64 +#else +#error sizeof(int) is not 4 or 8. +#endif +#endif + +#if SCM_SIZEOF_LONG == 4 +#define scm_to_long scm_to_int32 +#define scm_from_long scm_from_int32 +#define scm_to_ulong scm_to_uint32 +#define scm_from_ulong scm_from_uint32 +#else +#if SCM_SIZEOF_LONG == 8 +#define scm_to_long scm_to_int64 +#define scm_from_long scm_from_int64 +#define scm_to_ulong scm_to_uint64 +#define scm_from_ulong scm_from_uint64 +#else +#error sizeof(long) is not 4 or 8. +#endif +#endif + +#if SCM_SIZEOF_INTMAX == 4 +#define scm_to_intmax scm_to_int32 +#define scm_from_intmax scm_from_int32 +#define scm_to_uintmax scm_to_uint32 +#define scm_from_uintmax scm_from_uint32 +#else +#if SCM_SIZEOF_INTMAX == 8 +#define scm_to_intmax scm_to_int64 +#define scm_from_intmax scm_from_int64 +#define scm_to_uintmax scm_to_uint64 +#define scm_from_uintmax scm_from_uint64 +#else +#error sizeof(scm_t_intmax_t) is not 4 or 8. +#endif +#endif + +#if SCM_SIZEOF_LONG_LONG == 0 +#else +#if SCM_SIZEOF_LONG_LONG == 8 +#define scm_to_long_long scm_to_int64 +#define scm_from_long_long scm_from_int64 +#define scm_to_ulong_long scm_to_uint64 +#define scm_from_ulong_long scm_from_uint64 +#else +#error sizeof(long long) is not 8. +#endif +#endif + +#if SCM_SIZEOF_SIZE_T == 4 +#define scm_to_ssize_t scm_to_int32 +#define scm_from_ssize_t scm_from_int32 +#define scm_to_size_t scm_to_uint32 +#define scm_from_size_t scm_from_uint32 +#else +#if SCM_SIZEOF_SIZE_T == 8 +#define scm_to_ssize_t scm_to_int64 +#define scm_from_ssize_t scm_from_int64 +#define scm_to_size_t scm_to_uint64 +#define scm_from_size_t scm_from_uint64 +#else +#error sizeof(size_t) is not 4 or 8. +#endif +#endif + +/* conversion functions for reals */ SCM_API int scm_is_real (SCM val); SCM_API double scm_to_double (SCM val); From 4627df5a6bd4e9ab40135f4a491192f8ba5a8c21 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 15:48:54 +0000 Subject: [PATCH 80/89] * gen-scmconfig.c (SCM_SIZEOF_INTMAX, SCM_SIZEOF_SIZE_T): New. --- libguile/gen-scmconfig.c | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 3fd2df569..e4465c05f 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -270,6 +270,7 @@ main (int argc, char *argv[]) pf ("#define SCM_SIZEOF_UNSIGNED_LONG %d\n", SIZEOF_UNSIGNED_LONG); pf ("#define SCM_SIZEOF_INT %d\n", SIZEOF_INT); pf ("#define SCM_SIZEOF_UNSIGNED_INT %d\n", SIZEOF_UNSIGNED_INT); + pf ("#define SCM_SIZEOF_SIZE_T %d\n", SIZEOF_SIZE_T); pf ("\n"); pf ("/* Size of (unsigned) long long or 0 if not available (scm_t_*64 may\n" @@ -303,6 +304,15 @@ main (int argc, char *argv[]) pf ("typedef %s scm_t_intmax;\n", SCM_I_GSC_T_INTMAX); pf ("typedef %s scm_t_uintmax;\n", SCM_I_GSC_T_UINTMAX); + if (0 == strcmp ("intmax_t", SCM_I_GSC_T_INTMAX)) + pf ("#define SCM_SIZEOF_INTMAX %d\n", SIZEOF_INTMAX_T); + else if (0 == strcmp ("long long", SCM_I_GSC_T_INTMAX)) + pf ("#define SCM_SIZEOF_INTMAX %d\n", SIZEOF_LONG_LONG); + else if (0 == strcmp ("__int64", SCM_I_GSC_T_INTMAX)) + pf ("#define SCM_SIZEOF_INTMAX %d\n", SIZEOF___INT64); + else + return 1; + pf ("\n"); pf ("/* 64-bit integer -- if available SCM_HAVE_T_INT64 will be 1 and\n" " scm_t_int64 will be a suitable type, otherwise SCM_HAVE_T_INT64\n" From 51fdb325b0472e9eb27bf5280f4aaa4c84c2330f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 29 Jul 2004 15:49:04 +0000 Subject: [PATCH 81/89] *** empty log message *** --- ChangeLog | 3 ++- libguile/ChangeLog | 13 +++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 0f8459ef0..2df2158da 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,7 +2,8 @@ * configure.in: Bugfix: logic in detecting ptrdiff_t was inverted; assume ptrdiff_t is available when its size is non-zero, not when - it is zero. Do no longer define SCM_I_GSC_*_LIMITS macros. + it is zero. Do no longer define SCM_I_GSC_*_LIMITS macros. Check + for sizes of size_t and intmax_t. 2004-07-09 Marius Vollmer diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e52f62699..cabd3cf84 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,18 @@ 2004-07-29 Marius Vollmer + * numbers.h (scm_to_schar, scm_to_uchar, scm_to_char, + scm_to_short, scm_to_ushort, scm_to_int, scm_to_uint, scm_to_long, + scm_to_ulong, scm_to_long_long, scm_to_ulong_long, scm_to_intmax, + scm_to_uintmax, scm_to_size_t, scm_to_ssize_t scm_from_schar, + scm_from_uchar, scm_from_char, scm_from_short, scm_from_ushort, + scm_from_int, scm_from_uint, scm_from_long, scm_from_ulong, + scm_from_long_long, scm_from_ulong_long, scm_from_intmax, + scm_from_uintmax, scm_from_size_t, scm_from_ssize_t): No longer + defined in terms of scm_to_signed_integer, etc, but in terms of + scm_to_int8, etc. + + * gen-scmconfig.c (SCM_SIZEOF_INTMAX, SCM_SIZEOF_SIZE_T): New. + * gen-scmconfig.h.in: Removed SCM_I_GSC_*_LIMITS macros, they are no longer used. From f47029a180fbc1240886660028a5ce57bf830274 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 30 Jul 2004 12:39:29 +0000 Subject: [PATCH 82/89] (Formatted Output): Changed @w to @w{} in itemize. The former doesn't work for some reason... --- doc/ref/misc-modules.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index c22aa4d9c..963aa8980 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -760,7 +760,7 @@ Case conversion. Between @nicode{~(} and @nicode{~)} the case of all output is changed. The modifiers on @nicode{~(} control the conversion. -@itemize @w +@itemize @w{} @item no modifiers --- lower case. @c From da1e6e6710d6a803709214ccb32bff4dda652519 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 30 Jul 2004 12:39:36 +0000 Subject: [PATCH 83/89] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 0bedeceac..ace1cb5a5 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2004-07-30 Marius Vollmer + + * misc-modules.texi (Formatted Output): Changed @w to @w{} in + itemize. The former doesn't work for some reason... + 2004-07-28 Kevin Ryde * misc-modules.texi (Formatted Output): Rewrite, describing escapes From 7426a638b7017d7d67b647ae8b75f8ee26c17d80 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 31 Jul 2004 01:08:20 +0000 Subject: [PATCH 84/89] (scm_gensym): Use scm_i_misc_mutex around gensym_counter update, for thread safety. (gensym_counter): Move into scm_gensym which is its only user. (scm_init_symbols): No need to explicitly initialize gensym_counter. --- libguile/symbols.c | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index 1783a47bd..01261e2f1 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -264,8 +264,6 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, #define MAX_PREFIX_LENGTH 30 -static int gensym_counter; - SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, (SCM prefix), "Create a new symbol with a name constructed from a prefix and\n" @@ -275,6 +273,8 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, "resetting the counter.") #define FUNC_NAME s_scm_gensym { + static int gensym_counter = 0; + char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; char *name = buf; size_t len; @@ -293,7 +293,14 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, memcpy (name, SCM_STRING_CHARS (prefix), len); } { - int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); + int n, n_digits; + + /* mutex in case another thread looks and incs at the exact same moment */ + scm_mutex_lock (&scm_i_misc_mutex); + n = gensym_counter++; + scm_mutex_unlock (&scm_i_misc_mutex); + + n_digits = scm_iint2str (n, 10, &name[len]); SCM res = scm_mem2symbol (name, len + n_digits); if (name != buf) free (name); @@ -414,7 +421,6 @@ scm_symbols_prehistory () void scm_init_symbols () { - gensym_counter = 0; #include "libguile/symbols.x" } From 4af3c6f17ca4c94ac6709aa105bf35a56728485e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 31 Jul 2004 01:11:15 +0000 Subject: [PATCH 85/89] (scm_strerror): Use scm_i_misc_mutex around strerror since it's not thread safe. (scm_syserror): Use scm_strerror rather than SCM_I_STRERROR, to take advantage of this. --- libguile/error.c | 37 +++++++++++++++++++++++++++++++------ 1 file changed, 31 insertions(+), 6 deletions(-) diff --git a/libguile/error.c b/libguile/error.c index 849b0aaa6..f53b9ab4a 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -26,6 +26,7 @@ #include #include "libguile/_scm.h" +#include "libguile/dynwind.h" #include "libguile/pairs.h" #include "libguile/strings.h" #include "libguile/throw.h" @@ -142,13 +143,38 @@ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0, # define SCM_I_ERRNO() errno #endif /* __MINGW32__ */ +/* strerror may not be thread safe, for instance in glibc (version 2.3.2) an + error number not among the known values results in a string like "Unknown + error 9999" formed in a static buffer, which will be overwritten by a + similar call in another thread. A test program running two threads with + different unknown error numbers can trip this fairly quickly. + + Some systems don't do what glibc does, instead just giving a single + "Unknown error" for unrecognised numbers. It doesn't seem worth trying + to tell if that's the case, a mutex is reasonably fast, and strerror + isn't needed very often. + + strerror_r (when available) could be used, it might be a touch faster + than a frame and a mutex, though there's probably not much + difference. */ + SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0, (SCM err), "Return the Unix error message corresponding to @var{err}, which\n" "must be an integer value.") #define FUNC_NAME s_scm_strerror { - return scm_makfrom0str (SCM_I_STRERROR (scm_to_int (err))); + SCM ret; + scm_frame_begin (0); + scm_frame_unwind_handler ((void(*)(void*)) scm_mutex_unlock, + &scm_i_misc_mutex, + SCM_F_WIND_EXPLICITLY); + scm_mutex_lock (&scm_i_misc_mutex); + + ret = scm_makfrom0str (SCM_I_STRERROR (scm_to_int (err))); + + scm_frame_end (); + return ret; } #undef FUNC_NAME @@ -156,13 +182,12 @@ SCM_GLOBAL_SYMBOL (scm_system_error_key, "system-error"); void scm_syserror (const char *subr) { - int save_errno = SCM_I_ERRNO (); - + SCM err = scm_from_int (SCM_I_ERRNO ()); scm_error (scm_system_error_key, subr, "~A", - scm_cons (scm_makfrom0str (SCM_I_STRERROR (save_errno)), SCM_EOL), - scm_cons (scm_from_int (save_errno), SCM_EOL)); + scm_cons (scm_strerror (err), SCM_EOL), + scm_cons (err, SCM_EOL)); } void From fd08c23657f0e660ee29ca4ff625e1536b2e24f9 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 31 Jul 2004 01:12:24 +0000 Subject: [PATCH 86/89] * error.c (scm_strerror): Use scm_i_misc_mutex around strerror since it's not thread safe. (scm_syserror): Use scm_strerror rather than SCM_I_STRERROR, to take advantage of this. * fports.c (scm_open_file): Use scm_strerror likewise. --- libguile/fports.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/fports.c b/libguile/fports.c index 3cdf110b3..cb824db17 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -336,7 +336,7 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, int en = errno; SCM_SYSERROR_MSG ("~A: ~S", - scm_cons (scm_makfrom0str (strerror (en)), + scm_cons (scm_strerror (scm_from_int (en)), scm_cons (filename, SCM_EOL)), en); } port = scm_fdes_to_port (fdes, md, filename); From 3572cd6b8f6c6c9cc6549ab67a179563d89e2ae0 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 31 Jul 2004 01:13:29 +0000 Subject: [PATCH 87/89] * error.c (scm_strerror): Use scm_i_misc_mutex around strerror since it's not thread safe. (scm_syserror): Use scm_strerror rather than SCM_I_STRERROR, to take advantage of this. * fports.c (scm_open_file): Use scm_strerror likewise. * filesys.c (scm_stat, scm_lstat): Ditto. --- libguile/filesys.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 79cfa0131..e27bdca99 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -640,7 +640,7 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, int en = errno; SCM_SYSERROR_MSG ("~A: ~S", - scm_list_2 (scm_makfrom0str (strerror (errno)), + scm_list_2 (scm_strerror (scm_from_int (en)), object), en); } @@ -1393,7 +1393,7 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, int en = errno; SCM_SYSERROR_MSG ("~A: ~S", - scm_list_2 (scm_makfrom0str (strerror (errno)), str), + scm_list_2 (scm_strerror (scm_from_int (en)), str), en); } return scm_stat2scm(&stat_temp); From 01046395accac9b6de5930bc827d3b08a54a7842 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 31 Jul 2004 01:19:26 +0000 Subject: [PATCH 88/89] (scm_copy_file): Avoid fd leak when destination file cannot be opened. --- libguile/filesys.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index e27bdca99..fa8cd18e1 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1424,7 +1424,10 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0, newfd = open (SCM_STRING_CHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC, oldstat.st_mode & 07777); if (newfd == -1) - SCM_SYSERROR; + { + close (oldfd); + SCM_SYSERROR; + } while ((n = read (oldfd, buf, sizeof buf)) > 0) if (write (newfd, buf, n) != n) From 5e996bd608f223ce552890401f6113d6b1f0fdb1 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 31 Jul 2004 01:24:34 +0000 Subject: [PATCH 89/89] New file, exercising copy-file. --- test-suite/tests/filesys.test | 39 +++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) create mode 100644 test-suite/tests/filesys.test diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test new file mode 100644 index 000000000..8b57a9af0 --- /dev/null +++ b/test-suite/tests/filesys.test @@ -0,0 +1,39 @@ +;;;; filesys.test --- test file system functions -*- scheme -*- +;;;; +;;;; Copyright (C) 2004 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (test-suite test-filesys) + #:use-module (test-suite lib)) + +;;; +;;; copy-file +;;; + +(with-test-prefix "copy-file" + + ;; return next prospective file descriptor number + (define (next-fd) + (let ((fd (dup 0))) + (close fd) + fd)) + + ;; in guile 1.6.4 and earlier, copy-file didn't close the input fd when + ;; the output could not be opened + (pass-if "fd leak when dest unwritable" + (let ((old-next (next-fd))) + (false-if-exception (copy-file "/dev/null" "no/such/dir/foo")) + (= old-next (next-fd)))))