From a015df9b8da16f2369c574d5a4e9006eff4b022e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 9 Aug 2004 01:28:23 +0000 Subject: [PATCH 01/64] * tests/slib.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 5c5091a3b..aa26fbc06 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -57,6 +57,7 @@ SCM_TESTS = tests/alist.test \ tests/r5rs_pitfall.test \ tests/reader.test \ tests/regexp.test \ + tests/slib.test \ tests/socket.test \ tests/srcprop.test \ tests/srfi-1.test \ From abc358f9c5224b69098bcce110640c2b8d6f62cc Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 9 Aug 2004 01:29:52 +0000 Subject: [PATCH 02/64] (SLIB): Add notes on delete-file, provided? and open-file overridden by ice-9 slib module. --- doc/ref/slib.texi | 38 ++++++++++++++++++++++++++++++++++---- 1 file changed, 34 insertions(+), 4 deletions(-) diff --git a/doc/ref/slib.texi b/doc/ref/slib.texi index 1fe3847df..a719494b6 100644 --- a/doc/ref/slib.texi +++ b/doc/ref/slib.texi @@ -27,11 +27,41 @@ slib, The SLIB Manual}). For example, @result{} #t @end example +Note that the following Guile core functions are overridden by +@code{(ice-9 slib)}, to implement SLIB specified semantics. + +@table @code +@item delete-file +@findex delete-file +Returns @code{#t} for success or @code{#f} for failure +(@pxref{Input/Output,,, slib, The SLIB Manual}), as opposed to the +Guile core version unspecified for success and throwing an error for +failure (@pxref{File System}). + +@c `provide' is also exported by ice-9 slib, but its definition in +@c slib require.scm is the same as guile boot-9.scm, so believe +@c nothing needs to be said about that. + +@item provided? +@findex provided? +Accepts a feature specification containing @code{and} and @code{or} +forms combining symbols (@pxref{Feature,,, slib, The SLIB Manual}), as +opposed to the Guile core taking only plain symbols (@pxref{Feature +Manipulation}). + +@item open-file +@findex open-file +Takes a symbol @code{r}, @code{rb}, @code{w} or @code{wb} for the open +mode (@pxref{Input/Output,,, slib, The SLIB Manual}), as opposed to +the Guile core version taking a string (@pxref{File Ports}). + +@item system @findex system -Note that @code{(ice-9 slib)} provides a new definition of -@code{system}, one giving a plain exit code return value, as per the -SLIB specification (@pxref{System Interface,,, slib, The SLIB -Manual}). +Returns a plain exit code 0 to 255 (@pxref{System Interface,,, slib, +The SLIB Manual}), as opposed to the Guile core version returning a +wait status that must be examined with @code{status:exit-val} etc +(@pxref{Processes}). +@end table @menu * SLIB installation:: From c755b8615ea36d7618cd2e16a1cd5795ba94d6fb Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 9 Aug 2004 01:32:22 +0000 Subject: [PATCH 03/64] (File Ports): In open-file, describe the "b" binary flag. --- doc/ref/api-io.texi | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index f8611d4d1..1540422b8 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -684,6 +684,7 @@ representing that file. The attributes of the port are determined by the @var{mode} string. The way in which this is interpreted is similar to C stdio. The first character must be one of the following: + @table @samp @item r Open an existing file for input. @@ -696,7 +697,9 @@ exist. All writes to the port will go to the end of the file. The "append mode" can be turned off while the port is in use @pxref{Ports and File Descriptors, fcntl} @end table + The following additional characters can be appended: + @table @samp @item + Open the port for both input and output. E.g., @code{r+}: open @@ -711,7 +714,19 @@ setvbuf} @item l Add line-buffering to the port. The port output buffer will be automatically flushed whenever a newline character is written. +@item b +Use binary mode. On DOS systems the default text mode converts CR+LF +in the file to newline for the program, whereas binary mode reads and +writes all bytes unchanged. On Unix-like systems there is no such +distinction, text files already contain just newlines and no +conversion is ever made. The @code{b} flag is accepted on all +systems, but has no effect on Unix-like systems. + +(For reference, Guile leaves text versus binary up to the C library, +@code{b} here just adds @code{O_BINARY} to the underlying @code{open} +call, when that flag is available.) @end table + In theory we could create read/write ports which were buffered in one direction only. However this isn't included in the current interfaces. If a file cannot be opened with the access From 092bdcc46b30775aba7117cda0602fc6e39f0b0f Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 9 Aug 2004 01:33:03 +0000 Subject: [PATCH 04/64] In open-file, split a paragraph for clarity. --- doc/ref/api-io.texi | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 1540422b8..d5ba25b43 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -727,10 +727,12 @@ systems, but has no effect on Unix-like systems. call, when that flag is available.) @end table +If a file cannot be opened with the access +requested, @code{open-file} throws an exception. + In theory we could create read/write ports which were buffered in one direction only. However this isn't included in the -current interfaces. If a file cannot be opened with the access -requested, @code{open-file} throws an exception. +current interfaces. @end deffn @rnindex open-input-file From 636d4be53542ae29129febdbedcf02e3014f3779 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 9 Aug 2004 01:33:36 +0000 Subject: [PATCH 05/64] *** empty log message *** --- doc/ref/ChangeLog | 7 +++++++ test-suite/ChangeLog | 5 +++++ 2 files changed, 12 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 564b84906..8189d628a 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,10 @@ +2004-08-09 Kevin Ryde + + * api-io.texi (File Ports): In open-file, describe the "b" binary flag. + + * slib.texi (SLIB): Add notes on delete-file, provided? and open-file + overridden by ice-9 slib module. + 2004-08-05 Kevin Ryde * api-scheduling.texi (Arbiters): Tweak wording for clarity, note any diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 3a0041fc4..612620103 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-08-09 Kevin Ryde + + * tests/slib.test: New file. + * Makefile.am (SCM_TESTS): Add it. + 2004-08-06 Kevin Ryde * tests/unif.test (array-set!): Exercise byte array range checks. From 2d51a8a1654c6c7686ef5d56c48b0525a69aa330 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 9 Aug 2004 21:56:00 +0000 Subject: [PATCH 06/64] (generic-write): In the local procedure `wr', use object->string to print all data (except for the reader macros), rather than implementing an own printer. The user-visible difference is that procedures and control characters like #\tab are now printed in the same way as by `write'. --- ice-9/pretty-print.scm | 53 +++++------------------------------------- 1 file changed, 6 insertions(+), 47 deletions(-) diff --git a/ice-9/pretty-print.scm b/ice-9/pretty-print.scm index c478c1525..ac6054a44 100644 --- a/ice-9/pretty-print.scm +++ b/ice-9/pretty-print.scm @@ -53,53 +53,12 @@ (and col (output str) (+ col (string-length str)))) (define (wr obj col) - - (define (wr-expr expr col) - (if (read-macro? expr) - (wr (read-macro-body expr) (out (read-macro-prefix expr) col)) - (wr-lst expr col))) - - (define (wr-lst l col) - (if (pair? l) - (let loop ((l (cdr l)) - (col (and col (wr (car l) (out "(" col))))) - (cond ((not col) col) - ((pair? l) - (loop (cdr l) (wr (car l) (out " " col)))) - ((null? l) (out ")" col)) - (else (out ")" (wr l (out " . " col)))))) - (out "()" col))) - - (cond ((pair? obj) (wr-expr obj col)) - ((null? obj) (wr-lst obj col)) - ((vector? obj) (wr-lst (vector->list obj) (out "#" col))) - ((boolean? obj) (out (if obj "#t" "#f") col)) - ((number? obj) (out (number->string obj) col)) - ((symbol? obj) (out (symbol->string obj) col)) - ((procedure? obj) (out "#[procedure]" col)) - ((string? obj) (if display? - (out obj col) - (let loop ((i 0) (j 0) (col (out "\"" col))) - (if (and col (< j (string-length obj))) - (let ((c (string-ref obj j))) - (if (or (char=? c #\\) - (char=? c #\")) - (loop j - (+ j 1) - (out "\\" - (out (substring obj i j) - col))) - (loop i (+ j 1) col))) - (out "\"" - (out (substring obj i j) col)))))) - ((char? obj) (if display? - (out (make-string 1 obj) col) - (out (case obj - ((#\space) "space") - ((#\newline) "newline") - (else (make-string 1 obj))) - (out "#\\" col)))) - (else (out (object->string obj) col)))) + (cond ((and (pair? obj) + (read-macro? obj)) + (wr (read-macro-body obj) + (out (read-macro-prefix obj) col))) + (else + (out (object->string obj (if display? display write)) col)))) (define (pp obj col) From d2afa1fc9f903ec601ae6470865e9ef3de605ae1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 9 Aug 2004 21:56:19 +0000 Subject: [PATCH 07/64] *** empty log message *** --- ice-9/ChangeLog | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 6eb890c5c..b67ababe3 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,13 @@ +2004-08-09 Marius Vollmer + + From Matthias Koeppe. Thanks! + + * pretty-print.scm (generic-write): In the local procedure `wr', use + object->string to print all data (except for the reader macros), + rather than implementing an own printer. The user-visible + difference is that procedures and control characters like #\tab + are now printed in the same way as by `write'. + 2004-08-09 Kevin Ryde * slib.scm (*features*): Remove array and array-for-each, core From 565b4a6f318f05d03bcd13828fe37b7178ed9a7c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 9 Aug 2004 21:58:14 +0000 Subject: [PATCH 08/64] Removed caveat that pretty-print uses its own 'write' implementation. --- doc/ref/misc-modules.texi | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index 963aa8980..8898509ab 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -59,25 +59,6 @@ Print within the given @var{columns}. The default is 79. @end table @end deffn -Beware: Since @code{pretty-print} uses it's own write procedure, it's -output will not be the same as for example the output of @code{write}. -Consider the following example. - -@lisp -(write (lambda (x) x)) -@print{} -# - -(pretty-print (lambda (x) x)) -@print{} -#[procedure] -@end lisp - -The reason is that @code{pretty-print} does not know as much about -Guile's object types as the builtin procedures. This is particularly -important for smobs, for which a write procedure can be defined and be -used by @code{write}, but not by @code{pretty-print}. - @page @node Formatted Output From 3101f40f7634b0262f1e936dc3df06ab89aacd15 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 9 Aug 2004 23:32:14 +0000 Subject: [PATCH 09/64] (scm_round, scm_truncate): Renamed to scm_c_round and scm_c_truncate; deprecated versions installed in deprecated.h and deprecated.c. Changed all uses. --- libguile/deprecated.c | 18 +++++++++++++++++- libguile/deprecated.h | 6 ++++++ libguile/numbers.c | 23 +++++++++-------------- libguile/numbers.h | 4 ++-- 4 files changed, 34 insertions(+), 17 deletions(-) diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 18173bfc7..846dc7cc2 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -2,7 +2,7 @@ deprecate something, move it here when that is feasible. */ -/* Copyright (C) 2003 Free Software Foundation, Inc. +/* Copyright (C) 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 @@ -1129,6 +1129,22 @@ SCM_INUM (SCM obj) return scm_to_intmax (obj); } +double +scm_truncate (double x) +{ + scm_c_issue_deprecation_warning + ("scm_truncate is deprecated. Use scm_c_truncate instead."); + return scm_c_truncate (x); +} + +double +scm_round (double x) +{ + scm_c_issue_deprecation_warning + ("scm_round is deprecated. Use scm_c_round instead."); + return scm_c_round (x); +} + void scm_i_init_deprecated () { diff --git a/libguile/deprecated.h b/libguile/deprecated.h index e91f22a8f..f9f500e6f 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -382,6 +382,12 @@ SCM_API scm_t_signed_bits SCM_INUM (SCM obj); } while (0) +/* Deprecated because the names belong to what is now + scm_truncate_number and scm_round_number. +*/ +SCM_API double scm_truncate (double x); +SCM_API double scm_round (double x); + void scm_i_init_deprecated (void); #endif diff --git a/libguile/numbers.c b/libguile/numbers.c index 3e8e5e630..c0e7d58dc 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4895,13 +4895,8 @@ SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) atanh, g_atanh); */ -/* XXX - eventually, we should remove this definition of scm_round and - rename scm_round_number to scm_round. Likewise for scm_truncate - and scm_truncate_number. - */ - double -scm_truncate (double x) +scm_c_truncate (double x) { #if HAVE_TRUNC return trunc (x); @@ -4912,10 +4907,10 @@ scm_truncate (double x) #endif } -/* scm_round is done using floor(x+0.5) to round to nearest and with - half-way case (ie. when x is an integer plus 0.5) going upwards. Then - half-way cases are identified and adjusted down if the round-upwards - didn't give the desired even integer. +/* scm_c_round is done using floor(x+0.5) to round to nearest and with + half-way case (ie. when x is an integer plus 0.5) going upwards. + Then half-way cases are identified and adjusted down if the + round-upwards didn't give the desired even integer. "plus_half == result" identifies a half-way case. If plus_half, which is x + 0.5, is an integer then x must be an integer plus 0.5. @@ -4939,7 +4934,7 @@ scm_truncate (double x) an 0.5 to be represented, and hence added without a bad rounding. */ double -scm_round (double x) +scm_c_round (double x) { double plus_half, result; @@ -4948,7 +4943,7 @@ scm_round (double x) plus_half = x + 0.5; result = floor (plus_half); - /* Adjust so that the scm_round is towards even. */ + /* Adjust so that the rounding is towards even. */ return ((plus_half == result && plus_half / 2 != floor (plus_half / 2)) ? result - 1 : result); @@ -4978,7 +4973,7 @@ SCM_DEFINE (scm_round_number, "round", 1, 0, 0, if (SCM_I_INUMP (x) || SCM_BIGP (x)) return x; else if (SCM_REALP (x)) - return scm_from_double (scm_round (SCM_REAL_VALUE (x))); + return scm_from_double (scm_c_round (SCM_REAL_VALUE (x))); else { /* OPTIMIZE-ME: Fraction case could be done more efficiently by a @@ -4986,7 +4981,7 @@ SCM_DEFINE (scm_round_number, "round", 1, 0, 0, the rounding should go. */ SCM plus_half = scm_sum (x, exactly_one_half); SCM result = scm_floor (plus_half); - /* Adjust so that the scm_round is towards even. */ + /* Adjust so that the rounding is towards even. */ if (scm_is_true (scm_num_eq_p (plus_half, result)) && scm_is_true (scm_odd_p (result))) return scm_difference (result, SCM_I_MAKINUM (1)); diff --git a/libguile/numbers.h b/libguile/numbers.h index dc1f4c2b8..4e39a2cc1 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -241,8 +241,8 @@ SCM_API SCM scm_ceiling (SCM x); SCM_API double scm_asinh (double x); SCM_API double scm_acosh (double x); SCM_API double scm_atanh (double x); -SCM_API double scm_truncate (double x); -SCM_API double scm_round (double x); +SCM_API double scm_c_truncate (double x); +SCM_API double scm_c_round (double x); SCM_API SCM scm_truncate_number (SCM x); SCM_API SCM scm_round_number (SCM x); SCM_API SCM scm_sys_expt (SCM z1, SCM z2); From 409eb4e54f4b4f03f626f281276ad4db3b57eb1e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 9 Aug 2004 23:33:27 +0000 Subject: [PATCH 10/64] *** empty log message *** --- NEWS | 6 ++++++ libguile/ChangeLog | 7 +++++++ 2 files changed, 13 insertions(+) diff --git a/NEWS b/NEWS index c7c912650..4f8f9a901 100644 --- a/NEWS +++ b/NEWS @@ -681,6 +681,12 @@ code. Use scm_is_eq for new code, which fits better into the naming conventions. +** The functions scm_round and scm_truncate have been deprecated and + are now available as scm_c_round and scm_c_truncate, respectively. + +These functions occupy the names that scm_round_number and +scm_truncate_number should have. + ** SCM_CELL_WORD_LOC has been deprecated. Use the new macro SCM_CELL_OBJECT_LOC instead, which return a pointer diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 36950c48f..db8c9af2b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2004-08-10 Marius Vollmer + + * numbers.h, number.c, deprecated.h, deprecated.c (scm_round, + scm_truncate): Renamed to scm_c_round and scm_c_truncate; + deprecated versions installed in deprecated.h and deprecated.c. + Changed all uses. + 2004-08-06 Rob Browning * net_db.c (scm_resolv_error): don't cause an exception while From c065f326149f5269fd88043aa479ba492c7cf5ea Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 10 Aug 2004 00:52:50 +0000 Subject: [PATCH 11/64] More of: New file. --- test-suite/tests/slib.test | 281 +++++++++++++++++++++++++++++-------- 1 file changed, 223 insertions(+), 58 deletions(-) diff --git a/test-suite/tests/slib.test b/test-suite/tests/slib.test index 274ca1573..6ade45339 100644 --- a/test-suite/tests/slib.test +++ b/test-suite/tests/slib.test @@ -26,60 +26,211 @@ (begin (define-module (test-suite test-ice-9-slib) - #:duplicates (last) ;; avoid warnings about various replacements #:use-module (test-suite lib) #:use-module (ice-9 slib)) - ;; - ;; delete-file - ;; - ;; in guile 1.6.4 and earlier delete-file didn't match the slib spec - (with-test-prefix "delete-file" - (pass-if "non existant file" - (eq? #f (delete-file "nosuchfile"))) - (pass-if "existing file" - (call-with-output-file "slibtest.tmp" noop) - (eq? #t (delete-file "slibtest.tmp")))) + (with-test-prefix "Configuration" - ;; - ;; browse-url - ;; + ;; + ;; char-code-limit + ;; - (with-test-prefix "browse-url" - (pass-if (procedure? browse-url))) + (with-test-prefix "char-code-limit" + (pass-if "integer" (integer? char-code-limit))) - ;; - ;; call-with-open-ports - ;; + ;; + ;; most-positive-fixnum + ;; - (with-test-prefix "call-with-open-ports" - (pass-if (procedure? call-with-open-ports)) - - (pass-if "close on return" - (let ((port (open-input-file "/dev/null"))) - (call-with-open-ports port (lambda (port) #f)) - (port-closed? port)))) + (with-test-prefix "most-positive-fixnum" + (pass-if "integer" (integer? most-positive-fixnum))) - ;; - ;; nil - ;; + ;; + ;; slib:form-feed + ;; - ;; in guile 1.6.4 and earlier this was missing - (with-test-prefix "nil" - (pass-if (eq? #f nil))) + (with-test-prefix "slib:form-feed" + ;; in guile 1.6.4 this wasn't exported + (pass-if "char" (char? slib:form-feed))) - ;; - ;; open-file - ;; + ;; + ;; slib:report + ;; + + (with-test-prefix "slib:report" + (pass-if "exists" (procedure? slib:report))) + + ;; + ;; slib:report-version + ;; + + (with-test-prefix "slib:report-version" + (pass-if "exists" (procedure? slib:report-version))) + + ;; + ;; slib:tab + ;; + + (with-test-prefix "slib:tab" + ;; in guile 1.6.4 this wasn't exported + (pass-if "char" (char? slib:tab))) + + ;; + ;; software-type + ;; + + (with-test-prefix "software-type" + (pass-if "exists" (procedure? software-type)))) + + + (with-test-prefix "Input/Output" + + ;; + ;; call-with-open-ports + ;; + + (with-test-prefix "call-with-open-ports" + (pass-if "exists" (procedure? call-with-open-ports)) + + (pass-if "close on return" + (let ((port (open-input-file "/dev/null"))) + (call-with-open-ports port (lambda (port) #f)) + (port-closed? port)))) + + ;; + ;; delete-file + ;; + + ;; in guile 1.6.4 and earlier delete-file didn't match the slib spec + (with-test-prefix "delete-file" + (pass-if "non existant file" + (eq? #f (delete-file "nosuchfile"))) + (pass-if "existing file" + (call-with-output-file "slibtest.tmp" noop) + (eq? #t (delete-file "slibtest.tmp")))) + + ;; + ;; output-port-height + ;; + + (with-test-prefix "output-port-height" + ;; in guile 1.6.4 this wasn't exported + (pass-if "exists" (procedure? output-port-height))) + + ;; + ;; output-port-width + ;; + + (with-test-prefix "output-port-width" + ;; in guile 1.6.4 this wasn't exported + (pass-if "exists" (procedure? output-port-width))) + + ;; + ;; open-file + ;; + + ;; this style open-file is only a requirement in slib 3a1 and up, but + ;; we provide it always + (with-test-prefix "open-file" + (pass-if "r" (port? (open-file "/dev/null" 'r))) + (pass-if "rb" (port? (open-file "/dev/null" 'rb))) + (pass-if "w" (port? (open-file "/dev/null" 'w))) + (pass-if "wb" (port? (open-file "/dev/null" 'wb))))) + + + (with-test-prefix "System stuff" + + ;; + ;; browse-url + ;; + + (with-test-prefix "browse-url" + (pass-if "exists" (procedure? browse-url))) + + ;; + ;; slib:error + ;; + + (with-test-prefix "slib:error" + ;; in guile 1.6.4 this wasn't exported + (pass-if "exists" (procedure? slib:error))) + + ;; + ;; slib:eval + ;; + + (with-test-prefix "slib:eval" + ;; in guile 1.6.4 this wasn't exported + (pass-if "exists" (procedure? slib:eval))) + + ;; + ;; slib:eval-load + ;; + + (with-test-prefix "slib:eval-load" + ;; in guile 1.6.4 this wasn't exported + (pass-if "exists" (procedure? slib:eval-load))) + + ;; + ;; slib:exit + ;; + + (with-test-prefix "slib:exit" + ;; in guile 1.6.4 this wasn't exported + (pass-if "exists" (procedure? slib:exit))) + + ;; + ;; slib:load + ;; + + (with-test-prefix "slib:load" + (pass-if "exists" (procedure? slib:load))) + + ;; + ;; slib:load-source + ;; + + (with-test-prefix "slib:load-source" + ;; in guile 1.6.4 this wasn't exported + (pass-if "exists" (procedure? slib:load-source))) + + ;; + ;; slib:warn + ;; + + (with-test-prefix "slib:warn" + ;; in guile 1.6.4 this wasn't exported + (pass-if "exists" (procedure? slib:warn)))) + + + (with-test-prefix "Miscellany" + + ;; + ;; identity + ;; + + (with-test-prefix "identity" + (pass-if "exists" (procedure? identity))) + + (with-test-prefix "Legacy" + + ;; + ;; nil + ;; + + ;; in guile 1.6.4 and earlier this was missing + (with-test-prefix "nil" + (pass-if "value" (eq? #f nil))) + + ;; + ;; t + ;; + + ;; in guile 1.6.4 and earlier this was missing + (with-test-prefix "t" + (pass-if "value" (eq? #t t))))) - ;; this style open-file is only a requirement in slib 3a1 and up, but - ;; we provide it always - (with-test-prefix "open-file" - (pass-if (port? (open-file "/dev/null" 'r))) - (pass-if (port? (open-file "/dev/null" 'rb))) - (pass-if (port? (open-file "/dev/null" 'w))) - (pass-if (port? (open-file "/dev/null" 'wb)))) ;; ;; rev2-procedures @@ -89,12 +240,13 @@ ;; these existed, but they didn't (with-test-prefix "rev2-procedures" (require 'rev2-procedures) - (pass-if (procedure? -1+)) - (pass-if (procedure? ?)) - (pass-if (procedure? >=?))) + (pass-if "-1+" (procedure? -1+)) + (pass-if "?" (procedure? >?)) + (pass-if ">=?" (procedure? >=?))) + ;; ;; system @@ -102,17 +254,29 @@ ;; in guile 1.6.4 and earlier system didn't match the slib spec (with-test-prefix "system" - (pass-if (= 0 (system "exit 0"))) - (pass-if (= 1 (system "exit 1"))) - (pass-if (= 99 (system "exit 99")))) + (pass-if "exit 0" (= 0 (system "exit 0"))) + (pass-if "exit 1" (= 1 (system "exit 1"))) + (pass-if "exit 99" (= 99 (system "exit 99")))) - ;; - ;; t - ;; - ;; in guile 1.6.4 and earlier this was missing - (with-test-prefix "t" - (pass-if (eq? #t t))) + (with-test-prefix "Time" + + ;; + ;; difftime + ;; + + (with-test-prefix "difftime" + ;; in guile 1.6.4 this wasn't exported + (pass-if "exists" (procedure? difftime))) + + ;; + ;; offset-time + ;; + + (with-test-prefix "offset-time" + ;; in guile 1.6.4 this wasn't exported + (pass-if "exists" (procedure? offset-time)))) + (require 'array) (with-test-prefix "array" @@ -124,4 +288,5 @@ ;; create-array isn't in old slib, but when it exists it should work (if (defined? 'create-array) (with-test-prefix "create-array" - (pass-if (array? (create-array (As32 0) '(0 1))))))))) + (pass-if "As32 create" + (array? (create-array (As32 0) '(0 1))))))))) From ee3e40b78ef9ce28faa04b5eaf6e5ded622104d6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 12:19:49 +0000 Subject: [PATCH 12/64] Replaced all uses of scm_round with scm_c_round. --- test-suite/standalone/test-round.c | 40 +++++++++++++++--------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/test-suite/standalone/test-round.c b/test-suite/standalone/test-round.c index 3cab0600e..b6bf00786 100644 --- a/test-suite/standalone/test-round.c +++ b/test-suite/standalone/test-round.c @@ -31,7 +31,7 @@ #define numberof(x) (sizeof (x) / sizeof ((x)[0])) static void -test_scm_round () +test_scm_c_round () { /* FE constants are defined only where supported, in particular for instance some ARM systems have been seen with only a couple of modes */ @@ -66,50 +66,50 @@ test_scm_round () #endif } - assert (scm_round (0.0) == 0.0); - assert (scm_round (1.0) == 1.0); - assert (scm_round (-1.0) == -1.0); + assert (scm_c_round (0.0) == 0.0); + assert (scm_c_round (1.0) == 1.0); + assert (scm_c_round (-1.0) == -1.0); - assert (scm_round (0.5) == 0.0); - assert (scm_round (1.5) == 2.0); - assert (scm_round (-1.5) == -2.0); - assert (scm_round (2.5) == 2.0); - assert (scm_round (-2.5) == -2.0); - assert (scm_round (3.5) == 4.0); - assert (scm_round (-3.5) == -4.0); + assert (scm_c_round (0.5) == 0.0); + assert (scm_c_round (1.5) == 2.0); + assert (scm_c_round (-1.5) == -2.0); + assert (scm_c_round (2.5) == 2.0); + assert (scm_c_round (-2.5) == -2.0); + assert (scm_c_round (3.5) == 4.0); + assert (scm_c_round (-3.5) == -4.0); /* 2^(DBL_MANT_DIG-1)-1+0.5 */ x = ldexp (1.0, DBL_MANT_DIG - 1) - 1.0 + 0.5; want = ldexp (1.0, DBL_MANT_DIG - 1); - assert (scm_round (x) == want); + assert (scm_c_round (x) == want); /* -(2^(DBL_MANT_DIG-1)-1+0.5) */ x = - (ldexp (1.0, DBL_MANT_DIG - 1) - 1.0 + 0.5); want = - ldexp (1.0, DBL_MANT_DIG - 1); - assert (scm_round (x) == want); + assert (scm_c_round (x) == want); /* 2^DBL_MANT_DIG-1 - In the past scm_round had incorrectly incremented this value, due + In the past scm_c_round had incorrectly incremented this value, due to the way that x+0.5 would round upwards (in the usual default nearest-even mode on most systems). */ x = ldexp (1.0, DBL_MANT_DIG) - 1.0; assert (x == floor (x)); /* should be an integer already */ - assert (scm_round (x) == x); /* scm_round should return it unchanged */ + assert (scm_c_round (x) == x); /* scm_c_round should return it unchanged */ /* -(2^DBL_MANT_DIG-1) */ x = - (ldexp (1.0, DBL_MANT_DIG) - 1.0); assert (x == floor (x)); /* should be an integer already */ - assert (scm_round (x) == x); /* scm_round should return it unchanged */ + assert (scm_c_round (x) == x); /* scm_c_round should return it unchanged */ /* 2^64 */ x = ldexp (1.0, 64); - assert (scm_round (x) == x); + assert (scm_c_round (x) == x); /* -2^64 - In the past scm_round had incorrectely gone to the next highest + In the past scm_c_round had incorrectely gone to the next highest representable value in FE_UPWARD, due to x+0.5 rounding. */ x = - ldexp (1.0, 64); - assert (scm_round (x) == x); + assert (scm_c_round (x) == x); } } @@ -117,6 +117,6 @@ int main (int argc, char *argv[]) { scm_init_guile(); - test_scm_round (); + test_scm_c_round (); return 0; } From 8d3fd10b91080f629c822c843bc87eca72b31dbc Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 12:20:02 +0000 Subject: [PATCH 13/64] *** empty log message *** --- test-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 612620103..ceb5a0b2d 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-08-10 Marius Vollmer + + * standalone/test-round.c: Replaced all uses of scm_round with + scm_c_round. + 2004-08-09 Kevin Ryde * tests/slib.test: New file. From c829a4274f35bae62cae06312335a0596504a333 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 13:20:59 +0000 Subject: [PATCH 14/64] * strings.h, deprecated.h (SCM_STRING_COERCE_0TERMINATION_X): Moved from string.h to deprecated.h. * deprecated.c, deprecated.h (SCM_CHARS, SCM_LENGTH): Removed. * strings.h, strings.c (SCM_MAKE_STRING_TAG): Rename dto SCM_I_MAKE_STRING_TAG, changed all uses. (SCM_STRING_CHARS, SCM_STRING_UCHARS, SCM_STRING_LENGTH): Renamed to SCM_I_STRING_CHARS, SCM_I_STRING_UCHARS, and SCM_I_LENGTH respectively. For a short time, the old names are still there as aliases. Not all uses have been changed yet, but the ones in strings.c have. (SCM_STRING_MAX_LEN): Do not hardcode to 24 bits, compute from SCM_T_BITS_MAX. (scm_is_string, scm_from_locale_string, scm_from_locale_stringn, scm_take_locale_string, scm_take_locale_stringn, scm_to_locale_string, scm_to_locale_stringn, scm_to_locale_stringbuf): New. (scm_c_string2str, scm_c_substring2str): Deprecated by moving to deprecated.[hc]. Implemented in terms of the new functions above. (scm_take_str, scm_take0str, scm_mem2string, scm_str2string, scm_makfrom0str): Reimplemented in terms of the new functions from above. They will be discouraged shortly. (scm_substring): Do not use scm_mem2string. (scm_i_allocate_string_pointers, scm_i_free_string_pointers): New, to replace similar code from posix.c, simpos.c, and dynl.c. (scm_string_append): Use memcpy instead of explicit loop. Do not use register keyword. Use plain 'char' instead of 'unsigned char'. --- libguile/deprecated.c | 73 +++++++----- libguile/deprecated.h | 40 +++++-- libguile/strings.c | 255 ++++++++++++++++++++++++++++-------------- libguile/strings.h | 58 ++++++---- 4 files changed, 278 insertions(+), 148 deletions(-) diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 846dc7cc2..99b6e70cd 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -649,33 +649,6 @@ scm_strprint_obj (SCM obj) return scm_object_to_string (obj, SCM_UNDEFINED); } -char * -scm_i_object_chars (SCM obj) -{ - scm_c_issue_deprecation_warning - ("SCM_CHARS is deprecated. Use SCM_STRING_CHARS or " - "SCM_SYMBOL_CHARS instead."); - if (SCM_STRINGP (obj)) - return SCM_STRING_CHARS (obj); - if (SCM_SYMBOLP (obj)) - return SCM_SYMBOL_CHARS (obj); - abort (); -} - -long -scm_i_object_length (SCM obj) -{ - scm_c_issue_deprecation_warning - ("SCM_LENGTH is deprecated. Use SCM_STRING_LENGTH instead, for example."); - if (SCM_STRINGP (obj)) - return SCM_STRING_LENGTH (obj); - if (SCM_SYMBOLP (obj)) - return SCM_SYMBOL_LENGTH (obj); - if (SCM_VECTORP (obj)) - return SCM_VECTOR_LENGTH (obj); - abort (); -} - SCM scm_sym2ovcell_soft (SCM sym, SCM obarray) { @@ -841,8 +814,8 @@ SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, else if (scm_is_eq (o, SCM_BOOL_T)) o = SCM_BOOL_F; - vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), - SCM_STRING_LENGTH (s), + vcell = scm_intern_obarray_soft (SCM_I_STRING_CHARS(s), + SCM_I_STRING_LENGTH (s), o, softness); if (scm_is_false (vcell)) @@ -1074,10 +1047,10 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, else { SCM_VALIDATE_STRING (1, prefix); - len = SCM_STRING_LENGTH (prefix); + len = SCM_I_STRING_LENGTH (prefix); if (len > MAX_PREFIX_LENGTH) name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); - strncpy (name, SCM_STRING_CHARS (prefix), len); + strncpy (name, SCM_I_STRING_CHARS (prefix), len); } if (SCM_UNBNDP (obarray)) @@ -1129,6 +1102,44 @@ SCM_INUM (SCM obj) return scm_to_intmax (obj); } +char * +scm_c_string2str (SCM obj, char *str, size_t *lenp) +{ + scm_c_issue_deprecation_warning + ("scm_c_string2str is deprecated. Use scm_to_locale_stringbuf or similar instead."); + + if (str == NULL) + { + char *result = scm_to_locale_string (obj); + if (lenp) + *lenp = SCM_I_STRING_LENGTH (obj); + return result; + } + else + { + /* Pray that STR is large enough. + */ + size_t len = scm_to_locale_stringbuf (obj, str, SCM_I_SIZE_MAX); + str[len] = '\0'; + if (lenp) + *lenp = len; + return str; + } +} + +char * +scm_c_substring2str (SCM obj, char *str, size_t start, size_t len) +{ + scm_c_issue_deprecation_warning + ("scm_c_substring2str is deprecated. Use scm_substring plus scm_to_locale_stringbuf instead."); + + if (start) + obj = scm_substring (obj, scm_from_size_t (start), SCM_UNDEFINED); + + scm_to_locale_stringbuf (obj, str, len); + return str; +} + double scm_truncate (double x) { diff --git a/libguile/deprecated.h b/libguile/deprecated.h index f9f500e6f..4336dd472 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -226,15 +226,6 @@ SCM_API SCM scm_strprint_obj (SCM obj); SCM_API SCM scm_read_0str (char *expr); SCM_API SCM scm_eval_0str (const char *expr); -SCM_API char *scm_i_object_chars (SCM); - -#define SCM_CHARS(x) scm_i_object_chars(x) -#define SCM_UCHARS(x) ((unsigned char *)SCM_CHARS(x)) - -SCM_API long scm_i_object_length (SCM); - -#define SCM_LENGTH(x) scm_i_object_length(x) - #define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n)) SCM_API SCM scm_sym2ovcell_soft (SCM sym, SCM obarray); @@ -381,6 +372,37 @@ SCM_API scm_t_signed_bits SCM_INUM (SCM obj); cvar = SCM_INUM (k); \ } while (0) +#define SCM_STRING_COERCE_0TERMINATION_X(x) (x) + +/* XXX - buggy interface, STR might not be large enough. + + Converts the given Scheme string OBJ into a C string, containing a copy + of OBJ's content with a trailing null byte. If LENP is non-NULL, set + *LENP to the string's length. + + When STR is non-NULL it receives the copy and is returned by the function, + otherwise new memory is allocated and the caller is responsible for + freeing it via free(). If out of memory, NULL is returned. + + Note that Scheme strings may contain arbitrary data, including null + characters. This means that null termination is not a reliable way to + determine the length of the returned value. However, the function always + copies the complete contents of OBJ, and sets *LENP to the length of the + scheme string (if LENP is non-null). +*/ +SCM_API char *scm_c_string2str (SCM obj, char *str, size_t *lenp); + +/* XXX - buggy interface, you don't know how many bytes have been copied. + + Copy LEN characters at START from the Scheme string OBJ to memory + at STR. START is an index into OBJ; zero means the beginning of + the string. STR has already been allocated by the caller. + + If START + LEN is off the end of OBJ, silently truncate the source + region to fit the string. If truncation occurs, the corresponding + area of STR is left unchanged. +*/ +SCM_API char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len); /* Deprecated because the names belong to what is now scm_truncate_number and scm_round_number. diff --git a/libguile/strings.c b/libguile/strings.c index 9c45d7396..1308753aa 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -26,6 +26,7 @@ #include "libguile/strings.h" #include "libguile/deprecation.h" #include "libguile/validate.h" +#include "libguile/dynwind.h" @@ -37,7 +38,7 @@ SCM_DEFINE (scm_string_p, "string?", 1, 0, 0, "Return @code{#t} if @var{obj} is a string, else @code{#f}.") #define FUNC_NAME s_scm_string_p { - return scm_from_bool (SCM_STRINGP (obj)); + return scm_from_bool (SCM_I_STRINGP (obj)); } #undef FUNC_NAME @@ -61,7 +62,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, } { - unsigned char *data = SCM_STRING_UCHARS (result); + unsigned char *data = SCM_I_STRING_UCHARS (result); while (!SCM_NULLP (chrs)) { @@ -108,7 +109,7 @@ scm_take_str (char *s, size_t len) SCM_ASSERT_RANGE (2, scm_from_ulong (len), len <= SCM_STRING_MAX_LENGTH); - answer = scm_cell (SCM_MAKE_STRING_TAG (len), (scm_t_bits) s); + answer = scm_cell (SCM_I_MAKE_STRING_TAG (len), (scm_t_bits) s); scm_gc_register_collectable_memory (s, len+1, "string"); return answer; @@ -120,24 +121,21 @@ scm_take_str (char *s, size_t len) SCM scm_take0str (char *s) { - return scm_take_str (s, strlen (s)); + return scm_take_locale_string (s); } SCM scm_mem2string (const char *src, size_t len) { - SCM s = scm_allocate_string (len); - char *dst = SCM_STRING_CHARS (s); - memcpy (dst, src, len); - return s; + return scm_from_locale_stringn (src, len); } SCM scm_str2string (const char *src) { - return scm_mem2string (src, strlen (src)); + return scm_from_locale_string (src); } @@ -145,7 +143,7 @@ SCM scm_makfrom0str (const char *src) { if (!src) return SCM_BOOL_F; - return scm_mem2string (src, strlen (src)); + return scm_from_locale_string (src); } @@ -168,7 +166,7 @@ scm_allocate_string (size_t len) mem = (char *) scm_gc_malloc (len + 1, "string"); mem[len] = 0; - s = scm_cell (SCM_MAKE_STRING_TAG (len), (scm_t_bits) mem); + s = scm_cell (SCM_I_MAKE_STRING_TAG (len), (scm_t_bits) mem); return s; } @@ -192,7 +190,7 @@ SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, SCM_VALIDATE_CHAR (2, chr); - dst = SCM_STRING_UCHARS (res); + dst = SCM_I_STRING_UCHARS (res); memset (dst, SCM_CHAR (chr), i); } @@ -207,7 +205,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_from_size_t (SCM_STRING_LENGTH (string)); + return scm_from_size_t (SCM_I_STRING_LENGTH (string)); } #undef FUNC_NAME @@ -220,8 +218,8 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, unsigned long idx; SCM_VALIDATE_STRING (1, str); - idx = scm_to_unsigned_integer (k, 0, SCM_STRING_LENGTH(str)-1); - return SCM_MAKE_CHAR (SCM_STRING_UCHARS (str)[idx]); + idx = scm_to_unsigned_integer (k, 0, SCM_I_STRING_LENGTH(str)-1); + return SCM_MAKE_CHAR (SCM_I_STRING_UCHARS (str)[idx]); } #undef FUNC_NAME @@ -236,9 +234,9 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, unsigned long idx; SCM_VALIDATE_STRING (1, str); - idx = scm_to_unsigned_integer (k, 0, SCM_STRING_LENGTH(str)-1); + idx = scm_to_unsigned_integer (k, 0, SCM_I_STRING_LENGTH(str)-1); SCM_VALIDATE_CHAR (3, chr); - SCM_STRING_UCHARS (str)[idx] = SCM_CHAR (chr); + SCM_I_STRING_UCHARS (str)[idx] = SCM_CHAR (chr); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -259,12 +257,14 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, SCM substr; SCM_VALIDATE_STRING (1, str); - from = scm_to_unsigned_integer (start, 0, SCM_STRING_LENGTH(str)); + from = scm_to_unsigned_integer (start, 0, SCM_I_STRING_LENGTH(str)); if (SCM_UNBNDP (end)) - to = SCM_STRING_LENGTH(str); + to = SCM_I_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); + to = scm_to_unsigned_integer (end, from, SCM_I_STRING_LENGTH(str)); + substr = scm_allocate_string (to - from); + memcpy (SCM_I_STRING_CHARS (substr), SCM_I_STRING_CHARS (str) + from, + to - from); scm_remember_upto_here_1 (str); return substr; } @@ -279,91 +279,178 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, { SCM res; size_t i = 0; - register SCM l, s; - register unsigned char *data; + SCM l, s; + char *data; SCM_VALIDATE_REST_ARGUMENT (args); - for (l = args; !SCM_NULLP (l); l = SCM_CDR (l)) { - s = SCM_CAR (l); - SCM_VALIDATE_STRING (SCM_ARGn, s); - i += SCM_STRING_LENGTH (s); - } + for (l = args; !SCM_NULLP (l); l = SCM_CDR (l)) + { + s = SCM_CAR (l); + SCM_VALIDATE_STRING (SCM_ARGn, s); + i += SCM_I_STRING_LENGTH (s); + } res = scm_allocate_string (i); - data = SCM_STRING_UCHARS (res); - for (l = args; !SCM_NULLP (l);l = SCM_CDR (l)) { - s = SCM_CAR (l); - for (i = 0;i SCM_STRING_MAX_LENGTH) + { + free (str); + scm_out_of_range (NULL, scm_from_size_t (len)); } - memcpy (str, SCM_STRING_CHARS (obj), len); - scm_remember_upto_here_1 (obj); - str[len] = '\0'; + res = scm_cell (SCM_I_MAKE_STRING_TAG (len), (scm_t_bits) str); + scm_gc_register_collectable_memory (str, len+1, "string"); - if (lenp != NULL) + return res; +} + +char * +scm_to_locale_stringn (SCM str, size_t *lenp) +{ + char *res; + size_t len; + + if (!SCM_I_STRINGP (str)) + scm_wrong_type_arg_msg (NULL, 0, str, "string"); + len = SCM_I_STRING_LENGTH (str); + res = scm_malloc (len + ((lenp==NULL)? 1 : 0)); + memcpy (res, SCM_I_STRING_CHARS (str), len); + if (lenp == NULL) + { + res[len] = '\0'; + if (strlen (res) != len) + { + free (res); + scm_misc_error (NULL, + "string contains #\\nul character: ~S", + scm_list_1 (str)); + } + } + else *lenp = len; - return str; + scm_remember_upto_here_1 (str); + return res; } -#undef FUNC_NAME - -/* Copy LEN characters at START from the Scheme string OBJ to memory - at STR. START is an index into OBJ; zero means the beginning of - the string. STR has already been allocated by the caller. - - If START + LEN is off the end of OBJ, silently truncate the source - region to fit the string. If truncation occurs, the corresponding - area of STR is left unchanged. */ -#define FUNC_NAME "scm_c_substring2str" char * -scm_c_substring2str (SCM obj, char *str, size_t start, size_t len) +scm_to_locale_string (SCM str) { - size_t src_length, effective_length; - - SCM_ASSERT (SCM_STRINGP (obj), obj, SCM_ARG2, FUNC_NAME); - src_length = SCM_STRING_LENGTH (obj); - effective_length = (len + start <= src_length) ? len : src_length - start; - memcpy (str, SCM_STRING_CHARS (obj) + start, effective_length); - scm_remember_upto_here_1 (obj); - return str; + return scm_to_locale_stringn (str, NULL); } -#undef FUNC_NAME +size_t +scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len) +{ + size_t len; + + if (!SCM_I_STRINGP (str)) + scm_wrong_type_arg_msg (NULL, 0, str, "string"); + len = SCM_I_STRING_LENGTH (str); + memcpy (buf, SCM_I_STRING_CHARS (str), (len > max_len)? max_len : len); + scm_remember_upto_here_1 (str); + return len; +} + +/* Return a newly allocated array of char pointers to each of the strings + in args, with a terminating NULL pointer. */ + +char ** +scm_i_allocate_string_pointers (SCM list) +{ + char **result; + int len = scm_ilength (list); + int i; + + if (len < 0) + scm_wrong_type_arg_msg (NULL, 0, list, "proper list"); + + scm_frame_begin (0); + + result = (char **) scm_malloc ((len + 1) * sizeof (char *)); + result[len] = NULL; + scm_frame_unwind_handler (free, result, 0); + + /* The list might be have been modified in another thread, so + we check LIST before each access. + */ + for (i = 0; i < len && SCM_CONSP (list); i++) + { + result[i] = scm_to_locale_string (SCM_CAR (list)); + list = SCM_CDR (list); + } + + scm_frame_end (); + return result; +} + +void +scm_i_free_string_pointers (char **pointers) +{ + int i; + + for (i = 0; pointers[i]; i++) + free (pointers[i]); + free (pointers); +} void scm_init_strings () diff --git a/libguile/strings.h b/libguile/strings.h index 8e915d470..09edabbcb 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -26,19 +26,30 @@ -#define SCM_STRINGP(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_string)) -#define SCM_STRING_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) -#define SCM_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) -#define SCM_SET_STRING_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) -#define SCM_STRING_MAX_LENGTH ((1UL << 24) - 1UL) -#define SCM_STRING_LENGTH(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 8)) -#define SCM_MAKE_STRING_TAG(l) ((((scm_t_bits) (l)) << 8) + scm_tc7_string) -#define SCM_SET_STRING_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), SCM_MAKE_STRING_TAG (l))) +#define SCM_STRING_MAX_LENGTH ((SCM_T_BITS_MAX-255)/256) + +#define SCM_I_MAKE_STRING_TAG(l) ((((scm_t_bits) (l)) << 8) + scm_tc7_string) +#define SCM_I_STRINGP(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_string)) +#define SCM_I_STRING_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) +#define SCM_I_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) +#define SCM_I_STRING_LENGTH(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 8)) + +#define SCM_STRINGP SCM_I_STRINGP +#define SCM_STRING_CHARS SCM_I_STRING_CHARS +#define SCM_STRING_UCHARS SCM_I_STRING_UCHARS +#define SCM_STRING_LENGTH SCM_I_STRING_LENGTH SCM_API SCM scm_string_p (SCM x); SCM_API SCM scm_string (SCM chrs); +SCM_API SCM scm_make_string (SCM k, SCM chr); +SCM_API SCM scm_string_length (SCM str); +SCM_API SCM scm_string_ref (SCM str, SCM k); +SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr); +SCM_API SCM scm_substring (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_append (SCM args); + SCM_API SCM scm_makfromstrs (int argc, char **argv); SCM_API SCM scm_take_str (char *s, size_t len); SCM_API SCM scm_take0str (char *s); @@ -47,23 +58,22 @@ SCM_API SCM scm_str2string (const char *src); SCM_API SCM scm_makfrom0str (const char *src); SCM_API SCM scm_makfrom0str_opt (const char *src); SCM_API SCM scm_allocate_string (size_t len); -SCM_API SCM scm_make_string (SCM k, SCM chr); -SCM_API SCM scm_string_length (SCM str); -SCM_API SCM scm_string_ref (SCM str, SCM k); -SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr); -SCM_API SCM scm_substring (SCM str, SCM start, SCM end); -SCM_API SCM scm_string_append (SCM args); + +SCM_API int scm_is_string (SCM x); +SCM_API SCM scm_from_locale_string (const char *str); +SCM_API SCM scm_from_locale_stringn (const char *str, size_t len); +SCM_API SCM scm_take_locale_string (char *str); +SCM_API SCM scm_take_locale_stringn (char *str, size_t len); +SCM_API char *scm_to_locale_string (SCM str); +SCM_API char *scm_to_locale_stringn (SCM str, size_t *lenp); +SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len); + +/* internal utility functions. */ + +SCM_API char **scm_i_allocate_string_pointers (SCM list); +SCM_API void scm_i_free_string_pointers (char **pointers); + SCM_API void scm_init_strings (void); -SCM_API char *scm_c_string2str (SCM obj, char *str, size_t *lenp); -SCM_API char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len); - - - -#if (SCM_ENABLE_DEPRECATED == 1) - -#define SCM_STRING_COERCE_0TERMINATION_X(x) (x) - -#endif #endif /* SCM_STRINGS_H */ From 7d04d68bf70aa1f1873df5cbf7ad9731b6836255 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 13:30:12 +0000 Subject: [PATCH 15/64] (scm_internal_parse_path): Removed. (scm_parse_path): Use scm_string_split to do the work. (scm_init_load_path): Use scm_parse_path instead of scm_internal_parse_path. (scm_search_path): Rewritten string handling part of the code in terms of scm_to_locale_stringbuf and so that it is thread safe. --- libguile/load.c | 278 ++++++++++++++++++++++++++---------------------- libguile/load.h | 1 - 2 files changed, 151 insertions(+), 128 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 00ec130a1..3cc48b969 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -23,6 +23,7 @@ #endif #include +#include #include "libguile/_scm.h" #include "libguile/libpath.h" @@ -36,6 +37,8 @@ #include "libguile/strings.h" #include "libguile/modules.h" #include "libguile/lang.h" +#include "libguile/chars.h" +#include "libguile/strop.h" #include "libguile/validate.h" #include "libguile/load.h" @@ -172,37 +175,6 @@ static SCM *scm_loc_load_path; static SCM *scm_loc_load_extensions; -/* Parse the null-terminated string PATH as if it were a standard path - environment variable (i.e. a colon-separated list of strings), and - prepend the elements to TAIL. */ -SCM -scm_internal_parse_path (char *path, SCM tail) -{ - if (path && path[0] != '\0') - { - char *scan, *elt_end; - - /* Scan backwards from the end of the string, to help - construct the list in the right order. */ - scan = elt_end = path + strlen (path); - do { - /* Scan back to the beginning of the current element. */ - do scan--; -#ifdef __MINGW32__ - while (scan >= path && *scan != ';'); -#else - while (scan >= path && *scan != ':'); -#endif - tail = scm_cons (scm_mem2string (scan + 1, elt_end - (scan + 1)), - tail); - elt_end = scan; - } while (scan >= path); - } - - return tail; -} - - SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, (SCM path, SCM tail), "Parse @var{path}, which is expected to be a colon-separated\n" @@ -211,14 +183,17 @@ SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, "is returned.") #define FUNC_NAME s_scm_parse_path { - SCM_ASSERT (scm_is_false (path) || (SCM_STRINGP (path)), - path, - SCM_ARG1, FUNC_NAME); +#ifdef __MINGW32__ + SCM sep = SCM_MAKE_CHAR (';'); +#else + SCM sep = SCM_MAKE_CHAR (':'); +#endif + if (SCM_UNBNDP (tail)) tail = SCM_EOL; return (scm_is_false (path) ? tail - : scm_internal_parse_path (SCM_STRING_CHARS (path), tail)); + : scm_append_x (scm_list_2 (scm_string_split (path, sep), tail))); } #undef FUNC_NAME @@ -237,13 +212,86 @@ scm_init_load_path () scm_makfrom0str (SCM_PKGDATA_DIR)); #endif /* SCM_LIBRARY_DIR */ - path = scm_internal_parse_path (getenv ("GUILE_LOAD_PATH"), path); + path = scm_parse_path (scm_from_locale_string (getenv ("GUILE_LOAD_PATH")), + path); *scm_loc_load_path = path; } SCM scm_listofnullstr; +/* Utility functions for assembling C strings in a buffer. + */ + +struct stringbuf { + char *buf, *ptr; + size_t buf_len; +}; + +static void +stringbuf_free (void *data) +{ + struct stringbuf *buf = (struct stringbuf *)data; + free (buf->buf); +} + +static void +stringbuf_grow (struct stringbuf *buf) +{ + size_t ptroff = buf->ptr - buf->buf; + buf->buf_len *= 2; + // fprintf (stderr, "growing to %u\n", buf->buf_len); + buf->buf = scm_realloc (buf->buf, buf->buf_len); + buf->ptr = buf->buf + ptroff; +} + +static void +stringbuf_cat_locale_string (struct stringbuf *buf, SCM str) +{ + size_t max_len = buf->buf_len - (buf->ptr - buf->buf) - 1; + size_t len = scm_to_locale_stringbuf (str, buf->ptr, max_len); + if (len > max_len) + { + /* buffer is too small, double its size and try again. + */ + stringbuf_grow (buf); + stringbuf_cat_locale_string (buf, str); + } + else + { + /* string fits, terminate it and check for embedded '\0'. + */ + buf->ptr[len] = '\0'; + if (strlen (buf->ptr) != len) + scm_misc_error (NULL, + "string contains #\\nul character: ~S", + scm_list_1 (str)); + buf->ptr += len; + } +} + +static void +stringbuf_cat (struct stringbuf *buf, char *str) +{ + size_t max_len = buf->buf_len - (buf->ptr - buf->buf) - 1; + size_t len = strlen (str); + if (len > max_len) + { + /* buffer is too small, double its size and try again. + */ + stringbuf_grow (buf); + stringbuf_cat (buf, str); + } + else + { + /* string fits, copy it into buffer. + */ + strcpy (buf->ptr, str); + buf->ptr += len; + } +} + + /* Search PATH for a directory containing a file named FILENAME. The file must be readable, and not a directory. If we find one, return its full filename; otherwise, return #f. @@ -261,20 +309,19 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, "concatenated with each @var{extension}.") #define FUNC_NAME s_scm_search_path { + struct stringbuf buf; char *filename_chars; - int filename_len; - size_t max_path_len; /* maximum length of any PATH element */ - size_t max_ext_len; /* maximum length of any EXTENSIONS element */ + size_t filename_len; + SCM result = SCM_BOOL_F; - SCM_VALIDATE_LIST (1, path); - SCM_VALIDATE_STRING (2, filename); if (SCM_UNBNDP (extensions)) extensions = SCM_EOL; - else - SCM_VALIDATE_LIST (3, extensions); - filename_chars = SCM_STRING_CHARS (filename); - filename_len = SCM_STRING_LENGTH (filename); + scm_frame_begin (0); + + filename_chars = scm_to_locale_string (filename); + filename_len = strlen (filename_chars); + scm_frame_free (filename_chars); /* If FILENAME is absolute, return it unchanged. */ #ifdef __MINGW32__ @@ -287,22 +334,10 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, #else if (filename_len >= 1 && filename_chars[0] == '/') #endif - return filename; - - /* Find the length of the longest element of path. */ - { - SCM walk; - - max_path_len = 0; - for (walk = path; !SCM_NULL_OR_NIL_P (walk); walk = SCM_CDR (walk)) - { - SCM elt = SCM_CAR (walk); - SCM_ASSERT_TYPE (SCM_STRINGP (elt), path, 1, FUNC_NAME, - "list of strings"); - if (SCM_STRING_LENGTH (elt) > max_path_len) - max_path_len = SCM_STRING_LENGTH (elt); - } - } + { + scm_frame_end (); + return filename; + } /* If FILENAME has an extension, don't try to add EXTENSIONS to it. */ { @@ -330,81 +365,70 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, } } - /* Find the length of the longest element of the load extensions - list. */ - { /* scope */ - SCM walk; + /* This simplifies the loop below a bit. + */ + if (SCM_NULLP (extensions)) + extensions = scm_listofnullstr; - max_ext_len = 0; - for (walk = extensions; !SCM_NULL_OR_NIL_P (walk); walk = SCM_CDR (walk)) - { - SCM elt = SCM_CAR (walk); - SCM_ASSERT_TYPE (SCM_STRINGP (elt), elt, 3, FUNC_NAME, - "list of strings"); - if (SCM_STRING_LENGTH (elt) > max_ext_len) - max_ext_len = SCM_STRING_LENGTH (elt); - } - } + buf.buf_len = 512; + buf.buf = scm_malloc (buf.buf_len); + scm_frame_unwind_handler (stringbuf_free, &buf, SCM_F_WIND_EXPLICITLY); - SCM_DEFER_INTS; + /* Try every path element. + */ + for (; SCM_CONSP (path); path = SCM_CDR (path)) + { + SCM dir = SCM_CAR (path); + SCM exts; + size_t sans_ext_len; - { /* scope */ - SCM result = SCM_BOOL_F; - size_t buf_size = max_path_len + 1 + filename_len + max_ext_len + 1; - char *buf = scm_malloc (buf_size); - - /* This simplifies the loop below a bit. */ - if (SCM_NULL_OR_NIL_P (extensions)) - extensions = scm_listofnullstr; - - /* Try every path element. At this point, we know the path is a - proper list of strings. */ - for (; !SCM_NULL_OR_NIL_P (path); path = SCM_CDR (path)) - { - size_t len; - SCM dir = SCM_CAR (path); - SCM exts; - - /* Concatenate the path name and the filename. */ - len = SCM_STRING_LENGTH (dir); - memcpy (buf, SCM_STRING_CHARS (dir), len); + buf.ptr = buf.buf; + stringbuf_cat_locale_string (&buf, dir); + + /* Concatenate the path name and the filename. */ + #ifdef __MINGW32__ - if (len >= 1 && buf[len - 1] != '/' && buf[len - 1] != '\\') + if (buf.ptr > buf.buf && buf.ptr[-1] != '/' && buf.ptr[-1] != '\\') #else - if (len >= 1 && buf[len - 1] != '/') + if (buf.ptr > buf.buf >= 1 && buf.ptr[-1] != '/') #endif - buf[len++] = '/'; - memcpy (buf + len, filename_chars, filename_len); - len += filename_len; + stringbuf_cat (&buf, "/"); - /* Try every extension. At this point, we know the extension - list is a proper, nonempty list of strings. */ - for (exts = extensions; !SCM_NULL_OR_NIL_P (exts); exts = SCM_CDR (exts)) - { - SCM ext = SCM_CAR (exts); - size_t ext_len = SCM_STRING_LENGTH (ext); - struct stat mode; + stringbuf_cat (&buf, filename_chars); + sans_ext_len = buf.ptr - buf.buf; - /* Concatenate the extension. */ - memcpy (buf + len, SCM_STRING_CHARS (ext), ext_len); - buf[len + ext_len] = '\0'; - - /* If the file exists at all, we should return it. If the - file is inaccessible, then that's an error. */ - if (stat (buf, &mode) == 0 - && ! (mode.st_mode & S_IFDIR)) - { - result = scm_mem2string (buf, len + ext_len); - goto end; - } - } - } + /* Try every extension. */ + for (exts = extensions; SCM_CONSP (exts); exts = SCM_CDR (exts)) + { + SCM ext = SCM_CAR (exts); + struct stat mode; + + buf.ptr = buf.buf + sans_ext_len; + stringbuf_cat_locale_string (&buf, ext); + + /* If the file exists at all, we should return it. If the + file is inaccessible, then that's an error. */ - end: - free (buf); - SCM_ALLOW_INTS; - return result; - } + // fprintf (stderr, "trying: %s\n", buf.buf); + + if (stat (buf.buf, &mode) == 0 + && ! (mode.st_mode & S_IFDIR)) + { + result = scm_from_locale_string (buf.buf); + goto end; + } + } + + if (!SCM_NULL_OR_NIL_P (exts)) + scm_wrong_type_arg_msg (NULL, 0, extensions, "proper list"); + } + + if (!SCM_NULL_OR_NIL_P (path)) + scm_wrong_type_arg_msg (NULL, 0, path, "proper list"); + + end: + scm_frame_end (); + return result; } #undef FUNC_NAME diff --git a/libguile/load.h b/libguile/load.h index 17f705271..98bca8b31 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -25,7 +25,6 @@ #include "libguile/__scm.h" -SCM_API SCM scm_internal_parse_path (char *path, SCM tail); SCM_API SCM scm_parse_path (SCM path, SCM tail); SCM_API void scm_init_load_path (void); SCM_API SCM scm_primitive_load (SCM filename); From 3b9ee0a4f8515e9a5f0781d0f8c46ea82cb1d6dd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 13:31:22 +0000 Subject: [PATCH 16/64] * backtrace.c: Replaced SCM_STRINGP with scm_is_string. (display_header): Print FNAME when it is true, not merely when it is a string. --- libguile/backtrace.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 3f6efac2f..9dd278189 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -84,7 +84,7 @@ display_header (SCM source, SCM port) * filename with the source properties? Then we could in case of * non-file ports give at least some more details than just * "". */ - if (SCM_STRINGP (fname)) + if (scm_is_true (fname)) scm_prin1 (fname, port, 0); else scm_puts ("", port); @@ -116,7 +116,7 @@ struct display_error_message_data { static SCM display_error_message (struct display_error_message_data *d) { - if (SCM_STRINGP (d->message) && scm_is_true (scm_list_p (d->args))) + if (scm_is_string (d->message) && scm_is_true (scm_list_p (d->args))) scm_simple_format (d->port, d->message, d->args); else scm_display (d->message, d->port); @@ -176,7 +176,7 @@ display_expression (SCM frame, SCM pname, SCM source, SCM port) pstate->fancyp = 1; pstate->level = DISPLAY_EXPRESSION_MAX_LEVEL; pstate->length = DISPLAY_EXPRESSION_MAX_LENGTH; - if (SCM_SYMBOLP (pname) || SCM_STRINGP (pname)) + if (SCM_SYMBOLP (pname) || scm_is_string (pname)) { if (SCM_FRAMEP (frame) && SCM_FRAME_EVAL_ARGS_P (frame)) @@ -227,11 +227,13 @@ display_error_body (struct display_error_args *a) prev_frame = SCM_FRAME_PREV (current_frame); 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) + if (!SCM_SYMBOLP (pname) + && !scm_is_string (pname) + && SCM_FRAME_PROC_P (current_frame) && 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)) + if (SCM_SYMBOLP (pname) || scm_is_string (pname) || SCM_MEMOIZEDP (source)) { display_header (source, a->port); display_expression (current_frame, pname, source, a->port); @@ -530,7 +532,8 @@ display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate) { pstate -> writingp = 0; #ifdef HAVE_POSIX - scm_iprin1 (SCM_STRINGP (file) ? scm_basename (file, SCM_UNDEFINED) : file, + scm_iprin1 ((scm_is_string (file)? + scm_basename (file, SCM_UNDEFINED) : file), port, pstate); #else scm_iprin1 (file, port, pstate); From 6d5649b7b8a365455f881fdf2b44fcbc02708e1f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 13:35:28 +0000 Subject: [PATCH 17/64] (scm_frame_free): New. --- libguile/dynwind.c | 6 ++++++ libguile/dynwind.h | 2 ++ 2 files changed, 8 insertions(+) diff --git a/libguile/dynwind.c b/libguile/dynwind.c index e8059be27..299842912 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -234,6 +234,12 @@ scm_frame_rewind_handler_with_scm (void (*proc) (SCM), SCM data, proc (data); } +void +scm_frame_free (void *mem) +{ + scm_frame_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY); +} + #ifdef GUILE_DEBUG SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0, (), diff --git a/libguile/dynwind.h b/libguile/dynwind.h index ce68bcd64..9aab34881 100644 --- a/libguile/dynwind.h +++ b/libguile/dynwind.h @@ -63,6 +63,8 @@ SCM_API void scm_frame_unwind_handler_with_scm (void (*func) (SCM), SCM data, SCM_API void scm_frame_rewind_handler_with_scm (void (*func) (SCM), SCM data, scm_t_wind_flags); +SCM_API void scm_frame_free (void *mem); + #ifdef GUILE_DEBUG SCM_API SCM scm_wind_chain (void); #endif /*GUILE_DEBUG*/ From 18f9d34373e4ebf33b49b8144d48b40ce6f6c769 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 13:36:45 +0000 Subject: [PATCH 18/64] Instead calling scm_puts on the SCM_STRING_CHARS of a string, call scm_display on the string itself. --- libguile/environments.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libguile/environments.c b/libguile/environments.c index 5448c9294..1b75bcd2d 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -484,7 +484,7 @@ observer_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED) SCM base16 = scm_number_to_string (address, scm_from_int (16)); scm_puts ("#", port); return 1; @@ -982,7 +982,7 @@ leaf_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED) SCM base16 = scm_number_to_string (address, scm_from_int (16)); scm_puts ("#", port); return 1; @@ -1342,7 +1342,7 @@ eval_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED) SCM base16 = scm_number_to_string (address, scm_from_int (16)); scm_puts ("#", port); return 1; @@ -1761,7 +1761,7 @@ import_environment_print (SCM type, SCM port, SCM base16 = scm_number_to_string (address, scm_from_int (16)); scm_puts ("#", port); return 1; @@ -2066,7 +2066,7 @@ export_environment_print (SCM type, SCM port, SCM base16 = scm_number_to_string (address, scm_from_int (16)); scm_puts ("#", port); return 1; From 24d1f17168dde1fa6a10ff5e8a7b2fbf5d62187e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 13:37:11 +0000 Subject: [PATCH 19/64] (scm_error_scm): Throw directly instead of calling scm_error, this avoids the back and forth conversion of SUBR and MESSAGE and also plugs a memory leak. (scm_error): Call scm_error_scm. --- libguile/error.c | 68 ++++++++++++------------------------------------ 1 file changed, 16 insertions(+), 52 deletions(-) diff --git a/libguile/error.c b/libguile/error.c index f53b9ab4a..e61004a7a 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -52,35 +52,18 @@ */ -/* All errors should pass through here. */ +/* Scheme interface to scm_error_scm. */ void scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest) { - SCM arg_list; - if (scm_gc_running_p) - { - /* The error occured during GC --- abort */ - fprintf (stderr, "Error in %s during GC: %s\n", - subr ? subr : "unknown function", - message ? message : ""); - abort (); - } - arg_list = scm_list_4 (subr ? scm_makfrom0str (subr) : SCM_BOOL_F, - message ? scm_makfrom0str (message) : SCM_BOOL_F, - args, - rest); - scm_ithrow (key, arg_list, 1); - - /* No return, but just in case: */ - { - const char msg[] = "guile:scm_error:scm_ithrow returned!\n"; - - write (2, msg, (sizeof msg) - 1); - } - exit (1); + scm_error_scm + (key, + (subr == NULL) ? SCM_BOOL_F : scm_from_locale_string (subr), + (message == NULL) ? SCM_BOOL_F : scm_from_locale_string (message), + args, rest); } -/* Scheme interface to scm_error. */ +/* All errors should pass through here. */ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0, (SCM key, SCM subr, SCM message, SCM args, SCM data), "Raise an error with key @var{key}. @var{subr} can be a string\n" @@ -98,37 +81,18 @@ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0, "it will usually be @code{#f}.") #define FUNC_NAME s_scm_error_scm { - char *szSubr; - char *szMessage; - - SCM_VALIDATE_SYMBOL (1, key); - - if (scm_is_false (subr)) + if (scm_gc_running_p) { - szSubr = NULL; - } - else if (SCM_SYMBOLP (subr)) - { - szSubr = SCM_SYMBOL_CHARS (subr); - } - else - { - SCM_VALIDATE_STRING (2, subr); - szSubr = SCM_STRING_CHARS (subr); + /* The error occured during GC --- abort */ + fprintf (stderr, "Guile: error during GC.\n"), + abort (); } - if (scm_is_false (message)) - { - szMessage = NULL; - } - else - { - SCM_VALIDATE_STRING (2, message); - szMessage = SCM_STRING_CHARS (message); - } - - scm_error (key, szSubr, szMessage, args, data); - /* not reached. */ + scm_ithrow (key, scm_list_4 (subr, message, args, data), 1); + + /* No return, but just in case: */ + fprintf (stderr, "Guile scm_ithrow returned!\n"); + exit (1); } #undef FUNC_NAME From 79c98b33fea416592cdac95e94a69e08cf3b3f8f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 13:43:55 +0000 Subject: [PATCH 20/64] Replaced SCM_STRINGP, SCM_STRING_CHARS, and SCM_STRING_LENGTH with SCM_I_STRINGP, SCM_I_STRING_CHARS, and SCM_I_STRING_LENGTH, respectively. (gh_scm2newstr): Implement in terms of scm_to_locale_string. --- libguile/gh_data.c | 41 ++++++++++++++--------------------------- 1 file changed, 14 insertions(+), 27 deletions(-) diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 6bc67b4d8..7f41b206d 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -80,10 +80,10 @@ gh_set_substr (char *src, SCM dst, long start, size_t len) char *dst_ptr; size_t dst_len; - SCM_ASSERT (SCM_STRINGP (dst), dst, SCM_ARG3, "gh_set_substr"); + SCM_ASSERT (SCM_I_STRINGP (dst), dst, SCM_ARG3, "gh_set_substr"); - dst_ptr = SCM_STRING_CHARS (dst); - dst_len = SCM_STRING_LENGTH (dst); + dst_ptr = SCM_I_STRING_CHARS (dst); + dst_len = SCM_I_STRING_LENGTH (dst); SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr"); memmove (dst_ptr + start, src, len); @@ -259,12 +259,12 @@ gh_scm2chars (SCM obj, char *m) break; #endif case scm_tc7_string: - n = SCM_STRING_LENGTH (obj); + n = SCM_I_STRING_LENGTH (obj); if (m == 0) m = (char *) malloc (n * sizeof (char)); if (m == NULL) return NULL; - memcpy (m, SCM_VELTS (obj), n * sizeof (char)); + memcpy (m, SCM_I_STRING_CHARS (obj), n * sizeof (char)); break; default: scm_wrong_type_arg (0, 0, obj); @@ -518,30 +518,17 @@ char * gh_scm2newstr (SCM str, size_t *lenp) { char *ret_str; - size_t len; - SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG3, "gh_scm2newstr"); - - len = SCM_STRING_LENGTH (str); - - ret_str = (char *) malloc ((len + 1) * sizeof (char)); - if (ret_str == NULL) - return NULL; - /* so we copy tmp_str to ret_str, which is what we will allocate */ - memcpy (ret_str, SCM_STRING_CHARS (str), len); - scm_remember_upto_here_1 (str); - /* now make sure we null-terminate it */ - ret_str[len] = '\0'; - - if (lenp != NULL) - { - *lenp = len; - } + /* We can't use scm_to_locale_stringn directly since it does not + guarantee null-termination when lenp is non-NULL. + */ + ret_str = scm_to_locale_string (str); + if (lenp) + *lenp = SCM_I_STRING_LENGTH (str); return ret_str; } - /* Copy LEN characters at START from the Scheme string SRC to memory at DST. START is an index into SRC; zero means the beginning of the string. DST has already been allocated by the caller. @@ -553,11 +540,11 @@ void gh_get_substr (SCM src, char *dst, long start, size_t len) { size_t src_len, effective_length; - SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr"); + SCM_ASSERT (SCM_I_STRINGP (src), src, SCM_ARG3, "gh_get_substr"); - src_len = SCM_STRING_LENGTH (src); + src_len = SCM_I_STRING_LENGTH (src); effective_length = (len < src_len) ? len : src_len; - memcpy (dst + start, SCM_STRING_CHARS (src), effective_length * sizeof (char)); + memcpy (dst + start, SCM_I_STRING_CHARS (src), effective_length * sizeof (char)); /* FIXME: must signal an error if len > src_len */ scm_remember_upto_here_1 (src); } From 29a837fd27e8062caa6eba124d8c84b51b202fc6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 13:54:01 +0000 Subject: [PATCH 21/64] (scm_input_error): Use a SCM value for 'fn', not a C string. This avoids a conversion round-trip. --- libguile/read.c | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 4e27f6591..d3f448aac 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -76,22 +76,21 @@ scm_t_option scm_read_opts[] = { static void -scm_input_error(char const * function, - SCM port, const char * message, SCM arg) +scm_input_error (char const *function, + SCM port, const char *message, SCM arg) { - char *fn = SCM_STRINGP (SCM_FILENAME(port)) - ? SCM_STRING_CHARS(SCM_FILENAME(port)) - : "#"; + SCM fn = (scm_is_string (SCM_FILENAME(port)) + ? SCM_FILENAME(port) + : scm_from_locale_string ("#")); - SCM string_port = scm_open_output_string (); + SCM string_port = scm_open_output_string (); SCM string = SCM_EOL; scm_simple_format (string_port, scm_makfrom0str ("~A:~S:~S: ~A"), - scm_list_4 (scm_makfrom0str (fn), + scm_list_4 (fn, scm_from_int (SCM_LINUM (port) + 1), scm_from_int (SCM_COL (port) + 1), scm_makfrom0str (message))); - string = scm_get_output_string (string_port); scm_close_output_port (string_port); From 7f03f970369e46e54867938950dd1a2f652b7647 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 13:54:16 +0000 Subject: [PATCH 22/64] * procs.c, posix.c, ports.c, net_db.c, fports.c, filesys.c, eval.c, deprecation.c, dynl.c: Replaced uses of SCM_STRING_CHARS with proper uses of scm_to_locale_string. Replaced SCM_STRINGP with scm_is_string. * posix.c (allocate_string_pointers, environ_list_to_c): Removed, replaced all uses with scm_i_allocate_string_pointers. --- libguile/posix.c | 144 +++++++++++++++++------------------------------ 1 file changed, 53 insertions(+), 91 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index d867be186..dc10d7ea7 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -888,32 +888,10 @@ SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0, #undef FUNC_NAME #endif /* HAVE_TCSETPGRP */ -/* return a newly allocated array of char pointers to each of the strings - in args, with a terminating NULL pointer. */ -/* Note: a similar function is defined in dynl.c, but we don't necessarily - want to export it. */ -static char **allocate_string_pointers (SCM args) +static void +free_string_pointers (void *data) { - char **result; - int n_args = scm_ilength (args); - int i; - - SCM_ASSERT (n_args >= 0, args, SCM_ARGn, "allocate_string_pointers"); - result = (char **) scm_malloc ((n_args + 1) * sizeof (char *)); - result[n_args] = NULL; - for (i = 0; i < n_args; i++) - { - SCM car = SCM_CAR (args); - - if (!SCM_STRINGP (car)) - { - free (result); - scm_wrong_type_arg ("allocate_string_pointers", SCM_ARGn, car); - } - result[i] = SCM_STRING_CHARS (SCM_CAR (args)); - args = SCM_CDR (args); - } - return result; + scm_i_free_string_pointers ((char **)data); } SCM_DEFINE (scm_execl, "execl", 1, 0, 1, @@ -929,16 +907,23 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1, "call, but we call it @code{execl} because of its Scheme calling interface.") #define FUNC_NAME s_scm_execl { - char **execargv; - int save_errno; - SCM_VALIDATE_STRING (1, filename); - execargv = allocate_string_pointers (args); - execv (SCM_STRING_CHARS (filename), execargv); - save_errno = errno; - free (execargv); - errno = save_errno; + char *exec_file; + char **exec_argv; + + scm_frame_begin (0); + + exec_file = scm_to_locale_string (filename); + scm_frame_free (exec_file); + + exec_argv = scm_i_allocate_string_pointers (args); + scm_frame_unwind_handler (free_string_pointers, exec_argv, + SCM_F_WIND_EXPLICITLY); + + execv (exec_file, exec_argv); SCM_SYSERROR; + /* not reached. */ + scm_frame_end (); return SCM_BOOL_F; } #undef FUNC_NAME @@ -953,50 +938,27 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1, "call, but we call it @code{execlp} because of its Scheme calling interface.") #define FUNC_NAME s_scm_execlp { - char **execargv; - int save_errno; - SCM_VALIDATE_STRING (1, filename); - execargv = allocate_string_pointers (args); - execvp (SCM_STRING_CHARS (filename), execargv); - save_errno = errno; - free (execargv); - errno = save_errno; + char *exec_file; + char **exec_argv; + + scm_frame_begin (0); + + exec_file = scm_to_locale_string (filename); + scm_frame_free (exec_file); + + exec_argv = scm_i_allocate_string_pointers (args); + scm_frame_unwind_handler (free_string_pointers, exec_argv, + SCM_F_WIND_EXPLICITLY); + + execvp (exec_file, exec_argv); SCM_SYSERROR; + /* not reached. */ + scm_frame_end (); return SCM_BOOL_F; } #undef FUNC_NAME -static char ** -environ_list_to_c (SCM envlist, int arg, const char *proc) -{ - int num_strings; - char **result; - int i; - - num_strings = scm_ilength (envlist); - SCM_ASSERT (num_strings >= 0, envlist, arg, proc); - result = (char **) scm_malloc ((num_strings + 1) * sizeof (char *)); - if (result == NULL) - scm_memory_error (proc); - for (i = 0; !SCM_NULL_OR_NIL_P (envlist); ++i, envlist = SCM_CDR (envlist)) - { - SCM str = SCM_CAR (envlist); - int len; - char *src; - - SCM_ASSERT (SCM_STRINGP (str), envlist, arg, proc); - len = SCM_STRING_LENGTH (str); - src = SCM_STRING_CHARS (str); - result[i] = scm_malloc (len + 1); - if (result[i] == NULL) - scm_memory_error (proc); - memcpy (result[i], src, len); - result[i][len] = 0; - } - result[i] = 0; - return result; -} /* OPTIMIZE-ME: scm_execle doesn't need malloced copies of the environment list strings the way environ_list_to_c gives. */ @@ -1010,23 +972,28 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1, "call, but we call it @code{execle} because of its Scheme calling interface.") #define FUNC_NAME s_scm_execle { - char **execargv; + char **exec_argv; char **exec_env; - int save_errno, i; + char *exec_file; - SCM_VALIDATE_STRING (1, filename); - - execargv = allocate_string_pointers (args); - exec_env = environ_list_to_c (env, SCM_ARG2, FUNC_NAME); - execve (SCM_STRING_CHARS (filename), execargv, exec_env); - save_errno = errno; - free (execargv); - for (i = 0; exec_env[i] != NULL; i++) - free (exec_env[i]); - free (exec_env); - errno = save_errno; + scm_frame_begin (0); + + exec_file = scm_to_locale_string (filename); + scm_frame_free (exec_file); + + exec_argv = scm_i_allocate_string_pointers (args); + scm_frame_unwind_handler (free_string_pointers, exec_argv, + SCM_F_WIND_EXPLICITLY); + + exec_env = scm_i_allocate_string_pointers (env); + scm_frame_unwind_handler (free_string_pointers, exec_env, + SCM_F_WIND_EXPLICITLY); + + execve (exec_file, exec_argv, exec_env); SCM_SYSERROR; + /* not reached. */ + scm_frame_end (); return SCM_BOOL_F; } #undef FUNC_NAME @@ -1096,19 +1063,14 @@ SCM_DEFINE (scm_environ, "environ", 0, 1, 0, { char **new_environ; - new_environ = environ_list_to_c (env, SCM_ARG1, FUNC_NAME); + new_environ = scm_i_allocate_string_pointers (env); /* Free the old environment, except when called for the first * time. */ { - char **ep; static int first = 1; if (!first) - { - for (ep = environ; *ep != NULL; ep++) - free (*ep); - free ((char *) environ); - } + scm_i_free_string_pointers (environ); first = 0; } environ = new_environ; From 7fd0a36919c3441352a78fd8f687fdb877fcbbb5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 14:05:14 +0000 Subject: [PATCH 23/64] (scm_i_index): Replaced SCM_STRINGP, SCM_STRING_CHARS, and SCM_STRING_LENGTH with SCM_I_STRINGP, SCM_I_STRING_CHARS, and SCM_I_STRING_LENGTH, respectively. Pass string object directly, not as a pointer. Use scm_remember_upto_here_1 to protect it. --- libguile/strop.c | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/libguile/strop.c b/libguile/strop.c index 0400870cc..6f4b8cd88 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -48,7 +48,7 @@ xSCM_DEFINE (scm_i_index, "i-index", 2, 2, 0, */ /* implements index if direction > 0 otherwise rindex. */ static long -scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, +scm_i_index (SCM str, SCM chr, int direction, SCM sub_start, SCM sub_end, const char *why) { unsigned char * p; @@ -57,38 +57,42 @@ scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, long upper; int ch; - SCM_ASSERT (SCM_STRINGP (*str), *str, SCM_ARG1, why); + SCM_ASSERT (SCM_I_STRINGP (str), str, SCM_ARG1, why); SCM_ASSERT (SCM_CHARP (chr), chr, SCM_ARG2, why); if (scm_is_false (sub_start)) lower = 0; else - lower = scm_to_signed_integer (sub_start, 0, SCM_STRING_LENGTH(*str)); + lower = scm_to_signed_integer (sub_start, 0, SCM_I_STRING_LENGTH(str)); if (scm_is_false (sub_end)) - upper = SCM_STRING_LENGTH (*str); + upper = SCM_I_STRING_LENGTH (str); else - upper = scm_to_signed_integer (sub_end, lower, SCM_STRING_LENGTH(*str)); + upper = scm_to_signed_integer (sub_end, lower, SCM_I_STRING_LENGTH(str)); + + x = -1; if (direction > 0) { - p = SCM_STRING_UCHARS (*str) + lower; + p = SCM_I_STRING_UCHARS (str) + lower; ch = SCM_CHAR (chr); for (x = lower; x < upper; ++x, ++p) if (*p == ch) - return x; + goto found_it; } else { - p = upper - 1 + SCM_STRING_UCHARS (*str); + p = upper - 1 + SCM_I_STRING_UCHARS (str); ch = SCM_CHAR (chr); for (x = upper - 1; x >= lower; --x, --p) if (*p == ch) - return x; + goto found_it; } - return -1; + found_it: + scm_remember_upto_here_1 (str); + return x; } SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, @@ -115,7 +119,7 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, frm = SCM_BOOL_F; if (SCM_UNBNDP (to)) to = SCM_BOOL_F; - pos = scm_i_index (&str, chr, 1, frm, to, FUNC_NAME); + pos = scm_i_index (str, chr, 1, frm, to, FUNC_NAME); return (pos < 0 ? SCM_BOOL_F : scm_from_long (pos)); @@ -145,7 +149,7 @@ SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0, frm = SCM_BOOL_F; if (SCM_UNBNDP (to)) to = SCM_BOOL_F; - pos = scm_i_index (&str, chr, -1, frm, to, FUNC_NAME); + pos = scm_i_index (str, chr, -1, frm, to, FUNC_NAME); return (pos < 0 ? SCM_BOOL_F : scm_from_long (pos)); From ebea155a3cc519e81919accaba980b1ad8954842 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 14:06:59 +0000 Subject: [PATCH 24/64] (scm_mkstrport): Use SCM_I_STRING_UCHARS instead of SCM_STRING_UCHARS. Use SCM_I_STRINGP instead of SCM_STRINGP. --- libguile/strports.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/strports.c b/libguile/strports.c index 30ce38509..70d8e66f0 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -252,8 +252,8 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) scm_t_port *pt; size_t str_len, c_pos; - SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG1, caller); - str_len = SCM_STRING_LENGTH (str); + SCM_ASSERT (SCM_I_STRINGP (str), str, SCM_ARG1, caller); + str_len = SCM_I_STRING_LENGTH (str); c_pos = scm_to_unsigned_integer (pos, 0, str_len); if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG))) @@ -264,7 +264,7 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) pt = SCM_PTAB_ENTRY(z); 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->write_buf = pt->read_buf = SCM_I_STRING_UCHARS (str); 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; From 02573e4c7a10dee980618c93f4902887b225433c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 14:07:35 +0000 Subject: [PATCH 25/64] *** empty log message *** --- libguile/ChangeLog | 83 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 83 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index db8c9af2b..15ab194bb 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,86 @@ +2004-08-10 Marius Vollmer + + * strings.h, deprecated.h (SCM_STRING_COERCE_0TERMINATION_X): + Moved from string.h to deprecated.h. + + * deprecated.c, deprecated.h (SCM_CHARS, SCM_LENGTH): Removed. + + * strings.h, strings.c (SCM_MAKE_STRING_TAG): Rename dto + SCM_I_MAKE_STRING_TAG, changed all uses. + (SCM_STRING_CHARS, SCM_STRING_UCHARS, SCM_STRING_LENGTH): Renamed + to SCM_I_STRING_CHARS, SCM_I_STRING_UCHARS, and SCM_I_LENGTH + respectively. For a short time, the old names are still there as + aliases. Not all uses have been changed yet, but the ones in + strings.c have. + (SCM_STRING_MAX_LEN): Do not hardcode to 24 bits, compute from + SCM_T_BITS_MAX. + (scm_is_string, scm_from_locale_string, scm_from_locale_stringn, + scm_take_locale_string, scm_take_locale_stringn, + scm_to_locale_string, scm_to_locale_stringn, + scm_to_locale_stringbuf): New. + (scm_c_string2str, scm_c_substring2str): Deprecated by moving to + deprecated.[hc]. Implemented in terms of the new functions above. + (scm_take_str, scm_take0str, scm_mem2string, scm_str2string, + scm_makfrom0str): Reimplemented in terms of the new functions from + above. They will be discouraged shortly. + (scm_substring): Do not use scm_mem2string. + (scm_i_allocate_string_pointers, scm_i_free_string_pointers): New, + to replace similar code from posix.c, simpos.c, and dynl.c. + (scm_string_append): Use memcpy instead of explicit loop. Do not + use register keyword. Use plain 'char' instead of 'unsigned + char'. + + * strports.c (scm_mkstrport): Use SCM_I_STRING_UCHARS instead of + SCM_STRING_UCHARS. Use SCM_I_STRINGP instead of SCM_STRINGP. + + * strop.c (scm_i_index): Replaced SCM_STRINGP, SCM_STRING_CHARS, + and SCM_STRING_LENGTH with SCM_I_STRINGP, SCM_I_STRING_CHARS, and + SCM_I_STRING_LENGTH, respectively. Pass string object directly, + not as a pointer. Use scm_remember_upto_here_1 to protect it. + + * read.c (scm_input_error): Use a SCM value for 'fn', not a C + string. This avoids a conversion round-trip. + + * gh_data.c: Replaced SCM_STRINGP, SCM_STRING_CHARS, and + SCM_STRING_LENGTH with SCM_I_STRINGP, SCM_I_STRING_CHARS, and + SCM_I_STRING_LENGTH, respectively. + (gh_scm2newstr): Implement in terms of scm_to_locale_string. + + * environments.c: Instead calling scm_puts on the SCM_STRING_CHARS + of a string, call scm_display on the string itself. + + * dynwind.c, dynwind.h (scm_frame_free): New. + + * stime.c, socket.c, simpos.c, procs.c, posix.c, ports.c, + net_db.c, fports.c, filesys.c, eval.c, deprecation.c, dynl.c: + Replaced uses of SCM_STRING_CHARS with proper uses of + scm_to_locale_string. Replaced SCM_STRINGP with scm_is_string. + Replaced scm_mem2string with scm_from_locale_string. + + * simpos.c, posix.c (allocate_string_pointers, environ_list_to_c): + Removed, replaced all uses with scm_i_allocate_string_pointers. + + * load.h, load.c (scm_internal_parse_path): Removed. + (scm_parse_path): Use scm_string_split to do the work. + (scm_init_load_path): Use scm_parse_path instead of + scm_internal_parse_path. + (scm_search_path): Rewritten string handling part of the code in + terms of scm_to_locale_stringbuf and so that it is thread safe. + + * error.c (scm_error_scm): Throw directly instead of calling + scm_error, this avoids the back and forth conversion of SUBR and + MESSAGE and also plugs a memory leak. + (scm_error): Call scm_error_scm. + + * backtrace.c: Replaced SCM_STRINGP with scm_is_string. + (display_header): Print FNAME when it is true, not + merely when it is a string. + + * strings.h (SCM_SET_STRING_LENGTH, SCM_SET_STRING_CHARS): Removed + unceremoniously. They were unused by Guile itself, and external + use should stop immediately. + + 2004-08-10 Marius Vollmer * numbers.h, number.c, deprecated.h, deprecated.c (scm_round, From 7f9994d90437cfdaf6d733b9c3b050d66326f3bb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 14:08:02 +0000 Subject: [PATCH 26/64] * stime.c, socket.c, simpos.c, procs.c, posix.c, ports.c, net_db.c, fports.c, filesys.c, eval.c, deprecation.c, dynl.c: Replaced uses of SCM_STRING_CHARS with proper uses of scm_to_locale_string. Replaced SCM_STRINGP with scm_is_string. Replaced scm_mem2string with scm_from_locale_string. * simpos.c, posix.c (allocate_string_pointers, environ_list_to_c): Removed, replaced all uses with scm_i_allocate_string_pointers. --- libguile/deprecation.c | 6 ++-- libguile/dynl.c | 67 ++++++++++++++++--------------------- libguile/eval.c | 2 +- libguile/filesys.c | 9 +++-- libguile/fports.c | 16 ++++++--- libguile/net_db.c | 76 +++++++++++++++++++++++++++++------------- libguile/ports.c | 16 +++++---- libguile/procs.c | 2 +- libguile/simpos.c | 61 ++++++++++++--------------------- libguile/socket.c | 17 ++++++---- libguile/stime.c | 14 +++++--- 11 files changed, 152 insertions(+), 134 deletions(-) diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 2c7d2a413..3d4852a2f 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -105,6 +105,7 @@ SCM_DEFINE(scm_issue_deprecation_warning, { SCM nl = scm_str2string ("\n"); SCM msgs_nl = SCM_EOL; + char *c_msgs; while (SCM_CONSP (msgs)) { if (msgs_nl != SCM_EOL) @@ -113,8 +114,9 @@ SCM_DEFINE(scm_issue_deprecation_warning, msgs = SCM_CDR (msgs); } msgs_nl = scm_string_append (scm_reverse_x (msgs_nl, SCM_EOL)); - scm_c_issue_deprecation_warning (SCM_STRING_CHARS (msgs_nl)); - scm_remember_upto_here_1 (msgs_nl); + c_msgs = scm_to_locale_string (msgs_nl); + scm_c_issue_deprecation_warning (c_msgs); + free (c_msgs); } return SCM_UNSPECIFIED; } diff --git a/libguile/dynl.c b/libguile/dynl.c index 76380de4d..99c6dc837 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -51,6 +51,7 @@ maybe_drag_in_eprintf () #include "libguile/deprecation.h" #include "libguile/lang.h" #include "libguile/validate.h" +#include "libguile/dynwind.h" #include "guile-ltdl.h" @@ -149,9 +150,13 @@ SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0, #define FUNC_NAME s_scm_dynamic_link { void *handle; + char *file; - SCM_VALIDATE_STRING (1, filename); - handle = sysdep_dynl_link (SCM_STRING_CHARS (filename), FUNC_NAME); + scm_frame_begin (0); + file = scm_to_locale_string (filename); + scm_frame_free (file); + handle = sysdep_dynl_link (file, FUNC_NAME); + scm_frame_end (); SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (filename), handle); } #undef FUNC_NAME @@ -216,9 +221,12 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0, } else { char *chars; - chars = SCM_STRING_CHARS (name); + scm_frame_begin (0); + chars = scm_to_locale_string (name); + scm_frame_free (chars); func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj), FUNC_NAME); + scm_frame_end (); return scm_from_ulong ((unsigned long) func); } } @@ -247,41 +255,18 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0, { void (*fptr) (); - if (SCM_STRINGP (func)) + if (scm_is_string (func)) func = scm_dynamic_func (func, dobj); - fptr = (void (*) ()) SCM_NUM2ULONG (1, func); + fptr = (void (*) ()) scm_to_ulong (func); fptr (); return SCM_UNSPECIFIED; } #undef FUNC_NAME -/* return a newly allocated array of char pointers to each of the strings - in args, with a terminating NULL pointer. */ -/* Note: a similar function is defined in posix.c, but we don't necessarily - want to export it. */ -static char **allocate_string_pointers (SCM args, int *num_args_return) +static void +free_string_pointers (void *data) { - char **result; - int n_args = scm_ilength (args); - int i; - - SCM_ASSERT (n_args >= 0, args, SCM_ARGn, "allocate_string_pointers"); - result = (char **) scm_malloc ((n_args + 1) * sizeof (char *)); - result[n_args] = NULL; - for (i = 0; i < n_args; i++) - { - SCM car = SCM_CAR (args); - - if (!SCM_STRINGP (car)) - { - free (result); - scm_wrong_type_arg ("allocate_string_pointers", SCM_ARGn, car); - } - result[i] = SCM_STRING_CHARS (SCM_CAR (args)); - args = SCM_CDR (args); - } - *num_args_return = n_args; - return result; + scm_i_free_string_pointers ((char **)data); } SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0, @@ -304,17 +289,21 @@ SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0, int result, argc; char **argv; - if (SCM_STRINGP (func)) + scm_frame_begin (0); + + if (scm_is_string (func)) func = scm_dynamic_func (func, dobj); - fptr = (int (*) (int, char **)) SCM_NUM2ULONG (1, func); - argv = allocate_string_pointers (args, &argc); - /* if the procedure mutates its arguments, the original strings will be - changed -- in Guile 1.6 and earlier, this wasn't the case since a - new copy of each string was allocated. */ - result = (*fptr) (argc, argv); - free (argv); + fptr = (int (*) (int, char **)) scm_to_ulong (func); + argv = scm_i_allocate_string_pointers (args); + scm_frame_unwind_handler (free_string_pointers, argv, + SCM_F_WIND_EXPLICITLY); + for (argc = 0; argv[argc]; argc++) + ; + result = (*fptr) (argc, argv); + + scm_frame_end (); return scm_from_int (result); } #undef FUNC_NAME diff --git a/libguile/eval.c b/libguile/eval.c index 18db8906c..d8dfc9e70 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1480,7 +1480,7 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED) * the documentation string will have to be skipped with every execution * of the closure. */ cddr_expr = SCM_CDR (cdr_expr); - documentation = (length >= 3 && SCM_STRINGP (SCM_CAR (cddr_expr))); + documentation = (length >= 3 && scm_is_string (SCM_CAR (cddr_expr))); body = documentation ? SCM_CDR (cddr_expr) : cddr_expr; new_body = m_body (SCM_IM_LAMBDA, body); diff --git a/libguile/filesys.c b/libguile/filesys.c index 29c86883e..459f5530c 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -610,18 +610,17 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, SCM_SYSCALL (rv = fstat (scm_to_int (object), &stat_temp)); #endif } - else if (SCM_STRINGP (object)) + else if (scm_is_string (object)) { + char *file = scm_to_locale_string (object); #ifdef __MINGW32__ - char *p, *file = strdup (SCM_STRING_CHARS (object)); + char *p; p = file + strlen (file) - 1; while (p > file && (*p == '/' || *p == '\\')) *p-- = '\0'; +#endif SCM_SYSCALL (rv = stat (file, &stat_temp)); free (file); -#else - SCM_SYSCALL (rv = stat (SCM_STRING_CHARS (object), &stat_temp)); -#endif } else { diff --git a/libguile/fports.c b/libguile/fports.c index cb824db17..6b462e03e 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -27,6 +27,7 @@ #include "libguile/strings.h" #include "libguile/validate.h" #include "libguile/gc.h" +#include "libguile/dynwind.h" #include "libguile/fports.h" @@ -289,11 +290,13 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, char *md; char *ptr; - SCM_VALIDATE_STRING (1, filename); - SCM_VALIDATE_STRING (2, mode); + scm_frame_begin (0); - file = SCM_STRING_CHARS (filename); - md = SCM_STRING_CHARS (mode); + file = scm_to_locale_string (filename); + scm_frame_free (file); + + md = scm_to_locale_string (mode); + scm_frame_free (md); switch (*md) { @@ -340,6 +343,9 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, scm_cons (filename, SCM_EOL)), en); } port = scm_fdes_to_port (fdes, md, filename); + + scm_frame_end (); + return port; } #undef FUNC_NAME @@ -489,7 +495,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { int fdes; SCM name = SCM_FILENAME (exp); - if (SCM_STRINGP (name) || SCM_SYMBOLP (name)) + if (scm_is_string (name) || SCM_SYMBOLP (name)) scm_display (name, port); else scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); diff --git a/libguile/net_db.c b/libguile/net_db.c index 539599189..41f05a9d7 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -35,6 +35,7 @@ #include "libguile/feature.h" #include "libguile/strings.h" #include "libguile/vectors.h" +#include "libguile/dynwind.h" #include "libguile/validate.h" #include "libguile/net_db.h" @@ -139,6 +140,7 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, struct in_addr inad; char **argv; int i = 0; + if (SCM_UNBNDP (host)) { #ifdef HAVE_GETHOSTENT @@ -157,15 +159,18 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_STRINGP (host)) + else if (scm_is_string (host)) { - entry = gethostbyname (SCM_STRING_CHARS (host)); + char *str = scm_to_locale_string (host); + entry = gethostbyname (str); + free (str); } else { - inad.s_addr = htonl (SCM_NUM2ULONG (1, host)); + inad.s_addr = htonl (scm_to_ulong (host)); entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET); } + if (!entry) scm_resolv_error (FUNC_NAME, host); @@ -211,8 +216,9 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, "given.") #define FUNC_NAME s_scm_getnet { - SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED); + SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED); struct netent *entry; + int eno; if (SCM_UNBNDP (net)) { @@ -225,18 +231,23 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_STRINGP (net)) + else if (scm_is_string (net)) { - entry = getnetbyname (SCM_STRING_CHARS (net)); + char *str = scm_to_locale_string (net); + entry = getnetbyname (str); + eno = errno; + free (str); } else { - unsigned long netnum; - netnum = SCM_NUM2ULONG (1, net); + unsigned long netnum = scm_to_ulong (net); entry = getnetbyaddr (netnum, AF_INET); + eno = errno; } + if (!entry) - SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net), errno); + SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net), eno); + 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_from_int (entry->n_addrtype)); @@ -257,9 +268,10 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, "@code{getprotoent} (see below) if no arguments are supplied.") #define FUNC_NAME s_scm_getproto { - SCM result = scm_c_make_vector (3, SCM_UNSPECIFIED); - + SCM result = scm_c_make_vector (3, SCM_UNSPECIFIED); struct protoent *entry; + int eno; + if (SCM_UNBNDP (protocol)) { entry = getprotoent (); @@ -271,18 +283,23 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_STRINGP (protocol)) + else if (scm_is_string (protocol)) { - entry = getprotobyname (SCM_STRING_CHARS (protocol)); + char *str = scm_to_locale_string (protocol); + entry = getprotobyname (str); + eno = errno; + free (str); } else { - unsigned long protonum; - protonum = SCM_NUM2ULONG (1, protocol); + unsigned long protonum = scm_to_ulong (protocol); entry = getprotobynumber (protonum); + eno = errno; } + if (!entry) - SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol), errno); + SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol), eno); + 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_from_int (entry->p_proto)); @@ -318,6 +335,9 @@ SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0, #define FUNC_NAME s_scm_getserv { struct servent *entry; + char *protoname; + int eno; + if (SCM_UNBNDP (name)) { entry = getservent (); @@ -330,19 +350,29 @@ SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0, } return scm_return_entry (entry); } - SCM_VALIDATE_STRING (2, protocol); - if (SCM_STRINGP (name)) + + scm_frame_begin (0); + + protoname = scm_to_locale_string (protocol); + scm_frame_free (protoname); + + if (scm_is_string (name)) { - entry = getservbyname (SCM_STRING_CHARS (name), - SCM_STRING_CHARS (protocol)); + char *str = scm_to_locale_string (name); + entry = getservbyname (str, protoname); + eno = errno; + free (str); } else { - entry = getservbyport (htons (scm_to_int (name)), - SCM_STRING_CHARS (protocol)); + entry = getservbyport (htons (scm_to_int (name)), protoname); + eno = errno; } + if (!entry) - SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name), errno); + SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name), eno); + + scm_frame_end (); return scm_return_entry (entry); } #undef FUNC_NAME diff --git a/libguile/ports.c b/libguile/ports.c index 101244d84..02d72b448 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1397,7 +1397,7 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, "@var{length} bytes. @var{object} can be a string containing a\n" "file name or an integer file descriptor or a port.\n" "@var{length} may be omitted if @var{object} is not a file name,\n" - "in which case the truncation occurs at the current port.\n" + "in which case the truncation occurs at the current port\n" "position. The return value is unspecified.") #define FUNC_NAME s_scm_truncate_file { @@ -1409,14 +1409,12 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, if (SCM_UNBNDP (length)) { /* must supply length if object is a filename. */ - if (SCM_STRINGP (object)) + if (scm_is_string (object)) SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL); 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); + c_length = scm_to_size_t (length); object = SCM_COERCE_OUTPORT (object); if (scm_is_integer (object)) @@ -1440,8 +1438,12 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, } else { - SCM_VALIDATE_STRING (1, object); - SCM_SYSCALL (rv = truncate (SCM_STRING_CHARS (object), c_length)); + char *str = scm_to_locale_string (object); + int eno; + SCM_SYSCALL (rv = truncate (str, c_length)); + eno = errno; + free (str); + errno = eno; } if (rv == -1) SCM_SYSERROR; diff --git a/libguile/procs.c b/libguile/procs.c index a03ef8bb3..a625b6e30 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -258,7 +258,7 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, if (SCM_NULLP (SCM_CDR (code))) return SCM_BOOL_F; code = SCM_CAR (code); - if (SCM_STRINGP (code)) + if (scm_is_string (code)) return code; else return SCM_BOOL_F; diff --git a/libguile/simpos.c b/libguile/simpos.c index a35de86dc..ff4637d61 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -33,6 +33,7 @@ #include "libguile/validate.h" #include "libguile/simpos.h" +#include "libguile/dynwind.h" #ifdef HAVE_STRING_H #include @@ -84,33 +85,10 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, #ifdef HAVE_SYSTEM #ifdef HAVE_WAITPID -/* return a newly allocated array of char pointers to each of the strings - in args, with a terminating NULL pointer. */ -/* Note: a similar function is defined in dynl.c, but we don't necessarily - want to export it. */ -static char ** -allocate_string_pointers (SCM args) +static void +free_string_pointers (void *data) { - char **result; - int n_args = scm_ilength (args); - int i; - - SCM_ASSERT (n_args >= 0, args, SCM_ARGn, "allocate_string_pointers"); - result = (char **) scm_malloc ((n_args + 1) * sizeof (char *)); - result[n_args] = NULL; - for (i = 0; i < n_args; i++) - { - SCM car = SCM_CAR (args); - - if (!SCM_STRINGP (car)) - { - free (result); - scm_wrong_type_arg ("allocate_string_pointers", SCM_ARGn, car); - } - result[i] = SCM_STRING_CHARS (SCM_CAR (args)); - args = SCM_CDR (args); - } - return result; + scm_i_free_string_pointers ((char **)data); } SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, @@ -146,9 +124,12 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, int pid; char **execargv; - SCM_VALIDATE_STRING (1, SCM_CAR (args)); + scm_frame_begin (0); + /* allocate before fork */ - execargv = allocate_string_pointers (args); + execargv = scm_i_allocate_string_pointers (args); + scm_frame_unwind_handler (free_string_pointers, execargv, + SCM_F_WIND_EXPLICITLY); /* make sure the child can't kill us (as per normal system call) */ sig_ign = scm_from_long ((unsigned long) SIG_IGN); @@ -161,33 +142,32 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, if (pid == 0) { /* child */ - execvp (SCM_STRING_CHARS (SCM_CAR (args)), execargv); - scm_remember_upto_here_1 (args); + execvp (execargv[0], execargv); SCM_SYSERROR; /* not reached. */ + scm_frame_end (); return SCM_BOOL_F; } else { /* parent */ - int wait_result, status, save_errno; + int wait_result, status; - save_errno = errno; - free (execargv); - errno = save_errno; if (pid == -1) SCM_SYSERROR; SCM_SYSCALL (wait_result = waitpid (pid, &status, 0)); - if (wait_result == -1) SCM_SYSERROR; + if (wait_result == -1) + SCM_SYSERROR; scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint)); scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit)); - scm_remember_upto_here_2 (oldint, oldquit); + + scm_frame_end (); return scm_from_int (status); } } else - SCM_WRONG_TYPE_ARG (1, SCM_CAR (args)); + SCM_WRONG_TYPE_ARG (1, args); } #undef FUNC_NAME #endif /* HAVE_WAITPID */ @@ -202,9 +182,10 @@ SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, #define FUNC_NAME s_scm_getenv { char *val; - SCM_VALIDATE_STRING (1, nam); - val = getenv (SCM_STRING_CHARS (nam)); - return val ? scm_mem2string (val, strlen (val)) : SCM_BOOL_F; + char *var = scm_to_locale_string (nam); + val = getenv (var); + free (var); + return val ? scm_from_locale_string (val) : SCM_BOOL_F; } #undef FUNC_NAME diff --git a/libguile/socket.c b/libguile/socket.c index 2761964ea..7135be618 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -31,6 +31,7 @@ #include "libguile/fports.h" #include "libguile/strings.h" #include "libguile/vectors.h" +#include "libguile/dynwind.h" #include "libguile/validate.h" #include "libguile/socket.h" @@ -782,8 +783,13 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, { struct sockaddr_un *soka; int addr_size; + char *c_address; + + scm_frame_begin (0); + + c_address = scm_to_locale_string (address); + scm_frame_free (c_address); - SCM_ASSERT (SCM_STRINGP (address), address, which_arg, proc); /* the static buffer size in sockaddr_un seems to be arbitrary and not necessarily a hard limit. e.g., the glibc manual suggests it may be possible to declare it size 0. let's @@ -791,15 +797,14 @@ scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, connect/bind etc., to fail. sun_path is always the last member of the structure. */ addr_size = sizeof (struct sockaddr_un) - + max (0, SCM_STRING_LENGTH (address) + 1 - (sizeof soka->sun_path)); + + max (0, strlen (c_address) + 1 - (sizeof soka->sun_path)); soka = (struct sockaddr_un *) scm_malloc (addr_size); - if (!soka) - scm_memory_error (proc); memset (soka, 0, addr_size); /* for sun_len: see sin_len above. */ soka->sun_family = AF_UNIX; - memcpy (soka->sun_path, SCM_STRING_CHARS (address), - SCM_STRING_LENGTH (address)); + strcpy (soka->sun_path, c_address); *size = SUN_LEN (soka); + + scm_frame_end (); return (struct sockaddr *) soka; } #endif diff --git a/libguile/stime.c b/libguile/stime.c index c237ae7fb..f08ae28b5 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -293,10 +293,14 @@ setzone (SCM zone, int pos, const char *subr) { static char *tmpenv[2]; char *buf; - - SCM_ASSERT (SCM_STRINGP (zone), zone, pos, subr); - buf = scm_malloc (SCM_STRING_LENGTH (zone) + sizeof (tzvar) + 1); - sprintf (buf, "%s=%s", tzvar, SCM_STRING_CHARS (zone)); + size_t zone_len; + + zone_len = scm_to_locale_stringbuf (zone, NULL, 0); + buf = scm_malloc (zone_len + sizeof (tzvar) + 1); + strcpy (buf, tzvar); + buf[sizeof(tzvar)-1] = '='; + scm_to_locale_stringbuf (zone, buf+sizeof(tzvar), zone_len); + buf[sizeof(tzvar)+zone_len] = '\0'; oldenv = environ; tmpenv[0] = buf; tmpenv[1] = 0; @@ -459,7 +463,7 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) { SCM_ASSERT (scm_is_integer (velts[i]), sbd_time, pos, subr); } - SCM_ASSERT (scm_is_false (velts[10]) || SCM_STRINGP (velts[10]), + SCM_ASSERT (scm_is_false (velts[10]) || scm_is_string (velts[10]), sbd_time, pos, subr); lt->tm_sec = scm_to_int (velts[0]); From a90968fabb5a9f7131c9f3604b9bac99c24df713 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 14:14:46 +0000 Subject: [PATCH 27/64] Docs for scm_frame_free. --- doc/ref/api-memory.texi | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/doc/ref/api-memory.texi b/doc/ref/api-memory.texi index 7be8d4243..62bc23ec6 100644 --- a/doc/ref/api-memory.texi +++ b/doc/ref/api-memory.texi @@ -121,6 +121,9 @@ in place of @code{realloc} when appropriate, @code{scm_gc_calloc} and @code{scm_calloc}, to be used in place of @code{calloc} when appropriate. +There function @code{scm_frame_free} can be useful when memory should +be freed when a frame is left, @xref{Frames}. + For really specialized needs, take at look at @code{scm_gc_register_collectable_memory} and @code{scm_gc_unregister_collectable_memory}. @@ -135,7 +138,7 @@ memory when it deems it appropriate. The memory is allocated by the libc @code{malloc} function and can be freed with @code{free}. There is no @code{scm_free} function to go with @code{scm_malloc} to make it easier to pass memory back and forth -between different modules. +between different modules. The function @code{scm_calloc} is similar to @code{scm_malloc}, but initializes the block of memory to zero as well. @@ -202,6 +205,12 @@ frees us from tracking this value in the GC itself, which will keep the memory management overhead very low. @end deftypefn +@deftypefn {C Function} void scm_frame_free (void *mem) +Equivalent to @code{scm_frame_unwind_handler (free, @var{mem}, +SCM_F_WIND_EXPLICITLY)}. That is, the memory block at @var{mem} will +be freed when the current frame is left. +@end deftypefn + @deffn {Scheme Procedure} malloc-stats Return an alist ((@var{what} . @var{n}) ...) describing number of malloced objects. From 91210d629f70da49a2912da0e77f79a3a3e8123c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 14:15:33 +0000 Subject: [PATCH 28/64] Docs for scm_is_string, scm_to_locale_string*, and scm_from_locale_string*. --- doc/ref/api-data.texi | 82 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index ed36baf6c..f89c61930 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1869,6 +1869,7 @@ called with string containing unusual characters. * String Searching:: Searching in strings. * Alphabetic Case Mapping:: Convert the alphabetic case of strings. * Appending Strings:: Appending strings to form a new string. +* Conversion to/from C:: @end menu @node String Syntax @@ -1946,6 +1947,10 @@ fulfills some specified property. Return @code{#t} if @var{obj} is a string, else @code{#f}. @end deffn +@deftypefn {C Function} int scm_is_string (SCM obj) +Returns @code{1} if @var{obj} is a string, @code{0} otherwise. +@end deftypefn + @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 @@ -2311,6 +2316,83 @@ concatenation of the given strings, @var{args}. @end example @end deffn +@node Conversion to/from C +@subsubsection Conversion to/from C + +When creating a Scheme string from a C string or when converting a +Scheme string to a C string, the concept of character encoding becomes +important. + +In C, a string is just a sequence of bytes, and the character encoding +describes the relation between these bytes and the actual characters +that the string contains. For Scheme strings, character encoding not +an issue (most of the time), since in Scheme you never get to see the +bytes, only the characters. + +Well, ideally, anyway. Right now, Guile simply equates Scheme +characters and bytes, ignoring the possibility of multi-byte encodings +completely. This will change in the future, where Guile will use +Unicode codepoints as its characters and UTF-8 (or maybe UCS-4) as its +internal encoding. When you exclusively use the functions listed in +this section, you are `future-proof'. + +Converting a Scheme string to a C string will allocate fresh memory to +hold the result. You must take care that this memory is properly +freed eventually. In many cases, this can be achieved by using +@code{scm_frame_free} inside an appropriate frame, @xref{Frames}. + +@deftypefn {C Function} SCM scm_from_locale_string (const char *str) +@deftypefnx {C Function} SCM scm_from_locale_stringn (const char *str, size_t len) +Creates a new Scheme string that has the same contents as @var{str} +when interpreted in the current locale character encoding. + +For @code{scm_from_locale_string}, @var{str} must be null-terminated. + +For @code{scm_from_locale_stringn}, @var{len} specifies the length of +@var{str} in bytes, and @var{str} does not need to be null-terminated. +If @var{len} is @code{(size_t)-1}, then @var{str} does need to be +null-terminated and the real length will be found with @code{strlen}. +@end deftypefn + +@deftypefn {C Function} SCM scm_take_locale_string (char *str) +@deftypefnx {C Function} SCM scm_take_locale_stringn (char *str, size_t len) +Like @code{scm_from_locale_string} and @code{scm_from_locale_stringn}, +respectively, but also frees @var{str} with @code{free} eventually. +Thus, you can use this function when you would free @var{str} anyway +immediately after creating the Scheme string. In certain cases, Guile +can then use @var{str} directly as its internal representation. +@end deftypefn + +@deftypefn {C Function} char *scm_to_locale_string (SCM str) +@deftypefnx {C Function} char *scm_to_locale_stringn (SCM str, size_t *lenp) +Returns a C string in the current locale encoding with the same +contents as @var{str}. The C string must be freed with @code{free} +eventually, maybe by using @code{scm_frame_free}, @xref{Frames}. + +For @code{scm_to_locale_string}, the returned string is +null-terminated and an error is signalled when @var{str} contains +@code{#\nul} characters. + +For @code{scm_to_locale_stringn} and @var{lenp} not @code{NULL}, +@var{str} might contain @code{#\nul} characters and the length of the +returned string in bytes is stored in @code{*@var{lenp}}. The +returned string will not be null-terminated in this case. If +@var{lenp} is @code{NULL}, @code{scm_to_locale_stringn} behaves like +@code{scm_to_locale_string}. +@end deftypefn + +@deftypefn {C Function} size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len) +Puts @var{str} as a C string in the current locale encoding into the +memory pointed to by @var{buf}. The buffer at @var{buf} has room for +@var{max_len} bytes and @code{scm_to_local_stringbuf} will never store +more than that. No terminating @code{'\0'} will be stored. + +The return value of @code{scm_to_locale_stringbuf} is the number of +bytes that are needed for all of @var{str}, regardless of whether +@var{buf} was large enough to hold them. Thus, when the return value +is larger than @var{max_len}, only @var{max_len} bytes have been +stored and you probably need to try again with a larger buffer. +@end deftypefn @node Regular Expressions @subsection Regular Expressions From 273167608a1a3c37bc9f8e68b4d52e01af1bcf8d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 14:16:34 +0000 Subject: [PATCH 29/64] Updated example to use scm_to_locale_string instead of roll-your-own scm_to_string. Also showcase scm_frame_free. --- doc/ref/api-control.texi | 30 ++++++++++-------------------- 1 file changed, 10 insertions(+), 20 deletions(-) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index cbc386a05..ae64514da 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1077,24 +1077,8 @@ 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) @{ @@ -1102,11 +1086,17 @@ scm_foo (SCM s1, SCM s2) scm_frame_begin (0); - c_s1 = scm_to_string (s1); + c_s1 = scm_to_locale_string (s1); + + /* Call 'free (c_s1)' when the frame is left. + */ 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_s2 = scm_to_locale_string (s2); + + /* Same as above, but more concisely. + */ + scm_frame_free (c_s2); c_res = foo (c_s1, c_s2); if (c_res == NULL) @@ -1114,7 +1104,7 @@ scm_foo (SCM s1, SCM s2) scm_frame_end (); - return scm_take0str (res); + return scm_take_locale_string (res); @} @end example From f9751e8660b05a730218378dd99393adabf21139 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 14:16:46 +0000 Subject: [PATCH 30/64] *** empty log message *** --- doc/ref/ChangeLog | 11 +++++++++++ libguile/ChangeLog | 2 +- 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 8189d628a..ee0a50b20 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,14 @@ +2004-08-10 Marius Vollmer + + * api-control.texi: Updated example to use scm_to_locale_string + instead of roll-your-own scm_to_string. Also showcase + scm_frame_free. + + * api-data.texi: Docs for scm_is_string, scm_to_locale_string*, + and scm_from_locale_string*. + + * api-memory.texi: Docs for scm_frame_free. + 2004-08-09 Kevin Ryde * api-io.texi (File Ports): In open-file, describe the "b" binary flag. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 15ab194bb..053c0af17 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -5,7 +5,7 @@ * deprecated.c, deprecated.h (SCM_CHARS, SCM_LENGTH): Removed. - * strings.h, strings.c (SCM_MAKE_STRING_TAG): Rename dto + * strings.h, strings.c (SCM_MAKE_STRING_TAG): Renamed to SCM_I_MAKE_STRING_TAG, changed all uses. (SCM_STRING_CHARS, SCM_STRING_UCHARS, SCM_STRING_LENGTH): Renamed to SCM_I_STRING_CHARS, SCM_I_STRING_UCHARS, and SCM_I_LENGTH From 9bd10f4617927c04ec135183ed28c9d4969a5a41 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 15:45:49 +0000 Subject: [PATCH 31/64] (test_locale_strings): New. --- test-suite/standalone/test-conversion.c | 161 ++++++++++++++++++++++++ 1 file changed, 161 insertions(+) diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c index 59f65befa..ff246325f 100644 --- a/test-suite/standalone/test-conversion.c +++ b/test-suite/standalone/test-conversion.c @@ -19,6 +19,7 @@ #include #include +#include static void test_1 (const char *str, scm_t_intmax min, scm_t_intmax max, @@ -196,6 +197,12 @@ wrong_type_handler (void *data, SCM key, SCM args) return scm_equal_p (key, scm_str2symbol ("wrong-type-arg")); } +static SCM +misc_error_handler (void *data, SCM key, SCM args) +{ + return scm_equal_p (key, scm_str2symbol ("misc-error")); +} + static SCM any_handler (void *data, SCM key, SCM args) { @@ -850,6 +857,159 @@ test_to_double () test_10 ("+1i", 0.0, 1); } +typedef struct { + SCM val; + char *result; +} to_locale_string_data; + +static SCM +to_locale_string_body (void *data) +{ + to_locale_string_data *d = (to_locale_string_data *)data; + d->result = scm_to_locale_string (d->val); + return SCM_BOOL_F; +} + +static void +test_11 (const char *str, const char *result, int misc_error, int type_error) +{ + to_locale_string_data data; + data.val = scm_c_eval_string (str); + data.result = NULL; + + if (misc_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_locale_string_body, &data, + misc_error_handler, NULL))) + { + fprintf (stderr, + "fail: scm_to_locale_string (%s) -> misc error\n", str); + exit (1); + } + } + else if (type_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_locale_string_body, &data, + wrong_type_handler, NULL))) + { + fprintf (stderr, + "fail: scm_to_locale_string (%s) -> wrong type\n", str); + exit (1); + } + } + else + { + if (scm_is_true (scm_internal_catch (SCM_BOOL_T, + to_locale_string_body, &data, + any_handler, NULL)) + || data.result == NULL || strcmp (data.result, result)) + { + fprintf (stderr, + "fail: scm_to_locale_string (%s) = %s\n", str, result); + exit (1); + } + } + + free (data.result); +} + +static void +test_locale_strings () +{ + const char *lstr = "This is not a string."; + char *lstr2; + SCM str, str2; + char buf[20]; + size_t len; + + if (!scm_is_string (scm_c_eval_string ("\"foo\""))) + { + fprintf (stderr, "fail: scm_is_string (\"foo\") = true\n"); + exit (1); + } + + str = scm_from_locale_string (lstr); + + if (!scm_is_string (str)) + { + fprintf (stderr, "fail: scm_is_string (str) = true\n"); + exit (1); + } + + lstr2 = scm_to_locale_string (str); + if (strcmp (lstr, lstr2)) + { + fprintf (stderr, "fail: lstr = lstr2\n"); + exit (1); + } + free (lstr2); + + buf[15] = 'x'; + len = scm_to_locale_stringbuf (str, buf, 15); + if (len != strlen (lstr)) + { + fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = strlen(lstr)\n"); + exit (1); + } + if (buf[15] != 'x') + { + fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n"); + exit (1); + } + if (strncmp (lstr, buf, 15)) + { + fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n"); + exit (1); + } + + str2 = scm_from_locale_stringn (lstr, 10); + + if (!scm_is_string (str2)) + { + fprintf (stderr, "fail: scm_is_string (str2) = true\n"); + exit (1); + } + + lstr2 = scm_to_locale_string (str2); + if (strncmp (lstr, lstr2, 10)) + { + fprintf (stderr, "fail: lstr = lstr2\n"); + exit (1); + } + free (lstr2); + + buf[10] = 'x'; + len = scm_to_locale_stringbuf (str2, buf, 20); + if (len != 10) + { + fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = 10\n"); + exit (1); + } + if (buf[10] != 'x') + { + fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n"); + exit (1); + } + if (strncmp (lstr, buf, 10)) + { + fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n"); + exit (1); + } + + lstr2 = scm_to_locale_stringn (str2, &len); + if (len != 10) + { + fprintf (stderr, "fail: scm_to_locale_stringn, len = 10\n"); + exit (1); + } + + test_11 ("#f", NULL, 0, 1); + test_11 ("\"foo\"", "foo", 0, 0); + test_11 ("(string #\\f #\\nul)", NULL, 1, 0); +} + int main (int argc, char *argv[]) { @@ -863,5 +1023,6 @@ main (int argc, char *argv[]) test_int_sizes (); test_from_double (); test_to_double (); + test_locale_strings (); return 0; } From 44825fffb027bb0057ff88e3ca23324d37708eca Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 15:45:58 +0000 Subject: [PATCH 32/64] *** empty log message *** --- test-suite/ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index ceb5a0b2d..b02229bbd 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,5 +1,7 @@ 2004-08-10 Marius Vollmer + * standalone/test-conversion.c (test_locale_strings): New. + * standalone/test-round.c: Replaced all uses of scm_round with scm_c_round. From c88453e881a4d67fb93675f7fc8327dfc120371e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 15:58:57 +0000 Subject: [PATCH 33/64] Typos. --- doc/ref/api-data.texi | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index f89c61930..2a4934bf5 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -2325,9 +2325,9 @@ important. In C, a string is just a sequence of bytes, and the character encoding describes the relation between these bytes and the actual characters -that the string contains. For Scheme strings, character encoding not -an issue (most of the time), since in Scheme you never get to see the -bytes, only the characters. +that make up the string. For Scheme strings, character encoding is +not an issue (most of the time), since in Scheme you never get to see +the bytes, only the characters. Well, ideally, anyway. Right now, Guile simply equates Scheme characters and bytes, ignoring the possibility of multi-byte encodings @@ -2336,10 +2336,11 @@ Unicode codepoints as its characters and UTF-8 (or maybe UCS-4) as its internal encoding. When you exclusively use the functions listed in this section, you are `future-proof'. -Converting a Scheme string to a C string will allocate fresh memory to -hold the result. You must take care that this memory is properly -freed eventually. In many cases, this can be achieved by using -@code{scm_frame_free} inside an appropriate frame, @xref{Frames}. +Converting a Scheme string to a C string will often allocate fresh +memory to hold the result. You must take care that this memory is +properly freed eventually. In many cases, this can be achieved by +using @code{scm_frame_free} inside an appropriate frame, +@xref{Frames}. @deftypefn {C Function} SCM scm_from_locale_string (const char *str) @deftypefnx {C Function} SCM scm_from_locale_stringn (const char *str, size_t len) From 214195e127847a83fe44d2d8d698c820b868ec07 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 10 Aug 2004 15:59:31 +0000 Subject: [PATCH 34/64] Removed commented out debugging fprintfs. --- libguile/load.c | 3 --- 1 file changed, 3 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 3cc48b969..938a86c94 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -240,7 +240,6 @@ stringbuf_grow (struct stringbuf *buf) { size_t ptroff = buf->ptr - buf->buf; buf->buf_len *= 2; - // fprintf (stderr, "growing to %u\n", buf->buf_len); buf->buf = scm_realloc (buf->buf, buf->buf_len); buf->ptr = buf->buf + ptroff; } @@ -409,8 +408,6 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, /* If the file exists at all, we should return it. If the file is inaccessible, then that's an error. */ - // fprintf (stderr, "trying: %s\n", buf.buf); - if (stat (buf.buf, &mode) == 0 && ! (mode.st_mode & S_IFDIR)) { From 35da08ee37b4d68075c3461d5658b6c9a43c3dff Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 11 Aug 2004 19:36:55 +0000 Subject: [PATCH 35/64] (scm_c_round, scm_c_truncate): Docs for'em. --- doc/ref/api-data.texi | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 2a4934bf5..6601c96da 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1141,6 +1141,12 @@ Round the number @var{x} towards minus infinity. Round the number @var{x} towards infinity. @end deffn +@deftypefn {C Function} double scm_c_truncate (double x) +@deftypefnx {C Function} double scm_c_round (double x) +Like @code{scm_truncate_number} or @code{scm_round_number}, +respectively, but these functions take and return @code{double} +values. +@end deftypefn @node Scientific @subsubsection Scientific Functions From 82c76fd357e059f7bc662b29c8d6abcd557f94b4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 11 Aug 2004 19:38:58 +0000 Subject: [PATCH 36/64] (scm_init_storage, scm_stand_in_procs, scm_stand_in_proc): Use a hastable for scm_stand_in_procs instead of an alist. Thanks to Matthias Koeppe! --- libguile/gc.c | 2 +- libguile/procprop.c | 13 +++++++------ 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/libguile/gc.c b/libguile/gc.c index 5f966acd0..4c0a633f7 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -917,7 +917,7 @@ scm_init_storage () #endif #endif - scm_stand_in_procs = SCM_EOL; + scm_stand_in_procs = scm_c_make_hash_table (257); scm_permobjs = SCM_EOL; scm_protects = scm_c_make_hash_table (31); scm_gc_registered_roots = scm_c_make_hash_table (31); diff --git a/libguile/procprop.c b/libguile/procprop.c index d91c72904..03043890d 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,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 @@ -28,6 +28,7 @@ #include "libguile/smob.h" #include "libguile/root.h" #include "libguile/vectors.h" +#include "libguile/hashtab.h" #include "libguile/validate.h" #include "libguile/procprop.h" @@ -136,15 +137,15 @@ scm_i_procedure_arity (SCM proc) static SCM scm_stand_in_scm_proc(SCM proc) { - SCM answer; - answer = scm_assq (proc, scm_stand_in_procs); - if (scm_is_false (answer)) + SCM handle, answer; + handle = scm_hashq_get_handle (scm_stand_in_procs, proc); + if (scm_is_false (handle)) { answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL); - scm_stand_in_procs = scm_acons (proc, answer, scm_stand_in_procs); + scm_hashq_set_x (scm_stand_in_procs, proc, answer); } else - answer = SCM_CDR (answer); + answer = SCM_CDR (handle); return answer; } From bb26cc2d28d8398385ac2e5c8390666526f64d22 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 11 Aug 2004 19:39:44 +0000 Subject: [PATCH 37/64] *** empty log message *** --- doc/ref/ChangeLog | 4 ++++ libguile/ChangeLog | 6 ++++++ 2 files changed, 10 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index ee0a50b20..565492418 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,7 @@ +2004-08-11 Marius Vollmer + + * api-data.texi (scm_c_round, scm_c_truncate): Docs for'em. + 2004-08-10 Marius Vollmer * api-control.texi: Updated example to use scm_to_locale_string diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 053c0af17..4fcc39edd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2004-08-11 Marius Vollmer + + * gc.c, procprop.c (scm_init_storage, scm_stand_in_procs, + scm_stand_in_proc): Use a hastable for scm_stand_in_procs instead + of an alist. Thanks to Matthias Koeppe! + 2004-08-10 Marius Vollmer * strings.h, deprecated.h (SCM_STRING_COERCE_0TERMINATION_X): From ffa747a6ead5e8ba3c6af1fc26c4bbaa72e2d72b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 11:57:42 +0000 Subject: [PATCH 38/64] (scm_primitive_load_path): Do not check for absolute filenames when scm_sys_search_load_path returns false, which will return absolute filenames unchanged. --- libguile/load.c | 17 ++--------------- 1 file changed, 2 insertions(+), 15 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 938a86c94..449855224 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -468,24 +468,11 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, { SCM full_filename; - SCM_VALIDATE_STRING (1, filename); - full_filename = scm_sys_search_load_path (filename); if (scm_is_false (full_filename)) - { - int absolute = (SCM_STRING_LENGTH (filename) >= 1 -#ifdef __MINGW32__ - && (SCM_STRING_CHARS (filename)[0] == '/' || - SCM_STRING_CHARS (filename)[0] == '\\')); -#else - && SCM_STRING_CHARS (filename)[0] == '/'); -#endif - SCM_MISC_ERROR ((absolute - ? "Unable to load file ~S" - : "Unable to find file ~S in load path"), - scm_list_1 (filename)); - } + SCM_MISC_ERROR ("Unable to find file ~S in load path", + scm_list_1 (filename)); return scm_primitive_load (full_filename); } From d617ee1895503e4b85da9fa72fcafb7a3b79951d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:03:36 +0000 Subject: [PATCH 39/64] * fports.h, fports.c (scm_i_fdes_to_port): New, like scm_fdes_to_port, but take mode bits directly instead of as a C string. (scm_i_fdes_to_port): Implement using above. (scm_open_file): Use scm_i_fdes_to_port together with scm_i_mode_bits to avoid accessing internals of SCM string from C. * vports.c (scm_make_soft_port): Use scm_i_fdes_to_port together with scm_i_mode_bits to avoid accessing internals of SCM string from C. * ports.h (scm_i_mode_bits): New, same as scm_mode_bits but with a SCM string as argument. * ports.c (scm_i_void_port): New, like scm_void_port but take mode bits directly instead of C string. (scm_void_port): Implement using above. (scm_sys_make_void_port): Use scm_i_void_port together with scm_i_mode_bits to avoid accessing internals of SCM string. * convert.i.c, backtrace.c, strop.c, strorder.c, strports.c, struct.c, unif.c, ports.c: Use SCM_I_STRING_CHARS, SCM_I_STRING_UCHARS, and SCM_I_STRING_LENGTH instead of SCM_STRING_CHARS, SCM_STRING_UCHARS, and SCM_STRING_LENGTH, respectively. Also, replaced scm_return_first with more explicit scm_remember_upto_here_1, etc, or introduced them in the first place. --- libguile/fports.c | 11 ++++++++--- libguile/fports.h | 4 ++++ libguile/ports.c | 30 +++++++++++++++++++++++------- libguile/ports.h | 5 +++++ libguile/vports.c | 2 +- 5 files changed, 41 insertions(+), 11 deletions(-) diff --git a/libguile/fports.c b/libguile/fports.c index 6b462e03e..769474952 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -342,7 +342,7 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, scm_cons (scm_strerror (scm_from_int (en)), scm_cons (filename, SCM_EOL)), en); } - port = scm_fdes_to_port (fdes, md, filename); + port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode), filename); scm_frame_end (); @@ -401,10 +401,9 @@ static int getflags (int fdes) NAME is a string to be used as the port's filename. */ SCM -scm_fdes_to_port (int fdes, char *mode, SCM name) +scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) #define FUNC_NAME "scm_fdes_to_port" { - long mode_bits = scm_mode_bits (mode); SCM port; scm_t_port *pt; int flags; @@ -448,6 +447,12 @@ scm_fdes_to_port (int fdes, char *mode, SCM name) } #undef FUNC_NAME +SCM +scm_fdes_to_port (int fdes, char *mode, SCM name) +{ + return scm_i_fdes_to_port (fdes, scm_mode_bits (mode), name); +} + /* Return a lower bound on the number of bytes available for input. */ static int fport_input_waiting (SCM port) diff --git a/libguile/fports.h b/libguile/fports.h index 9ce23f546..3d88c2fb4 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -55,6 +55,10 @@ SCM_API SCM scm_fdes_to_port (int fdes, char *mode, SCM name); SCM_API SCM scm_file_port_p (SCM obj); SCM_API void scm_init_fports (void); +/* internal functions */ + +SCM_API SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name); + #endif /* SCM_FPORTS_H */ /* diff --git a/libguile/ports.c b/libguile/ports.c index 02d72b448..d0931ed71 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -330,7 +330,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, count += pt->saved_read_end - pt->saved_read_pos; result = scm_allocate_string (count); - scm_take_from_input_buffers (port, SCM_STRING_CHARS (result), count); + scm_take_from_input_buffers (port, SCM_I_STRING_CHARS (result), count); return result; } @@ -680,6 +680,18 @@ scm_mode_bits (char *modes) | (strchr (modes, 'l') ? SCM_BUFLINE : 0)); } +long +scm_i_mode_bits (SCM modes) +{ + long bits; + + if (!scm_is_string (modes)) + scm_wrong_type_arg_msg (NULL, 0, modes, "string"); + + bits = scm_mode_bits (SCM_I_STRING_CHARS (modes)); + scm_remember_upto_here_1 (modes); + return bits; +} /* Return the mode flags from an open port. * Some modes such as "append" are only used when opening @@ -1310,7 +1322,7 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0, else SCM_VALIDATE_OPINPORT (2, port); - scm_ungets (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), port); + scm_ungets (SCM_I_STRING_CHARS (str), SCM_I_STRING_LENGTH (str), port); return str; } @@ -1599,12 +1611,11 @@ write_void_port (SCM port SCM_UNUSED, { } -SCM -scm_void_port (char *mode_str) +static SCM +scm_i_void_port (long mode_bits) { scm_mutex_lock (&scm_i_port_table_mutex); { - int mode_bits = scm_mode_bits (mode_str); SCM answer = scm_new_port_table_entry (scm_tc16_void_port); scm_t_port * pt = SCM_PTAB_ENTRY(answer); @@ -1617,6 +1628,12 @@ scm_void_port (char *mode_str) } } +SCM +scm_void_port (char *mode_str) +{ + return scm_i_void_port (scm_mode_bits (mode_str)); +} + SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1, 0, 0, (SCM mode), "Create and return a new void port. A void port acts like\n" @@ -1625,8 +1642,7 @@ SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1, 0, 0, "documentation for @code{open-file} in @ref{File Ports}.") #define FUNC_NAME s_scm_sys_make_void_port { - SCM_VALIDATE_STRING (1, mode); - return scm_void_port (SCM_STRING_CHARS (mode)); + return scm_i_void_port (scm_i_mode_bits (mode)); } #undef FUNC_NAME diff --git a/libguile/ports.h b/libguile/ports.h index ee53d3773..93f3344cc 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -301,6 +301,11 @@ SCM_API SCM scm_pt_size (void); SCM_API SCM scm_pt_member (SCM member); #endif /* GUILE_DEBUG */ +/* internal */ + +SCM_API long scm_i_mode_bits (SCM modes); + + #endif /* SCM_PORTS_H */ /* diff --git a/libguile/vports.c b/libguile/vports.c index 096b26c7f..e99d7961c 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -196,7 +196,7 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, z = scm_new_port_table_entry (scm_tc16_sfport); pt = SCM_PTAB_ENTRY (z); scm_port_non_buffer (pt); - SCM_SET_CELL_TYPE (z, scm_tc16_sfport | scm_mode_bits (SCM_STRING_CHARS (modes))); + SCM_SET_CELL_TYPE (z, scm_tc16_sfport | scm_i_mode_bits (modes)); SCM_SETSTREAM (z, SCM_UNPACK (pv)); scm_mutex_unlock (&scm_i_port_table_mutex); From 4695c759477615b3e103a0c0ed4539e158838142 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:06:37 +0000 Subject: [PATCH 40/64] (load_extension): Convert lib and init to locale strings instead of accessing the internals directly. (scm_c_load_extension): Use scm_from_locale_string instead of scm_makfrom0str. --- libguile/extensions.c | 36 +++++++++++++++++++++++------------- 1 file changed, 23 insertions(+), 13 deletions(-) diff --git a/libguile/extensions.c b/libguile/extensions.c index 61948a84c..f6e1e1b9e 100644 --- a/libguile/extensions.c +++ b/libguile/extensions.c @@ -27,6 +27,7 @@ #include "libguile/strings.h" #include "libguile/gc.h" #include "libguile/dynl.h" +#include "libguile/dynwind.h" #include "libguile/extensions.h" @@ -71,17 +72,28 @@ static void load_extension (SCM lib, SCM init) { /* Search the registry. */ - { - extension_t *ext; + if (registered_extensions != NULL) + { + extension_t *ext; + char *clib, *cinit; - for (ext = registered_extensions; ext; ext = ext->next) - if ((ext->lib == NULL || !strcmp (ext->lib, SCM_STRING_CHARS (lib))) - && !strcmp (ext->init, SCM_STRING_CHARS (init))) - { - ext->func (ext->data); - return; - } - } + scm_frame_begin (0); + + clib = scm_to_locale_string (lib); + scm_frame_free (clib); + cinit = scm_to_locale_string (init); + scm_frame_free (cinit); + + for (ext = registered_extensions; ext; ext = ext->next) + if ((ext->lib == NULL || !strcmp (ext->lib, clib)) + && !strcmp (ext->init, cinit)) + { + ext->func (ext->data); + break; + } + + scm_frame_end (); + } /* Dynamically link the library. */ scm_dynamic_call (init, scm_dynamic_link (lib)); @@ -90,7 +102,7 @@ load_extension (SCM lib, SCM init) void scm_c_load_extension (const char *lib, const char *init) { - load_extension (scm_makfrom0str (lib), scm_makfrom0str (init)); + load_extension (scm_from_locale_string (lib), scm_from_locale_string (init)); } SCM_DEFINE (scm_load_extension, "load-extension", 2, 0, 0, @@ -131,8 +143,6 @@ SCM_DEFINE (scm_load_extension, "load-extension", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_load_extension { - SCM_VALIDATE_STRING (1, lib); - SCM_VALIDATE_STRING (2, init); load_extension (lib, init); return SCM_UNSPECIFIED; } From 86e14f5c3b3c4b0240381f2805e008334f172c33 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:16:49 +0000 Subject: [PATCH 41/64] (scm_fdopen): Use scm_i_fdes_to_port together with scm_i_mode_bits to avoid accessing internals of SCM string from C. --- libguile/ioext.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/ioext.c b/libguile/ioext.c index 09392c057..22a2de57e 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -32,6 +32,7 @@ #include "libguile/ports.h" #include "libguile/strings.h" #include "libguile/validate.h" +#include "libguile/dynwind.h" #include @@ -218,9 +219,8 @@ 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_STRING (2, modes); - return scm_fdes_to_port (scm_to_int (fdes), - SCM_STRING_CHARS (modes), SCM_BOOL_F); + return scm_i_fdes_to_port (scm_to_int (fdes), + scm_i_mode_bits (modes), SCM_BOOL_F); } #undef FUNC_NAME From f015614ae0102da219e2de3892d6bf51a4a499d7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:28:06 +0000 Subject: [PATCH 42/64] (WITH_STRING): New helper macro. Use it where one locale string is needed for a short piece of code. (STRING_SYSCALL): New helper macro. Use it instead of SCM_SYSCALL when one locale string is needed. (scm_mkstemp): Convert tmpl to a locale string. (scm_putenv): Rewritten to use only C strings. (scm_setlocale, scm_crpt): Convert argument strings to locale strings. --- libguile/posix.c | 163 +++++++++++++++++++++++++++-------------------- 1 file changed, 94 insertions(+), 69 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index dc10d7ea7..37b46bdaf 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -188,6 +188,27 @@ extern char ** environ; #define environ (*_NSGetEnviron()) #endif + + +/* Two often used patterns + */ + +#define WITH_STRING(str,cstr,code) \ + do { \ + char *cstr = scm_to_locale_string (str); \ + code; \ + free (cstr); \ + } while (0) + +#define STRING_SYSCALL(str,cstr,code) \ + do { \ + int eno; \ + char *cstr = scm_to_locale_string (str); \ + SCM_SYSCALL (code); \ + eno = errno; free (cstr); errno = eno; \ + } while (0) + + SCM_SYMBOL (sym_read_pipe, "read pipe"); SCM_SYMBOL (sym_write_pipe, "write pipe"); @@ -328,8 +349,8 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, } else { - SCM_VALIDATE_STRING (1, user); - entry = getpwnam (SCM_STRING_CHARS (user)); + WITH_STRING (user, c_user, + entry = getpwnam (c_user)); } if (!entry) SCM_MISC_ERROR ("entry not found", SCM_EOL); @@ -394,10 +415,8 @@ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0, else if (scm_is_integer (name)) SCM_SYSCALL (entry = getgrgid (scm_to_int (name))); else - { - SCM_VALIDATE_STRING (1, name); - SCM_SYSCALL (entry = getgrnam (SCM_STRING_CHARS (name))); - } + STRING_SYSCALL (name, c_name, + entry = getgrnam (c_name)); if (!entry) SCM_SYSERROR; @@ -1117,10 +1136,13 @@ SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, #define FUNC_NAME s_scm_mkstemp { char *c_tmpl; - int rv; + int rv, eno; - SCM_VALIDATE_STRING_COPY (1, tmpl, c_tmpl); + c_tmpl = scm_to_locale_string (tmpl); SCM_SYSCALL (rv = mkstemp (c_tmpl)); + eno = errno; + free (c_tmpl); + errno = eno; if (rv == -1) SCM_SYSERROR; return scm_fdes_to_port (rv, "w+", tmpl); @@ -1144,7 +1166,6 @@ SCM_DEFINE (scm_utime, "utime", 1, 2, 0, int rv; struct utimbuf utm_tmp; - SCM_VALIDATE_STRING (1, pathname); if (SCM_UNBNDP (actime)) SCM_SYSCALL (time (&utm_tmp.actime)); else @@ -1155,7 +1176,8 @@ SCM_DEFINE (scm_utime, "utime", 1, 2, 0, else utm_tmp.modtime = SCM_NUM2ULONG (3, modtime); - SCM_SYSCALL (rv = utime (SCM_STRING_CHARS (pathname), &utm_tmp)); + STRING_SYSCALL (pathname, c_pathname, + rv = utime (c_pathname, &utm_tmp)); if (rv != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1191,8 +1213,8 @@ SCM_DEFINE (scm_access, "access?", 2, 0, 0, { int rv; - SCM_VALIDATE_STRING (1, path); - rv = access (SCM_STRING_CHARS (path), scm_to_int (how)); + WITH_STRING (path, c_path, + rv = access (c_path, scm_to_int (how))); return scm_from_bool (!rv); } #undef FUNC_NAME @@ -1220,42 +1242,35 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, #define FUNC_NAME s_scm_putenv { int rv; - char *ptr; + char *c_str = scm_to_locale_string (str); +#ifdef __MINGW32__ + size_t len = strlen (c_str); +#endif - SCM_VALIDATE_STRING (1, str); - - if (strchr (SCM_STRING_CHARS (str), '=') == NULL) + if (strchr (c_str, '=') == NULL) { #ifdef HAVE_UNSETENV /* No '=' in argument means we should remove the variable from the environment. Not all putenvs understand this (for instance FreeBSD 4.8 doesn't). To be safe, we do it explicitely using unsetenv. */ - unsetenv (SCM_STRING_CHARS (str)); + unsetenv (c_str); + free (c_str); #else /* On e.g. Win32 hosts putenv() called with 'name=' removes the environment variable 'name'. */ int e; - ptr = scm_malloc (SCM_STRING_LENGTH (str) + 2); - if (ptr == NULL) - SCM_MEMORY_ERROR; - strncpy (ptr, SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str)); - ptr[SCM_STRING_LENGTH (str)] = '='; - ptr[SCM_STRING_LENGTH (str) + 1] = 0; + ptr = scm_malloc (len + 2); + strcpy (ptr, c_str); + strcpy (ptr+len, "="); rv = putenv (ptr); - e = errno; free (ptr); errno = e; + e = errno; free (ptr); free (c_str); errno = e; if (rv < 0) SCM_SYSERROR; #endif /* !HAVE_UNSETENV */ } else { - /* must make a new copy to be left in the environment, safe from gc. */ - ptr = scm_malloc (SCM_STRING_LENGTH (str) + 1); - if (ptr == NULL) - SCM_MEMORY_ERROR; - strncpy (ptr, SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str)); - #ifdef __MINGW32__ /* If str is "FOO=", ie. attempting to set an empty string, then we need to see if it's been successful. On MINGW, "FOO=" @@ -1263,35 +1278,32 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, set "FOO= ", ie. a space, and then modify the string returned by getenv. It's not enough just to modify the string we set, because MINGW putenv copies it. */ - if (ptr[SCM_STRING_LENGTH (str) - 1] == '=') + + if (c_str[len-1] == '=') { - char *alt; - 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); - if (alt == NULL) - { - free (ptr); - SCM_MEMORY_ERROR; - } - memcpy (alt, SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str)); - alt[SCM_STRING_LENGTH (str)] = ' '; - alt[SCM_STRING_LENGTH (str) + 1] = '\0'; - rv = putenv (alt); - if (rv < 0) - SCM_SYSERROR; - free (ptr); /* don't need the old string we gave to putenv */ + char *ptr = scm_malloc (len+2); + strcpy (ptr, c_str); + strcpy (ptr+len, " "); + rv = putenv (ptr); + if (rv < 0) + { + int eno = errno; + free (c_str); + errno = eno; + SCM_SYSERROR; } - alt = getenv (SCM_STRING_CHARS (name)); - alt[0] = '\0'; + /* truncate to just the name */ + c_str[len-1] = '\0'; + ptr = getenv (c_str); + if (ptr) + ptr[0] = '\0'; return SCM_UNSPECIFIED; } #endif /* __MINGW32__ */ - ptr[SCM_STRING_LENGTH (str)] = 0; - rv = putenv (ptr); + /* Leave c_str in the environment. */ + + rv = putenv (c_str); if (rv < 0) SCM_SYSERROR; } @@ -1316,20 +1328,24 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, char *clocale; char *rv; + scm_frame_begin (0); + if (SCM_UNBNDP (locale)) { clocale = NULL; } else { - SCM_VALIDATE_STRING (2, locale); - clocale = SCM_STRING_CHARS (locale); + clocale = scm_to_locale_string (locale); + scm_frame_free (clocale); } rv = setlocale (scm_to_int (category), clocale); if (rv == NULL) SCM_SYSERROR; - return scm_makfrom0str (rv); + + scm_frame_end (); + return scm_from_locale_string (rv); } #undef FUNC_NAME #endif /* HAVE_SETLOCALE */ @@ -1379,9 +1395,10 @@ 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_to_int (perms), - scm_to_int (dev))); + STRING_SYSCALL (path, c_path, + val = mknod (c_path, + ctype | scm_to_int (perms), + scm_to_int (dev))); if (val != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1443,8 +1460,7 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, #define FUNC_NAME s_scm_crypt { SCM ret; - SCM_VALIDATE_STRING (1, key); - SCM_VALIDATE_STRING (2, salt); + char *c_key, *c_salt; scm_frame_begin (0); scm_frame_unwind_handler ((void(*)(void*)) scm_mutex_unlock, @@ -1452,8 +1468,12 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, SCM_F_WIND_EXPLICITLY); scm_mutex_lock (&scm_i_misc_mutex); - ret = scm_makfrom0str (crypt (SCM_STRING_CHARS (key), - SCM_STRING_CHARS (salt))); + c_key = scm_to_locale_string (key); + scm_frame_free (c_key); + c_salt = scm_to_locale_string (salt); + scm_frame_free (c_key); + + ret = scm_from_locale_string (crypt (c_key, c_salt)); scm_frame_end (); return ret; @@ -1471,9 +1491,11 @@ SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0, "root directory.") #define FUNC_NAME s_scm_chroot { - SCM_VALIDATE_STRING (1, path); + int rv; - if (chroot (SCM_STRING_CHARS (path)) == -1) + WITH_STRING (path, c_path, + rv = chroot (c_path)); + if (rv == -1) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -1611,8 +1633,9 @@ SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0, SCM_VALIDATE_STRING (1, prompt); - p = getpass(SCM_STRING_CHARS (prompt)); - passwd = scm_makfrom0str (p); + WITH_STRING (prompt, c_prompt, + p = getpass(c_prompt)); + passwd = scm_from_locale_string (p); /* Clear out the password in the static buffer. */ memset (p, 0, strlen (p)); @@ -1735,9 +1758,11 @@ SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0, "specified.") #define FUNC_NAME s_scm_sethostname { - SCM_VALIDATE_STRING (1, name); + int rv; - if (sethostname (SCM_STRING_CHARS (name), SCM_STRING_LENGTH (name)) == -1) + WITH_STRING (name, c_name, + rv = sethostname (c_name, strlen(c_name))); + if (rv == -1) SCM_SYSERROR; return SCM_UNSPECIFIED; } From 1299a0f17b334b2b901f383aeae49fd772b8a477 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:32:07 +0000 Subject: [PATCH 43/64] (STRING_SYSCALL, STRING2_SYSCALL): New helper macros. Use them instead of SCM_SYSCALL when one or two strings need to be converted into locale strings. (my_rename): New, gathers platform dependent code for renaming. (scm_rename): Use it. (scm_readlink, scm_copy_file): Convert SCM strings to locale strings instead of accessing their internals. (scm_basename, scm_dirname): Use SCM_I_STRING_CHARS and SCM_I_STRING_LENGTH instead of SCM_STRING_CHARS and SCM_STRING_LENGTH. --- libguile/filesys.c | 151 ++++++++++++++++++++++++++++----------------- 1 file changed, 95 insertions(+), 56 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 459f5530c..403996d04 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -35,6 +35,7 @@ #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/lang.h" +#include "libguile/dynwind.h" #include "libguile/validate.h" #include "libguile/filesys.h" @@ -175,6 +176,28 @@ #endif /* __MINGW32__ */ +/* Two helper macros for an often used pattern */ + +#define STRING_SYSCALL(str,cstr,code) \ + do { \ + int eno; \ + char *cstr = scm_to_locale_string (str); \ + SCM_SYSCALL (code); \ + eno = errno; free (cstr); errno = eno; \ + } while (0) + +#define STRING2_SYSCALL(str1,cstr1,str2,cstr2,code) \ + do { \ + int eno; \ + char *cstr1, *cstr2; \ + scm_frame_begin (0); \ + cstr1 = scm_to_locale_string (str1); \ + scm_frame_free (cstr1); \ + cstr2 = scm_to_locale_string (str2); \ + scm_frame_free (cstr2); \ + SCM_SYSCALL (code); \ + eno = errno; scm_frame_end (); errno = eno; \ + } while (0) @@ -212,9 +235,9 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0, else #endif { - SCM_VALIDATE_STRING (1, object); - SCM_SYSCALL (rv = chown (SCM_STRING_CHARS (object), - scm_to_int (owner), scm_to_int (group))); + STRING_SYSCALL (object, c_object, + rv = chown (c_object, + scm_to_int (owner), scm_to_int (group))); } if (rv == -1) SCM_SYSERROR; @@ -250,8 +273,8 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0, } else { - SCM_VALIDATE_STRING (1, object); - SCM_SYSCALL (rv = chmod (SCM_STRING_CHARS (object), scm_to_int (mode))); + STRING_SYSCALL (object, c_object, + rv = chmod (c_object, scm_to_int (mode))); } if (rv == -1) SCM_SYSERROR; @@ -293,10 +316,9 @@ SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0, int iflags; int imode; - SCM_VALIDATE_STRING (1, path); iflags = SCM_NUM2INT (2, flags); imode = SCM_NUM2INT_DEF (3, mode, 0666); - SCM_SYSCALL (fd = open (SCM_STRING_CHARS (path), iflags, imode)); + STRING_SYSCALL (path, c_path, fd = open (c_path, iflags, imode)); if (fd == -1) SCM_SYSERROR; return scm_from_int (fd); @@ -662,10 +684,9 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0, { int val; - SCM_VALIDATE_STRING (1, oldpath); - SCM_VALIDATE_STRING (2, newpath); - SCM_SYSCALL (val = link (SCM_STRING_CHARS (oldpath), - SCM_STRING_CHARS (newpath))); + STRING2_SYSCALL (oldpath, c_oldpath, + newpath, c_newpath, + val = link (c_oldpath, c_newpath)); if (val != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -673,7 +694,25 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0, #undef FUNC_NAME #endif /* HAVE_LINK */ +#ifdef HAVE_RENAME +#define my_rename rename +#else +static int +my_rename (const char *oldname, const char *newname) +{ + int rv; + SCM_SYSCALL (rv = link (oldname, newname)); + if (rv == 0) + { + SCM_SYSCALL (rv = unlink (oldname)); + if (rv != 0) + /* unlink failed. remove new name */ + SCM_SYSCALL (unlink (newname)); + } + return rv; +} +#endif SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0, (SCM oldname, SCM newname), @@ -682,20 +721,10 @@ SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0, #define FUNC_NAME s_scm_rename { int rv; - SCM_VALIDATE_STRING (1, oldname); - SCM_VALIDATE_STRING (2, newname); -#ifdef HAVE_RENAME - SCM_SYSCALL (rv = rename (SCM_STRING_CHARS (oldname), SCM_STRING_CHARS (newname))); -#else - SCM_SYSCALL (rv = link (SCM_STRING_CHARS (oldname), SCM_STRING_CHARS (newname))); - if (rv == 0) - { - SCM_SYSCALL (rv = unlink (SCM_STRING_CHARS (oldname)));; - if (rv != 0) - /* unlink failed. remove new name */ - SCM_SYSCALL (unlink (SCM_STRING_CHARS (newname))); - } -#endif + + STRING2_SYSCALL (oldname, c_oldname, + newname, c_newname, + rv = my_rename (c_oldname, c_newname)); if (rv != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -709,8 +738,7 @@ SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0, #define FUNC_NAME s_scm_delete_file { int ans; - SCM_VALIDATE_STRING (1, str); - SCM_SYSCALL (ans = unlink (SCM_STRING_CHARS (str))); + STRING_SYSCALL (str, c_str, ans = unlink (c_str)); if (ans != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -728,16 +756,16 @@ SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0, { int rv; mode_t mask; - SCM_VALIDATE_STRING (1, path); + if (SCM_UNBNDP (mode)) { mask = umask (0); umask (mask); - SCM_SYSCALL (rv = mkdir (SCM_STRING_CHARS (path), 0777 ^ mask)); + STRING_SYSCALL (path, c_path, rv = mkdir (c_path, 0777 ^ mask)); } else { - SCM_SYSCALL (rv = mkdir (SCM_STRING_CHARS (path), scm_to_uint (mode))); + STRING_SYSCALL (path, c_path, rv = mkdir (c_path, scm_to_uint (mode))); } if (rv != 0) SCM_SYSERROR; @@ -755,8 +783,7 @@ SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0, { int val; - SCM_VALIDATE_STRING (1, path); - SCM_SYSCALL (val = rmdir (SCM_STRING_CHARS (path))); + STRING_SYSCALL (path, c_path, val = rmdir (c_path)); if (val != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -790,8 +817,7 @@ SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0, #define FUNC_NAME s_scm_opendir { DIR *ds; - SCM_VALIDATE_STRING (1, dirname); - SCM_SYSCALL (ds = opendir (SCM_STRING_CHARS (dirname))); + STRING_SYSCALL (dirname, c_dirname, ds = opendir (c_dirname)); if (ds == NULL) SCM_SYSERROR; SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_DIR_FLAG_OPEN, ds); @@ -919,8 +945,7 @@ SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0, { int ans; - SCM_VALIDATE_STRING (1, str); - SCM_SYSCALL (ans = chdir (SCM_STRING_CHARS (str))); + STRING_SYSCALL (str, c_str, ans = chdir (c_str)); if (ans != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1331,9 +1356,9 @@ SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0, { int val; - SCM_VALIDATE_STRING (1, oldpath); - SCM_VALIDATE_STRING (2, newpath); - SCM_SYSCALL (val = symlink (SCM_STRING_CHARS (oldpath), SCM_STRING_CHARS (newpath))); + STRING2_SYSCALL (oldpath, c_oldpath, + newpath, c_newpath, + val = symlink (c_oldpath, c_newpath)); if (val != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1352,9 +1377,16 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, int size = 100; char *buf; SCM result; - SCM_VALIDATE_STRING (1, path); + char *c_path; + + scm_frame_begin (0); + + c_path = scm_to_locale_string (path); + scm_frame_free (c_path); + buf = scm_malloc (size); - while ((rv = readlink (SCM_STRING_CHARS (path), buf, size)) == size) + + while ((rv = readlink (c_path, buf, size)) == size) { free (buf); size *= 2; @@ -1367,8 +1399,9 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, errno = save_errno; SCM_SYSERROR; } - result = scm_mem2string (buf, rv); - free (buf); + result = scm_take_locale_stringn (buf, rv); + + scm_frame_end (); return result; } #undef FUNC_NAME @@ -1385,8 +1418,7 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, int rv; struct stat stat_temp; - SCM_VALIDATE_STRING (1, str); - SCM_SYSCALL (rv = lstat (SCM_STRING_CHARS (str), &stat_temp)); + STRING_SYSCALL (str, c_str, rv = lstat (c_str, &stat_temp)); if (rv != 0) { int en = errno; @@ -1395,7 +1427,7 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, scm_list_2 (scm_strerror (scm_from_int (en)), str), en); } - return scm_stat2scm(&stat_temp); + return scm_stat2scm (&stat_temp); } #undef FUNC_NAME #endif /* HAVE_LSTAT */ @@ -1406,15 +1438,20 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0, "The return value is unspecified.") #define FUNC_NAME s_scm_copy_file { + char *c_oldfile, *c_newfile; int oldfd, newfd; int n, rv; char buf[BUFSIZ]; struct stat oldstat; - SCM_VALIDATE_STRING (1, oldfile); - SCM_VALIDATE_STRING (2, newfile); + scm_frame_begin (0); + + c_oldfile = scm_to_locale_string (oldfile); + scm_frame_free (c_oldfile); + c_newfile = scm_to_locale_string (newfile); + scm_frame_free (c_newfile); - oldfd = open (SCM_STRING_CHARS (oldfile), O_RDONLY); + oldfd = open (c_oldfile, O_RDONLY); if (oldfd == -1) SCM_SYSERROR; @@ -1427,7 +1464,7 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0, goto err_close_oldfd; /* use POSIX flags instead of 07777?. */ - newfd = open (SCM_STRING_CHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC, + newfd = open (c_newfile, O_WRONLY | O_CREAT | O_TRUNC, oldstat.st_mode & 07777); if (newfd == -1) { @@ -1446,6 +1483,8 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0, close (oldfd); if (close (newfd) == -1) SCM_SYSERROR; + + scm_frame_end (); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1468,8 +1507,8 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, SCM_VALIDATE_STRING (1, filename); - s = SCM_STRING_CHARS (filename); - len = SCM_STRING_LENGTH (filename); + s = SCM_I_STRING_CHARS (filename); + len = SCM_I_STRING_LENGTH (filename); i = len - 1; #ifdef __MINGW32__ @@ -1509,16 +1548,16 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, int i, j, len, end; SCM_VALIDATE_STRING (1, filename); - f = SCM_STRING_CHARS (filename); - len = SCM_STRING_LENGTH (filename); + f = SCM_I_STRING_CHARS (filename); + len = SCM_I_STRING_LENGTH (filename); if (SCM_UNBNDP (suffix)) j = -1; else { SCM_VALIDATE_STRING (2, suffix); - s = SCM_STRING_CHARS (suffix); - j = SCM_STRING_LENGTH (suffix) - 1; + s = SCM_I_STRING_CHARS (suffix); + j = SCM_I_STRING_LENGTH (suffix) - 1; } i = len - 1; #ifdef __MINGW32__ From 3eb1e2aa881a7da9de2336c6b421707d3627eacb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:32:15 +0000 Subject: [PATCH 44/64] (scm_read_delimited_x): Avoid SCM_VALIDATE_SUBSTRING_SPEC_COPY and use scm_from_size_t instead of scm_from_long for the returned number of read characters. --- libguile/rdelim.c | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/libguile/rdelim.c b/libguile/rdelim.c index a552cbd78..3967a1d72 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -63,14 +63,19 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, char *cdelims; size_t num_delims; - SCM_VALIDATE_STRING_COPY (1, delims, cdelims); - num_delims = SCM_STRING_LENGTH (delims); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, str, buf, 5, start, cstart, - 6, end, cend); + SCM_VALIDATE_STRING (1, delims); + cdelims = SCM_I_STRING_CHARS (delims); + num_delims = SCM_I_STRING_LENGTH (delims); + + SCM_VALIDATE_STRING (2, str); + buf = SCM_I_STRING_CHARS (str); + scm_i_get_substring_spec (SCM_I_STRING_LENGTH (str), + start, &cstart, end, &cend); + if (SCM_UNBNDP (port)) port = scm_cur_inp; else - SCM_VALIDATE_OPINPORT (4,port); + SCM_VALIDATE_OPINPORT (4, port); for (j = cstart; j < cend; j++) { @@ -85,16 +90,16 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, scm_ungetc (c, port); return scm_cons (SCM_MAKE_CHAR (c), - scm_from_long (j - cstart)); + scm_from_size_t (j - cstart)); } } if (c == EOF) return scm_cons (SCM_EOF_VAL, - scm_from_long (j - cstart)); + scm_from_size_t (j - cstart)); buf[j] = c; } - return scm_cons (SCM_BOOL_F, scm_from_long (j - cstart)); + return scm_cons (SCM_BOOL_F, scm_from_size_t (j - cstart)); } #undef FUNC_NAME From 0d189573e59f2e5e15bf1287d08dc2af2a47e07d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:35:53 +0000 Subject: [PATCH 45/64] Convert version to locale string before printing it. --- libguile/script.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/script.c b/libguile/script.c index 8b47633db..a8a84185f 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -584,7 +584,7 @@ scm_compile_shell_switches (int argc, char **argv) "certain other uses are permitted as well. For details, see the file\n" "`COPYING', which is included in the Guile distribution.\n" "There is no warranty, to the extent permitted by law.\n", - SCM_STRING_CHARS (scm_version ())); + scm_to_locale_string (scm_version ())); exit (0); } From ddae95259d1875ea0ea5e3afc2187e325946b80a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:38:52 +0000 Subject: [PATCH 46/64] (scm_system): Convert SCM strings to locale strings instead of accessing their internals. --- libguile/simpos.c | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/libguile/simpos.c b/libguile/simpos.c index ff4637d61..d0a5a28f1 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -64,8 +64,9 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, "indicating whether the command processor is available.") #define FUNC_NAME s_scm_system { - int rv; - + int rv, eno; + char *c_cmd; + if (SCM_UNBNDP (cmd)) { rv = system (NULL); @@ -73,7 +74,9 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, } SCM_VALIDATE_STRING (1, cmd); errno = 0; - rv = system (SCM_STRING_CHARS (cmd)); + c_cmd = scm_to_locale_string (cmd); + rv = system (c_cmd); + eno = errno; free (c_cmd); errno = eno; if (rv == -1 || (rv == 127 && errno != 0)) SCM_SYSERROR; return scm_from_int (rv); From 396e5506d6c7ba9e669856cae97445e5c307ba34 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:43:17 +0000 Subject: [PATCH 47/64] * socket.c (scm_inet_aton, scm_inet_pton): Convert SCM strings to locale strings instead of accessing their internals. (scm_recv, scm_send, scm_recvfrom, scm_sendto): Use SCM_I_STRING_CHARS and SCM_I_STRING_LENGTH instead of SCM_STRING_CHARS and SCM_STRING_LENGTH. * socket.c, rw.c, deprecated.h, validate.h (SCM_VALIDATE_STRING_COPY): Deprecated. Replaced all uses with SCM_VALIDATE_STRING plus SCM_I_STRING_CHARS or scm_to_locale_string, etc. (SCM_VALIDATE_SUBSTRING_SPEC_COPY): Deprecated. Replaced as above, plus scm_i_get_substring_spec. --- libguile/socket.c | 47 +++++++++++++++++++++++++++++++++++------------ 1 file changed, 35 insertions(+), 12 deletions(-) diff --git a/libguile/socket.c b/libguile/socket.c index 7135be618..53034f678 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -136,9 +136,13 @@ SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, #define FUNC_NAME s_scm_inet_aton { struct in_addr soka; + char *c_address; + int rv; - SCM_VALIDATE_STRING (1, address); - if (inet_aton (SCM_STRING_CHARS (address), &soka) == 0) + c_address = scm_to_locale_string (address); + rv = inet_aton (c_address, &soka); + free (c_address); + if (rv == 0) SCM_MISC_ERROR ("bad address", SCM_EOL); return scm_from_ulong (ntohl (soka.s_addr)); } @@ -398,12 +402,15 @@ SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0, int af; char *src; char dst[16]; - int rv; + int rv, eno; af = scm_to_int (family); SCM_ASSERT_RANGE (1, family, af == AF_INET || af == AF_INET6); - SCM_VALIDATE_STRING_COPY (2, address, src); + src = scm_to_locale_string (address); rv = inet_pton (af, src, dst); + eno = errno; + free (src); + errno = eno; if (rv == -1) SCM_SYSERROR; else if (rv == 0) @@ -1136,10 +1143,13 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, flg = scm_to_int (flags); fd = SCM_FPORT_FDES (sock); - SCM_SYSCALL (rv = recv (fd, SCM_STRING_CHARS (buf), SCM_STRING_LENGTH (buf), flg)); + SCM_SYSCALL (rv = recv (fd, + SCM_I_STRING_CHARS (buf), SCM_I_STRING_LENGTH (buf), + flg)); if (rv == -1) SCM_SYSERROR; + scm_remember_upto_here_1 (buf); return scm_from_int (rv); } #undef FUNC_NAME @@ -1173,9 +1183,14 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, flg = scm_to_int (flags); fd = SCM_FPORT_FDES (sock); - SCM_SYSCALL (rv = send (fd, SCM_STRING_CHARS (message), SCM_STRING_LENGTH (message), flg)); + SCM_SYSCALL (rv = send (fd, + SCM_I_STRING_CHARS (message), + SCM_I_STRING_LENGTH (message), + flg)); if (rv == -1) SCM_SYSERROR; + + scm_remember_upto_here_1 (message); return scm_from_int (rv); } #undef FUNC_NAME @@ -1207,8 +1222,8 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, int fd; int flg; char *buf; - int offset; - int cend; + size_t offset; + size_t cend; SCM address; int addr_size = MAX_ADDR_SIZE; char max_addr[MAX_ADDR_SIZE]; @@ -1216,8 +1231,12 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, SCM_VALIDATE_OPFPORT (1, sock); fd = SCM_FPORT_FDES (sock); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, str, buf, 4, start, offset, - 5, end, cend); + + SCM_VALIDATE_STRING (2, str); + buf = SCM_I_STRING_CHARS (str); + scm_i_get_substring_spec (SCM_I_STRING_LENGTH (str), + start, &offset, end, &cend); + if (SCM_UNBNDP (flags)) flg = 0; else @@ -1236,6 +1255,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, else address = SCM_BOOL_F; + scm_remember_upto_here_1 (str); return scm_cons (scm_from_int (rv), address); } #undef FUNC_NAME @@ -1280,8 +1300,9 @@ SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, SCM_VALIDATE_CONS (5, args_and_flags); flg = SCM_NUM2ULONG (5, SCM_CAR (args_and_flags)); } - SCM_SYSCALL (rv = sendto (fd, SCM_STRING_CHARS (message), - SCM_STRING_LENGTH (message), + SCM_SYSCALL (rv = sendto (fd, + SCM_I_STRING_CHARS (message), + SCM_I_STRING_LENGTH (message), flg, soka, size)); if (rv == -1) { @@ -1291,6 +1312,8 @@ SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, SCM_SYSERROR; } free (soka); + + scm_remember_upto_here_1 (message); return scm_from_int (rv); } #undef FUNC_NAME From 6f14f578d2e24f58594e682061755dab41ed1f9e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:43:41 +0000 Subject: [PATCH 48/64] * strings.h, strings.c (scm_i_get_substring_spec): New. * socket.c, rw.c, deprecated.h, validate.h (SCM_VALIDATE_STRING_COPY): Deprecated. Replaced all uses with SCM_VALIDATE_STRING plus SCM_I_STRING_CHARS or scm_to_locale_string, etc. (SCM_VALIDATE_SUBSTRING_SPEC_COPY): Deprecated. Replaced as above, plus scm_i_get_substring_spec. --- libguile/deprecated.h | 29 +++++++++++++++++++++++++++++ libguile/strings.c | 16 ++++++++++++++++ libguile/strings.h | 3 +++ libguile/validate.h | 27 ++------------------------- 4 files changed, 50 insertions(+), 25 deletions(-) diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 4336dd472..bc7f527f7 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -410,6 +410,35 @@ SCM_API char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len) SCM_API double scm_truncate (double x); SCM_API double scm_round (double x); +/* Deprecated because we don't want people to access the internal + representation of strings directly. +*/ + +#define SCM_VALIDATE_STRING_COPY(pos, str, cvar) \ + do { \ + SCM_ASSERT (SCM_STRINGP (str), str, pos, FUNC_NAME); \ + cvar = SCM_STRING_CHARS(str); \ + } while (0) + +/* validate a string and optional start/end arguments which default to + 0/string-len. this is unrelated to the old shared substring + support, so please do not deprecate it :) */ +#define SCM_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \ + pos_start, start, c_start,\ + pos_end, end, c_end) \ + do {\ + SCM_VALIDATE_STRING_COPY (pos_str, str, c_str);\ + 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));\ + SCM_ASSERT_RANGE (pos_end, end,\ + c_start <= c_end \ + && (size_t) c_end <= SCM_STRING_LENGTH (str));\ + } while (0) + + void scm_i_init_deprecated (void); #endif diff --git a/libguile/strings.c b/libguile/strings.c index 1308753aa..0e15f7222 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -452,6 +452,22 @@ scm_i_free_string_pointers (char **pointers) free (pointers); } +void +scm_i_get_substring_spec (size_t len, + SCM start, size_t *cstart, + SCM end, size_t *cend) +{ + if (SCM_UNBNDP (start)) + *cstart = 0; + else + *cstart = scm_to_unsigned_integer (start, 0, len); + + if (SCM_UNBNDP (end)) + *cend = len; + else + *cend = scm_to_unsigned_integer (end, *cstart, len); +} + void scm_init_strings () { diff --git a/libguile/strings.h b/libguile/strings.h index 09edabbcb..942001e07 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -72,6 +72,9 @@ SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len); SCM_API char **scm_i_allocate_string_pointers (SCM list); SCM_API void scm_i_free_string_pointers (char **pointers); +SCM_API void scm_i_get_substring_spec (size_t len, + SCM start, size_t *cstart, + SCM end, size_t *cend); SCM_API void scm_init_strings (void); diff --git a/libguile/validate.h b/libguile/validate.h index 04bcb2b85..886a4d646 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -152,31 +152,7 @@ cvar = SCM_CHAR (scm); \ } while (0) -#define SCM_VALIDATE_STRING(pos, str) SCM_MAKE_VALIDATE_MSG (pos, str, STRINGP, "string") - -#define SCM_VALIDATE_STRING_COPY(pos, str, cvar) \ - do { \ - SCM_ASSERT (SCM_STRINGP (str), str, pos, FUNC_NAME); \ - cvar = SCM_STRING_CHARS(str); \ - } while (0) - -/* validate a string and optional start/end arguments which default to - 0/string-len. this is unrelated to the old shared substring - support, so please do not deprecate it :) */ -#define SCM_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \ - pos_start, start, c_start,\ - pos_end, end, c_end) \ - do {\ - SCM_VALIDATE_STRING_COPY (pos_str, str, c_str);\ - 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));\ - SCM_ASSERT_RANGE (pos_end, end,\ - c_start <= c_end \ - && (size_t) c_end <= SCM_STRING_LENGTH (str));\ - } while (0) +#define SCM_VALIDATE_STRING(pos, str) SCM_MAKE_VALIDATE_MSG (pos, str, I_STRINGP, "string") #define SCM_VALIDATE_REAL(pos, z) SCM_MAKE_VALIDATE_MSG (pos, z, REALP, "real") @@ -386,6 +362,7 @@ SCM_ASSERT (SCM_VECTORP (v) && len == SCM_VECTOR_LENGTH (v), v, pos, FUNC_NAME); \ } while (0) + #endif /* SCM_VALIDATE_H */ /* From 70f7ee4188c0a752154d8cc63daf5a99ba89951f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:44:43 +0000 Subject: [PATCH 49/64] *** empty log message *** --- libguile/ChangeLog | 89 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4fcc39edd..5e1d3a847 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,92 @@ +2004-08-12 Marius Vollmer + + * socket.c (scm_inet_aton, scm_inet_pton): Convert SCM strings to + locale strings instead of accessing their internals. + (scm_recv, scm_send, scm_recvfrom, scm_sendto): Use + SCM_I_STRING_CHARS and SCM_I_STRING_LENGTH instead of + SCM_STRING_CHARS and SCM_STRING_LENGTH. + + * simpos.c (scm_system): Convert SCM strings to locale strings + instead of accessing their internals. + + * script.c (scm_compile_shell_switches): Convert version to locale + string before printing it. + + * rdelim.c (scm_read_delimited_x): Avoid + SCM_VALIDATE_SUBSTRING_SPEC_COPY and use scm_from_size_t instead + of scm_from_long for the returned number of read characters. + + * ioext.c (scm_fdopen): Use scm_i_fdes_to_port together with + scm_i_mode_bits to avoid accessing internals of SCM string from C. + + * filesys.c (STRING_SYSCALL, STRING2_SYSCALL): New helper macros. + Use them instead of SCM_SYSCALL when one or two strings need to be + converted into locale strings. + (my_rename): New, gathers platform dependent code for renaming. + (scm_rename): Use it. + (scm_readlink, scm_copy_file): Convert SCM strings to locale + strings instead of accessing their internals. + (scm_basename, scm_dirname): Use SCM_I_STRING_CHARS and + SCM_I_STRING_LENGTH instead of SCM_STRING_CHARS and + SCM_STRING_LENGTH. + + * extensions.c (load_extension): Convert lib and init to locale + strings instead of accessing the internals directly. + (scm_c_load_extension): Use scm_from_locale_string instead of + scm_makfrom0str. + + * fports.h, fports.c (scm_i_fdes_to_port): New, like + scm_fdes_to_port, but take mode bits directly instead of as a C + string. + (scm_i_fdes_to_port): Implement using above. + (scm_open_file): Use scm_i_fdes_to_port together with + scm_i_mode_bits to avoid accessing internals of SCM string from C. + * vports.c (scm_make_soft_port): Use scm_i_fdes_to_port together + with scm_i_mode_bits to avoid accessing internals of SCM string + from C. + + * ports.h (scm_i_mode_bits): New, same as scm_mode_bits but with a + SCM string as argument. + + * ports.c (scm_i_void_port): New, like scm_void_port but take mode + bits directly instead of C string. + (scm_void_port): Implement using above. + (scm_sys_make_void_port): Use scm_i_void_port together with + scm_i_mode_bits to avoid accessing internals of SCM string. + + * strings.h, strings.c (scm_i_get_substring_spec): New. + + * socket.c, rw.c, deprecated.h, validate.h + (SCM_VALIDATE_STRING_COPY): Deprecated. Replaced all uses with + SCM_VALIDATE_STRING plus SCM_I_STRING_CHARS or + scm_to_locale_string, etc. + (SCM_VALIDATE_SUBSTRING_SPEC_COPY): Deprecated. Replaced as + above, plus scm_i_get_substring_spec. + + * regex-posix.c, read.c, random.c, ramap.c, print.c, numbers.c, + hash.c, gc.c, gc-card.c, convert.i.c, backtrace.c, strop.c, + strorder.c, strports.c, struct.c, symbols.c, unif.c, ports.c: Use + SCM_I_STRING_CHARS, SCM_I_STRING_UCHARS, and SCM_I_STRING_LENGTH + instead of SCM_STRING_CHARS, SCM_STRING_UCHARS, and + SCM_STRING_LENGTH, respectively. Also, replaced scm_return_first + with more explicit scm_remember_upto_here_1, etc, or introduced + them in the first place. + + * posix.c (WITH_STRING): New helper macro. Use it where one + locale string is needed for a short piece of code. + (STRING_SYSCALL): New helper macro. Use it instead of SCM_SYSCALL + when one locale string is needed. + (scm_mkstemp): Convert tmpl to a locale string. + (scm_putenv): Rewritten to use only C strings. + (scm_setlocale, scm_crpt): Convert argument strings to locale + strings. + +2004-08-11 Marius Vollmer + + * load.c (scm_primitive_load_path): Do not check for absolute + filenames when scm_sys_search_load_path returns false, which will + return absolute filenames unchanged. + 2004-08-11 Marius Vollmer * gc.c, procprop.c (scm_init_storage, scm_stand_in_procs, From 8824ac88f08cffc954a907b85858ccd5b3c9843f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:45:03 +0000 Subject: [PATCH 50/64] * socket.c, rw.c, deprecated.h, validate.h (SCM_VALIDATE_STRING_COPY): Deprecated. Replaced all uses with SCM_VALIDATE_STRING plus SCM_I_STRING_CHARS or scm_to_locale_string, etc. (SCM_VALIDATE_SUBSTRING_SPEC_COPY): Deprecated. Replaced as above, plus scm_i_get_substring_spec. * regex-posix.c, read.c, random.c, ramap.c, print.c, numbers.c, hash.c, gc.c, gc-card.c, convert.i.c, backtrace.c, strop.c, strorder.c, strports.c, struct.c, symbols.c, unif.c, ports.c: Use SCM_I_STRING_CHARS, SCM_I_STRING_UCHARS, and SCM_I_STRING_LENGTH instead of SCM_STRING_CHARS, SCM_STRING_UCHARS, and SCM_STRING_LENGTH, respectively. Also, replaced scm_return_first with more explicit scm_remember_upto_here_1, etc, or introduced them in the first place. --- libguile/backtrace.c | 12 +++++--- libguile/convert.i.c | 4 +-- libguile/gc-card.c | 4 +-- libguile/gc.c | 2 +- libguile/hash.c | 7 ++++- libguile/numbers.c | 9 +++--- libguile/print.c | 11 ++++---- libguile/ramap.c | 8 +++--- libguile/random.c | 8 ++++-- libguile/read.c | 38 +++++++++++++------------- libguile/regex-posix.c | 12 ++++---- libguile/rw.c | 30 +++++++++++++------- libguile/strop.c | 62 ++++++++++++++++++++++++------------------ libguile/strorder.c | 56 +++++++++++++++++++++++--------------- libguile/strports.c | 8 ++++-- libguile/struct.c | 18 ++++++++---- libguile/symbols.c | 13 +++++---- libguile/unif.c | 22 +++++++-------- 18 files changed, 189 insertions(+), 135 deletions(-) diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 9dd278189..23e67e4da 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -22,6 +22,7 @@ #include #include +#include #include "libguile/_scm.h" @@ -398,18 +399,21 @@ display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, S while (indentation + n > SCM_BACKTRACE_WIDTH && i < n_print_params); ptob->truncate (sport, n); string = scm_strport_to_string (sport); + assert (scm_is_string (string)); + /* Remove control characters */ for (i = 0; i < n; ++i) - if (iscntrl ((int) (unsigned char) SCM_STRING_CHARS (string)[i])) - SCM_STRING_CHARS (string)[i] = ' '; + if (iscntrl ((int) SCM_I_STRING_UCHARS (string)[i])) + SCM_I_STRING_UCHARS (string)[i] = ' '; /* Truncate */ if (indentation + n > SCM_BACKTRACE_WIDTH) { n = SCM_BACKTRACE_WIDTH - indentation; - SCM_STRING_CHARS (string)[n - 1] = '$'; + SCM_I_STRING_UCHARS (string)[n - 1] = '$'; } - scm_lfwrite (SCM_STRING_CHARS (string), n, port); + scm_lfwrite (SCM_I_STRING_CHARS (string), n, port); + scm_remember_upto_here_1 (string); } static void diff --git a/libguile/convert.i.c b/libguile/convert.i.c index f0ba6ae54..1fe928110 100644 --- a/libguile/convert.i.c +++ b/libguile/convert.i.c @@ -163,11 +163,11 @@ SCM2CTYPES (SCM obj, CTYPE *data) #if SIZEOF_CTYPE == 1 case scm_tc7_string: - n = SCM_STRING_LENGTH (obj); + n = SCM_I_STRING_LENGTH (obj); if (data == NULL) if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) return NULL; - memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE)); + memcpy (data, SCM_I_STRING_CHARS (obj), n * sizeof (CTYPE)); break; #endif diff --git a/libguile/gc-card.c b/libguile/gc-card.c index a458cbaf0..2f57736b3 100644 --- a/libguile/gc-card.c +++ b/libguile/gc-card.c @@ -193,8 +193,8 @@ scm_i_sweep_card (scm_t_cell * p, SCM *free_list, scm_t_heap_segment*seg) } break; case scm_tc7_string: - scm_gc_free (SCM_STRING_CHARS (scmptr), - SCM_STRING_LENGTH (scmptr) + 1, "string"); + scm_gc_free (SCM_I_STRING_CHARS (scmptr), + SCM_I_STRING_LENGTH (scmptr) + 1, "string"); break; case scm_tc7_symbol: scm_gc_free (SCM_SYMBOL_CHARS (scmptr), diff --git a/libguile/gc.c b/libguile/gc.c index 4c0a633f7..2e163df83 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -642,7 +642,7 @@ scm_igc (const char *what) * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the * call to 'some_function'. Note that this would not be necessary if str was * used anyway after the call to 'some_function'. - * char *chars = SCM_STRING_CHARS (str); + * char *chars = SCM_I_STRING_CHARS (str); * some_function (chars); * scm_remember_upto_here_1 (str); // str will be alive up to this point. */ diff --git a/libguile/hash.c b/libguile/hash.c index 4415bf82f..b2c7fa592 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -109,7 +109,12 @@ scm_hasher(SCM obj, unsigned long n, size_t d) } /* Fall through */ case scm_tc7_string: - return scm_string_hash (SCM_STRING_UCHARS (obj), SCM_STRING_LENGTH (obj)) % n; + { + unsigned long hash = scm_string_hash (SCM_I_STRING_UCHARS (obj), + SCM_I_STRING_LENGTH (obj)) % n; + scm_remember_upto_here_1 (obj); + return hash; + } case scm_tc7_symbol: return SCM_SYMBOL_HASH (obj) % n; case scm_tc7_wvect: diff --git a/libguile/numbers.c b/libguile/numbers.c index c0e7d58dc..a50ca8889 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2338,7 +2338,7 @@ scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) SCM str; scm_i_fraction_reduce (sexp); str = scm_number_to_string (sexp, SCM_UNDEFINED); - scm_lfwrite (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), port); + scm_lfwrite (SCM_I_STRING_CHARS (str), SCM_I_STRING_LENGTH (str), port); scm_remember_upto_here_1 (str); return !0; } @@ -2967,10 +2967,11 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, else base = scm_to_unsigned_integer (radix, 2, INT_MAX); - answer = scm_i_mem2number (SCM_STRING_CHARS (string), - SCM_STRING_LENGTH (string), + answer = scm_i_mem2number (SCM_I_STRING_CHARS (string), + SCM_I_STRING_LENGTH (string), base); - return scm_return_first (answer, string); + scm_remember_upto_here_1 (string); + return answer; } #undef FUNC_NAME diff --git a/libguile/print.c b/libguile/print.c index a2fe9785f..0b69ebd0e 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -487,9 +487,9 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) size_t i; scm_putc ('"', port); - for (i = 0; i < SCM_STRING_LENGTH (exp); ++i) + for (i = 0; i < SCM_I_STRING_LENGTH (exp); ++i) { - unsigned char ch = SCM_STRING_CHARS (exp)[i]; + unsigned char ch = SCM_I_STRING_CHARS (exp)[i]; if ((ch < 32 && ch != '\n') || (127 <= ch && ch < 148)) { static char const hex[]="0123456789abcdef"; @@ -508,8 +508,9 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_putc ('"', port); } else - scm_lfwrite (SCM_STRING_CHARS (exp), SCM_STRING_LENGTH (exp), + scm_lfwrite (SCM_I_STRING_CHARS (exp), SCM_I_STRING_LENGTH (exp), port); + scm_remember_upto_here_1 (exp); break; case scm_tc7_symbol: if (SCM_SYMBOL_INTERNED_P (exp)) @@ -937,8 +938,8 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, SCM_VALIDATE_STRING (2, message); SCM_VALIDATE_REST_ARGUMENT (args); - start = SCM_STRING_CHARS (message); - end = start + SCM_STRING_LENGTH (message); + start = SCM_I_STRING_CHARS (message); + end = start + SCM_I_STRING_LENGTH (message); for (p = start; p != end; ++p) if (*p == '~') { diff --git a/libguile/ramap.c b/libguile/ramap.c index 53d36294b..49ec40f11 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -469,7 +469,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) case scm_tc7_string: SCM_ASRTGO (SCM_CHARP (fill), badarg2); for (i = base; n--; i += inc) - SCM_STRING_CHARS (ra)[i] = SCM_CHAR (fill); + SCM_I_STRING_CHARS (ra)[i] = SCM_CHAR (fill); break; case scm_tc7_byvect: if (SCM_CHARP (fill)) @@ -631,7 +631,7 @@ racp (SCM src, SCM dst) if (SCM_TYP7 (src) != scm_tc7_string) goto gencase; for (; n-- > 0; i_s += inc_s, i_d += inc_d) - SCM_STRING_CHARS (dst)[i_d] = SCM_STRING_CHARS (src)[i_s]; + SCM_I_STRING_CHARS (dst)[i_d] = SCM_I_STRING_CHARS (src)[i_s]; break; case scm_tc7_byvect: if (SCM_TYP7 (src) != scm_tc7_byvect) @@ -1791,8 +1791,8 @@ raeql_1 (SCM ra0, SCM as_equal, SCM ra1) return 1; case scm_tc7_string: { - char *v0 = SCM_STRING_CHARS (ra0) + i0; - char *v1 = SCM_STRING_CHARS (ra1) + i1; + char *v0 = SCM_I_STRING_CHARS (ra0) + i0; + char *v1 = SCM_I_STRING_CHARS (ra1) + i1; for (; n--; v0 += inc0, v1 += inc1) if (*v0 != *v1) return 0; diff --git a/libguile/random.c b/libguile/random.c index 991900af3..bb8d48355 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -383,11 +383,15 @@ SCM_DEFINE (scm_seed_to_random_state, "seed->random-state", 1, 0, 0, "Return a new random state using @var{seed}.") #define FUNC_NAME s_scm_seed_to_random_state { + SCM res; if (SCM_NUMBERP (seed)) seed = scm_number_to_string (seed, SCM_UNDEFINED); SCM_VALIDATE_STRING (1, seed); - return make_rstate (scm_c_make_rstate (SCM_STRING_CHARS (seed), - SCM_STRING_LENGTH (seed))); + res = make_rstate (scm_c_make_rstate (SCM_I_STRING_CHARS (seed), + SCM_I_STRING_LENGTH (seed))); + scm_remember_upto_here_1 (seed); + return res; + } #undef FUNC_NAME diff --git a/libguile/read.c b/libguile/read.c index d3f448aac..fc973dcd2 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -151,15 +151,15 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0, char * scm_grow_tok_buf (SCM *tok_buf) { - size_t oldlen = SCM_STRING_LENGTH (*tok_buf); + size_t oldlen = SCM_I_STRING_LENGTH (*tok_buf); SCM newstr = scm_allocate_string (2 * oldlen); size_t i; for (i = 0; i != oldlen; ++i) - SCM_STRING_CHARS (newstr) [i] = SCM_STRING_CHARS (*tok_buf) [i]; + SCM_I_STRING_CHARS (newstr) [i] = SCM_I_STRING_CHARS (*tok_buf) [i]; *tok_buf = newstr; - return SCM_STRING_CHARS (newstr); + return SCM_I_STRING_CHARS (newstr); } @@ -437,7 +437,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) #if SCM_HAVE_ARRAYS case '*': j = scm_read_token (c, tok_buf, port, 0); - p = scm_istr2bve (SCM_STRING_CHARS (*tok_buf) + 1, (long) (j - 1)); + p = scm_istr2bve (SCM_I_STRING_CHARS (*tok_buf) + 1, (long) (j - 1)); if (scm_is_true (p)) return p; else @@ -446,7 +446,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) case '{': j = scm_read_token (c, tok_buf, port, 1); - return scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); + return scm_mem2symbol (SCM_I_STRING_CHARS (*tok_buf), j); case '\\': c = scm_getc (port); @@ -460,20 +460,20 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) * does only consist of octal digits. Finally, it should be * checked whether the resulting fixnum is in the range of * characters. */ - p = scm_i_mem2number (SCM_STRING_CHARS (*tok_buf), j, 8); + p = scm_i_mem2number (SCM_I_STRING_CHARS (*tok_buf), j, 8); 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] - && (scm_casei_streq (scm_charnames[c], SCM_STRING_CHARS (*tok_buf)))) + && (scm_casei_streq (scm_charnames[c], SCM_I_STRING_CHARS (*tok_buf)))) return SCM_MAKE_CHAR (scm_charnums[c]); scm_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL); /* #:SYMBOL is a syntax for keywords supported in all contexts. */ case ':': j = scm_read_token ('-', tok_buf, port, 0); - p = scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); + p = scm_mem2symbol (SCM_I_STRING_CHARS (*tok_buf), j); return scm_make_keyword_from_dash_symbol (p); default: @@ -509,7 +509,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) if (c == EOF) str_eof: scm_input_error (FUNC_NAME, port, "end of file in string constant", SCM_EOL); - while (j + 2 >= SCM_STRING_LENGTH (*tok_buf)) + while (j + 2 >= SCM_I_STRING_LENGTH (*tok_buf)) scm_grow_tok_buf (tok_buf); if (c == '\\') @@ -574,13 +574,13 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) "illegal character in escape sequence: ~S", scm_list_1 (SCM_MAKE_CHAR (c))); } - SCM_STRING_CHARS (*tok_buf)[j] = c; + SCM_I_STRING_CHARS (*tok_buf)[j] = c; ++j; } if (j == 0) return scm_nullstr; - SCM_STRING_CHARS (*tok_buf)[j] = 0; - return scm_mem2string (SCM_STRING_CHARS (*tok_buf), j); + SCM_I_STRING_CHARS (*tok_buf)[j] = 0; + return scm_mem2string (SCM_I_STRING_CHARS (*tok_buf), j); case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': @@ -593,7 +593,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) /* Shortcut: Detected symbol '+ or '- */ goto tok; - p = scm_i_mem2number (SCM_STRING_CHARS (*tok_buf), j, 10); + p = scm_i_mem2number (SCM_I_STRING_CHARS (*tok_buf), j, 10); if (scm_is_true (p)) return p; if (c == '#') @@ -601,7 +601,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) if ((j == 2) && (scm_getc (port) == '(')) { scm_ungetc ('(', port); - c = SCM_STRING_CHARS (*tok_buf)[1]; + c = SCM_I_STRING_CHARS (*tok_buf)[1]; goto callshrp; } scm_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL); @@ -612,7 +612,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) 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); + p = scm_mem2symbol (SCM_I_STRING_CHARS (*tok_buf), j); return scm_make_keyword_from_dash_symbol (p); } /* fallthrough */ @@ -624,7 +624,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) /* fallthrough */ tok: - return scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); + return scm_mem2symbol (SCM_I_STRING_CHARS (*tok_buf), j); } } #undef FUNC_NAME @@ -642,14 +642,14 @@ scm_read_token (int ic, SCM *tok_buf, SCM port, int weird) register char *p; c = (SCM_CASE_INSENSITIVE_P ? scm_c_downcase(ic) : ic); - p = SCM_STRING_CHARS (*tok_buf); + p = SCM_I_STRING_CHARS (*tok_buf); if (weird) j = 0; else { j = 0; - while (j + 2 >= SCM_STRING_LENGTH (*tok_buf)) + while (j + 2 >= SCM_I_STRING_LENGTH (*tok_buf)) p = scm_grow_tok_buf (tok_buf); p[j] = c; ++j; @@ -657,7 +657,7 @@ scm_read_token (int ic, SCM *tok_buf, SCM port, int weird) while (1) { - while (j + 2 >= SCM_STRING_LENGTH (*tok_buf)) + while (j + 2 >= SCM_I_STRING_LENGTH (*tok_buf)) p = scm_grow_tok_buf (tok_buf); c = scm_getc (port); switch (c) diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 7bc4dfa76..a79fde6c6 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -100,14 +100,14 @@ scm_regexp_error_msg (int regerrno, regex_t *rx) errmsg = scm_make_string (scm_from_int (80), SCM_UNDEFINED); SCM_DEFER_INTS; - l = regerror (regerrno, rx, SCM_STRING_CHARS (errmsg), 80); + l = regerror (regerrno, rx, SCM_I_STRING_CHARS (errmsg), 80); if (l > 80) { errmsg = scm_make_string (scm_from_int (l), SCM_UNDEFINED); - regerror (regerrno, rx, SCM_STRING_CHARS (errmsg), l); + regerror (regerrno, rx, SCM_I_STRING_CHARS (errmsg), l); } SCM_ALLOW_INTS; - return SCM_STRING_CHARS (errmsg); + return SCM_I_STRING_CHARS (errmsg); } SCM_DEFINE (scm_regexp_p, "regexp?", 1, 0, 0, @@ -182,7 +182,7 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, } rx = scm_gc_malloc (sizeof(regex_t), "regex"); - status = regcomp (rx, SCM_STRING_CHARS (pat), + status = regcomp (rx, SCM_I_STRING_CHARS (pat), /* Make sure they're not passing REG_NOSUB; regexp-exec assumes we're getting match data. */ cflags & ~REG_NOSUB); @@ -234,7 +234,7 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, if (SCM_UNBNDP (start)) offset = 0; else - offset = scm_to_signed_integer (start, 0, SCM_STRING_LENGTH (str)); + offset = scm_to_signed_integer (start, 0, SCM_I_STRING_LENGTH (str)); if (SCM_UNBNDP (flags)) flags = SCM_INUM0; @@ -245,7 +245,7 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, nmatches = SCM_RGX(rx)->re_nsub + 1; SCM_DEFER_INTS; matches = scm_malloc (sizeof (regmatch_t) * nmatches); - status = regexec (SCM_RGX (rx), SCM_STRING_CHARS (str) + offset, + status = regexec (SCM_RGX (rx), SCM_I_STRING_CHARS (str) + offset, nmatches, matches, scm_to_int (flags)); if (!status) diff --git a/libguile/rw.c b/libguile/rw.c index 94f813b90..23b562d8f 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -107,11 +107,13 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, int fdes; { - long offset; - long last; + size_t offset; + size_t last; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, dest, 3, start, offset, - 4, end, last); + SCM_VALIDATE_STRING (1, str); + dest = SCM_I_STRING_CHARS (str); + scm_i_get_substring_spec (SCM_I_STRING_LENGTH (str), + start, &offset, end, &last); dest += offset; read_len = last - offset; } @@ -145,8 +147,13 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, SCM_SYSERROR; } else if (chars_read == 0) - return SCM_BOOL_F; + { + scm_remember_upto_here_1 (str); + return SCM_BOOL_F; + } } + + scm_remember_upto_here_1 (str); return scm_from_long (chars_read); } #undef FUNC_NAME @@ -200,11 +207,13 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, int fdes; { - long offset; - long last; + size_t offset; + size_t last; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, src, 3, start, offset, - 4, end, last); + SCM_VALIDATE_STRING (1, str); + src = SCM_I_STRING_CHARS (str); + scm_i_get_substring_spec (SCM_I_STRING_LENGTH (str), + start, &offset, end, &last); src += offset; write_len = last - offset; } @@ -246,7 +255,8 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, else SCM_SYSERROR; } - + + scm_remember_upto_here_1 (str); return scm_from_long (rv); } } diff --git a/libguile/strop.c b/libguile/strop.c index 6f4b8cd88..1d7483d97 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -167,16 +167,17 @@ SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, SCM_VALIDATE_STRING (1, str1); SCM_VALIDATE_STRING (4, str2); - s1 = scm_to_unsigned_integer (start1, 0, SCM_STRING_LENGTH(str1)); - e = scm_to_unsigned_integer (end1, s1, SCM_STRING_LENGTH(str1)); + s1 = scm_to_unsigned_integer (start1, 0, SCM_I_STRING_LENGTH(str1)); + e = scm_to_unsigned_integer (end1, s1, SCM_I_STRING_LENGTH(str1)); len = e - s1; - s2 = scm_to_unsigned_integer (start2, 0, SCM_STRING_LENGTH(str2)-len); + s2 = scm_to_unsigned_integer (start2, 0, SCM_I_STRING_LENGTH(str2)-len); - SCM_SYSCALL(memmove((void *)(&(SCM_STRING_CHARS(str2)[s2])), - (void *)(&(SCM_STRING_CHARS(str1)[s1])), + SCM_SYSCALL(memmove((void *)(&(SCM_I_STRING_CHARS(str2)[s2])), + (void *)(&(SCM_I_STRING_CHARS(str1)[s1])), len)); - return scm_return_first(SCM_UNSPECIFIED, str1, str2); + scm_remember_upto_here_2 (str1, str2); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -197,10 +198,11 @@ SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, size_t i, e; char c; SCM_VALIDATE_STRING (1, str); - i = scm_to_unsigned_integer (start, 0, SCM_STRING_LENGTH (str)); - e = scm_to_unsigned_integer (end, i, SCM_STRING_LENGTH (str)); + i = scm_to_unsigned_integer (start, 0, SCM_I_STRING_LENGTH (str)); + e = scm_to_unsigned_integer (end, i, SCM_I_STRING_LENGTH (str)); SCM_VALIDATE_CHAR_COPY (4, fill, c); - while (ilist", 1, 0, 0, SCM res = SCM_EOL; unsigned char *src; SCM_VALIDATE_STRING (1, str); - src = SCM_STRING_UCHARS (str); - for (i = SCM_STRING_LENGTH (str)-1;i >= 0;i--) res = scm_cons (SCM_MAKE_CHAR (src[i]), res); + src = SCM_I_STRING_UCHARS (str); + for (i = SCM_I_STRING_LENGTH (str)-1;i >= 0;i--) + res = scm_cons (SCM_MAKE_CHAR (src[i]), res); + scm_remember_upto_here_1 (src); return res; } #undef FUNC_NAME @@ -247,9 +251,10 @@ SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0, static SCM string_copy (SCM str) { - const char* chars = SCM_STRING_CHARS (str); - size_t length = SCM_STRING_LENGTH (str); - SCM new_string = scm_mem2string (chars, length); + const char* chars = SCM_I_STRING_CHARS (str); + size_t length = SCM_I_STRING_LENGTH (str); + SCM new_string = scm_allocate_string (length); + memcpy (SCM_I_STRING_CHARS (new_string), chars, length+1); scm_remember_upto_here_1 (str); return new_string; } @@ -273,11 +278,14 @@ SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0, "return an unspecified value.") #define FUNC_NAME s_scm_string_fill_x { - register char *dst, c; - register long k; - SCM_VALIDATE_STRING_COPY (1, str, dst); + char *dst, c; + long k; + SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_CHAR_COPY (2, chr, c); - for (k = SCM_STRING_LENGTH (str)-1;k >= 0;k--) dst[k] = c; + dst = SCM_I_STRING_CHARS (str); + for (k = SCM_I_STRING_LENGTH (str)-1;k >= 0;k--) + dst[k] = c; + scm_remember_upto_here_1 (str); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -290,8 +298,8 @@ string_upcase_x (SCM v) { unsigned long k; - for (k = 0; k < SCM_STRING_LENGTH (v); ++k) - SCM_STRING_UCHARS (v) [k] = scm_c_upcase (SCM_STRING_UCHARS (v) [k]); + for (k = 0; k < SCM_I_STRING_LENGTH (v); ++k) + SCM_I_STRING_UCHARS (v) [k] = scm_c_upcase (SCM_I_STRING_UCHARS (v) [k]); return v; } @@ -335,8 +343,8 @@ string_downcase_x (SCM v) { unsigned long k; - for (k = 0; k < SCM_STRING_LENGTH (v); ++k) - SCM_STRING_UCHARS (v) [k] = scm_c_downcase (SCM_STRING_UCHARS (v) [k]); + for (k = 0; k < SCM_I_STRING_LENGTH (v); ++k) + SCM_I_STRING_UCHARS (v) [k] = scm_c_downcase (SCM_I_STRING_UCHARS (v) [k]); return v; } @@ -382,8 +390,8 @@ string_capitalize_x (SCM str) long i, len; int in_word=0; - len = SCM_STRING_LENGTH(str); - sz = SCM_STRING_UCHARS (str); + len = SCM_I_STRING_LENGTH(str); + sz = SCM_I_STRING_UCHARS (str); for(i=0; i= 0) { diff --git a/libguile/strorder.c b/libguile/strorder.c index ac19d7370..6e8b647d3 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -43,18 +43,22 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, SCM_VALIDATE_STRING (1, s1); SCM_VALIDATE_STRING (2, s2); - length = SCM_STRING_LENGTH (s2); - if (SCM_STRING_LENGTH (s1) == length) + length = SCM_I_STRING_LENGTH (s2); + if (SCM_I_STRING_LENGTH (s1) == length) { - unsigned char *c1 = SCM_STRING_UCHARS (s1) + length - 1; - unsigned char *c2 = SCM_STRING_UCHARS (s2) + length - 1; + unsigned char *c1 = SCM_I_STRING_UCHARS (s1) + length - 1; + unsigned char *c2 = SCM_I_STRING_UCHARS (s2) + length - 1; size_t i; /* comparing from back to front typically finds mismatches faster */ for (i = 0; i != length; ++i, --c1, --c2) if (*c1 != *c2) - return SCM_BOOL_F; + { + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; + } + scm_remember_upto_here_2 (s1, s2); return SCM_BOOL_T; } else @@ -78,18 +82,22 @@ SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, SCM_VALIDATE_STRING (1, s1); SCM_VALIDATE_STRING (2, s2); - length = SCM_STRING_LENGTH (s2); - if (SCM_STRING_LENGTH (s1) == length) + length = SCM_I_STRING_LENGTH (s2); + if (SCM_I_STRING_LENGTH (s1) == length) { - unsigned char *c1 = SCM_STRING_UCHARS (s1) + length - 1; - unsigned char *c2 = SCM_STRING_UCHARS (s2) + length - 1; + unsigned char *c1 = SCM_I_STRING_UCHARS (s1) + length - 1; + unsigned char *c2 = SCM_I_STRING_UCHARS (s2) + length - 1; size_t i; /* comparing from back to front typically finds mismatches faster */ for (i = 0; i != length; ++i, --c1, --c2) if (scm_c_upcase (*c1) != scm_c_upcase (*c2)) - return SCM_BOOL_F; + { + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; + } + scm_remember_upto_here_2 (s1, s2); return SCM_BOOL_T; } else @@ -108,16 +116,18 @@ string_less_p (SCM s1, SCM s2) size_t i, length1, length2, lengthm; unsigned char *c1, *c2; - length1 = SCM_STRING_LENGTH (s1); - length2 = SCM_STRING_LENGTH (s2); + length1 = SCM_I_STRING_LENGTH (s1); + length2 = SCM_I_STRING_LENGTH (s2); lengthm = min (length1, length2); - c1 = SCM_STRING_UCHARS (s1); - c2 = SCM_STRING_UCHARS (s2); + c1 = SCM_I_STRING_UCHARS (s1); + c2 = SCM_I_STRING_UCHARS (s2); for (i = 0; i != lengthm; ++i, ++c1, ++c2) { int c = *c1 - *c2; - if (c < 0) return SCM_BOOL_T; - if (c > 0) return SCM_BOOL_F; + if (c == 0) + continue; + scm_remember_upto_here_2 (s1, s2); + return scm_from_bool (c < 0); } return scm_from_bool (length1 < length2); @@ -188,16 +198,18 @@ string_ci_less_p (SCM s1, SCM s2) size_t i, length1, length2, lengthm; unsigned char *c1, *c2; - length1 = SCM_STRING_LENGTH (s1); - length2 = SCM_STRING_LENGTH (s2); + length1 = SCM_I_STRING_LENGTH (s1); + length2 = SCM_I_STRING_LENGTH (s2); lengthm = min (length1, length2); - c1 = SCM_STRING_UCHARS (s1); - c2 = SCM_STRING_UCHARS (s2); + c1 = SCM_I_STRING_UCHARS (s1); + c2 = SCM_I_STRING_UCHARS (s2); for (i = 0; i != lengthm; ++i, ++c1, ++c2) { int c = scm_c_upcase (*c1) - scm_c_upcase (*c2); - if (c < 0) return SCM_BOOL_T; - if (c > 0) return SCM_BOOL_F; + if (c == 0) + continue; + scm_remember_upto_here_2 (s1, s2); + return scm_from_bool (c < 0); } return scm_from_bool (length1 < length2); diff --git a/libguile/strports.c b/libguile/strports.c index 70d8e66f0..aa9844bc7 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -80,7 +80,7 @@ st_resize_port (scm_t_port *pt, off_t new_size) { SCM old_stream = SCM_PACK (pt->stream); SCM new_stream = scm_allocate_string (new_size); - unsigned long int old_size = SCM_STRING_LENGTH (old_stream); + unsigned long int old_size = SCM_I_STRING_LENGTH (old_stream); unsigned long int min_size = min (old_size, new_size); unsigned long int i; @@ -89,12 +89,14 @@ st_resize_port (scm_t_port *pt, off_t new_size) pt->write_buf_size = new_size; for (i = 0; i != min_size; ++i) - SCM_STRING_CHARS (new_stream) [i] = SCM_STRING_CHARS (old_stream) [i]; + SCM_I_STRING_CHARS (new_stream) [i] = SCM_I_STRING_CHARS (old_stream) [i]; + + scm_remember_upto_here_1 (old_stream); /* reset buffer. */ { pt->stream = SCM_UNPACK (new_stream); - pt->read_buf = pt->write_buf = SCM_STRING_UCHARS (new_stream); + pt->read_buf = pt->write_buf = SCM_I_STRING_UCHARS (new_stream); pt->read_pos = pt->write_pos = pt->write_buf + index; pt->write_end = pt->write_buf + pt->write_buf_size; pt->read_end = pt->read_buf + pt->read_buf_size; diff --git a/libguile/struct.c b/libguile/struct.c index dac3ae5ab..efb17d3a4 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -63,12 +63,12 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, size_t len; int x; - len = SCM_STRING_LENGTH (fields); + len = SCM_I_STRING_LENGTH (fields); if (len % 2 == 1) SCM_MISC_ERROR ("odd length field specification: ~S", scm_list_1 (fields)); - field_desc = SCM_STRING_CHARS (fields); + field_desc = SCM_I_STRING_CHARS (fields); for (x = 0; x < len; x += 2) { @@ -122,7 +122,8 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, } new_sym = scm_mem2symbol (field_desc, len); } - return scm_return_first (new_sym, fields); + scm_remember_upto_here_1 (fields); + return new_sym; } #undef FUNC_NAME @@ -231,17 +232,22 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, { SCM layout; scm_t_bits * mem; + int tmp; if (!SCM_STRUCTP (x)) return SCM_BOOL_F; layout = SCM_STRUCT_LAYOUT (x); - if (SCM_SYMBOL_LENGTH (layout) < SCM_STRING_LENGTH (required_vtable_fields)) + if (SCM_SYMBOL_LENGTH (layout) + < SCM_I_STRING_LENGTH (required_vtable_fields)) return SCM_BOOL_F; - if (strncmp (SCM_SYMBOL_CHARS (layout), SCM_STRING_CHARS (required_vtable_fields), - SCM_STRING_LENGTH (required_vtable_fields))) + tmp = strncmp (SCM_SYMBOL_CHARS (layout), + SCM_I_STRING_CHARS (required_vtable_fields), + SCM_I_STRING_LENGTH (required_vtable_fields)); + scm_remember_upto_here_1 (required_vtable_fields); + if (tmp) return SCM_BOOL_F; mem = SCM_STRUCT_DATA (x); diff --git a/libguile/symbols.c b/libguile/symbols.c index f7fd68145..dc413c369 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -186,8 +186,8 @@ SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0, { SCM sym; SCM_VALIDATE_STRING (1, name); - sym = scm_mem2uninterned_symbol (SCM_STRING_CHARS (name), - SCM_STRING_LENGTH (name)); + sym = scm_mem2uninterned_symbol (SCM_I_STRING_CHARS (name), + SCM_I_STRING_LENGTH (name)); scm_remember_upto_here_1 (name); return sym; } @@ -255,8 +255,8 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, { SCM sym; SCM_VALIDATE_STRING (1, string); - sym = scm_mem2symbol (SCM_STRING_CHARS (string), - SCM_STRING_LENGTH (string)); + sym = scm_mem2symbol (SCM_I_STRING_CHARS (string), + SCM_I_STRING_LENGTH (string)); scm_remember_upto_here_1 (string); return sym; } @@ -287,10 +287,11 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, else { SCM_VALIDATE_STRING (1, prefix); - len = SCM_STRING_LENGTH (prefix); + len = SCM_I_STRING_LENGTH (prefix); if (len > MAX_PREFIX_LENGTH) name = scm_malloc (len + SCM_INTBUFLEN); - memcpy (name, SCM_STRING_CHARS (prefix), len); + memcpy (name, SCM_I_STRING_CHARS (prefix), len); + scm_remember_upto_here_1 (prefix); } { int n, n_digits; diff --git a/libguile/unif.c b/libguile/unif.c index 78612621c..7936f2491 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -220,7 +220,7 @@ SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, case scm_tc7_wvect: return scm_from_size_t (SCM_VECTOR_LENGTH (v)); case scm_tc7_string: - return scm_from_size_t (SCM_STRING_LENGTH (v)); + return scm_from_size_t (SCM_I_STRING_LENGTH (v)); case scm_tc7_bvect: return scm_from_size_t (SCM_BITVECTOR_LENGTH (v)); case scm_tc7_byvect: @@ -939,11 +939,11 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, 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; - SCM_STRING_CHARS (axv)[j] = 1; + SCM_I_STRING_CHARS (axv)[j] = 1; } for (j = 0, k = 0; k < noutr; k++, j++) { - while (SCM_STRING_CHARS (axv)[j]) + while (SCM_I_STRING_CHARS (axv)[j]) j++; SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd; SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd; @@ -1109,7 +1109,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, else return SCM_BOOL_F; case scm_tc7_string: - return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]); + return SCM_MAKE_CHAR (SCM_I_STRING_UCHARS (v)[pos]); case scm_tc7_byvect: return scm_from_schar (((char *) SCM_UVECTOR_BASE (v))[pos]); case scm_tc7_uvect: @@ -1155,7 +1155,7 @@ scm_cvref (SCM v, unsigned long pos, SCM last) else return SCM_BOOL_F; case scm_tc7_string: - return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]); + return SCM_MAKE_CHAR (SCM_I_STRING_UCHARS (v)[pos]); case scm_tc7_byvect: return scm_from_char (((char *) SCM_UVECTOR_BASE (v))[pos]); case scm_tc7_uvect: @@ -1269,7 +1269,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, break; case scm_tc7_string: SCM_ASRTGO (SCM_CHARP (obj), badobj); - SCM_STRING_UCHARS (v)[pos] = SCM_CHAR (obj); + SCM_I_STRING_UCHARS (v)[pos] = SCM_CHAR (obj); break; case scm_tc7_byvect: if (SCM_CHARP (obj)) @@ -1478,7 +1478,7 @@ loop: v = SCM_ARRAY_V (cra); goto loop; case scm_tc7_string: - base = SCM_STRING_CHARS (v); + base = SCM_I_STRING_CHARS (v); sz = sizeof (char); break; case scm_tc7_bvect: @@ -1644,7 +1644,7 @@ loop: v = SCM_ARRAY_V (v); goto loop; case scm_tc7_string: - base = SCM_STRING_CHARS (v); + base = SCM_I_STRING_CHARS (v); sz = sizeof (char); break; case scm_tc7_bvect: @@ -2321,16 +2321,16 @@ tail: break; case scm_tc7_string: if (n-- > 0) - scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate); + scm_iprin1 (SCM_MAKE_CHAR (SCM_I_STRING_UCHARS (ra)[j]), port, pstate); if (SCM_WRITINGP (pstate)) for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); - scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate); + scm_iprin1 (SCM_MAKE_CHAR (SCM_I_STRING_UCHARS (ra)[j]), port, pstate); } else for (j += inc; n-- > 0; j += inc) - scm_putc (SCM_STRING_CHARS (ra)[j], port); + scm_putc (SCM_I_STRING_CHARS (ra)[j], port); break; case scm_tc7_byvect: if (n-- > 0) From 57d4d32fa36d733a99f92d6515d6abf6d960f641 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:49:59 +0000 Subject: [PATCH 51/64] (MY_VALIDATE_SUBSTRING_SPEC_COPY, MY_VALIDATE_STRING_COPY): Modernized clones of the deprecated validation macros. Replaced every use. --- srfi/srfi-13.c | 556 ++++++++++++++++++++++++++----------------------- 1 file changed, 291 insertions(+), 265 deletions(-) diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index e46e7c408..f7afa2784 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -26,6 +26,32 @@ #include "srfi-13.h" #include "srfi-14.h" +/* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages + messing with the internal representation of strings. We define our + own version since we use it so much and are messing with Guile + internals anyway. +*/ + +#define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \ + pos_start, start, c_start, \ + pos_end, end, c_end) \ + do { \ + SCM_VALIDATE_STRING (pos_str, str); \ + c_str = SCM_I_STRING_CHARS (str); \ + scm_i_get_substring_spec (SCM_I_STRING_LENGTH (str), \ + start, &c_start, end, &c_end); \ + } while (0) + + +/* Likewise for SCM_VALIDATE_STRING_COPY. */ + +#define MY_VALIDATE_STRING_COPY(pos, str, cvar) \ + do { \ + SCM_VALIDATE_STRING (pos, str); \ + cvar = SCM_I_STRING_CHARS(str); \ + } while (0) + + SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, (SCM pred, SCM s, SCM start, SCM end), "Check if the predicate @var{pred} is true for any character in\n" @@ -46,9 +72,9 @@ SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, SCM res; SCM_VALIDATE_PROC (1, pred); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); cstr += cstart; while (cstart < cend) { @@ -87,9 +113,9 @@ SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0, SCM res; SCM_VALIDATE_PROC (1, pred); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); res = SCM_BOOL_T; cstr += cstart; while (cstart < cend) @@ -147,9 +173,9 @@ SCM_DEFINE (scm_string_to_listS, "string->list", 1, 2, 0, int cstart, cend; SCM result = SCM_EOL; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); while (cstart < cend) { cend--; @@ -366,9 +392,9 @@ SCM_DEFINE (scm_string_copyS, "string-copy", 1, 2, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); return scm_mem2string (cstr + cstart, cend - cstart); } @@ -412,12 +438,12 @@ SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0, int len; SCM sdummy = SCM_UNDEFINED; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target, ctarget, - 2, tstart, ctstart, - 2, sdummy, dummy); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, - 4, start, cstart, - 5, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, target, ctarget, + 2, tstart, ctstart, + 2, sdummy, dummy); + MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, + 4, start, cstart, + 5, end, cend); len = cend - cstart; SCM_ASSERT_RANGE (3, s, len <= SCM_STRING_LENGTH (target) - ctstart); @@ -437,7 +463,7 @@ SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0, char * cstr; size_t cn; - SCM_VALIDATE_STRING_COPY (1, s, cstr); + MY_VALIDATE_STRING_COPY (1, s, cstr); cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s)); return scm_mem2string (cstr, cn); @@ -453,7 +479,7 @@ SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0, char * cstr; size_t cn; - SCM_VALIDATE_STRING_COPY (1, s, cstr); + MY_VALIDATE_STRING_COPY (1, s, cstr); cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s)); return scm_mem2string (cstr + cn, SCM_STRING_LENGTH (s) - cn); @@ -469,7 +495,7 @@ SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0, char * cstr; size_t cn; - SCM_VALIDATE_STRING_COPY (1, s, cstr); + MY_VALIDATE_STRING_COPY (1, s, cstr); cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s)); return scm_mem2string (cstr + SCM_STRING_LENGTH (s) - cn, cn); @@ -485,7 +511,7 @@ SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0, char * cstr; size_t cn; - SCM_VALIDATE_STRING_COPY (1, s, cstr); + MY_VALIDATE_STRING_COPY (1, s, cstr); cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s)); return scm_mem2string (cstr, SCM_STRING_LENGTH (s) - cn); @@ -506,9 +532,9 @@ SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0, size_t cstart, cend, clen; SCM result; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 4, start, cstart, - 5, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 4, start, cstart, + 5, end, cend); clen = scm_to_size_t (len); if (SCM_UNBNDP (chr)) @@ -549,9 +575,9 @@ SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0, size_t cstart, cend, clen; SCM result; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 4, start, cstart, - 5, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 4, start, cstart, + 5, end, cend); clen = scm_to_size_t (len); if (SCM_UNBNDP (chr)) @@ -601,9 +627,9 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, char * cstr; size_t cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); if (SCM_UNBNDP (char_pred)) { while (cstart < cend) @@ -676,9 +702,9 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); if (SCM_UNBNDP (char_pred)) { while (cstart < cend) @@ -751,9 +777,9 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); if (SCM_UNBNDP (char_pred)) { while (cstart < cend) @@ -838,9 +864,9 @@ SCM_DEFINE (scm_string_fill_xS, "string-fill!", 2, 2, 0, int c; long k; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 3, start, cstart, + 4, end, cend); SCM_VALIDATE_CHAR_COPY (2, chr, c); for (k = cstart; k < cend; k++) cstr[k] = c; @@ -862,12 +888,12 @@ SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 6, start1, cstart1, - 7, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 8, start2, cstart2, - 9, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 6, start1, cstart1, + 7, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 8, start2, cstart2, + 9, end2, cend2); SCM_VALIDATE_PROC (3, proc_lt); SCM_VALIDATE_PROC (4, proc_eq); SCM_VALIDATE_PROC (5, proc_gt); @@ -905,12 +931,12 @@ SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 6, start1, cstart1, - 7, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 8, start2, cstart2, - 9, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 6, start1, cstart1, + 7, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 8, start2, cstart2, + 9, end2, cend2); SCM_VALIDATE_PROC (3, proc_lt); SCM_VALIDATE_PROC (4, proc_eq); SCM_VALIDATE_PROC (5, proc_gt); @@ -943,12 +969,12 @@ SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { @@ -978,12 +1004,12 @@ SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { @@ -1013,12 +1039,12 @@ SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { @@ -1048,12 +1074,12 @@ SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { @@ -1083,12 +1109,12 @@ SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { @@ -1118,12 +1144,12 @@ SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { @@ -1154,12 +1180,12 @@ SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { @@ -1190,12 +1216,12 @@ SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { @@ -1226,12 +1252,12 @@ SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { @@ -1262,12 +1288,12 @@ SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { @@ -1298,12 +1324,12 @@ SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { @@ -1334,12 +1360,12 @@ SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0, char * cstr1, * cstr2; int cstart1, cend1, cstart2, cend2; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { @@ -1370,12 +1396,12 @@ SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0, int cstart1, cend1, cstart2, cend2; int len = 0; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { if (cstr1[cstart1] != cstr2[cstart2]) @@ -1399,12 +1425,12 @@ SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0, int cstart1, cend1, cstart2, cend2; int len = 0; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2])) @@ -1428,12 +1454,12 @@ SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0, int cstart1, cend1, cstart2, cend2; int len = 0; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { cend1--; @@ -1457,12 +1483,12 @@ SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0, int cstart1, cend1, cstart2, cend2; int len = 0; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { cend1--; @@ -1485,12 +1511,12 @@ SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0, int cstart1, cend1, cstart2, cend2; int len = 0, len1; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); len1 = cend1 - cstart1; while (cstart1 < cend1 && cstart2 < cend2) { @@ -1514,12 +1540,12 @@ SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0, int cstart1, cend1, cstart2, cend2; int len = 0, len1; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); len1 = cend1 - cstart1; while (cstart1 < cend1 && cstart2 < cend2) { @@ -1543,12 +1569,12 @@ SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0, int cstart1, cend1, cstart2, cend2; int len = 0, len1; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); len1 = cend1 - cstart1; while (cstart1 < cend1 && cstart2 < cend2) { @@ -1572,12 +1598,12 @@ SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0, int cstart1, cend1, cstart2, cend2; int len = 0, len1; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); len1 = cend1 - cstart1; while (cstart1 < cend1 && cstart2 < cend2) { @@ -1614,9 +1640,9 @@ SCM_DEFINE (scm_string_indexS, "string-index", 2, 2, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); if (SCM_CHARP (char_pred)) { char cchr = SCM_CHAR (char_pred); @@ -1673,9 +1699,9 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); if (SCM_CHARP (char_pred)) { char cchr = SCM_CHAR (char_pred); @@ -1733,9 +1759,9 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); if (SCM_CHARP (char_pred)) { char cchr = SCM_CHAR (char_pred); @@ -1793,9 +1819,9 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); if (SCM_CHARP (char_pred)) { char cchr = SCM_CHAR (char_pred); @@ -1853,9 +1879,9 @@ SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0, int cstart, cend; int count = 0; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); if (SCM_CHARP (char_pred)) { char cchr = SCM_CHAR (char_pred); @@ -1907,12 +1933,12 @@ SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0, int cstart1, cend1, cstart2, cend2; int len2, i, j; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2, + 5, start2, cstart2, + 6, end2, cend2); len2 = cend2 - cstart2; while (cstart1 <= cend1 - len2) { @@ -1948,12 +1974,12 @@ SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0, int cstart1, cend1, cstart2, cend2; int len2, i, j; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2, + 5, start2, cstart2, + 6, end2, cend2); len2 = cend2 - cstart2; while (cstart1 <= cend1 - len2) { @@ -2005,9 +2031,9 @@ SCM_DEFINE (scm_string_upcase_xS, "string-upcase!", 1, 2, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); return string_upcase_x (str, cstart, cend); } #undef FUNC_NAME @@ -2023,9 +2049,9 @@ SCM_DEFINE (scm_string_upcaseS, "string-upcase", 1, 2, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); return string_upcase_x (scm_string_copy (str), cstart, cend); } #undef FUNC_NAME @@ -2064,9 +2090,9 @@ SCM_DEFINE (scm_string_downcase_xS, "string-downcase!", 1, 2, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); return string_downcase_x (str, cstart, cend); } #undef FUNC_NAME @@ -2082,9 +2108,9 @@ SCM_DEFINE (scm_string_downcaseS, "string-downcase", 1, 2, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); return string_downcase_x (scm_string_copy (str), cstart, cend); } #undef FUNC_NAME @@ -2129,9 +2155,9 @@ SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); return string_titlecase_x (str, cstart, cend); } #undef FUNC_NAME @@ -2145,9 +2171,9 @@ SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0, char * cstr; int cstart, cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); return string_titlecase_x (scm_string_copy (str), cstart, cend); } #undef FUNC_NAME @@ -2184,9 +2210,9 @@ SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0, int cend; SCM result; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); result = scm_string_copy (str); string_reverse_x (SCM_STRING_CHARS (result), cstart, cend); return result; @@ -2205,9 +2231,9 @@ SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0, int cstart; int cend; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); string_reverse_x (SCM_STRING_CHARS (str), cstart, cend); return SCM_UNSPECIFIED; } @@ -2398,9 +2424,9 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, SCM result; SCM_VALIDATE_PROC (1, proc); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); result = scm_allocate_string (cend - cstart); p = SCM_STRING_CHARS (result); while (cstart < cend) @@ -2429,9 +2455,9 @@ SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0, int cstart, cend; SCM_VALIDATE_PROC (1, proc); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); p = SCM_STRING_CHARS (s) + cstart; while (cstart < cend) { @@ -2460,9 +2486,9 @@ SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0, SCM result; SCM_VALIDATE_PROC (1, kons); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, - 4, start, cstart, - 5, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, + 4, start, cstart, + 5, end, cend); result = knil; while (cstart < cend) { @@ -2488,9 +2514,9 @@ SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0, SCM result; SCM_VALIDATE_PROC (1, kons); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, - 4, start, cstart, - 5, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, + 4, start, cstart, + 5, end, cend); result = knil; while (cstart < cend) { @@ -2637,9 +2663,9 @@ SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0, int cstart, cend; SCM_VALIDATE_PROC (1, proc); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); while (cstart < cend) { unsigned int c = (unsigned char) cstr[cstart]; @@ -2660,9 +2686,9 @@ SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0, int cstart, cend; SCM_VALIDATE_PROC (1, proc); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); while (cstart < cend) { scm_call_1 (proc, SCM_I_MAKINUM (cstart)); @@ -2690,9 +2716,9 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, size_t cstart, cend, cfrom, cto; SCM result; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cs, - 4, start, cstart, - 5, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cs, + 4, start, cstart, + 5, end, cend); cfrom = scm_to_size_t (from); if (SCM_UNBNDP (to)) cto = cfrom + (cend - cstart); @@ -2733,12 +2759,12 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, SCM dummy = SCM_UNDEFINED; int cdummy; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target, ctarget, - 2, tstart, ctstart, - 2, dummy, cdummy); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cs, - 6, start, cstart, - 7, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, target, ctarget, + 2, tstart, ctstart, + 2, dummy, cdummy); + MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cs, + 6, start, cstart, + 7, end, cend); csfrom = scm_to_size_t (sfrom); if (SCM_UNBNDP (sto)) csto = csfrom + (cend - cstart); @@ -2776,12 +2802,12 @@ SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0, size_t cstart1, cend1, cstart2, cend2; SCM result; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); result = scm_allocate_string (cstart1 + (cend2 - cstart2) + SCM_STRING_LENGTH (s1) - cend1); p = SCM_STRING_CHARS (result); @@ -2812,9 +2838,9 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, static SCM charset_graphic = SCM_BOOL_F; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); if (SCM_UNBNDP (token_set)) { @@ -2873,9 +2899,9 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, SCM result; int idx; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); if (SCM_CHARP (char_pred)) { SCM ls = SCM_EOL; @@ -2939,9 +2965,9 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, SCM result; int idx; - SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); if (SCM_CHARP (char_pred)) { SCM ls = SCM_EOL; From c41acab35c998e3597f4f2ebf537b66d70a7a644 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Aug 2004 17:52:49 +0000 Subject: [PATCH 52/64] *** empty log message *** --- NEWS | 18 ++++++++++++++++-- srfi/ChangeLog | 6 ++++++ 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 4f8f9a901..10b133173 100644 --- a/NEWS +++ b/NEWS @@ -687,6 +687,12 @@ conventions. These functions occupy the names that scm_round_number and scm_truncate_number should have. +** The functions scm_c_string2str and scm_c_substring2str have been + deprecated. + +Use scm_to_locale_stringbuf or similar instead, maybe together with +scm_substring. + ** SCM_CELL_WORD_LOC has been deprecated. Use the new macro SCM_CELL_OBJECT_LOC instead, which return a pointer @@ -729,7 +735,8 @@ prevent a potential memory leak: scm_frame_unwind_handler (free, mem, SCM_F_WIND_EXPLICITELY); /* MEM would leak if BAR throws an error. - SCM_FRAME_UNWIND_HANDLER frees it nevertheless. */ + SCM_FRAME_UNWIND_HANDLER frees it nevertheless. + */ bar (); @@ -742,6 +749,12 @@ prevent a potential memory leak: For full documentation, see the node "Frames" in the manual. +** New function scm_frame_free + +This function calls 'free' on a given pointer when a frame is left. +Thus the call to scm_frame_unwind_handler above could be replaced with +simply scm_frame_free (mem). + ** New way to block and unblock asyncs In addition to scm_c_call_with_blocked_asyncs you can now also use @@ -1225,7 +1238,8 @@ SCM_VALIDATE_RWSTRING, DIGITS, scm_small_istr2int, scm_istr2int, scm_istr2flo, scm_istring2number, scm_istr2int, scm_istr2flo, scm_istring2number, scm_vtable_index_vcell, scm_si_vcell, SCM_ECONSP, SCM_NECONSP, SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL, -SCM_GLOC_VAL_LOC, scm_make_gloc, scm_gloc_p, scm_tc16_variable +SCM_GLOC_VAL_LOC, scm_make_gloc, scm_gloc_p, scm_tc16_variable, +SCM_CHARS, SCM_LENGTH, SCM_SET_STRING_CHARS, SCM_SET_STRING_LENGTH. ** Deprecated definitions for debugging: scm_debug_mode, SCM_DEBUGGINGP diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 03812704e..63c0a5cc6 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2004-08-12 Marius Vollmer + + * srfi-13.c (MY_VALIDATE_SUBSTRING_SPEC_COPY, + MY_VALIDATE_STRING_COPY): Modernized clones of the deprecated + validation macros. Replaced every use. + 2004-08-05 Kevin Ryde * srfi-13.c (scm_string_any, scm_string_every): Enhance docstrings as From 11c5e0bf6ba28b1f79c1a6add2a84120c9469106 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 13 Aug 2004 12:28:23 +0000 Subject: [PATCH 53/64] (scm_init_load_path): Do not pass NULL to scm_to_locale_string, which would happen when GUILE_LOAD_PATH is not set. Thanks to Bill Schottstaedt. --- libguile/load.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 449855224..d50211dcf 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -204,6 +204,7 @@ SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, void scm_init_load_path () { + char *env; SCM path = SCM_EOL; #ifdef SCM_LIBRARY_DIR @@ -212,8 +213,9 @@ scm_init_load_path () scm_makfrom0str (SCM_PKGDATA_DIR)); #endif /* SCM_LIBRARY_DIR */ - path = scm_parse_path (scm_from_locale_string (getenv ("GUILE_LOAD_PATH")), - path); + env = getenv ("GUILE_LOAD_PATH"); + if (env) + path = scm_parse_path (scm_from_locale_string (env), path); *scm_loc_load_path = path; } From fa0c0a4b12be5a12ed7c79946d758a0a1980d479 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 13 Aug 2004 12:28:38 +0000 Subject: [PATCH 54/64] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5e1d3a847..6e4600112 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2004-08-13 Marius Vollmer + + * load.c (scm_init_load_path): Do not pass NULL to + scm_to_locale_string, which would happen when GUILE_LOAD_PATH is + not set. Thanks to Bill Schottstaedt. + 2004-08-12 Marius Vollmer * socket.c (scm_inet_aton, scm_inet_pton): Convert SCM strings to From 788dafed64a4f08d3c3a3825f4e7c95a274d1631 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 14 Aug 2004 00:37:53 +0000 Subject: [PATCH 55/64] (scm_string_any, scm_string_every): Add support for char and charset as predicates, per SRFI-13 spec. --- srfi/srfi-13.c | 79 +++++++++++++++++++++++++++++++++++++------------- 1 file changed, 59 insertions(+), 20 deletions(-) diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index f7afa2784..2698095d3 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -53,7 +53,7 @@ SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, - (SCM pred, SCM s, SCM start, SCM end), + (SCM char_pred, SCM s, SCM start, SCM end), "Check if the predicate @var{pred} is true for any character in\n" "the string @var{s}.\n" "\n" @@ -71,18 +71,36 @@ SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, int cstart, cend; SCM res; - SCM_VALIDATE_PROC (1, pred); MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, 3, start, cstart, 4, end, cend); - cstr += cstart; - while (cstart < cend) + + if (SCM_CHARP (char_pred)) { - res = scm_call_1 (pred, SCM_MAKE_CHAR (*cstr)); - if (scm_is_true (res)) - return res; - cstr++; - cstart++; + return (memchr (cstr+cstart, (int) SCM_CHAR (char_pred), + cend-cstart) == NULL + ? SCM_BOOL_F : SCM_BOOL_T); + } + else if (SCM_CHARSETP (char_pred)) + { + int i; + for (i = cstart; i < cend; i++) + if (SCM_CHARSET_GET (char_pred, cstr[i])) + return SCM_BOOL_T; + } + else + { + SCM_VALIDATE_PROC (1, char_pred); + + cstr += cstart; + while (cstart < cend) + { + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (*cstr)); + if (scm_is_true (res)) + return res; + cstr++; + cstart++; + } } return SCM_BOOL_F; } @@ -90,7 +108,7 @@ SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0, - (SCM pred, SCM s, SCM start, SCM end), + (SCM char_pred, SCM s, SCM start, SCM end), "Check if the predicate @var{pred} is true for every character\n" "in the string @var{s}.\n" "\n" @@ -112,21 +130,42 @@ SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0, int cstart, cend; SCM res; - SCM_VALIDATE_PROC (1, pred); MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, 3, start, cstart, 4, end, cend); - res = SCM_BOOL_T; - cstr += cstart; - while (cstart < cend) + if (SCM_CHARP (char_pred)) { - res = scm_call_1 (pred, SCM_MAKE_CHAR (*cstr)); - if (scm_is_false (res)) - return res; - cstr++; - cstart++; + char cchr = SCM_CHAR (char_pred); + int i; + for (i = cstart; i < cend; i++) + if (cstr[i] != cchr) + return SCM_BOOL_F; + return SCM_BOOL_T; + } + else if (SCM_CHARSETP (char_pred)) + { + int i; + for (i = cstart; i < cend; i++) + if (! SCM_CHARSET_GET (char_pred, cstr[i])) + return SCM_BOOL_F; + return SCM_BOOL_T; + } + else + { + SCM_VALIDATE_PROC (1, char_pred); + + res = SCM_BOOL_T; + cstr += cstart; + while (cstart < cend) + { + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (*cstr)); + if (scm_is_false (res)) + return res; + cstr++; + cstart++; + } + return res; } - return res; } #undef FUNC_NAME From 038a7484b60116f765b6168d3afb7bae652d4030 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 14 Aug 2004 00:39:01 +0000 Subject: [PATCH 56/64] *** empty log message *** --- srfi/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 63c0a5cc6..6176d9204 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2004-08-14 Kevin Ryde + + * srfi-13.c (scm_string_any, scm_string_every): Add support for char + and charset as predicates, per SRFI-13 spec. + 2004-08-12 Marius Vollmer * srfi-13.c (MY_VALIDATE_SUBSTRING_SPEC_COPY, From 967c0904a07b02e342df669ee82f486ac2a40459 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 14 Aug 2004 00:43:56 +0000 Subject: [PATCH 57/64] (string-any, string-every): Exercise char and charset predicate cases. --- test-suite/tests/srfi-13.test | 228 +++++++++++++++++++++++++++------- 1 file changed, 186 insertions(+), 42 deletions(-) diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test index bb5c09123..4cd636f3b 100644 --- a/test-suite/tests/srfi-13.test +++ b/test-suite/tests/srfi-13.test @@ -28,34 +28,106 @@ (define exception:strict-infix-grammar (cons 'misc-error "^strict-infix")) +;;; +;;; string-any +;;; + (with-test-prefix "string-any" - (pass-if "no match" - (not (string-any char-upper-case? "abcde"))) + (with-test-prefix "bad char_pred" - (pass-if "one match" - (string-any char-upper-case? "abCde")) + (pass-if-exception "integer" exception:wrong-type-arg + (string-any 123 "abcde")) - (pass-if "more than one match" - (string-any char-upper-case? "abCDE")) + (pass-if-exception "string" exception:wrong-type-arg + (string-any "zzz" "abcde"))) - (pass-if "no match, start index" - (not (string-any char-upper-case? "Abcde" 1))) + (with-test-prefix "char" - (pass-if "one match, start index" - (string-any char-upper-case? "abCde" 1)) + (pass-if "no match" + (not (string-any #\C "abcde"))) - (pass-if "more than one match, start index" - (string-any char-upper-case? "abCDE" 1)) + (pass-if "one match" + (string-any #\C "abCde")) - (pass-if "no match, start and end index" - (not (string-any char-upper-case? "AbcdE" 1 4))) + (pass-if "more than one match" + (string-any #\X "abXXX")) - (pass-if "one match, start and end index" - (string-any char-upper-case? "abCde" 1 4)) + (pass-if "no match, start index" + (not (string-any #\A "Abcde" 1))) - (pass-if "more than one match, start and end index" - (string-any char-upper-case? "abCDE" 1 4))) + (pass-if "one match, start index" + (string-any #\C "abCde" 1)) + + (pass-if "more than one match, start index" + (string-any #\X "abXXX" 1)) + + (pass-if "no match, start and end index" + (not (string-any #\X "XbcdX" 1 4))) + + (pass-if "one match, start and end index" + (string-any #\C "abCde" 1 4)) + + (pass-if "more than one match, start and end index" + (string-any #\X "abXXX" 1 4))) + + (with-test-prefix "charset" + + (pass-if "no match" + (not (string-any char-set:upper-case "abcde"))) + + (pass-if "one match" + (string-any char-set:upper-case "abCde")) + + (pass-if "more than one match" + (string-any char-set:upper-case "abCDE")) + + (pass-if "no match, start index" + (not (string-any char-set:upper-case "Abcde" 1))) + + (pass-if "one match, start index" + (string-any char-set:upper-case "abCde" 1)) + + (pass-if "more than one match, start index" + (string-any char-set:upper-case "abCDE" 1)) + + (pass-if "no match, start and end index" + (not (string-any char-set:upper-case "AbcdE" 1 4))) + + (pass-if "one match, start and end index" + (string-any char-set:upper-case "abCde" 1 4)) + + (pass-if "more than one match, start and end index" + (string-any char-set:upper-case "abCDE" 1 4))) + + (with-test-prefix "pred" + + (pass-if "no match" + (not (string-any char-upper-case? "abcde"))) + + (pass-if "one match" + (string-any char-upper-case? "abCde")) + + (pass-if "more than one match" + (string-any char-upper-case? "abCDE")) + + (pass-if "no match, start index" + (not (string-any char-upper-case? "Abcde" 1))) + + (pass-if "one match, start index" + (string-any char-upper-case? "abCde" 1)) + + (pass-if "more than one match, start index" + (string-any char-upper-case? "abCDE" 1)) + + (pass-if "no match, start and end index" + (not (string-any char-upper-case? "AbcdE" 1 4))) + + (pass-if "one match, start and end index" + (string-any char-upper-case? "abCde" 1 4)) + + (pass-if "more than one match, start and end index" + (string-any char-upper-case? "abCDE" 1 4)))) ;;; ;;; string-every @@ -63,39 +135,111 @@ (with-test-prefix "string-every" - ;; in guile 1.6.4 and earlier string-every incorrectly returned #f on an - ;; empty string - (pass-if "empty string" - (string-every char-upper-case? "")) - (pass-if "empty substring" - (string-every char-upper-case? "abc" 1 1)) + (with-test-prefix "char" - (pass-if "no match at all" - (not (string-every char-upper-case? "abcde"))) + (pass-if "empty string" + (string-every #\X "")) - (pass-if "not all match" - (not (string-every char-upper-case? "abCDE"))) + (pass-if "empty substring" + (string-every #\X "abc" 1 1)) - (pass-if "all match" - (string-every char-upper-case? "ABCDE")) + (pass-if "no match at all" + (not (string-every #\X "abcde"))) - (pass-if "no match at all, start index" - (not (string-every char-upper-case? "Abcde" 1))) + (pass-if "not all match" + (not (string-every #\X "abXXX"))) - (pass-if "not all match, start index" - (not (string-every char-upper-case? "ABcde" 1))) + (pass-if "all match" + (string-every #\X "XXXXX")) - (pass-if "all match, start index" - (string-every char-upper-case? "aBCDE" 1)) + (pass-if "no match at all, start index" + (not (string-every #\X "Xbcde" 1))) - (pass-if "no match at all, start and end index" - (not (string-every char-upper-case? "AbcdE" 1 4))) + (pass-if "not all match, start index" + (not (string-every #\X "XXcde" 1))) - (pass-if "not all match, start and end index" - (not (string-every char-upper-case? "ABcde" 1 4))) + (pass-if "all match, start index" + (string-every #\X "aXXXX" 1)) - (pass-if "all match, start and end index" - (string-every char-upper-case? "aBCDe" 1 4))) + (pass-if "no match at all, start and end index" + (not (string-every #\X "XbcdX" 1 4))) + + (pass-if "not all match, start and end index" + (not (string-every #\X "XXcde" 1 4))) + + (pass-if "all match, start and end index" + (string-every #\X "aXXXe" 1 4))) + + (with-test-prefix "charset" + + (pass-if "empty string" + (string-every char-set:upper-case "")) + + (pass-if "empty substring" + (string-every char-set:upper-case "abc" 1 1)) + + (pass-if "no match at all" + (not (string-every char-set:upper-case "abcde"))) + + (pass-if "not all match" + (not (string-every char-set:upper-case "abCDE"))) + + (pass-if "all match" + (string-every char-set:upper-case "ABCDE")) + + (pass-if "no match at all, start index" + (not (string-every char-set:upper-case "Abcde" 1))) + + (pass-if "not all match, start index" + (not (string-every char-set:upper-case "ABcde" 1))) + + (pass-if "all match, start index" + (string-every char-set:upper-case "aBCDE" 1)) + + (pass-if "no match at all, start and end index" + (not (string-every char-set:upper-case "AbcdE" 1 4))) + + (pass-if "not all match, start and end index" + (not (string-every char-set:upper-case "ABcde" 1 4))) + + (pass-if "all match, start and end index" + (string-every char-set:upper-case "aBCDe" 1 4))) + + (with-test-prefix "pred" + + ;; in guile 1.6.4 and earlier string-every incorrectly returned #f on an + ;; empty string + (pass-if "empty string" + (string-every char-upper-case? "")) + (pass-if "empty substring" + (string-every char-upper-case? "abc" 1 1)) + + (pass-if "no match at all" + (not (string-every char-upper-case? "abcde"))) + + (pass-if "not all match" + (not (string-every char-upper-case? "abCDE"))) + + (pass-if "all match" + (string-every char-upper-case? "ABCDE")) + + (pass-if "no match at all, start index" + (not (string-every char-upper-case? "Abcde" 1))) + + (pass-if "not all match, start index" + (not (string-every char-upper-case? "ABcde" 1))) + + (pass-if "all match, start index" + (string-every char-upper-case? "aBCDE" 1)) + + (pass-if "no match at all, start and end index" + (not (string-every char-upper-case? "AbcdE" 1 4))) + + (pass-if "not all match, start and end index" + (not (string-every char-upper-case? "ABcde" 1 4))) + + (pass-if "all match, start and end index" + (string-every char-upper-case? "aBCDe" 1 4)))) (with-test-prefix "string-tabulate" From 3ff0e986f390e7aa4f269f5a676a11895e26d338 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 14 Aug 2004 00:44:29 +0000 Subject: [PATCH 58/64] *** empty log message *** --- test-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index b02229bbd..fb6e58059 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-08-14 Kevin Ryde + + * tests/srfi-13.test (string-any, string-every): Exercise char and + charset predicate cases. + 2004-08-10 Marius Vollmer * standalone/test-conversion.c (test_locale_strings): New. From 6ae50c7153b52cd7c2ddba24819de38b4d6a0f3f Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 14 Aug 2004 00:48:32 +0000 Subject: [PATCH 59/64] (SRFI-13 Predicates): Add string-any and string-every support for char and charset predicates. --- doc/ref/srfi-modules.texi | 62 +++++++++++++++++++++++++++++---------- 1 file changed, 46 insertions(+), 16 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 88bdb7a83..1280c2025 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1355,30 +1355,60 @@ In addition to the primitives @code{string?} and @code{string-null?}, which are already in the Guile core, the string predicates @code{string-any} and @code{string-every} are defined by SRFI-13. -@deffn {Scheme Procedure} string-any pred s [start end] -Check if the predicate @var{pred} is true for any character in -the string @var{s}. +@deffn {Scheme Procedure} string-any char_pred s [start end] +Return true if @code{char_pred} is satisfied for any character in the +string @var{s}. @var{char_pred} can be -Calls to @var{pred} are made from left to right across @var{s}. When -it returns true (ie.@: non-@code{#f}), that return value is the return -from @code{string-any}. +@itemize @bullet +@item +A character, to to test for any in @var{s} equal to that. +@item +A character set (@pxref{SRFI-14}), to test for any character in +@var{s} in that character set. +@item +A predicate function, called as @code{(@var{char_pred} c)} for each +character in @var{s}, from left to right, to test for any on which +@var{char_pred} returns true. + +When @var{char_pred} does return true (ie.@: non-@code{#f}), that +value is the value returned by @code{string-any}. +@end itemize + +If there are no characters in @var{s} (ie.@: @var{start} equals +@var{end}) then the return is @code{#f}. + +SRFI-13 specifies that when @var{char_pred} is a predicate function, +the call on the last character of @var{s} (assuming that point is +reached) is a tail call, but currently in Guile this is not the case. @end deffn -@deffn {Scheme Procedure} string-every pred s [start end] -Check if the predicate @var{pred} is true for every character -in the string @var{s}. +@deffn {Scheme Procedure} string-every char_pred s [start end] +Return true if @var{char_pred} is satisifed for every character in the +string @var{s}. @var{char_pred} can be -Calls to @var{pred} are made from left to right across @var{s}. If -the predicate is true for every character then the return value from -the last @var{pred} call is the return from @code{string-every}. +@itemize @bullet +@item +A character, to to test for every character in @var{s} equal to that. +@item +A character set (@pxref{SRFI-14}), to test for every character in +@var{s} being in that character set. +@item +A predicate function, called as @code{(@var{char_pred} c)} for each +character in @var{s}, from left to right, to test that it returns true +for every character in @var{s}. + +When @var{char_pred} does return true (ie.@: non-@code{#f}) for every +character, the return from the last call is the value returned by +@code{string-any}. +@end itemize If there are no characters in @var{s} (ie.@: @var{start} equals @var{end}) then the return is @code{#t}. -@end deffn -The SRFI-13 specification requires that the call to @var{pred} on the -last character of @var{s} (assuming that point is reached) be a tail -call, but currently in Guile this is not the case. +SRFI-13 specifies that when @var{char_pred} is a predicate function, +the call on the last character of @var{s} (assuming that point is +reached) is a tail call, but currently in Guile this is not the case. +@end deffn @c =================================================================== From 5b4dba24ef033bc2393f48ae50d9430178beb52c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 14 Aug 2004 00:51:57 +0000 Subject: [PATCH 60/64] Typo in: (SRFI-13 Predicates): Add string-any and string-every support for char and charset predicates. --- doc/ref/srfi-modules.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 1280c2025..13a2ed198 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1399,7 +1399,7 @@ for every character in @var{s}. When @var{char_pred} does return true (ie.@: non-@code{#f}) for every character, the return from the last call is the value returned by -@code{string-any}. +@code{string-every}. @end itemize If there are no characters in @var{s} (ie.@: @var{start} equals From 02d9c82a027e1135d22da1efbba02a2ad2cca83d Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 14 Aug 2004 00:55:00 +0000 Subject: [PATCH 61/64] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 565492418..4a4c35879 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2004-08-14 Kevin Ryde + + * srfi-modules.texi (SRFI-13 Predicates): Add string-any and + string-every support for char and charset predicates. + 2004-08-11 Marius Vollmer * api-data.texi (scm_c_round, scm_c_truncate): Docs for'em. From 3cf066df9b59d7fec390168f09da1a4aaa8d72e7 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 14 Aug 2004 01:02:37 +0000 Subject: [PATCH 62/64] (Mutexes): New datatype-centric section, adding fair mutexes and collecting up material from ... (Low level thread primitives, Higher level thread procedures, C level thread interface): ... these nodes. --- doc/ref/api-scheduling.texi | 249 ++++++++++++++++++++++-------------- 1 file changed, 153 insertions(+), 96 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index c3aef48a0..f85ea4aaa 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -20,6 +20,7 @@ reviewed and largely reorganized.] * Fluids:: Thread-local variables. * Futures:: Delayed execution in new threads. * Parallel Forms:: Parallel execution of forms. +* Mutexes:: Synchronization primitives. @end menu @@ -31,10 +32,10 @@ Arbiters are synchronization objects, they can be used by threads to control access to a shared resource. An arbiter can be locked to indicate a resource is in use, and unlocked when done. -An arbiter is like a light-weight mutex (@pxref{Low level thread -primitives}). It uses less memory and may be a little faster, but -there's no way for a thread to block waiting on an arbiter, it can -only test and get the status returned. +An arbiter is like a light-weight mutex (@pxref{Mutexes}). It uses +less memory and may be faster, but there's no way for a thread to +block waiting on an arbiter, it can only test and get the status +returned. @deffn {Scheme Procedure} make-arbiter name @deffnx {C Function} scm_make_arbiter (name) @@ -351,40 +352,6 @@ If one or more threads are waiting to execute, calling yield forces an immediate context switch to one of them. Otherwise, yield has no effect. @end deffn -@c begin (texi-doc-string "guile" "make-mutex") -@deffn {Scheme Procedure} make-mutex -Create a new mutex object. -@end deffn - -@c begin (texi-doc-string "guile" "lock-mutex") -@deffn {Scheme Procedure} lock-mutex mutex -Lock @var{mutex}. If the mutex is already locked, the calling thread -blocks until the mutex becomes available. The function returns when -the calling thread owns the lock on @var{mutex}. Locking a mutex that -a thread already owns will succeed right away and will not block the -thread. That is, Guile's mutexes are @emph{recursive}. - -When a system async is activated for a thread that is blocked in a -call to @code{lock-mutex}, the waiting is interrupted and the async is -executed. When the async returns, the waiting is resumed. -@end deffn - -@deffn {Scheme Procedure} try-mutex mutex -Try to lock @var{mutex}. If the mutex is already locked by someone -else, return @code{#f}. Else lock the mutex and return @code{#t}. -@end deffn - -@c begin (texi-doc-string "guile" "unlock-mutex") -@deffn {Scheme Procedure} unlock-mutex mutex -Unlocks @var{mutex} if the calling thread owns the lock on -@var{mutex}. Calling unlock-mutex on a mutex not owned by the current -thread results in undefined behaviour. Once a mutex has been unlocked, -one thread blocked on @var{mutex} is awakened and grabs the mutex -lock. Every call to @code{lock-mutex} by this thread must be matched -with a call to @code{unlock-mutex}. Only the last call to -@code{unlock-mutex} will actually unlock the mutex. -@end deffn - @c begin (texi-doc-string "guile" "make-condition-variable") @deffn {Scheme Procedure} make-condition-variable Make a new condition variable. @@ -425,7 +392,7 @@ Wake up all threads that are waiting for @var{cv}. Higher level thread procedures are available by loading the @code{(ice-9 threads)} module. These provide standardized -thread creation and mutex interaction. +thread creation. @deffn macro make-thread proc [args@dots{}] Apply @var{proc} to @var{args} in a new thread formed by @@ -439,31 +406,12 @@ Evaluate forms @var{first} and @var{rest} in a new thread formed by the error to the current error port. @end deffn -@deffn macro with-mutex m [body@dots{}] -Lock mutex @var{m}, evaluate @var{body}, and then unlock @var{m}. -These sub-operations form the branches of a @code{dynamic-wind}. -@end deffn - -@deffn macro monitor body@dots{} -Evaluate @var{body}, with a mutex locked so only one thread can -execute that code at any one time. Each @code{monitor} form has its -own private mutex and the locking is done as per @code{with-mutex} -above. The return value is the return from the last form in -@var{body}. - -The term ``monitor'' comes from operating system theory, where it -means a particular bit of code managing access to some resource and -which only ever executes on behalf of one process at any one time. -@end deffn - @node C level thread interface @subsubsection C level thread interface -You can create and manage threads, mutexes, and condition variables -with the C versions of the primitives above. For example, you can -create a mutex with @code{scm_make_mutex} and lock it with -@code{scm_lock_mutex}. In addition to these primitives there is also -a second set of primitives for threading related things. These +You can create and manage threads +with the C versions of the primitives above. +These functions and data types are only available from C and can not be mixed with the first set from above. However, they might be more efficient and can be used in situations where Scheme data types are @@ -539,47 +487,13 @@ might have been detached by the time it terminates. Return the handle of the calling thread. @end deftypefn -@deftp {C Data Type} scm_t_mutex -This data type represents a mutex, to be used with scm_mutex_init, -etc. -@end deftp - -@deftypefn {C Function} void scm_mutex_init (scm_t_mutex *m) -Initialize the mutex structure pointed to by @var{m}. -@end deftypefn - -@deftypefn {C Function} void scm_mutex_destroy (scm_t_mutex *m) -Deallocate all resources associated with @var{m}. -@end deftypefn - -@deftypefn {C Function} void scm_mutex_lock (scm_t_mutex *m) -Lock the mutex @var{m}. When it is already locked by a different -thread, wait until it becomes available. Locking a mutex that is -already locked by the current threads is not allowd and results in -undefined behavior. The mutices are not guaranteed to be fair. That -is, a thread that attempts a lock after yourself might be granted it -before you. -@end deftypefn - -@deftypefn {C Function} int scm_mutex_trylock (scm_t_mutex *m) -Lock @var{m} as with @code{scm_mutex_lock} but don't wait when this -does succeed immediately. Returns non-zero when the mutex could in -fact be locked , and zero when it is already locked by some other -thread. -@end deftypefn - -@deftypefn {C Function} void scm_mutex_unlock (scm_t_mutex *m) -Unlock the mutex @var{m}. The mutex must have been locked by the -current thread, else the behavior is undefined. -@end deftypefn - @deftp {C Data Type} scm_t_cond This data type represents a condition variable, to be used with scm_cond_init, etc. @end deftp @deftypefn {C Function} void scm_cond_init (scm_t_cond *c) -Initialize the mutex structure pointed to by @var{c}. +Initialize the condition variable structure pointed to by @var{c}. @end deftypefn @deftypefn {C Function} void scm_cond_destroy (scm_t_cond *c) @@ -858,6 +772,149 @@ completed, it doesn't need to wait for all to finish. @end deffn +@node Mutexes +@subsection Mutexes +@cindex mutex + +A mutex is a thread synchronization object, it can be used by threads +to control access to a shared resource. A mutex can be locked to +indicate a resource is in use, and other threads can then block on the +mutex to wait for the resource (or can just test and do something else +if not available). ``Mutex'' is short for ``mutual exclusion''. + +There are two types of mutexes, ``standard'' and ``fair''. They're +created by @code{make-mutex} and @code{make-fair-mutex} respectively, +the operation functions are then common to both. + +Note that for both types of mutex there's no protection against a +``deadly embrace''. For instance if one thread has locked mutex A and +is waiting on mutex B, but another thread owns B and is waiting on A, +then an endless wait will occur (in the current implementation). +Acquiring requisite mutexes in a fixed order (like always A before B) +in all threads is one way to avoid such problems. + +@sp 1 +@deffn {Scheme Procedure} make-mutex +@deffnx {Scheme Procedure} make-fair-mutex +Return a new mutex object. + +@code{make-mutex} creates a standard mutex. This is fast, but its +features are restricted. Recursive locking (multiple lock calls by +one thread) is not permitted, and an unlock can be done only when +already locked and only by the owning thread. When multiple threads +are blocked waiting to acquire the mutex, it's unspecified which will +get it next. + +@code{make-fair-mutex} creates a fair mutex. This has more features +and error checking. Recursive locking is allowed, a given thread can +make multiple lock calls and the mutex is released when a balancing +number of unlocks are done. Other threads blocked waiting to acquire +the mutex form a queue and the one waiting longest will be the next to +acquire it. +@end deffn + +@deffn {Scheme Procedure} lock-mutex mutex +Lock @var{mutex}. If the mutex is already locked by another thread +then block and return only when @var{mutex} has been acquired. + +For standard mutexes (@code{make-mutex}), if the thread has itself +already locked @var{mutex} it must not call @code{lock-mutex} on it a +further time. Behaviour is unspecified if this is done. + +For a fair mutex (@code{make-fair-mutex}), if the thread has itself +already locked @var{mutex}, then a further @code{lock-mutex} call +increments the lock count. An additional @code{unlock-mutex} will be +required to finally release. + +When a system async (@pxref{System asyncs}) is activated for a thread +blocked in @code{lock-mutex}, the wait is interrupted and the async is +executed. When the async returns the wait resumes. +@end deffn + +@deffn {Scheme Procedure} try-mutex mutex +Try to lock @var{mutex} as per @code{lock-mutex}. If @var{mutex} can +be acquired immediately then this is done and the return is @code{#t}. +If @var{mutex} is locked by some other thread then nothing is done and +the return is @code{#f}. +@end deffn + +@deffn {Scheme Procedure} unlock-mutex mutex +Unlock @var{mutex}. + +For a standard mutex (@code{make-mutex}), if @var{mutex} is not locked +by the calling thread then behaviour is unspecified. + +For a fair mutex (@code{make-fair-mutex}), if @var{mutex} is not +locked by the calling thread then an error is thrown. +@end deffn + +@sp 1 +The following are higher level operations on mutexes. These are +available from + +@example +(use-modules (ice-9 threads)) +@end example + +@deffn macro with-mutex mutex [body@dots{}] +Lock @var{mutex}, evaluate the @var{body} forms, then unlock +@var{mutex}. The return value is the return from the last @var{body} +form. + +The lock, body and unlock form the branches of a @code{dynamic-wind} +(@pxref{Dynamic Wind}), so @var{mutex} is automatically unlocked if an +error or new continuation exits @var{body}, and is re-locked if +@var{body} is re-entered by a captured continuation. +@end deffn + +@deffn macro monitor body@dots{} +Evaluate the @var{body} forms, with a mutex locked so only one thread +can execute that code at any one time. The return value is the return +from the last @var{body} form. + +Each @code{monitor} form has its own private mutex and the locking and +evaluation is as per @code{with-mutex} above. A standard mutex +(@code{make-mutex}) is used, which means @var{body} must not +recursively re-enter the @code{monitor} form. + +The term ``monitor'' comes from operating system theory, where it +means a particular bit of code managing access to some resource and +which only ever executes on behalf of one process at any one time. +@end deffn + +@sp 1 +The following provide access to standard mutexes from C code. + +@deftp {C Data Type} scm_t_mutex +A mutex, to be used with @code{scm_mutex_init}, etc. +@end deftp + +@deftypefn {C Function} void scm_mutex_init (scm_t_mutex *m) +Initialize the mutex structure pointed to by @var{m}. +@end deftypefn + +@deftypefn {C Function} void scm_mutex_destroy (scm_t_mutex *m) +Free all resources associated with @var{m}. +@end deftypefn + +@deftypefn {C Function} void scm_mutex_lock (scm_t_mutex *m) +Lock the mutex @var{m}. This is as per @code{lock-mutex} above on a +standard mutex. +@end deftypefn + +@deftypefn {C Function} int scm_mutex_trylock (scm_t_mutex *m) +Attempt to lock mutex @var{m}, as per @code{scm_mutex_lock}. If +@var{m} is unlocked then this is done and the return is non-zero. If +@var{m} is already locked by another thread then do nothing and return +zero. +@end deftypefn + +@deftypefn {C Function} void scm_mutex_unlock (scm_t_mutex *m) +Unlock the mutex @var{m}. The mutex must have been locked by the +current thread, otherwise the behavior is undefined. +@end deftypefn + + @c Local Variables: @c TeX-master: "guile.texi" @c End: From 80b707b7541e84db6533907fed31efa2dd264ca3 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 14 Aug 2004 01:06:13 +0000 Subject: [PATCH 63/64] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 4a4c35879..c57a05ffa 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,5 +1,10 @@ 2004-08-14 Kevin Ryde + * api-scheduling.texi (Mutexes): New datatype-centric section, adding + fair mutexes and collecting up material from ... + (Low level thread primitives, Higher level thread procedures, C level + thread interface): ... these nodes. + * srfi-modules.texi (SRFI-13 Predicates): Add string-any and string-every support for char and charset predicates. From 3514320f60c5c77716691055c8e2a6eeae7681e6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 15 Aug 2004 20:26:05 +0000 Subject: [PATCH 64/64] New, from Jose A Ortega Ruiz. Thanks! --- srfi/srfi-39.scm | 107 ++++++++++++++++++++++++++++++++++ test-suite/tests/srfi-39.test | 54 +++++++++++++++++ 2 files changed, 161 insertions(+) create mode 100644 srfi/srfi-39.scm create mode 100644 test-suite/tests/srfi-39.test diff --git a/srfi/srfi-39.scm b/srfi/srfi-39.scm new file mode 100644 index 000000000..b8bb1d364 --- /dev/null +++ b/srfi/srfi-39.scm @@ -0,0 +1,107 @@ +;;; srfi-39.scm --- Parameter objects + +;; Copyright (C) 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 the Free Software Foundation; either version 2, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of GUILE. +;; +;; The exception is that, if you link the GUILE library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the GUILE library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name GUILE. If you copy +;; code from other Free Software Foundation releases into a copy of +;; GUILE, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for GUILE, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +;;; Author: Jose Antonio Ortega Ruiz +;;; Date: 2004-05-05 + +;;; Commentary: + +;; This is an implementation of SRFI-39 (Parameter objects). +;; +;; The implementation is based on Guile's fluid objects, and is, therefore, +;; thread-safe (parameters are thread-local). +;; +;; In addition to the forms defined in SRFI-39 (`make-parameter', +;; `parameterize'), a new procedure `with-parameters*' is provided. +;; This procedures is analogous to `with-fluids*' but taking as first +;; argument a list of parameter objects instead of a list of fluids. +;; + +;;; Code: + +(define-module (srfi srfi-39) + #:use-module (ice-9 syncase) + #:use-module (srfi srfi-16) + + #:export (make-parameter) + #:export-syntax (parameterize) + + ;; helper procedure not in srfi-39. + #:export (with-parameters*)) + +;; Make 'srfi-39 available as a feature identifiere to `cond-expand'. +;; +(cond-expand-provide (current-module) '(srfi-39)) + +(define make-parameter + (case-lambda + ((val) (make-parameter/helper val (lambda (x) x))) + ((val conv) (make-parameter/helper val conv)))) + +(define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value +(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value + +(define (make-parameter/helper val conv) + (let ((value (make-fluid)) + (conv conv)) + (begin + (fluid-set! value (conv val)) + (lambda new-value + (cond + ((null? new-value) (fluid-ref value)) + ((eq? (car new-value) get-fluid-tag) value) + ((eq? (car new-value) get-conv-tag) conv) + ((null? (cdr new-value)) (fluid-set! value (conv (car new-value)))) + (else (error "make-parameter expects 0 or 1 arguments" new-value))))))) + +(define-syntax parameterize + (syntax-rules () + ((_ ((?param ?value) ...) ?body ...) + (with-parameters* (list ?param ...) + (list ?value ...) + (lambda () ?body ...))))) + +(define (with-parameters* params values thunk) + (with-fluids* (map (lambda (p) (p get-fluid-tag)) params) + (map (lambda (p v) ((p get-conv-tag) v)) params values) + thunk)) diff --git a/test-suite/tests/srfi-39.test b/test-suite/tests/srfi-39.test new file mode 100644 index 000000000..22d2bd056 --- /dev/null +++ b/test-suite/tests/srfi-39.test @@ -0,0 +1,54 @@ +;;;; srfi-39.test --- -*- scheme -*- +;;;; +;;;; Copyright (C) 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 +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (srfi srfi-39)) + +(define a (make-parameter 3)) +(define b (make-parameter 4)) + +(define (check a b a-val b-val) + (and (eqv? (a) a-val)) (eqv? (b) b-val)) + +(define c (make-parameter 2 (lambda (x) (if (< x 10) x 10)))) +(define d (make-parameter 15 (lambda (x) (if (< x 10) x 10)))) + +(with-test-prefix "SRFI-39" + + (pass-if "test 1" + (check a b 3 4)) + + (pass-if "test 2" + (parameterize ((a 2) (b 1)) + (and (check a b 2 1) + (parameterize ((b 8)) + (check a b 2 8))))) + + (pass-if "test 3" + (check a b 3 4)) + + (pass-if "test 4" + (check c d 2 10)) + + (pass-if "test 5" + (parameterize ((a 0) (b 1) (c 98) (d 9)) + (and (check a b 0 1) + (check c d 10 9) + (parameterize ((c (a)) (d (b))) + (and (check a b 0 1) + (check c d 0 1)))))))