scheme48 1.9-5 / usr / share / scheme48-1.9 / r6rs / bytevector-ieee.scm

This file is indexed.

/usr/share/scheme48-1.9/r6rs/bytevector-ieee.scm is in scheme48 1.9-5.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below. 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
; Part of Scheme 48 1.9.  See file COPYING for notices and license.

; Authors: Harald Glab-Phlak, Mike Sperber

(define (bytevector:nan? x)
  (and (real? x)
       (not (= x x))))

(define (bytevector:infinite? x)
  (and (real? x)
       (not (bytevector:nan? x))
       (bytevector:nan? (- x x))))

;exported stuff
(define (bytevector-ieee-single-native-ref bytevector k)
  (r6rs-bytevect->float bytevector k))

(define (bytevector-ieee-double-native-ref bytevector k)
  (r6rs-bytevect->double bytevector k))


(define (bytevector-ieee-single-ref bytevector k endness)
  (if (eq? endness (native-endianness))
      (if (= 0 (remainder k 4))
          (bytevector-ieee-single-native-ref bytevector k)
          (let ((b (make-bytevector 4)))
            (bytevector-copy! bytevector k b 0 4)
            (bytevector-ieee-single-native-ref b 0)))
      (let ((b (make-bytevector 4)))
        (bytevector-u8-set! b 0 (bytevector-u8-ref bytevector (+ k 3)))
        (bytevector-u8-set! b 1 (bytevector-u8-ref bytevector (+ k 2)))
        (bytevector-u8-set! b 2 (bytevector-u8-ref bytevector (+ k 1)))
        (bytevector-u8-set! b 3 (bytevector-u8-ref bytevector k))
        (bytevector-ieee-single-native-ref b 0))))

(define (bytevector-ieee-double-ref bytevector k endness)
  (if (eq? endness (native-endianness))
      (if (= 0 (remainder k 8))
          (bytevector-ieee-double-native-ref bytevector k)
          (let ((b (make-bytevector 8)))
            (bytevector-copy! bytevector k b 0 8)
            (bytevector-ieee-double-native-ref b 0)))
      (let ((b (make-bytevector 8)))
        (bytevector-u8-set! b 0 (bytevector-u8-ref bytevector (+ k 7)))
        (bytevector-u8-set! b 1 (bytevector-u8-ref bytevector (+ k 6)))
        (bytevector-u8-set! b 2 (bytevector-u8-ref bytevector (+ k 5)))
        (bytevector-u8-set! b 3 (bytevector-u8-ref bytevector (+ k 4)))
        (bytevector-u8-set! b 4 (bytevector-u8-ref bytevector (+ k 3)))
        (bytevector-u8-set! b 5 (bytevector-u8-ref bytevector (+ k 2)))
        (bytevector-u8-set! b 6 (bytevector-u8-ref bytevector (+ k 1)))
        (bytevector-u8-set! b 7 (bytevector-u8-ref bytevector k))
        (bytevector-ieee-double-native-ref b 0))))

(define (bytevector-ieee-single-native-set! bytevector k x)
  (r6rs-float->bytevect!  x bytevector k))

(define (bytevector-ieee-double-native-set! bytevector k x)
  (r6rs-double->bytevect!  x bytevector k))

(define (bytevector-ieee-single-set! bytevector k x endness)
  (if (eq? endness (native-endianness))
      (if (= 0 (remainder k 4))
          (bytevector-ieee-single-native-set! bytevector k x)
          (let ((b (make-bytevector 4)))
            (bytevector-ieee-single-native-set! b 0 x)
            (bytevector-copy! b 0 bytevector k 4)))
      (let ((b (make-bytevector 4)))
        (bytevector-ieee-single-native-set! b 0 x)
        (bytevector-u8-set! bytevector k (bytevector-u8-ref b 3))
        (bytevector-u8-set! bytevector (+ k 1) (bytevector-u8-ref b 2))
        (bytevector-u8-set! bytevector (+ k 2) (bytevector-u8-ref b 1))
        (bytevector-u8-set! bytevector (+ k 3) (bytevector-u8-ref b 0)))))

(define (bytevector-ieee-double-set! bytevector k x endness)
  (if (eq? endness (native-endianness))
      (if (= 0 (remainder k 8))
          (bytevector-ieee-double-native-set! bytevector k x)
          (let ((b (make-bytevector 8)))
            (bytevector-ieee-double-native-set! b 0 x)
            (bytevector-copy! b 0 bytevector k 8)))
      (let ((b (make-bytevector 8)))
        (bytevector-ieee-double-native-set! b 0 x)
        (bytevector-u8-set! bytevector k (bytevector-u8-ref b 7))
        (bytevector-u8-set! bytevector (+ k 1) (bytevector-u8-ref b 6))
        (bytevector-u8-set! bytevector (+ k 2) (bytevector-u8-ref b 5))
        (bytevector-u8-set! bytevector (+ k 3) (bytevector-u8-ref b 4))
        (bytevector-u8-set! bytevector (+ k 4) (bytevector-u8-ref b 3))
        (bytevector-u8-set! bytevector (+ k 5) (bytevector-u8-ref b 2))
        (bytevector-u8-set! bytevector (+ k 6) (bytevector-u8-ref b 1))
        (bytevector-u8-set! bytevector (+ k 7) (bytevector-u8-ref b 0)))))


(define (r6rs-float->bytevect!  float bytevect index)
  (external-r6rs-float->bytevect! float bytevect index))

(define (r6rs-bytevect->float bytevect index)
  (external-r6rs-bytevect->float bytevect index))

(define (r6rs-double->bytevect!  double bytevect index)
  (external-r6rs-double->bytevect! double bytevect index))

(define (r6rs-bytevect->double bytevect index)
  (external-r6rs-bytevect->double bytevect index))


;; external fun definition

(import-lambda-definition-2 external-r6rs-float->bytevect!
			    (double bytevect index)
			    "r6rs_float_to_bytevect")

(import-lambda-definition-2 external-r6rs-bytevect->float
			    (bytevect index)
			    "r6rs_bytevect_to_float")

(import-lambda-definition-2 external-r6rs-double->bytevect!
			    (double bytevect index)
			    "r6rs_double_to_bytevect")

(import-lambda-definition-2 external-r6rs-bytevect->double
			    (bytevect index)
			    "r6rs_bytevect_to_double")

APT Browse - Built by Thomas Orozco.