ikarus/scheme/ikarus.predicates.ss

275 lines
7.9 KiB
Scheme
Raw Normal View History

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; 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 program. If not, see <http://www.gnu.org/licenses/>.
(library (ikarus predicates)
(export fixnum? flonum? bignum? ratnum? compnum?
number? complex? real? rational?
2007-09-03 00:34:53 -04:00
integer? exact? inexact? eof-object? bwp-object? immediate?
boolean? char? vector? bytevector? string? procedure? null? pair?
2007-08-28 15:03:21 -04:00
symbol? code? not weak-pair? eq? eqv? equal? boolean=?
symbol=? finite? infinite? nan? real-valued?
rational-valued? integer-valued? transcoder?)
(import
(except (ikarus) fixnum? flonum? bignum? ratnum? compnum?
number? complex? real?
2007-09-03 00:34:53 -04:00
rational? integer? exact? inexact? eof-object? bwp-object?
immediate? boolean? char? vector? bytevector? string? procedure?
2007-05-06 22:48:10 -04:00
null? pair? weak-pair? symbol? code? not eq? eqv? equal?
transcoder? boolean=? symbol=?
finite? infinite? nan? real-valued? rational-valued?
integer-valued?)
(ikarus system $fx)
(ikarus system $flonums)
(ikarus system $pairs)
(ikarus system $chars)
(ikarus system $strings)
(ikarus system $vectors)
;(ikarus system $compnums)
(rename (only (ikarus) fixnum? flonum? bignum? ratnum? compnum?
eof-object?
bwp-object? immediate? boolean? char? vector? string?
bytevector? procedure? null? pair? symbol? code? eq?
transcoder?)
(fixnum? sys:fixnum?)
(flonum? sys:flonum?)
(bignum? sys:bignum?)
(ratnum? sys:ratnum?)
(compnum? sys:compnum?)
(eof-object? sys:eof-object?)
(bwp-object? sys:bwp-object?)
(immediate? sys:immediate?)
(boolean? sys:boolean?)
(char? sys:char?)
(vector? sys:vector?)
(bytevector? sys:bytevector?)
(string? sys:string?)
(procedure? sys:procedure?)
(null? sys:null?)
(pair? sys:pair?)
2007-05-05 05:09:15 -04:00
(symbol? sys:symbol?)
2007-05-06 22:48:10 -04:00
(code? sys:code?)
(eq? sys:eq?)
2007-12-06 05:05:26 -05:00
(transcoder? sys:transcoder?)
))
(define fixnum?
(lambda (x) (sys:fixnum? x)))
(define bignum?
(lambda (x) (sys:bignum? x)))
(define ratnum?
(lambda (x) (sys:ratnum? x)))
(define flonum?
(lambda (x) (sys:flonum? x)))
(define compnum?
(lambda (x) (sys:compnum? x)))
(define number?
(lambda (x)
(or (sys:fixnum? x)
(sys:bignum? x)
(sys:flonum? x)
(sys:ratnum? x)
(sys:compnum? x))))
(define complex?
(lambda (x) (number? x)))
(define real?
(lambda (x)
(or (sys:fixnum? x)
(sys:bignum? x)
(sys:flonum? x)
(sys:ratnum? x))))
(define real-valued?
(lambda (x) (real? x)))
(define rational?
(lambda (x)
(cond
[(sys:fixnum? x) #t]
[(sys:bignum? x) #t]
[(sys:ratnum? x) #t]
[(sys:flonum? x) ($flonum-rational? x)]
[else #f])))
(define rational-valued?
(lambda (x) (rational? x)))
(define integer?
(lambda (x)
(cond
[(sys:fixnum? x) #t]
[(sys:bignum? x) #t]
[(sys:ratnum? x) #f]
[(sys:flonum? x) ($flonum-integer? x)]
[else #f])))
(define integer-valued?
(lambda (x) (integer? x)))
(define exact?
(lambda (x)
(cond
[(sys:fixnum? x) #t]
[(sys:bignum? x) #t]
[(sys:ratnum? x) #t]
[(sys:flonum? x) #f]
[(sys:compnum? x) #t]
[else
(die 'exact? "not a number" x)])))
2007-09-03 00:34:53 -04:00
(define inexact?
(lambda (x)
(cond
[(sys:flonum? x) #t]
[(sys:fixnum? x) #f]
[(sys:bignum? x) #f]
[(sys:ratnum? x) #f]
[(sys:compnum? x) #f]
2007-09-03 00:34:53 -04:00
[else
(die 'inexact? "not a number" x)])))
2007-09-03 00:34:53 -04:00
2007-09-12 02:44:19 -04:00
(define finite?
(lambda (x)
(cond
[(sys:flonum? x) (flfinite? x)]
[(sys:fixnum? x) #t]
[(sys:bignum? x) #t]
[(sys:ratnum? x) #t]
[(sys:compnum? x) #t]
2007-09-12 02:44:19 -04:00
[else
(die 'finite? "not a number" x)])))
2007-09-12 02:44:19 -04:00
(define infinite?
(lambda (x)
(cond
[(sys:flonum? x) (flinfinite? x)]
[(sys:fixnum? x) #f]
[(sys:bignum? x) #f]
[(sys:ratnum? x) #f]
[(sys:compnum? x) #f]
2007-09-12 02:44:19 -04:00
[else
(die 'infinite? "not a number" x)])))
2007-09-12 02:44:19 -04:00
(define nan?
(lambda (x)
(cond
[(sys:flonum? x) (flnan? x)]
[(sys:fixnum? x) #f]
[(sys:bignum? x) #f]
[(sys:ratnum? x) #f]
[(sys:compnum? x) #f]
2007-09-12 02:44:19 -04:00
[else
(die 'nan? "not a number" x)])))
2007-09-12 02:44:19 -04:00
(define eof-object? (lambda (x) (sys:eof-object? x)))
(define bwp-object? (lambda (x) (sys:bwp-object? x)))
2007-12-06 05:05:26 -05:00
(define transcoder? (lambda (x) (sys:transcoder? x)))
(define immediate? (lambda (x) (sys:immediate? x)))
(define boolean? (lambda (x) (sys:boolean? x)))
(define char? (lambda (x) (sys:char? x)))
(define vector? (lambda (x) (sys:vector? x)))
(define bytevector? (lambda (x) (sys:bytevector? x)))
(define string? (lambda (x) (sys:string? x)))
(define procedure? (lambda (x) (sys:procedure? x)))
(define null? (lambda (x) (sys:null? x)))
(define pair? (lambda (x) (sys:pair? x)))
(define symbol? (lambda (x) (sys:symbol? x)))
2007-05-06 22:48:10 -04:00
(define code? (lambda (x) (sys:code? x)))
(define weak-pair?
(lambda (x)
(and (pair? x)
(foreign-call "ikrt_is_weak_pair" x))))
(define not (lambda (x) (if x #f #t)))
2007-05-05 05:09:15 -04:00
(define eq? (lambda (x y) (sys:eq? x y)))
2007-05-05 05:10:38 -04:00
(define eqv?
(lambda (x y)
(or (sys:eq? x y)
(and (number? x) (number? y) (= x y)))))
2007-05-05 05:35:09 -04:00
2007-08-28 15:03:21 -04:00
(define boolean=?
(lambda (x y)
(if (sys:boolean? x)
(if (sys:eq? x y)
#t
(if (sys:boolean? y)
#f
(die 'boolean=? "not a boolean" y)))
(die 'boolean=? "not a boolean" x))))
2007-08-28 15:03:21 -04:00
2007-05-05 05:35:09 -04:00
2007-08-28 15:03:21 -04:00
(define symbol=?
(lambda (x y)
(if (sys:symbol? x)
(if (sys:eq? x y)
#t
(if (sys:symbol? y)
#f
(die 'symbol=? "not a symbol" y)))
(die 'symbol=? "not a symbol" x))))
2007-05-05 05:35:09 -04:00
(module (equal?)
(define vector-loop
(lambda (x y i n)
(or ($fx= i n)
(and (equal? ($vector-ref x i) ($vector-ref y i))
(vector-loop x y ($fxadd1 i) n)))))
(define string-loop
(lambda (x y i n)
(or ($fx= i n)
(and ($char= ($string-ref x i) ($string-ref y i))
(string-loop x y ($fxadd1 i) n)))))
(define equal?
(lambda (x y)
(cond
[(sys:eq? x y) #t]
[(pair? x)
(and (pair? y)
(equal? ($car x) ($car y))
(equal? ($cdr x) ($cdr y)))]
[(vector? x)
(and (vector? y)
(let ([n ($vector-length x)])
(and ($fx= n ($vector-length y))
(vector-loop x y 0 n))))]
[(string? x)
(and (string? y)
(let ([n ($string-length x)])
(and ($fx= n ($string-length y))
(string-loop x y 0 n))))]
[(number? x) (and (number? y) (= x y))]
[(sys:bytevector? x)
(and (sys:bytevector? y) (bytevector=? x y))]
2007-05-05 05:35:09 -04:00
[else #f]))))
)