conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

symbol=? and boolean=? now accept 2+ args.

This commit is contained in:
Abdulaziz Ghuloum 2008-07-23 07:55:32 -07:00
parent acc9940379
commit 9f623124d5
2 changed files with 43 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
scheme/ikarus.predicates.ss
View File

@ -247,26 +247,48 @@
(= (imag-part x) (imag-part y)))] (= (imag-part x) (imag-part y)))]
[else #f]))) [else #f])))
(define boolean=?
(lambda (x y) (define-syntax define-pred
(if (sys:boolean? x) (syntax-rules ()
(if (sys:eq? x y) [(_ name pred? msg)
#t (begin
(if (sys:boolean? y) (define (err x) (die 'name msg x))
#f (define (g rest)
(die 'boolean=? "not a boolean" y))) (if (sys:pair? rest)
(die 'boolean=? "not a boolean" x)))) (let ([a (car rest)])
(if (pred? a)
(g (cdr rest))
(define symbol=? (err a)))
(lambda (x y) #f))
(if (sys:symbol? x) (define (f x rest)
(if (sys:eq? x y) (if (sys:pair? rest)
#t (let ([a (car rest)])
(if (sys:symbol? y) (if (sys:eq? x a)
#f (f x (cdr rest))
(die 'symbol=? "not a symbol" y))) (if (pred? a)
(die 'symbol=? "not a symbol" x)))) (g (cdr rest))
(err a))))
#t))
(define name
(case-lambda
[(x y)
(if (pred? x)
(if (sys:eq? x y)
#t
(if (pred? y)
#f
(err y)))
(err x))]
[(x y z . rest)
(if (pred? x)
(if (sys:eq? x y)
(if (sys:eq? x z)
(f x rest)
(if (pred? z) #f (err z)))
(if (pred? y) #f (err y)))
(err x))])))]))
(define-pred symbol=? sys:symbol? "not a symbol")
(define-pred boolean=? sys:boolean? "not a boolean")
(module (equal?) (module (equal?)
(define vector-loop (define vector-loop

2
scheme/last-revision
View File

@ -1 +1 @@
1547 1548