この SRFI で提案する手続きとマクロは
receive (SRFI
8) と let-values (SRFI 11)
と深い関係がある。
この SRFI では、以下の３つの操作を行うための rest-values 手続きを導入する。
また、rest-values から返される残余引数をさらに検証するための８個のマクロを導入する。
可変個引数をとる手続きを定義する場合、
検証マクロを伴う (または伴わない)
rest-values
手続きがあれば、
さまざまな条件分岐やエラー処理を行う煩雑な処理を軽減することができる。
(rest-values [<caller>] <rest-list>
[<args-number-limit> <default> ...])<caller> は任意の Scheme 式である。<args-number-limit> は整数, +, -, ブール値のいずれかでなければならない。<args-number-limit> が + または正の整数である場合、
各 <default> はデフォルト値のリストであるか、
または、car がデフォルト値で cdr が述語手続きであるペアでなければならない。
<args-number-limit> が - または負の整数である場合、
各 <default> は任意の Scheme 式である。<args-number-limit> がブール値である場合、
各 <default> は 1 の場合と同じである。
rest-values は、
<rest-list> の各要素が
対応する <default> リストの要素に一致するかどうか、
あるいは、
対応する <default> ペアの述語手続きを満たすかどうかを検証し、
検証した要素を返す。
要素が検証を通らなかった場合は、
rest-values はエラーになる。
<rest-list> の要素をすべて検証し終わると、
rest-values は残りの <default> の car 値を返す。
反対に、<rest-list> の要素数が
<default> の個数よりも多い場合は、
<args-number-limit> が + であるか、
あるいは、その値が <rest-list> の要素数以上であれば、
残りの余分な要素を返す。
１番目の操作モードと同じであるが、
rest-values は
<rest-list>
の要素を検証しない。
<args-number-limit> の値は
+ ではなく - であり、
その絶対値が使われる。
rest-values は
<default> リストの各要素が
<rest-list> の要素に一致するかどうか、
あるいは、
<rest-list> の任意の要素が
<default> ペアの述語手続きを満たすかどうかを検証し、
検証した値を返す。
<default> が検証を通らなかった場合は、
rest-values はその <default> の car 値を返す。
この処理を行った後で <rest-list> の要素が残る場合は、
<args-number-limit> が #t であれば
rest-values はエラーになり、
<args-number-limit> が #f であれば
<rest-list> は残りの要素を返す。
(arg-and [<caller>] <variable> <expr>
...) (syntax)(arg-ands [common <caller>] ([<caller>]
<variable> <expr> ...) ...) (syntax)(err-and <caller> <expression> ...) (syntax)(err-ands (<caller> <expression> ...) ...) (syntax)(arg-or [<caller>] <variable> <expr> ...) (syntax)(arg-ors [common <caller>] ([<caller>] <variable> <expr> ...) ...) (syntax)(err-or <caller> <expression> ...) (syntax)(err-ors (<caller> <expression> ...) ...)
(syntax)<variable> は手続きの引数でなければならない。
<caller>, <expr>, <expression>
は任意の Scheme 式であるが、
<expr> は対応する <variable>
を含まなければならない。
arg-and, arg-ands, err-and, err-ands
は and と同じであるが、
and が偽を返す場合には、これらの構文はエラーを発生させる。
arg-or, arg-ors, err-or, err-ors
は or と同じであるが、
or が真を返す場合には、これらの構文はエラーを発生させる。
使用例
caller => <procedure caller>
rest-list => (x 1)
(rest-values rest-list) => x 1
(rest-values rest-list 2) => x 1
(rest-values caller rest-list) => x 1
(rest-values caller rest-list -3) => x 1
(rest-values rest-list -2 'y 3 1)
=> error too many defaults (y 3 1) default-list (<= (length default-list) 2)
(rest-values 'caller rest-list 1 '(x y z))
=> error too many arguments (x 1) rest-list (<= (length rest-list) 1) caller
(rest-values caller rest-list 2 (list 'x 'y 'z) (cons "str" string?))
=> error incorrect argument 1 arg (<procedure string?> arg) <procedure caller>
(rest-values rest-list 2 '(y z) `(100 . ,number?))
=> error unmatched argument x arg (member arg (y z))
(rest-values "caller: bad argument" rest-list 2 '(y z) `(100 . ,number?))
=> error caller: bad argument x arg (member arg (y z))
(rest-values 'caller rest-list (list 'x 'y) (cons 1 number?))
=> error bad optional argument (x y) option
(or (boolean? option) (integer? option) (memq option (list + -))) caller
(rest-values rest-list - 'y 100 "str")
=> x 1 "str"
(rest-values rest-list + `(x y z) `(100 . ,number?) `("str" . ,string?))
=> x 1 "str"
(rest-values rest-list #t `(x y z) `(100 . ,number?) `("str" . ,string?))
=> x 1 "str"
(rest-values rest-list #t `(100 . ,number?) `("str" . ,string?) `(x y z))
=> 1 "str" x
(rest-values rest-list #t `(100 . ,number?) `("str" . ,string?) `(y z))
=> error bad argument (x) rest-list (null? rest-list)
(rest-values rest-list #f `(100 . ,number?) `("str" . ,string?) `(y z))
=> 1 "str" y x
recaller => <procedure caller>
str => "string"
num => 2
(arg-and num (number? num) (< num 2))
=> error incorrect argument 2 num (< num 2)
(arg-and caller num (number? num) (< num 2))
=> error incorrect argument 2 num (< num 2) <procedure caller>
(arg-and 'caller num (number? num) (< num 2))
=> error incorrect argument 2 num (< num 2) caller
(arg-and "caller: bad argument" num (number? num) (< num 2))
=> error caller: bad argument 2 num (< num 2)
(arg-ands (str (string? str) (< (string-length str) 7))
("caller: bad argument" num (number? num) (< num 2)))
=> error caller: bad argument 2 num (< num 2)
(arg-ands ("caller: bad argument" str (string? str) (< (string-length str) 7))
(num (number? num) (< num 2)))
=> error incorrect argument 2 num (< num 2)
(arg-ands common 'caller
(str (string? str) (< (string-length str) 7))
(num (number? num) (< num 2)))
=> error incorrect argument 2 num (< num 2) caller
(arg-ands common "caller: bad argument"
(str (string? str) (< (string-length str) 7))
("caller: incorrect argument" num (number? num) (< num 2)))
=> error caller: incorrect argument 2 num (< num 2)
(err-and 'caller
(string? str) (< (string-length str) 7) (number? num) (< num 2))
=> error false expression (< num 2) caller
(err-ands (caller (string? str) (< (string-length str) 7))
("num failed test in caller" (number? num) (< num 2)))
=> error num failed test in caller (< num 2)
(define (read-line . p-d)
;; p-d should be (<input-port> <symbol>).
(receive (p d) (rest-values p-d 2
(cons (current-input-port) input-port?)
(list 'trim 'concat 'split...))
...))
(define (read-line . p-d)
(receive (p d) (rest-values p-d -2 (current-input-port) 'trim)
(arg-ands (p (input-port? p))
(d (memq d '(trim concat split...))))
...))
(define (read-line . p-d)
;; p-d can be (<input-port> <symbol>) or (<symbol> <input-port>).
(receive (p d) (rest-values p-d #t
(cons (current-input-port) input-port?)
(list 'trim 'concat 'split...))
...))
(define (delete x ls . predicate)
(let ((pred (rest-values 'delete predicate 1 (list equal? eqv? eq?))))
...))
(define (delete x ls . predicate)
(let ((pred (rest-values 'delete predicate -1 equal?)))
(err-and 'delete (list? ls) (memq pred (list equal? eqv? eq?)))
...))
(define (substring str . start-end)
(let ((str-len (arg-and substring str (string? str) (string-length str))))
(receive (start end) (rest-values substring start-end -2 0 str-len)
(arg-ands common substring
(start (integer? start) (<= 0 start str-len))
(end (integer? end) (<= start end str-len)))
...)))
(define (procedure-with-sequential-binding-arguments . a-b-c)
(receive (a b c) (rest-values a-b-c -3 10 #f #f)
(let* ((b (or b (+ a 10)))
(c (or c (+ a b))))
...)))
(define (rest-values rest . default)
(let* ((caller (if (or (null? default)
(boolean? (car default))
(integer? (car default))
(memq (car default) (list + -)))
'()
(if (string? rest) rest (list rest))))
(rest-list (if (null? caller) rest (car default)))
(rest-length (if (list? rest-list)
(length rest-list)
(if (string? caller)
(error caller rest-list 'rest-list
'(list? rest-list))
(apply error "bad rest list" rest-list 'rest-list
'(list? rest-list) caller))))
(default (if (null? caller) default (cdr default)))
(default-list (if (null? default) default (cdr default)))
(default-length (length default-list))
(number
(and (not (null? default))
(let ((option (car default)))
(or (and (integer? option)
(or (and (> rest-length (abs option))
(if (string? caller)
(error caller rest-list 'rest-list
`(<= (length rest-list)
,(abs option)))
(apply error "too many arguments"
rest-list 'rest-list
`(<= (length rest-list)
,(abs option))
caller)))
(and (> default-length (abs option))
(if (string? caller)
(error caller default-list
'default-list
`(<= (length default-list)
,(abs option)))
(apply error "too many defaults"
default-list 'default-list
`(<= (length default-list)
,(abs option))
caller)))
option))
(eq? option #t)
(and (not option) 'false)
(and (eq? option +) +)
(and (eq? option -) -)
(if (string? caller)
(error caller option 'option
'(or (boolean? option)
(integer? option)
(memq option (list + -))))
(apply error "bad optional argument" option 'option
'(or (boolean? option)
(integer? option)
(memq option (list + -)))
caller)))))))
(cond
((or (eq? #t number) (eq? 'false number))
(and (not (every pair? default-list))
(if (string? caller)
(error caller default-list 'default-list
'(every pair? default-list))
(apply error "bad default list" default-list 'default-list
'(every pair? default-list) caller)))
(let loop ((rest-list rest-list)
(default-list default-list)
(result '()))
(if (null? default-list)
(if (null? rest-list)
(apply values (reverse result))
(if (eq? #t number)
(if (string? caller)
(error caller rest-list 'rest-list '(null? rest-list))
(apply error "bad argument" rest-list 'rest-list
'(null? rest-list) caller))
(apply values (append-reverse result rest-list))))
(if (null? rest-list)
(apply values (append-reverse result (map car default-list)))
(let ((default (car default-list)))
(let lp ((rest rest-list)
(head '()))
(if (null? rest)
(loop (reverse head)
(cdr default-list)
(cons (car default) result))
(if (list? default)
(if (member (car rest) default)
(loop (append-reverse head (cdr rest))
(cdr default-list)
(cons (car rest) result))
(lp (cdr rest) (cons (car rest) head)))
(if ((cdr default) (car rest))
(loop (append-reverse head (cdr rest))
(cdr default-list)
(cons (car rest) result))
(lp (cdr rest) (cons (car rest) head)))))))))))
((or (and (integer? number) (> number 0))
(eq? number +))
(and (not (every pair? default-list))
(if (string? caller)
(error caller default-list 'default-list
'(every pair? default-list))
(apply error "bad default list" default-list 'default-list
'(every pair? default-list) caller)))
(let loop ((rest rest-list)
(default default-list))
(if (or (null? rest) (null? default))
(apply values
(if (> default-length rest-length)
(append rest-list
(map car (list-tail default-list rest-length)))
rest-list))
(let ((arg (car rest))
(par (car default)))
(if (list? par)
(if (member arg par)
(loop (cdr rest) (cdr default))
(if (string? caller)
(error caller arg 'arg `(member arg ,par))
(apply error "unmatched argument"
arg 'arg `(member arg ,par) caller)))
(if ((cdr par) arg)
(loop (cdr rest) (cdr default))
(if (string? caller)
(error caller arg 'arg `(,(cdr par) arg))
(apply error "incorrect argument"
arg 'arg `(,(cdr par) arg) caller))))))))
(else
(apply values (if (> default-length rest-length)
(append rest-list (list-tail default-list rest-length))
rest-list))))))
(define-syntax arg-and
(syntax-rules()
((arg-and arg (a1 a2 ...) ...)
(and (or (symbol? 'arg)
(error "bad syntax" 'arg '(symbol? 'arg)
'(arg-and arg (a1 a2 ...) ...)))
(or (a1 a2 ...)
(error "incorrect argument" arg 'arg '(a1 a2 ...)))
...))
((arg-and caller arg (a1 a2 ...) ...)
(and (or (symbol? 'arg)
(error "bad syntax" 'arg '(symbol? 'arg)
'(arg-and caller arg (a1 a2 ...) ...)))
(or (a1 a2 ...)
(if (string? caller)
(error caller arg 'arg '(a1 a2 ...))
(error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
...))))
;; accessory macro for arg-ands
(define-syntax caller-arg-and
(syntax-rules()
((caller-arg-and caller arg (a1 a2 ...) ...)
(and (or (symbol? 'arg)
(error "bad syntax" 'arg '(symbol? 'arg)
'(caller-arg-and caller arg (a1 a2 ...) ...)))
(or (a1 a2 ...)
(if (string? caller)
(error caller arg 'arg '(a1 a2 ...))
(error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
...))
((caller-arg-and null caller arg (a1 a2 ...) ...)
(and (or (symbol? 'arg)
(error "bad syntax" 'arg '(symbol? 'arg)
'(caller-arg-and caller arg (a1 a2 ...) ...)))
(or (a1 a2 ...)
(if (string? caller)
(error caller arg 'arg '(a1 a2 ...))
(error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
...))))
(define-syntax arg-ands
(syntax-rules (common)
((arg-ands (a1 a2 ...) ...)
(and (arg-and a1 a2 ...) ...))
((arg-ands common caller (a1 a2 ...) ...)
(and (caller-arg-and caller a1 a2 ...) ...))))
(define-syntax arg-or
(syntax-rules()
((arg-or arg (a1 a2 ...) ...)
(or (and (not (symbol? 'arg))
(error "bad syntax" 'arg '(symbol? 'arg)
'(arg-or arg (a1 a2 ...) ...)))
(and (a1 a2 ...)
(error "incorrect argument" arg 'arg '(a1 a2 ...)))
...))
((arg-or caller arg (a1 a2 ...) ...)
(or (and (not (symbol? 'arg))
(error "bad syntax" 'arg '(symbol? 'arg)
'(arg-or caller arg (a1 a2 ...) ...)))
(and (a1 a2 ...)
(if (string? caller)
(error caller arg 'arg '(a1 a2 ...))
(error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
...))))
;; accessory macro for arg-ors
(define-syntax caller-arg-or
(syntax-rules()
((caller-arg-or caller arg (a1 a2 ...) ...)
(or (and (not (symbol? 'arg))
(error "bad syntax" 'arg '(symbol? 'arg)
'(caller-arg-or caller arg (a1 a2 ...) ...)))
(and (a1 a2 ...)
(if (string? caller)
(error caller arg 'arg '(a1 a2 ...))
(error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
...))
((caller-arg-or null caller arg (a1 a2 ...) ...)
(or (and (not (symbol? 'arg))
(error "bad syntax" 'arg '(symbol? 'arg)
'(caller-arg-or caller arg (a1 a2 ...) ...)))
(and (a1 a2 ...)
(if (string? caller)
(error caller arg 'arg '(a1 a2 ...))
(error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
...))))
(define-syntax arg-ors
(syntax-rules (common)
((arg-ors (a1 a2 ...) ...)
(or (arg-or a1 a2 ...) ...))
((arg-ors common caller (a1 a2 ...) ...)
(or (caller-arg-or caller a1 a2 ...) ...))))
(define-syntax err-and
(syntax-rules ()
((err-and err expression ...)
(and (or expression
(if (string? err)
(error err 'expression)
(error "false expression" 'expression err)))
...))))
(define-syntax err-ands
(syntax-rules ()
((err-ands (err expression ...) ...)
(and (err-and err expression ...)
...))))
(define-syntax err-or
(syntax-rules ()
((err-or err expression ...)
(or (and expression
(if (string? err)
(error err 'expression)
(error "true expression" 'expression err)))
...))))
(define-syntax err-ors
(syntax-rules ()
((err-ors (err expression ...) ...)
(or (err-or err expression ...)
...))))
Copyright (C) Joo ChurlSoo (2004). All Rights Reserved.
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.