Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[10d2c0]: contrib / sb-bsd-sockets / array-data.lisp Maximize Restore History

Download this file

array-data.lisp    73 lines (64 with data), 2.4 kB

 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
(in-package :sockint)
;;; borrowed from CMUCL manual, lightly ported
(defun array-data-address (array)
"Return the physical address of where the actual data of an array is
stored.
ARRAY must be a specialized array type - an array of one of these types:
double-float
single-float
(unsigned-byte 32)
(unsigned-byte 16)
(unsigned-byte 8)
(signed-byte 32)
(signed-byte 16)
(signed-byte 8)
"
(declare (type (or (array (signed-byte 8))
(array base-char)
simple-base-string
(array (signed-byte 16))
(array (signed-byte 32))
(array (unsigned-byte 8))
(array (unsigned-byte 16))
(array (unsigned-byte 32))
(array single-float)
(array double-float))
array)
(optimize (speed 0) (debug 3) (safety 3)))
;; with-array-data will get us to the actual data. However, because
;; the array could have been displaced, we need to know where the
;; data starts.
(let* ((type (car (multiple-value-list (array-element-type array))))
(type-size
(cond ((or (equal type '(signed-byte 8))
(equal type 'cl::base-char)
(equal type '(unsigned-byte 8)))
1)
((or (equal type '(signed-byte 16))
(equal type '(unsigned-byte 16)))
2)
((or (equal type '(signed-byte 32))
(equal type '(unsigned-byte 32)))
4)
((equal type 'single-float)
4)
((equal type 'double-float)
8)
(t (error "Unknown specialized array element type")))))
(with-array-data ((data array)
(start)
(end))
(declare (ignore end))
;; DATA is a specialized simple-array. Memory is laid out like this:
;;
;; byte offset Value
;; 0 type code (e.g. 70 for double-float vector)
;; 4 FIXNUMIZE(number of elements in vector)
;; 8 1st element of vector
;; ... ...
;;
(let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address data)))))
(declare (type (unsigned-byte 32) addr)
(optimize (speed 3) (safety 0)))
(sb-sys:int-sap (the (unsigned-byte 32)
(+ addr (* type-size start))))))))