#lang racket ;;; Racket Science Collection ;;; unsafe-ops-utils.ss ;;; Copyright (c) 2010 M. Douglas Williams ;;; ;;; This file is part of the Racket Science Collection. ;;; ;;; The Racket Science Collection is free software: you can redistribute it ;;; and/or modify it under the terms of the GNU Lesser General Public License as ;;; published by the Free Software Foundation, either version 3 of the License or ;;; (at your option) any later version. ;;; ;;; The Racket Science Collection is distributed in the hope that it will be ;;; useful, but WITHOUT WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser ;;; General Public License for more details. ;;; ;;; You should have received a copy of the GNU Lesser General Public License ;;; along with the Racket Science Collection. If not, see ;;; <http://www.gnu.org/licenses/>. ;;; ;;; ----------------------------------------------------------------------------- ;;; ;;; This code has utility functions that can be used to assure floats for unsafe ;;; code. The basic philosophy we are taking is to use the unsafe operations ;;; where it makes sense, but to protect the code so that the operands to unsafe ;;; operations are guaranteed to be of the correct type. ;;; ;;; Version Date Description ;;; 4.0.0 05/16/10 Moved the unsafe ops utility functions from math.ss and ;;; added with-fixed. (MDW) (require scheme/flonum) (require scheme/unsafe/ops) ;;; (real->float x) -> inexact-real? ;;; x : real? ;;; Returns an inexact real (i.e., a float) given real x. Raises an error if x ;;; is not a real. This can be used to assure a real value is a float, even in ;;; unsafe code. (define (real->float x) (if (real? x) (exact->inexact x) (error "expected real, given" x))) ;;; (real-vector->float-vector v) -> (vectorof inexact-real?) ;;; v : (vectorof real?) ;;; Returns a vector of inexact reals (i.e., floats) given a vector of reals, v. ;;; Raises an error if an element of v is not a real. (define (real-vector->float-vector v) (build-vector (vector-length v) (lambda (i) (real->float (vector-ref v i))))) ;;; (real-vector->flvector v) -> flvector? ;;; v : (vectorof real?) ;;; Returns an flvector given a vector of reals, v. Raises an error if an element ;;; of v is not a real. (define (real-vector->flvector v) (let ((fl-v (make-flvector (vector-length v)))) (for ((i (in-range (vector-length v)))) (unsafe-flvector-set! fl-v i (real->float (unsafe-vector-ref v i)))) fl-v)) ;;; (with-fixed (x ...) ;;; expr ...) ;;; Executes the expr's with the x's guaranteed to be fixnums. All of the x's ;;; must be identifiers. Note that this does not attempt to coerce anything to a ;;; fixnum, just assure that they are. (define-syntax (with-fixed stx) (syntax-case stx () ((with-fized (x ...) expr ...) (for ((id (in-list (syntax->list #'(x ...))))) (unless (identifier? id) (raise-syntax-error #f "not an identifier" stx id))) #`(let ((x (if (fixnum? x) x (error "expected fixed integer, given" x))) ...) expr ...)))) ;;; (with-float (x ...) ;;; expr ...) ;;; Executes the expr's with the x's guaranteed to be floats. All of the x's ;;; must be identifiers. (define-syntax (with-float stx) (syntax-case stx () ((with-float (x ...) expr ...) (for ((id (in-list (syntax->list #'(x ...))))) (unless (identifier? id) (raise-syntax-error #f "not an identifier" stx id))) #`(let ((x (if (real? x) (exact->inexact x) (error "expected real, given" x))) ...) expr ...)))) ;;; Module Contracts (provide with-fixed with-float) (provide/contract (real->float (-> real? inexact-real?)) (real-vector->float-vector (-> (vectorof real?) (vectorof inexact-real?))) (real-vector->flvector (-> (vectorof real?) flvector?)))