Skip to content

Commit

Permalink
Add vector-any, vector-every, string-any, string-every
Browse files Browse the repository at this point in the history
  • Loading branch information
@gambiteer
gambiteer committed Jan 28, 2024
1 parent 2cb4737 commit d8c743a
Show file tree
Hide file tree
Showing 8 changed files with 411 additions and 0 deletions.
89 changes: 89 additions & 0 deletions doc/gambit.txi
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4066,6 +4066,51 @@ For example:

@end deffn

@deffn procedure vector-any @var{pred} @var{vec1} @var{vec2} @dots{}

The procedure @code{vector-any} returns the first non-false value that
the predicate @var{pred} returns when applied to the elements of the vectors
@var{vec1} @var{vec2} @dots{} in order, beginning with index 0 and
stopping at the length of the shortest
vector argument. It returns @code{#f} if there is no such non-false value.

For example:

@smallexample
> @b{(vector-any = '#(1 2) '#(0 2 4))}
#t
> @b{(vector-any number? '#())}
#f
> @b{(vector-any (lambda (a b) (and a b)) '#(#f 1 #f 2) '#(1 #f 2 3 5))}
3
@end smallexample

@end deffn

@deffn procedure vector-every @var{pred} @var{vec1} @var{vec2} @dots{}

The procedure @code{vector-every} applies
the predicate @var{pred} to the elements of the vectors
@var{vec1} @var{vec2} @dots{} in order, beginning with index 0 and
stopping at the length of the shortest
vector argument. If the result of @var{pred} is ever @code{#f}, that is
returned; if the smallest vector is empty, then @code{#t} is returned;
otherwise, the last value of @var{pred} is returned.

For example:

@smallexample
> @b{(vector-every = '#(1 0) '#(1. 0. 4))}
#t
> @b{(vector-every char? '#())}
#t
> @b{(vector-every (lambda (a b) (or a b)) '#(#f 1 #f 2) '#(1 #f 2 3 5))}
2
> @b{(vector-every = '#(1 2) '#(1. 0. 4))}
#f
@end smallexample

@end deffn

@deffn procedure string-set @var{string} @var{k} @var{char}

Expand Down Expand Up @@ -4104,6 +4149,50 @@ For example:

@end deffn

@deffn procedure string-any @var{pred} @var{s1} @var{s2} @dots{}

The procedure @code{string-any} returns the first non-false value that
the predicate @var{pred} returns when applied to the elements of the strings
@var{s1} @var{s2} @dots{} in order, beginning with index 0 and
stopping at the length of the shortest
string argument. It returns @code{#f} if there is no such non-false value.

For example:

@smallexample
> @b{(string-any char-ci=? "abc" "1B")}
#t
> @b{(string-any char=? "abc" "1B")}
#f
> @b{(string-any char-alphabetic? "")}
#f
@end smallexample

@end deffn

@deffn procedure string-every @var{pred} @var{s1} @var{s2} @dots{}

The procedure @code{string-every} applies
the predicate @var{pred} to the elements of the strings
@var{s1} @var{s2} @dots{} in order, beginning with index 0 and
stopping at the length of the shortest
string argument. If the result of @var{pred} is ever @code{#f}, that is
returned; if the smallest string is empty, then @code{#t} is returned;
otherwise, the last value of @var{pred} is returned.

For example:

@smallexample
> @b{(string-every char-ci=? "abc" "aB")}
#t
> @b{(string-every char=? "abc" "aB")}
#f
> @b{(string-every char-alphabetic? "")}
#t
@end smallexample

@end deffn

@deffn procedure string-prefix-length @var{s1} @var{s2} @r{[}@var{start1} @r{[}@var{end1} @r{[}@var{start2} @r{[}@var{end2}@r{]}@r{]}@r{]}@r{]}
@deffnx procedure string-prefix-length-ci @var{s1} @var{s2} @r{[}@var{start1} @r{[}@var{end1} @r{[}@var{start2} @r{[}@var{end2}@r{]}@r{]}@r{]}@r{]}

Expand Down
210 changes: 210 additions & 0 deletions lib/_std#.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -404,6 +404,8 @@
(define vect-shrink! (sym name '-shrink!))
(define vect-map (sym name '-map))
(define vect-for-each (sym name '-for-each))
(define vect-every (sym name '-every))
(define vect-any (sym name '-any))

`(begin

Expand Down Expand Up @@ -1378,6 +1380,214 @@ end-of-code
,vect-for-each
proc
x-y))))))))))))

(define-prim (,vect-every proc x . y)
(macro-force-vars (proc x)
(macro-check-procedure proc 1 (,vect-every proc x . y)
(,macro-check-vect x 2 (,vect-every proc x . y)
(let ()

(define (vect-every-1 x)

(define (vect-every-1 i last)
(if (##fx< i last)
(and (proc (,prim-vect-ref x i))
(vect-every-1 (##fx+ i 1) last))
(proc (,prim-vect-ref x i)))) ;; last call in tail position

(let ((len (,prim-vect-length x)))
(or (##fx= len 0)
(vect-every-1 0 (##fx- len 1)))))

(define (vect-every-n len rev-x-y)

(define (get-args i)
(let loop ((lst rev-x-y)
(args '()))
(if (##pair? lst)
(loop (##cdr lst)
(##cons
(,prim-vect-ref (##car lst) i)
args))
args)))

(define (vect-every-n i last)
(if (##fx< i last)
(and (##apply proc (get-args i))
(vect-every-n (##fx+ i 1) last))
(##apply proc (get-args i)))) ;; last call in tail position

(or (##fx= len 0)
(vect-every-n 0 (##fx- len 1))))

(if (##null? y)
(vect-every-1 x)
(if ##allow-length-mismatch?

(let ((len-x (,prim-vect-length x))
(x-y (##cons x y)))
(let loop ((lst y)
(rev-x-y (##cons x '()))
(min-len len-x)
(arg-num 3))
(if (##pair? lst)
(let ((arg (##car lst)))
(macro-force-vars (arg)
(,macro-check-vect
arg
arg-num
(,vect-every proc . x-y)
(let ((len-arg
(,prim-vect-length arg)))
(loop (##cdr lst)
(##cons arg rev-x-y)
(##fxmin min-len len-arg)
(##fx+ arg-num 1))))))
(vect-every-n min-len rev-x-y))))

(let ((len-x (,prim-vect-length x))
(x-y (##cons x y)))
(let loop ((lst y)
(rev-x-y (##cons x '()))
(min-len len-x)
(max-len len-x)
(max-arg 2)
(arg-num 3))
(if (##pair? lst)
(let ((arg (##car lst)))
(macro-force-vars (arg)
(,macro-check-vect
arg
arg-num
(,vect-every proc . x-y)
(let ((len-arg
(,prim-vect-length arg)))
(if (##fx> len-arg max-len)
(loop (##cdr lst)
(##cons arg rev-x-y)
len-arg
max-len
arg-num
(##fx+ arg-num 1))
(loop (##cdr lst)
(##cons arg rev-x-y)
(##fxmin min-len
len-arg)
max-len
max-arg
(##fx+ arg-num 1)))))))
(if (##fx= min-len max-len)
(vect-every-n min-len rev-x-y)
(##raise-length-mismatch-exception
max-arg
'()
,vect-every
proc
x-y))))))))))))

(define-prim (,vect-any proc x . y)
(macro-force-vars (proc x)
(macro-check-procedure proc 1 (,vect-any proc x . y)
(,macro-check-vect x 2 (,vect-any proc x . y)
(let ()

(define (vect-any-1 x)

(define (vect-any-1 i last)
(if (##fx< i last)
(or (proc (,prim-vect-ref x i))
(vect-any-1 (##fx+ i 1) last))
(proc (,prim-vect-ref x i)))) ;; last call in tail position

(let ((len (,prim-vect-length x)))
(and (##fx> len 0)
(vect-any-1 0 (##fx- len 1)))))

(define (vect-any-n len rev-x-y)

(define (get-args i)
(let loop ((lst rev-x-y)
(args '()))
(if (##pair? lst)
(loop (##cdr lst)
(##cons
(,prim-vect-ref (##car lst) i)
args))
args)))

(define (vect-any-n i last)
(if (##fx< i last)
(or (##apply proc (get-args i))
(vect-any-n (##fx+ i 1) last))
(##apply proc (get-args i)))) ;; last call in tail position

(and (##fx> len 0)
(vect-any-n 0 (##fx- len 1))))

(if (##null? y)
(vect-any-1 x)
(if ##allow-length-mismatch?

(let ((len-x (,prim-vect-length x))
(x-y (##cons x y)))
(let loop ((lst y)
(rev-x-y (##cons x '()))
(min-len len-x)
(arg-num 3))
(if (##pair? lst)
(let ((arg (##car lst)))
(macro-force-vars (arg)
(,macro-check-vect
arg
arg-num
(,vect-any proc . x-y)
(let ((len-arg
(,prim-vect-length arg)))
(loop (##cdr lst)
(##cons arg rev-x-y)
(##fxmin min-len len-arg)
(##fx+ arg-num 1))))))
(vect-any-n min-len rev-x-y))))

(let ((len-x (,prim-vect-length x))
(x-y (##cons x y)))
(let loop ((lst y)
(rev-x-y (##cons x '()))
(min-len len-x)
(max-len len-x)
(max-arg 2)
(arg-num 3))
(if (##pair? lst)
(let ((arg (##car lst)))
(macro-force-vars (arg)
(,macro-check-vect
arg
arg-num
(,vect-any proc . x-y)
(let ((len-arg
(,prim-vect-length arg)))
(if (##fx> len-arg max-len)
(loop (##cdr lst)
(##cons arg rev-x-y)
len-arg
max-len
arg-num
(##fx+ arg-num 1))
(loop (##cdr lst)
(##cons arg rev-x-y)
(##fxmin min-len
len-arg)
max-len
max-arg
(##fx+ arg-num 1)))))))
(if (##fx= min-len max-len)
(vect-any-n min-len rev-x-y)
(##raise-length-mismatch-exception
max-arg
'()
,vect-any
proc
x-y))))))))))))
)

'())
Expand Down
4 changes: 4 additions & 0 deletions lib/gambit#.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -904,6 +904,7 @@ started-thread-exception-procedure
started-thread-exception?
step
step-level-set!
string-any
string->char-set
string->char-set!
string->keyword
Expand All @@ -913,6 +914,7 @@ string-ci=?-hash
string-concatenate
string-contains
string-contains-ci
string-every
string-prefix-ci?
string-prefix-length
string-prefix-length-ci
Expand Down Expand Up @@ -1170,8 +1172,10 @@ user-info-uid
user-info?
user-name
vector->bits
vector-any
vector-cas!
vector-concatenate
vector-every
vector-inc!
vector-set
vector-shrink!
Expand Down
4 changes: 4 additions & 0 deletions lib/gambit/gambit.sld
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1258,10 +1258,12 @@ string->char-set!
string->keyword
string->uninterned-keyword
string->uninterned-symbol
string-any
string-ci=?-hash
string-concatenate
string-contains
string-contains-ci
string-every
string-prefix-ci?
string-prefix-length
string-prefix-length-ci
Expand Down Expand Up @@ -1519,8 +1521,10 @@ user-info-uid
user-info?
user-name
vector->bits
vector-any
vector-cas!
vector-concatenate
vector-every
vector-inc!
vector-set
vector-shrink!
Expand Down
Loading

0 comments on commit d8c743a

Please sign in to comment.