mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-19 05:39:17 +02:00
79 lines
2.4 KiB
Scheme
79 lines
2.4 KiB
Scheme
;;;; Cyclone Scheme
|
|
;;;; https://github.com/justinethier/cyclone
|
|
;;;;
|
|
;;;; Copyright (c) 2014-2016, Justin Ethier
|
|
;;;; All rights reserved.
|
|
;;;;
|
|
;;;; This module contains the inexact library from r7rs.
|
|
;;;;
|
|
(define-library (scheme inexact)
|
|
(import (scheme base))
|
|
(export
|
|
acos
|
|
asin
|
|
atan
|
|
cos
|
|
exp
|
|
finite?
|
|
infinite?
|
|
log
|
|
nan?
|
|
sin
|
|
sqrt
|
|
tan
|
|
)
|
|
(begin
|
|
(define-syntax define-inexact-op
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(let* ((fnc (cadr expr))
|
|
(op (caddr expr))
|
|
(complex-op (cadddr expr))
|
|
)
|
|
`(define-c ,fnc
|
|
"(void *data, int argc, closure _, object k, object z)"
|
|
,(string-append
|
|
" return_inexact_double_or_cplx_op(data, k, " op ", " complex-op ", z);")
|
|
"(void *data, object ptr, object z)"
|
|
,(string-append
|
|
" return_inexact_double_or_cplx_op_no_cps(data, ptr, " op ", " complex-op ", z);"))))))
|
|
|
|
(define-c nan?
|
|
"(void *data, int argc, closure _, object k, object z)"
|
|
" Cyc_check_num(data, z);
|
|
if (obj_is_int(z) ||
|
|
type_of(z) == integer_tag ||
|
|
type_of(z) == bignum_tag ||
|
|
!isnan(((double_type *)z)->value))
|
|
{
|
|
return_closcall1(data, k, boolean_f);
|
|
}
|
|
return_closcall1(data, k, boolean_t);")
|
|
(define-c infinite?
|
|
"(void *data, int argc, closure _, object k, object z)"
|
|
" Cyc_check_num(data, z);
|
|
if (obj_is_int(z) ||
|
|
type_of(z) == integer_tag ||
|
|
type_of(z) == bignum_tag ||
|
|
!isinf(((double_type *)z)->value))
|
|
{
|
|
return_closcall1(data, k, boolean_f);
|
|
}
|
|
return_closcall1(data, k, boolean_t);")
|
|
(define (finite? z)
|
|
(if (infinite? z) #f #t))
|
|
(define (log z1 . z2)
|
|
(if (null? z2)
|
|
(c-log z1)
|
|
(let ((z2* (car z2)))
|
|
(/ (c-log z1) (c-log z2*)))))
|
|
(define-inexact-op c-log "log" "clog")
|
|
(define-inexact-op exp "exp" "cexp")
|
|
(define-inexact-op sqrt "sqrt" "csqrt")
|
|
(define-inexact-op sin "sin" "csin")
|
|
(define-inexact-op cos "cos" "ccos")
|
|
(define-inexact-op tan "tan" "ctan")
|
|
(define-inexact-op asin "asin" "casin")
|
|
(define-inexact-op acos "acos" "cacos")
|
|
(define-inexact-op atan "atan" "catan")
|
|
))
|