;;; 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 . (library (ikarus predicates) (export fixnum? flonum? bignum? ratnum? compnum? number? complex? real? rational? integer? exact? inexact? eof-object? bwp-object? immediate? boolean? char? vector? bytevector? string? procedure? null? pair? 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? rational? integer? exact? inexact? eof-object? bwp-object? immediate? boolean? char? vector? bytevector? string? procedure? 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?) (symbol? sys:symbol?) (code? sys:code?) (eq? sys:eq?) (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)]))) (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] [else (die 'inexact? "not a number" x)]))) (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] [else (die 'finite? "not a number" x)]))) (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] [else (die 'infinite? "not a number" x)]))) (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] [else (die 'nan? "not a number" x)]))) (define eof-object? (lambda (x) (sys:eof-object? x))) (define bwp-object? (lambda (x) (sys:bwp-object? x))) (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))) (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))) (define eq? (lambda (x y) (sys:eq? x y))) (define eqv? (lambda (x y) (or (sys:eq? x y) (and (number? x) (number? y) (= x y))))) (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)))) (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)))) (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))] [else #f])))) )