chiark - git - mdw - clg/blob - gffi/memory.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: memory.lisp,v 1.7 2007-12-11 12:01:34 espen Exp $
  24
  25
  26 (in-package "GFFI")
  27
  28 (deftype pointer ()
  29   #+(or cmu sbcl) 'system-area-pointer
  30   #+clisp 'ffi:foreign-address)
  31
  32 (defun make-pointer (address)
  33   #+(or cmu sbcl)(int-sap address)
  34   #+clisp(ffi:unsigned-foreign-address address)
  35   #-(or cmu sbcl clisp)address)
  36
  37 (defun pointer-address (pointer)
  38   #+(or cmu sbcl)(sap-int pointer)
  39   #+clisp(ffi:foreign-address-unsigned pointer)
  40   #-(or cmu sbcl clisp)pointer)
  41
  42 (defun null-pointer-p (pointer)
  43   #+(or cmu sbcl)(zerop (sap-int pointer))
  44   #+clisp(or (not pointer) (zerop (pointer-address pointer)))
  45   #-(or cmu sbcl clisp)(zerop pointer))
  46
  47 (defun pointer= (pointer1 pointer2)
  48   #+(or cmu sbcl)(sap= pointer1 pointer2)
  49   #+clisp(= (pointer-address pointer1) (pointer-address pointer2))
  50   #-(or cmu sbcl clisp)(= pointer1 pointer2))
  51
  52 (defun pointer+ (pointer offset)
  53   #+(or cmu sbcl)(sap+ pointer offset)
  54   #+clisp(make-pointer (+ (pointer-address pointer) offset))
  55   #-(or cmu sbcl clisp)(+ pointer offset))
  56
  57 (defun ref-pointer (location &optional (offset 0))
  58   #+(or cmu sbcl)(sap-ref-sap location offset)
  59   #+clisp(ffi:memory-as location 'ffi:c-pointer offset))
  60
  61 (defun (setf ref-pointer) (pointer location &optional (offset 0))
  62   (setf
  63    #+(or cmu sbcl)(sap-ref-sap location offset)
  64    #+clisp(ffi:memory-as location 'ffi:c-pointer offset)
  65    pointer))
  66
  67
  68 (deftype int-8 () '(signed-byte 8))
  69 (deftype uint-8 () '(unsigned-byte 8))
  70 (deftype int-16 () '(signed-byte 16))
  71 (deftype uint-16 () '(unsigned-byte 16))
  72 (deftype int-32 () '(signed-byte 32))
  73 (deftype uint-32 () '(unsigned-byte 32))
  74 (deftype int-64 () '(signed-byte 64))
  75 (deftype uint-64 () '(unsigned-byte 64))
  76
  77 (declaim
  78  (ftype (function (pointer &optional fixnum) int-8) ref-int-8)
  79  (inline ref-int-8))
  80 (defun ref-int-8 (location &optional (offset 0))
  81   #+(or cmu sbcl)(signed-sap-ref-8 location offset)
  82   #+clisp(ffi:memory-as location 'ffi:char offset))
  83
  84 (declaim
  85  (ftype (function (int-8 pointer &optional fixnum) int-8) (setf ref-int-8))
  86  (inline (setf ref-int-8)))
  87 (defun (setf ref-int-8) (byte location &optional (offset 0))
  88   (setf
  89    #+(or cmu sbcl)(signed-sap-ref-8 location offset)
  90    #+clisp(ffi:memory-as location 'ffi:char offset)
  91    byte))
  92
  93 ;; Deprecated functions
  94 (defun ref-byte (location &optional (offset 0))
  95   (ref-int-8 location offset))
  96 (defun (setf ref-byte) (byte location &optional (offset 0))
  97   (setf (ref-int-8 location offset) byte))
  98
  99
 100 (declaim
 101  (ftype (function (pointer &optional fixnum) uint-8) ref-uint-8)
 102  (inline ref-uint-8))
 103 (defun ref-uint-8 (location &optional (offset 0))
 104   #+(or cmu sbcl)(sap-ref-8 location offset)
 105   #+clisp(ffi:memory-as location 'ffi:uchar offset))
 106
 107 (declaim
 108  (ftype (function (uint-8 pointer &optional fixnum) uint-8) (setf ref-uint-8))
 109  (inline (setf ref-uint-8)))
 110 (defun (setf ref-uint-8) (byte location &optional (offset 0))
 111   (setf
 112    #+(or cmu sbcl)(sap-ref-8 location offset)
 113    #+clisp(ffi:memory-as location 'ffi:uchar offset)
 114    byte))
 115
 116
 117 (declaim
 118  (ftype (function (pointer &optional fixnum) int-16) ref-native-int-16)
 119  (inline ref-native-int-16))
 120 (defun ref-native-int-16 (location &optional (offset 0))
 121   #+(or cmu sbcl)(signed-sap-ref-16 location offset)
 122   #+clisp(ffi:memory-as location 'ffi:sint16 offset))
 123
 124 (declaim
 125  (ftype
 126   (function (uint-16 pointer &optional fixnum) int-16)
 127   (setf ref-native-int-16))
 128  (inline (setf ref-native-int-16)))
 129 (defun (setf ref-native-int-16) (value location &optional (offset 0))
 130   (setf
 131    #+(or cmu sbcl)(signed-sap-ref-16 location offset)
 132    #+clisp(ffi:memory-as location 'ffi:sint16 offset)
 133    value))
 134
 135 (declaim
 136  (ftype (function (pointer &optional fixnum) uint-16) ref-native-uint-16)
 137  (inline ref-native-uint-16))
 138 (defun ref-native-uint-16 (location &optional (offset 0))
 139   #+(or cmu sbcl)(sap-ref-16 location offset)
 140   #+clisp(ffi:memory-as location 'ffi:uint16 offset))
 141
 142 (declaim
 143  (ftype
 144   (function (uint-16 pointer &optional fixnum) uint-16)
 145   (setf ref-native-uint-16))
 146  (inline (setf ref-native-uint-16)))
 147 (defun (setf ref-native-uint-16) (value location &optional (offset 0))
 148   (setf
 149    #+(or cmu sbcl)(sap-ref-16 location offset)
 150    #+clisp(ffi:memory-as location 'ffi:uint16 offset)
 151    value))
 152
 153
 154 (declaim
 155  (ftype (function (pointer &optional fixnum) int-32) ref-native-int-32)
 156  (inline ref-native-int-32))
 157 (defun ref-native-int-32 (location &optional (offset 0))
 158   #+(or cmu sbcl)(signed-sap-ref-32 location offset)
 159   #+clisp(ffi:memory-as location 'ffi:sint32 offset))
 160
 161 (declaim
 162  (ftype (function (int-32 pointer &optional fixnum) int-32) (setf ref-native-int-32))
 163  (inline (setf ref-native-int-32)))
 164 (defun (setf ref-native-int-32) (value location &optional (offset 0))
 165   (setf
 166    #+(or cmu sbcl)(signed-sap-ref-32 location offset)
 167    #+clisp(ffi:memory-as location 'ffi:sint32 offset)
 168    value))
 169
 170 (declaim
 171  (ftype (function (pointer &optional fixnum) uint-32) ref-native-uint-32)
 172  (inline ref-native-uint-32))
 173 (defun ref-native-uint-32 (location &optional (offset 0))
 174   #+(or cmu sbcl)(sap-ref-32 location offset)
 175   #+clisp(ffi:memory-as location 'ffi:uint32 offset))
 176
 177 (declaim
 178  (ftype
 179   (function (uint-32 pointer &optional fixnum) uint-32)
 180   (setf ref-native-uint-32))
 181  (inline (setf ref-native-uint-32)))
 182 (defun (setf ref-native-uint-32) (value location &optional (offset 0))
 183   (setf
 184    #+(or cmu sbcl)(sap-ref-32 location offset)
 185    #+clisp(ffi:memory-as location 'ffi:uint32 offset)
 186    value))
 187
 188
 189 (declaim
 190  (ftype (function (pointer &optional fixnum) int-64) ref-native-int-64)
 191  (inline ref-native-int-64))
 192 (defun ref-native-int-64 (location &optional (offset 0))
 193   #+(or cmu sbcl)(signed-sap-ref-64 location offset)
 194   #+clisp(ffi:memory-as location 'ffi:sint64 offset))
 195
 196 (declaim
 197  (ftype (function (int-64 pointer &optional fixnum) int-64) (setf ref-native-int-64))
 198  (inline (setf ref-native-int-64)))
 199 (defun (setf ref-native-int-64) (value location &optional (offset 0))
 200   (setf
 201    #+(or cmu sbcl)(signed-sap-ref-64 location offset)
 202    #+clisp(ffi:memory-as location 'ffi:sint64 offset)
 203    value))
 204
 205 (declaim
 206  (ftype (function (pointer &optional fixnum) uint-64) ref-native-uint-64)
 207  (inline ref-native-uint-64))
 208 (defun ref-native-uint-64 (location &optional (offset 0))
 209   #+(or cmu sbcl)(sap-ref-64 location offset)
 210   #+clisp(ffi:memory-as location 'ffi:uint64 offset))
 211
 212 (declaim
 213  (ftype
 214   (function (uint-64 pointer &optional fixnum) uint-64)
 215   (setf ref-native-uint-64))
 216  (inline (setf ref-native-uint-64)))
 217 (defun (setf ref-native-uint-64) (value location &optional (offset 0))
 218   (setf
 219    #+(or cmu sbcl)(sap-ref-64 location offset)
 220    #+clisp(ffi:memory-as location 'ffi:uint64 offset)
 221    value))
 222
 223
 224 (declaim
 225  (ftype (function (pointer &optional fixnum) single-float) ref-native-single-float)
 226  (inline ref-native-single-float))
 227 (defun ref-native-single-float (location &optional (offset 0))
 228   #+(or cmu sbcl)(sap-ref-single location offset)
 229   #+clisp(ffi:memory-as location 'single-float offset))
 230
 231 (declaim
 232  (ftype
 233   (function (single-float pointer &optional fixnum) single-float)
 234   (setf ref-native-single-float))
 235  (inline (setf ref-native-single-float)))
 236 (defun (setf ref-native-single-float) (value location &optional (offset 0))
 237   (setf
 238    #+(or cmu sbcl)(sap-ref-single location offset)
 239    #+clisp(ffi:memory-as location 'single-float offset)
 240    value))
 241
 242 (declaim
 243  (ftype (function (pointer &optional fixnum) double-float) ref-native-double-float)
 244  (inline ref-native-double-float))
 245 (defun ref-native-double-float (location &optional (offset 0))
 246   #+(or cmu sbcl)(sap-ref-double location offset)
 247   #+clisp(ffi:memory-as location 'double-float offset))
 248
 249 (declaim
 250  (ftype
 251   (function (double-float pointer &optional fixnum) double-float)
 252   (setf ref-native-double-float))
 253  (inline (setf ref-native-double-float)))
 254 (defun (setf ref-native-double-float) (value location &optional (offset 0))
 255   (setf
 256    #+(or cmu sbcl)(sap-ref-double location offset)
 257    #+clisp(ffi:memory-as location 'double-float offset)
 258    value))
 259
 260
 261 (defparameter *memory-allocator* nil)
 262 (defparameter *memory-deallocator* nil)
 263
 264 (defun allocate-memory (size)
 265   (if *memory-allocator*
 266       (funcall *memory-allocator* size)
 267     (error "Memory allocator not set")))
 268
 269 (defun deallocate-memory (location)
 270   (if *memory-deallocator*
 271       (funcall *memory-deallocator* location)
 272     (warn "Memory deallocator not set")))
 273
 274 (defun copy-memory (from length &optional (to (allocate-memory length)))
 275   #+cmu(system-area-copy from 0 to 0 (* 8 length))
 276   #+sbcl(system-area-ub8-copy from 0 to 0 length)
 277   #-(or cmu sbcl)
 278   (loop
 279    for offset below length
 280    do (setf (ref-uint-8 to offset) (ref-uint-8 from offset)))
 281   to)
 282
 283 (defun clear-memory (from length &optional (offset 0))
 284   #+sbcl(system-area-ub8-fill 0 from offset length)
 285   #-sbcl
 286   (loop
 287    repeat length
 288    for byte-offset from offset
 289    do (setf (ref-uint-8 from byte-offset) 0)))
 290
 291 (defun memory-clear-p (from length &optional (offset 0))
 292   (loop
 293    repeat length
 294    for byte-offset from offset
 295    unless (zerop (ref-uint-8 from byte-offset))
 296    do (return-from memory-clear-p nil))
 297   t)
 298
 299 (defmacro with-memory ((var size) &body body)
 300   #-clisp
 301   (if (and #+(or cmu sbcl)t (constantp size))
 302       (let ((memory (make-symbol "MEMORY"))
 303             (size (eval size)))
 304         `(with-alien ((,memory (array #+sbcl(sb-alien:unsigned 8) #+cmu(alien:unsigned 8) ,size)))
 305            (let ((,var (alien-sap ,memory)))
 306              (clear-memory ,var ,size)
 307              ,@body)))
 308     `(let ((,var (allocate-memory ,size)))
 309        (unwind-protect
 310            (progn ,@body)
 311          (deallocate-memory ,var))))
 312   #+clisp
 313   (let ((memory (make-symbol "MEMORY")))
 314     `(ffi:with-foreign-object (,memory `(ffi:c-array ffi:uint8 ,,size))
 315        (let ((,var (ffi:foreign-address ,memory)))
 316          ,@body))))
 317
 318 (defmacro with-pointer ((var &optional (pointer '(make-pointer 0))) &body body)
 319   "Binds POINTER to VAR in a way which makes it possible to pass the location of VAR to in foreign function call."
 320   #+(or cmu sbcl)
 321   `(with-alien ((,var system-area-pointer ,pointer))
 322      ,@body)
 323   #+clisp
 324   `(ffi:with-c-var (,var `ffi:c-pointer ,pointer)
 325      ,@body))
 326
 327
 328 #+sbcl
 329 (progn
 330   (defun sb-sizeof-bits (type)
 331     (sb-alien-internals:alien-type-bits
 332      (sb-alien-internals:parse-alien-type type nil)))
 333
 334   (defun sb-sizeof (type)
 335     (/ (sb-sizeof-bits type) 8))
 336
 337   (defun sb-alignment (type)
 338     (/ (sb-alien-internals:alien-type-alignment
 339         (sb-alien-internals:parse-alien-type type nil))
 340        8)))
 341
 342
 343 (deftype endian () '(member :native :little :big))
 344
 345 (defmacro define-memory-accessor (type)
 346   (let* ((get-swapped (intern (format nil "GET-~A-SWAPPED" type)))
 347          (set-swapped (intern (format nil "SET-~A-SWAPPED" type)))
 348          (ref (intern (format nil "REF-~A" type)))
 349          (ref-native (intern (format nil "REF-NATIVE-~A" type))))
 350     `(progn
 351        (declaim (inline ,get-swapped) (inline ,set-swapped))
 352        (defbinding ,get-swapped () ,type
 353          (location pointer)
 354          (offset int))
 355        (defbinding ,set-swapped () nil
 356          (location pointer)
 357          (offset int)
 358          (value ,type))
 359        (declaim
 360         (ftype (function (pointer &optional fixnum endian) ,type) ,ref)
 361         (inline ,ref))
 362        (defun ,ref (location &optional offset (endian :native))
 363          (ecase endian
 364            ((:native #-big-endian :little #+big-endian :big)
 365             (,ref-native location offset))
 366            ((#-big-endian :big #+big-endian :little)
 367             (,get-swapped location offset))))
 368        (declaim
 369         (ftype
 370          (function (,type pointer &optional fixnum endian) ,type)
 371          (setf ,ref))
 372         (inline (setf ,ref)))
 373        (defun (setf ,ref) (value location &optional offset (endian :native))
 374          (ecase endian
 375            ((:native #-big-endian :little #+big-endian :big)
 376             (setf (,ref-native location offset) value))
 377            ((#-big-endian :big #+big-endian :little)
 378             (,set-swapped location offset value)
 379             value))))))