20071025 16:27:34 04:00



;;; Ikarus Scheme  A compiler for R6RS Scheme.

20080129 00:34:34 05:00



;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum

20071025 16:27:34 04:00



;;;




;;; 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/>.





20070505 03:24:33 04:00







(library (ikarus predicates)

20070505 03:34:59 04:00




20080524 13:13:01 04:00



(export fixnum? flonum? bignum? ratnum? compnum? cflonum?

20080518 23:39:41 04:00



number? complex? real? rational?

20070903 00:34:53 04:00



integer? exact? inexact? eofobject? bwpobject? immediate?

20070515 12:42:52 04:00



boolean? char? vector? bytevector? string? procedure? null? pair?

20081111 00:39:02 05:00



symbol? code? not weakpair? eq? eqv? boolean=?

20070912 03:10:54 04:00



symbol=? finite? infinite? nan? realvalued?

20071210 07:28:03 05:00



rationalvalued? integervalued? transcoder?)

20070505 03:24:33 04:00



(import

20080524 13:13:01 04:00



(except (ikarus) fixnum? flonum? bignum? ratnum? compnum? cflonum?

20080518 23:39:41 04:00



number? complex? real?

20070903 00:34:53 04:00



rational? integer? exact? inexact? eofobject? bwpobject?

20070515 12:42:52 04:00



immediate? boolean? char? vector? bytevector? string? procedure?

20081111 00:39:02 05:00



null? pair? weakpair? symbol? code? not eq? eqv?

20071210 07:28:03 05:00



transcoder? boolean=? symbol=?

20070912 03:10:54 04:00



finite? infinite? nan? realvalued? rationalvalued?




integervalued?)

20070506 18:43:04 04:00



(ikarus system $fx)

20070613 02:03:30 04:00



(ikarus system $flonums)

20070506 18:43:04 04:00



(ikarus system $pairs)




(ikarus system $chars)




(ikarus system $strings)




(ikarus system $vectors)

20080524 13:13:01 04:00



(only (ikarus system $compnums) $cflonumreal $cflonumimag)




(rename (only (ikarus) fixnum? flonum? bignum? ratnum? compnum? cflonum?

20080518 23:39:41 04:00



eofobject?

20070505 06:15:25 04:00



bwpobject? immediate? boolean? char? vector? string?

20070515 12:42:52 04:00



bytevector? procedure? null? pair? symbol? code? eq?

20071210 07:28:03 05:00



transcoder?)

20070505 03:24:33 04:00



(fixnum? sys:fixnum?)




(flonum? sys:flonum?)

20070505 03:27:53 04:00



(bignum? sys:bignum?)

20070520 23:23:54 04:00



(ratnum? sys:ratnum?)

20080518 23:39:41 04:00



(compnum? sys:compnum?)

20080524 13:13:01 04:00



(cflonum? sys:cflonum?)

20070505 03:27:53 04:00



(eofobject? sys:eofobject?)

20070505 06:15:25 04:00



(bwpobject? sys:bwpobject?)

20070505 03:34:59 04:00



(immediate? sys:immediate?)




(boolean? sys:boolean?)




(char? sys:char?)




(vector? sys:vector?)

20070515 12:42:52 04:00



(bytevector? sys:bytevector?)

20070505 03:34:59 04:00



(string? sys:string?)




(procedure? sys:procedure?)




(null? sys:null?)




(pair? sys:pair?)

20070505 05:09:15 04:00



(symbol? sys:symbol?)

20070506 22:48:10 04:00



(code? sys:code?)

20070505 17:44:24 04:00



(eq? sys:eq?)

20071206 05:05:26 05:00



(transcoder? sys:transcoder?)

20070505 17:44:24 04:00



))

20070505 03:24:33 04:00







(define fixnum?




(lambda (x) (sys:fixnum? x)))








(define bignum?




(lambda (x) (sys:bignum? x)))





20070520 23:23:54 04:00



(define ratnum?




(lambda (x) (sys:ratnum? x)))





20070505 03:24:33 04:00



(define flonum?




(lambda (x) (sys:flonum? x)))





20080518 23:39:41 04:00



(define compnum?




(lambda (x) (sys:compnum? x)))





20080524 13:13:01 04:00



(define cflonum?




(lambda (x) (sys:cflonum? x)))





20070505 03:24:33 04:00



(define number?




(lambda (x)




(or (sys:fixnum? x)




(sys:bignum? x)

20070520 23:23:54 04:00



(sys:flonum? x)

20080518 23:39:41 04:00



(sys:ratnum? x)

20080524 13:13:01 04:00



(sys:compnum? x)




(sys:cflonum? x))))

20070505 03:24:33 04:00







(define complex?




(lambda (x) (number? x)))








(define real?

20080518 23:39:41 04:00



(lambda (x)




(or (sys:fixnum? x)




(sys:bignum? x)




(sys:flonum? x)




(sys:ratnum? x))))

20070912 03:10:54 04:00







(define realvalued?

20080725 20:46:34 04:00



(lambda (x)




(cond




[(real? x) #t]




[(cflonum? x) (fl=? ($cflonumimag x) 0.0)]




[else #f])))

20070912 03:10:54 04:00




20070505 03:24:33 04:00



(define rational?




(lambda (x)




(cond




[(sys:fixnum? x) #t]




[(sys:bignum? x) #t]

20070520 23:23:54 04:00



[(sys:ratnum? x) #t]

20070613 02:03:30 04:00



[(sys:flonum? x) ($flonumrational? x)]

20070912 03:10:54 04:00



[else #f])))








(define rationalvalued?

20080725 20:46:34 04:00



(lambda (x)




(cond




[(rational? x) #t]




[(cflonum? x)




(and (fl=? ($cflonumimag x) 0.0)




($flonumrational? ($cflonumreal x)))]




[else #f])))

20070505 03:24:33 04:00







(define integer?




(lambda (x)




(cond




[(sys:fixnum? x) #t]




[(sys:bignum? x) #t]

20070520 23:23:54 04:00



[(sys:ratnum? x) #f]

20070613 02:03:30 04:00



[(sys:flonum? x) ($flonuminteger? x)]

20070505 03:24:33 04:00



[else #f])))





20070912 03:10:54 04:00



(define integervalued?

20080725 20:46:34 04:00



(lambda (x)




(cond




[(integer? x) #t]




[(cflonum? x)




(and (fl=? ($cflonumimag x) 0.0)




($flonuminteger? ($cflonumreal x)))]




[else #f])))





20070912 03:10:54 04:00




20070505 03:24:33 04:00



(define exact?




(lambda (x)




(cond




[(sys:fixnum? x) #t]




[(sys:bignum? x) #t]

20070613 02:03:30 04:00



[(sys:ratnum? x) #t]

20070505 03:24:33 04:00



[(sys:flonum? x) #f]

20080518 23:39:41 04:00



[(sys:compnum? x) #t]

20080524 13:13:01 04:00



[(sys:cflonum? x) #f]

20070505 03:24:33 04:00



[else

20071215 08:22:49 05:00



(die 'exact? "not a number" x)])))

20070505 03:27:53 04:00




20070903 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]

20080518 23:39:41 04:00



[(sys:compnum? x) #f]

20080524 13:13:01 04:00



[(sys:cflonum? x) #t]

20070903 00:34:53 04:00



[else

20071215 08:22:49 05:00



(die 'inexact? "not a number" x)])))

20070903 00:34:53 04:00




20070912 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]

20080518 23:39:41 04:00



[(sys:compnum? x) #t]

20080524 13:13:01 04:00



[(sys:cflonum? x)




(and




(flfinite? ($cflonumreal x))




(flfinite? ($cflonumimag x)))]

20070912 02:44:19 04:00



[else

20071215 08:22:49 05:00



(die 'finite? "not a number" x)])))

20070912 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]

20080518 23:39:41 04:00



[(sys:compnum? x) #f]

20080524 13:13:01 04:00



[(sys:cflonum? x)




(or




(flinfinite? ($cflonumreal x))




(flinfinite? ($cflonumimag x)))]

20070912 02:44:19 04:00



[else

20071215 08:22:49 05:00



(die 'infinite? "not a number" x)])))

20070912 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]

20080518 23:39:41 04:00



[(sys:compnum? x) #f]

20080524 13:13:01 04:00



[(sys:cflonum? x)




(or




(nan? ($cflonumreal x))




(nan? ($cflonumimag x)))]

20070912 02:44:19 04:00



[else

20071215 08:22:49 05:00



(die 'nan? "not a number" x)])))

20070912 02:44:19 04:00
















20070505 03:34:59 04:00



(define eofobject? (lambda (x) (sys:eofobject? x)))

20070505 06:15:25 04:00



(define bwpobject? (lambda (x) (sys:bwpobject? x)))

20071206 05:05:26 05:00



(define transcoder? (lambda (x) (sys:transcoder? x)))

20070505 03:34:59 04:00



(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)))

20070515 12:42:52 04:00



(define bytevector? (lambda (x) (sys:bytevector? x)))

20070505 03:34:59 04:00



(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)))

20070506 22:48:10 04:00



(define code? (lambda (x) (sys:code? x)))

20070505 06:18:29 04:00











(define weakpair?




(lambda (x)




(and (pair? x)




(foreigncall "ikrt_is_weak_pair" x))))





20070505 04:28:40 04:00



(define not (lambda (x) (if x #f #t)))

20070505 05:09:15 04:00







(define eq? (lambda (x y) (sys:eq? x y)))





20070505 05:10:38 04:00



(define eqv?




(lambda (x y)

20080524 13:13:01 04:00



(import (ikarus))




(cond




[(eq? x y) #t]

20081018 13:08:14 04:00



[(flonum? x)




(and (flonum? y)

20090720 03:01:05 04:00



(if ($fl< x y)




#f




(if ($fl> x y)




#f




(if ($fl= x 0.0)




($fl= ($fl/ 1.0 x) ($fl/ 1.0 y))




#t))))]

20080524 13:13:01 04:00



[(bignum? x) (and (bignum? y) (= x y))]




[(ratnum? x) (and (ratnum? y) (= x y))]




[(compnum? x)




(and (compnum? y)




(= (realpart x) (realpart y))




(= (imagpart x) (imagpart y)))]




[(cflonum? x)




(and (cflonum? y)




(= (realpart x) (realpart y))




(= (imagpart x) (imagpart y)))]




[else #f])))

20070505 05:35:09 04:00




20080723 10:55:32 04:00







(definesyntax definepred




(syntaxrules ()




[(_ name pred? msg)




(begin




(define (err x) (die 'name msg x))




(define (g rest)




(if (sys:pair? rest)




(let ([a (car rest)])




(if (pred? a)




(g (cdr rest))




(err a)))




#f))




(define (f x rest)




(if (sys:pair? rest)




(let ([a (car rest)])




(if (sys:eq? x a)




(f x (cdr rest))




(if (pred? a)




(g (cdr rest))




(err a))))




#t))




(define name




(caselambda




[(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))])))]))




(definepred symbol=? sys:symbol? "not a symbol")




(definepred boolean=? sys:boolean? "not a boolean")

20070505 05:35:09 04:00








20070505 17:44:24 04:00




20070505 03:27:53 04:00



)
