mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 01:30:27 +02:00
Code Activity

(string-any, string-every): Use a scheme

Browse source 
wrapper around the C code so for the final call to the predicate
procedure is a tail call, per SRFI-13 spec.
This commit is contained in:
Kevin Ryde 2004-12-13 23:33:30 +00:00
parent 4bf2783b00
commit b666fb5d31
2 changed files with 29 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

4
srfi/srfi-13.c
View file

@ -52,7 +52,7 @@
#include "srfi-13.h" #include "srfi-13.h"
#include "srfi-14.h" #include "srfi-14.h"
SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, SCM_DEFINE (scm_string_any, "string-any-c-code", 2, 2, 0,
(SCM char_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" "Check if the predicate @var{pred} is true for any character in\n"
"the string @var{s}, proceeding from left (index @var{start}) to\n" "the string @var{s}, proceeding from left (index @var{start}) to\n"
@ -99,7 +99,7 @@ SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0,
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0, SCM_DEFINE (scm_string_every, "string-every-c-code", 2, 2, 0,
(SCM char_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" "Check if the predicate @var{pred} is true for every character\n"
"in the string @var{s}, proceeding from left (index @var{start})\n" "in the string @var{s}, proceeding from left (index @var{start})\n"

28
srfi/srfi-13.scm
View file

@ -1,6 +1,6 @@
;;; srfi-13.scm --- String Library ;;; srfi-13.scm --- String Library
;; Copyright (C) 2001, 2002 Free Software Foundation, Inc. ;; Copyright (C) 2001, 2002, 2004 Free Software Foundation, Inc.
;; ;;
;; This program is free software; you can redistribute it and/or ;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as ;; modify it under the terms of the GNU General Public License as
@ -158,6 +158,32 @@
(load-extension "libguile-srfi-srfi-13-14-v-1" "scm_init_srfi_13") (load-extension "libguile-srfi-srfi-13-14-v-1" "scm_init_srfi_13")
;; this is scheme wrapping the C code so the final pred call is a tail call
(define (string-any char_pred s . rest)
(let ((start (if (null? rest)
0 (car rest)))
(end (if (or (null? rest) (null? (cdr rest)))
(string-length s) (cadr rest))))
(if (and (procedure? char_pred)
(> end start)
(<= end (string-length s))) ;; let c-code handle range error
(or (string-any-c-code char_pred s start (1- end))
(char_pred (string-ref s (1- end))))
(string-any-c-code char_pred s start end))))
;; this is scheme wrapping the C code so the final pred call is a tail call
(define (string-every char_pred s . rest)
(let ((start (if (null? rest)
0 (car rest)))
(end (if (or (null? rest) (null? (cdr rest)))
(string-length s) (cadr rest))))
(if (and (procedure? char_pred)
(> end start)
(<= end (string-length s))) ;; let c-code handle range error
(and (string-every-c-code char_pred s start (1- end))
(char_pred (string-ref s (1- end))))
(string-every-c-code char_pred s start end))))
(define string-hash (define string-hash
(lambda (s . rest) (lambda (s . rest)
(let ((bound (if (pair? rest) (let ((bound (if (pair? rest)