| 1 | ;; Common Lisp bindings for GTK+ v2.0 |
| 2 | ;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no> |
| 3 | ;; |
| 4 | ;; This library is free software; you can redistribute it and/or |
| 5 | ;; modify it under the terms of the GNU Lesser General Public |
| 6 | ;; License as published by the Free Software Foundation; either |
| 7 | ;; version 2 of the License, or (at your option) any later version. |
| 8 | ;; |
| 9 | ;; This library is distributed in the hope that it will be useful, |
| 10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 12 | ;; Lesser General Public License for more details. |
| 13 | ;; |
| 14 | ;; You should have received a copy of the GNU Lesser General Public |
| 15 | ;; License along with this library; if not, write to the Free Software |
| 16 | ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
| 17 | |
| 18 | ;; $Id: gforeign.lisp,v 1.5 2000/10/01 17:19:11 espen Exp $ |
| 19 | |
| 20 | (in-package "GLIB") |
| 21 | |
| 22 | ;;;; Type methods |
| 23 | |
| 24 | (defvar *type-methods* (make-hash-table)) |
| 25 | |
| 26 | (defun ensure-type-method-fun (fname) |
| 27 | (unless (fboundp fname) |
| 28 | (setf |
| 29 | (symbol-function fname) |
| 30 | #'(lambda (type-spec &rest args) |
| 31 | (apply |
| 32 | (find-applicable-type-method type-spec fname) type-spec args))))) |
| 33 | |
| 34 | (defmacro define-type-method-fun (fname lambda-list) |
| 35 | (declare (ignore lambda-list)) |
| 36 | `(defun ,fname (type-spec &rest args) |
| 37 | (apply |
| 38 | (find-applicable-type-method type-spec ',fname) type-spec args))) |
| 39 | |
| 40 | |
| 41 | (defun ensure-type-name (type) |
| 42 | (etypecase type |
| 43 | (symbol type) |
| 44 | (pcl::class (class-name type)))) |
| 45 | |
| 46 | (defun add-type-method (type fname function) |
| 47 | (push |
| 48 | (cons fname function) |
| 49 | (gethash (ensure-type-name type) *type-methods*))) |
| 50 | |
| 51 | (defun find-type-method (type fname) |
| 52 | (cdr (assoc fname (gethash (ensure-type-name type) *type-methods*)))) |
| 53 | |
| 54 | (defun find-applicable-type-method (type-spec fname &optional (error t)) |
| 55 | (flet ((find-superclass-method (class) |
| 56 | (when class |
| 57 | (dolist (super (cdr (pcl::class-precedence-list class))) |
| 58 | (return-if (find-type-method super fname))))) |
| 59 | (find-expanded-type-method (type-spec) |
| 60 | (multiple-value-bind (expanded-type-spec expanded-p) |
| 61 | (type-expand-1 type-spec) |
| 62 | (cond |
| 63 | (expanded-p |
| 64 | (find-applicable-type-method expanded-type-spec fname nil)) |
| 65 | ((neq type-spec t) |
| 66 | (find-applicable-type-method t fname nil)))))) |
| 67 | |
| 68 | (or |
| 69 | (typecase type-spec |
| 70 | (pcl::class |
| 71 | (or |
| 72 | (find-type-method type-spec fname) |
| 73 | (find-superclass-method type-spec))) |
| 74 | (symbol |
| 75 | (or |
| 76 | (find-type-method type-spec fname) |
| 77 | (find-expanded-type-method type-spec) |
| 78 | (find-superclass-method (find-class type-spec nil)))) |
| 79 | (cons |
| 80 | (or |
| 81 | (find-type-method (first type-spec) fname) |
| 82 | (find-expanded-type-method type-spec))) |
| 83 | (t |
| 84 | (error "Invalid type specifier ~A" type-spec))) |
| 85 | (and |
| 86 | error |
| 87 | (error |
| 88 | "No applicable method for ~A when called with type specifier ~A" |
| 89 | fname type-spec))))) |
| 90 | |
| 91 | (defmacro deftype-method (fname type lambda-list &body body) |
| 92 | `(progn |
| 93 | (ensure-type-method-fun ',fname) |
| 94 | (add-type-method ',type ',fname #'(lambda ,lambda-list ,@body)) |
| 95 | ',fname)) |
| 96 | |
| 97 | (defmacro deftype (name parameters &body body) |
| 98 | (destructuring-bind (lisp-name &optional alien-name) (mklist name) |
| 99 | `(progn |
| 100 | ,(when alien-name |
| 101 | `(setf (alien-type-name ',lisp-name) ,alien-name)) |
| 102 | (lisp:deftype ,lisp-name ,parameters ,@body)))) |
| 103 | |
| 104 | ;; To make the compiler shut up |
| 105 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 106 | (define-type-method-fun translate-type-spec (type-spec)) |
| 107 | (define-type-method-fun size-of (type-spec)) |
| 108 | (define-type-method-fun translate-to-alien (type-spec expr &optional copy)) |
| 109 | (define-type-method-fun translate-from-alien (type-spec expr &optional alloc)) |
| 110 | (define-type-method-fun cleanup-alien (type-spec alien &optional copied))) |
| 111 | |
| 112 | |
| 113 | ;;;; |
| 114 | |
| 115 | (defvar *type-function-cache* (make-hash-table :test #'equal)) |
| 116 | |
| 117 | (defun get-cached-function (type-spec fname) |
| 118 | (cdr (assoc fname (gethash type-spec *type-function-cache*)))) |
| 119 | |
| 120 | (defun set-cached-function (type-spec fname function) |
| 121 | (push (cons fname function) (gethash type-spec *type-function-cache*)) |
| 122 | function) |
| 123 | |
| 124 | |
| 125 | ;; Creates a function to translate an object of the specified type |
| 126 | ;; from lisp to alien representation. |
| 127 | (defun get-to-alien-function (type-spec) |
| 128 | (or |
| 129 | (get-cached-function type-spec 'to-alien-function) |
| 130 | (set-cached-function type-spec 'to-alien-function |
| 131 | (compile |
| 132 | nil |
| 133 | `(lambda (object) |
| 134 | (declare (ignorable object)) |
| 135 | ,(translate-to-alien type-spec 'object)))))) |
| 136 | |
| 137 | ;; and the opposite |
| 138 | (defun get-from-alien-function (type-spec) |
| 139 | (or |
| 140 | (get-cached-function type-spec 'from-alien-function) |
| 141 | (set-cached-function type-spec 'from-alien-function |
| 142 | (compile |
| 143 | nil |
| 144 | `(lambda (alien) |
| 145 | (declare (ignorable alien)) |
| 146 | ,(translate-from-alien type-spec 'alien)))))) |
| 147 | |
| 148 | ;; and for cleaning up |
| 149 | (defun get-cleanup-function (type-spec) |
| 150 | (or |
| 151 | (get-cached-function type-spec 'cleanup-function) |
| 152 | (set-cached-function type-spec 'cleanup-function |
| 153 | (compile |
| 154 | nil |
| 155 | `(lambda (alien) |
| 156 | (declare (ignorable alien)) |
| 157 | ,(cleanup-alien type-spec 'alien)))))) |
| 158 | |
| 159 | |
| 160 | |
| 161 | ;; Creates a function to write an object of the specified type |
| 162 | ;; to the given memory location |
| 163 | (defun get-writer-function (type-spec) |
| 164 | (or |
| 165 | (get-cached-function type-spec 'writer-function) |
| 166 | (set-cached-function type-spec 'writer-function |
| 167 | (compile |
| 168 | nil |
| 169 | `(lambda (value sap offset) |
| 170 | (declare (ignorable value sap offset)) |
| 171 | (setf |
| 172 | (,(sap-ref-fname type-spec) sap offset) |
| 173 | ,(translate-to-alien type-spec 'value :copy))))))) |
| 174 | |
| 175 | ;; Creates a function to read an object of the specified type |
| 176 | ;; from the given memory location |
| 177 | (defun get-reader-function (type-spec) |
| 178 | (or |
| 179 | (get-cached-function type-spec 'reader-function) |
| 180 | (set-cached-function type-spec 'reader-function |
| 181 | (compile |
| 182 | nil |
| 183 | `(lambda (sap offset) |
| 184 | (declare (ignorable sap offset)) |
| 185 | ,(translate-from-alien |
| 186 | type-spec `(,(sap-ref-fname type-spec) sap offset) :reference)))))) |
| 187 | |
| 188 | |
| 189 | (defun get-destroy-function (type-spec) |
| 190 | (or |
| 191 | (get-cached-function type-spec 'destroy-function) |
| 192 | (set-cached-function type-spec 'destroy-function |
| 193 | (compile |
| 194 | nil |
| 195 | `(lambda (sap offset) |
| 196 | (declare (ignorable sap offset)) |
| 197 | ,(cleanup-alien |
| 198 | type-spec `(,(sap-ref-fname type-spec) sap offset) :copied)))))) |
| 199 | |
| 200 | |
| 201 | |
| 202 | ;;;; |
| 203 | |
| 204 | (defconstant +bits-per-unit+ 8 |
| 205 | "Number of bits in an addressable unit (byte)") |
| 206 | |
| 207 | ;; Sizes of fundamental C types in addressable units |
| 208 | (defconstant +size-of-short+ 2) |
| 209 | (defconstant +size-of-int+ 4) |
| 210 | (defconstant +size-of-long+ 4) |
| 211 | (defconstant +size-of-sap+ 4) |
| 212 | (defconstant +size-of-float+ 4) |
| 213 | (defconstant +size-of-double+ 8) |
| 214 | |
| 215 | (defun sap-ref-unsigned (sap offset) |
| 216 | (sap-ref-32 sap offset)) |
| 217 | |
| 218 | (defun sap-ref-signed (sap offset) |
| 219 | (signed-sap-ref-32 sap offset)) |
| 220 | |
| 221 | (defun sap-ref-fname (type-spec) |
| 222 | (let ((alien-type-spec (mklist (translate-type-spec type-spec)))) |
| 223 | (ecase (first alien-type-spec) |
| 224 | (unsigned |
| 225 | (ecase (second alien-type-spec) |
| 226 | (8 'sap-ref-8) |
| 227 | (16 'sap-ref-16) |
| 228 | (32 'sap-ref-32) |
| 229 | (64 'sap-ref-64))) |
| 230 | (signed |
| 231 | (ecase (second alien-type-spec) |
| 232 | (8 'signed-sap-ref-8) |
| 233 | (16 'signed-sap-ref-16) |
| 234 | (32 'signed-sap-ref-32) |
| 235 | (64 'signed-sap-ref-64))) |
| 236 | (system-area-pointer 'sap-ref-sap) |
| 237 | (single-float 'sap-ref-single) |
| 238 | (double-float 'sap-ref-double)))) |
| 239 | |
| 240 | |
| 241 | ;;;; Foreign function call interface |
| 242 | |
| 243 | (defvar *package-prefix* nil) |
| 244 | |
| 245 | (defun set-package-prefix (prefix &optional (package *package*)) |
| 246 | (let ((package (find-package package))) |
| 247 | (delete-if #'(lambda (assoc) (eq (car assoc) package)) *package-prefix*) |
| 248 | (push (cons package prefix) *package-prefix*)) |
| 249 | prefix) |
| 250 | |
| 251 | (defun package-prefix (&optional (package *package*)) |
| 252 | (let ((package (find-package package))) |
| 253 | (or |
| 254 | (cdr (assoc package *package-prefix*)) |
| 255 | (substitute #\_ #\- (string-downcase (package-name package)))))) |
| 256 | |
| 257 | (defmacro use-prefix (prefix &optional (package *package*)) |
| 258 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
| 259 | (set-package-prefix ,prefix ,package))) |
| 260 | |
| 261 | |
| 262 | (defun default-alien-func-name (lisp-name) |
| 263 | (let* ((lisp-name-string |
| 264 | (if (char= (char (the simple-string (string lisp-name)) 0) #\%) |
| 265 | (subseq (the simple-string (string lisp-name)) 1) |
| 266 | (string lisp-name))) |
| 267 | (prefix (package-prefix *package*)) |
| 268 | (name (substitute #\_ #\- (string-downcase lisp-name-string)))) |
| 269 | (if (or (not prefix) (string= prefix "")) |
| 270 | name |
| 271 | (format nil "~A_~A" prefix name)))) |
| 272 | |
| 273 | |
| 274 | (defmacro define-foreign (name lambda-list return-type-spec &rest docs/args) |
| 275 | (multiple-value-bind (c-name lisp-name) |
| 276 | (if (atom name) |
| 277 | (values (default-alien-func-name name) name) |
| 278 | (values-list name)) |
| 279 | (let ((supplied-lambda-list lambda-list) |
| 280 | (docs nil) |
| 281 | (args nil)) |
| 282 | (dolist (doc/arg docs/args) |
| 283 | (if (stringp doc/arg) |
| 284 | (push doc/arg docs) |
| 285 | (progn |
| 286 | (destructuring-bind (expr type &optional (style :in)) doc/arg |
| 287 | (unless (member style '(:in :out :in-out)) |
| 288 | (error "Bogus argument style ~S in ~S." style doc/arg)) |
| 289 | (when (and |
| 290 | (not supplied-lambda-list) |
| 291 | (namep expr) (member style '(:in :in-out))) |
| 292 | (push expr lambda-list)) |
| 293 | (push |
| 294 | (list (if (namep expr) expr (gensym)) expr type style) args))))) |
| 295 | |
| 296 | (%define-foreign |
| 297 | c-name lisp-name (or supplied-lambda-list (nreverse lambda-list)) |
| 298 | return-type-spec (reverse docs) (reverse args))))) |
| 299 | |
| 300 | |
| 301 | #+cmu |
| 302 | (defun %define-foreign (foreign-name lisp-name lambda-list |
| 303 | return-type-spec docs args) |
| 304 | (ext:collect ((alien-types) (alien-bindings) (alien-parameters) |
| 305 | (alien-values) (alien-deallocators)) |
| 306 | (dolist (arg args) |
| 307 | (destructuring-bind (var expr type-spec style) arg |
| 308 | (let ((declaration (translate-type-spec type-spec)) |
| 309 | (deallocation (cleanup-alien type-spec expr))) |
| 310 | (cond |
| 311 | ((member style '(:out :in-out)) |
| 312 | (alien-types `(* ,declaration)) |
| 313 | (alien-parameters `(addr ,var)) |
| 314 | (alien-bindings |
| 315 | `(,var ,declaration |
| 316 | ,@(when (eq style :in-out) |
| 317 | (list (translate-to-alien type-spec expr))))) |
| 318 | (alien-values (translate-from-alien type-spec var))) |
| 319 | (deallocation |
| 320 | (alien-types declaration) |
| 321 | (alien-bindings |
| 322 | `(,var ,declaration ,(translate-to-alien type-spec expr))) |
| 323 | (alien-parameters var) |
| 324 | (alien-deallocators deallocation)) |
| 325 | (t |
| 326 | (alien-types declaration) |
| 327 | (alien-parameters (translate-to-alien type-spec expr))))))) |
| 328 | |
| 329 | (let ((alien-funcall `(alien-funcall ,lisp-name ,@(alien-parameters)))) |
| 330 | `(defun ,lisp-name ,lambda-list |
| 331 | ,@docs |
| 332 | (with-alien ((,lisp-name |
| 333 | (function |
| 334 | ,(translate-type-spec return-type-spec) |
| 335 | ,@(alien-types)) |
| 336 | :extern ,foreign-name) |
| 337 | ,@(alien-bindings)) |
| 338 | ,(if return-type-spec |
| 339 | `(let ((result |
| 340 | ,(translate-from-alien return-type-spec alien-funcall))) |
| 341 | ,@(alien-deallocators) |
| 342 | (values result ,@(alien-values))) |
| 343 | `(progn |
| 344 | ,alien-funcall |
| 345 | ,@(alien-deallocators) |
| 346 | (values ,@(alien-values))))))))) |
| 347 | |
| 348 | |
| 349 | |
| 350 | |
| 351 | ;;;; Definitons and translations of fundamental types |
| 352 | |
| 353 | (lisp:deftype long (&optional (min '*) (max '*)) `(integer ,min ,max)) |
| 354 | (lisp:deftype unsigned-long (&optional (min '*) (max '*)) `(integer ,min ,max)) |
| 355 | (lisp:deftype int (&optional (min '*) (max '*)) `(long ,min ,max)) |
| 356 | (lisp:deftype unsigned-int (&optional (min '*) (max '*)) `(unsigned-long ,min ,max)) |
| 357 | (lisp:deftype short (&optional (min '*) (max '*)) `(int ,min ,max)) |
| 358 | (lisp:deftype unsigned-short (&optional (min '*) (max '*)) `(unsigned-int ,min ,max)) |
| 359 | (lisp:deftype signed (&optional (size '*)) `(signed-byte ,size)) |
| 360 | (lisp:deftype unsigned (&optional (size '*)) `(signed-byte ,size)) |
| 361 | (lisp:deftype char () 'base-char) |
| 362 | (lisp:deftype pointer () 'system-area-pointer) |
| 363 | (lisp:deftype boolean (&optional (size '*)) |
| 364 | (declare (ignore size)) |
| 365 | `(member t nil)) |
| 366 | (lisp:deftype static (type) type) |
| 367 | (lisp:deftype invalid () nil) |
| 368 | |
| 369 | |
| 370 | |
| 371 | (deftype-method cleanup-alien t (type-spec alien &optional copied) |
| 372 | (declare (ignore type-spec alien copied)) |
| 373 | nil) |
| 374 | |
| 375 | |
| 376 | (deftype-method translate-to-alien integer (type-spec number &optional copy) |
| 377 | (declare (ignore type-spec copy)) |
| 378 | number) |
| 379 | |
| 380 | (deftype-method translate-from-alien integer (type-spec number &optional alloc) |
| 381 | (declare (ignore type-spec alloc)) |
| 382 | number) |
| 383 | |
| 384 | |
| 385 | (deftype-method translate-type-spec fixnum (type-spec) |
| 386 | (declare (ignore type-spec)) |
| 387 | (translate-type-spec 'signed)) |
| 388 | |
| 389 | (deftype-method size-of fixnum (type-spec) |
| 390 | (declare (ignore type-spec)) |
| 391 | (size-of 'signed)) |
| 392 | |
| 393 | (deftype-method translate-to-alien fixnum (type-spec number &optional copy) |
| 394 | (declare (ignore type-spec copy)) |
| 395 | number) |
| 396 | |
| 397 | (deftype-method translate-from-alien fixnum (type-spec number &optional alloc) |
| 398 | (declare (ignore type-spec alloc)) |
| 399 | number) |
| 400 | |
| 401 | |
| 402 | (deftype-method translate-type-spec long (type-spec) |
| 403 | (declare (ignore type-spec)) |
| 404 | `(signed ,(* +bits-per-unit+ +size-of-long+))) |
| 405 | |
| 406 | (deftype-method size-of long (type-spec) |
| 407 | (declare (ignore type-spec)) |
| 408 | +size-of-long+) |
| 409 | |
| 410 | |
| 411 | (deftype-method translate-type-spec unsigned-long (type-spec) |
| 412 | (declare (ignore type-spec)) |
| 413 | `(unsigned ,(* +bits-per-unit+ +size-of-long+))) |
| 414 | |
| 415 | (deftype-method size-of unsigned-long (type-spec) |
| 416 | (declare (ignore type-spec)) |
| 417 | +size-of-long+) |
| 418 | |
| 419 | |
| 420 | (deftype-method translate-type-spec int (type-spec) |
| 421 | (declare (ignore type-spec)) |
| 422 | `(signed ,(* +bits-per-unit+ +size-of-int+))) |
| 423 | |
| 424 | (deftype-method size-of int (type-spec) |
| 425 | (declare (ignore type-spec)) |
| 426 | +size-of-int+) |
| 427 | |
| 428 | |
| 429 | (deftype-method translate-type-spec unsigned-int (type-spec) |
| 430 | (declare (ignore type-spec)) |
| 431 | `(signed ,(* +bits-per-unit+ +size-of-int+))) |
| 432 | |
| 433 | (deftype-method size-of unsigned-int (type-spec) |
| 434 | (declare (ignore type-spec)) |
| 435 | +size-of-int+) |
| 436 | |
| 437 | |
| 438 | (deftype-method translate-type-spec short (type-spec) |
| 439 | (declare (ignore type-spec)) |
| 440 | `(signed ,(* +bits-per-unit+ +size-of-short+))) |
| 441 | |
| 442 | (deftype-method size-of short (type-spec) |
| 443 | (declare (ignore type-spec)) |
| 444 | +size-of-short+) |
| 445 | |
| 446 | |
| 447 | (deftype-method translate-type-spec unsigned-short (type-spec) |
| 448 | (declare (ignore type-spec)) |
| 449 | `(unsigned ,(* +bits-per-unit+ +size-of-short+))) |
| 450 | |
| 451 | (deftype-method size-of unsigned-short (type-spec) |
| 452 | (declare (ignore type-spec)) |
| 453 | +size-of-short+) |
| 454 | |
| 455 | |
| 456 | (deftype-method translate-type-spec signed-byte (type-spec) |
| 457 | (let ((size (second (mklist (type-expand-to 'signed-byte type-spec))))) |
| 458 | `(signed |
| 459 | ,(cond |
| 460 | ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+)) |
| 461 | (t size))))) |
| 462 | |
| 463 | (deftype-method size-of signed-byte (type-spec) |
| 464 | (let ((size (second (mklist (type-expand-to 'signed-byte type-spec))))) |
| 465 | (cond |
| 466 | ((member size '(nil *)) +size-of-int+) |
| 467 | (t (/ size +bits-per-unit+))))) |
| 468 | |
| 469 | (deftype-method translate-to-alien signed-byte (type-spec number &optional copy) |
| 470 | (declare (ignore type-spec copy)) |
| 471 | number) |
| 472 | |
| 473 | (deftype-method translate-from-alien signed-byte |
| 474 | (type-spec number &optional alloc) |
| 475 | (declare (ignore type-spec alloc)) |
| 476 | number) |
| 477 | |
| 478 | |
| 479 | (deftype-method translate-type-spec unsigned-byte (type-spec) |
| 480 | (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec))))) |
| 481 | `(signed |
| 482 | ,(cond |
| 483 | ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+)) |
| 484 | (t size))))) |
| 485 | |
| 486 | (deftype-method size-of unsigned-byte (type-spec) |
| 487 | (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec))))) |
| 488 | (cond |
| 489 | ((member size '(nil *)) +size-of-int+) |
| 490 | (t (/ size +bits-per-unit+))))) |
| 491 | |
| 492 | (deftype-method translate-to-alien unsigned-byte |
| 493 | (type-spec number &optional copy) |
| 494 | (declare (ignore type-spec copy)) |
| 495 | number) |
| 496 | |
| 497 | (deftype-method translate-from-alien unsigned-byte |
| 498 | (type-spec number &optional alloc) |
| 499 | (declare (ignore type-spec alloc)) |
| 500 | number) |
| 501 | |
| 502 | |
| 503 | (deftype-method translate-type-spec single-float (type-spec) |
| 504 | (declare (ignore type-spec)) |
| 505 | 'single-float) |
| 506 | |
| 507 | (deftype-method size-of single-float (type-spec) |
| 508 | (declare (ignore type-spec)) |
| 509 | +size-of-float+) |
| 510 | |
| 511 | (deftype-method translate-to-alien single-float |
| 512 | (type-spec number &optional copy) |
| 513 | (declare (ignore type-spec copy)) |
| 514 | number) |
| 515 | |
| 516 | (deftype-method translate-from-alien single-float |
| 517 | (type-spec number &optional alloc) |
| 518 | (declare (ignore type-spec alloc)) |
| 519 | number) |
| 520 | |
| 521 | |
| 522 | (deftype-method translate-type-spec double-float (type-spec) |
| 523 | (declare (ignore type-spec)) |
| 524 | 'double-float) |
| 525 | |
| 526 | (deftype-method size-of double-float (type-spec) |
| 527 | (declare (ignore type-spec)) |
| 528 | +size-of-double+) |
| 529 | |
| 530 | (deftype-method translate-to-alien double-float |
| 531 | (type-spec number &optional copy) |
| 532 | (declare (ignore type-spec copy)) |
| 533 | number) |
| 534 | |
| 535 | (deftype-method translate-from-alien double-float |
| 536 | (type-spec number &optional alloc) |
| 537 | (declare (ignore type-spec alloc)) |
| 538 | number) |
| 539 | |
| 540 | |
| 541 | (deftype-method translate-type-spec base-char (type-spec) |
| 542 | (declare (ignore type-spec)) |
| 543 | '(unsigned +bits-per-unit+)) |
| 544 | |
| 545 | (deftype-method size-of base-char (type-spec) |
| 546 | (declare (ignore type-spec)) |
| 547 | 1) |
| 548 | |
| 549 | (deftype-method translate-to-alien base-char (type-spec char &optional copy) |
| 550 | (declare (ignore type-spec copy)) |
| 551 | `(char-code ,char)) |
| 552 | |
| 553 | (deftype-method translate-from-alien base-char (type-spec code &optional alloc) |
| 554 | (declare (ignore type-spec alloc)) |
| 555 | `(code-char ,code)) |
| 556 | |
| 557 | |
| 558 | (deftype-method translate-type-spec string (type-spec) |
| 559 | (declare (ignore type-spec)) |
| 560 | 'system-area-pointer) |
| 561 | |
| 562 | (deftype-method size-of string (type-spec) |
| 563 | (declare (ignore type-spec)) |
| 564 | +size-of-sap+) |
| 565 | |
| 566 | (deftype-method translate-to-alien string (type-spec string &optional copy) |
| 567 | (declare (ignore type-spec)) |
| 568 | (if copy |
| 569 | `(let ((string ,string)) |
| 570 | (copy-memory |
| 571 | (make-pointer (1+ (kernel:get-lisp-obj-address string))) |
| 572 | (1+ (length string)))) |
| 573 | `(make-pointer (1+ (kernel:get-lisp-obj-address ,string))))) |
| 574 | |
| 575 | (deftype-method translate-from-alien string |
| 576 | (type-spec sap &optional (alloc :copy)) |
| 577 | (declare (ignore type-spec)) |
| 578 | `(let ((sap ,sap)) |
| 579 | (unless (null-pointer-p sap) |
| 580 | (prog1 |
| 581 | (c-call::%naturalize-c-string sap) |
| 582 | ;,(when (eq alloc :copy) `(deallocate-memory ,sap)) |
| 583 | )))) |
| 584 | |
| 585 | (deftype-method cleanup-alien string (type-spec sap &optional copied) |
| 586 | (declare (ignore type-spec)) |
| 587 | (when copied |
| 588 | `(let ((sap ,sap)) |
| 589 | (unless (null-pointer-p sap) |
| 590 | (deallocate-memory sap))))) |
| 591 | |
| 592 | |
| 593 | (deftype-method translate-type-spec boolean (type-spec) |
| 594 | (translate-type-spec |
| 595 | (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec)))))) |
| 596 | |
| 597 | (deftype-method size-of boolean (type-spec) |
| 598 | (size-of |
| 599 | (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec)))))) |
| 600 | |
| 601 | (deftype-method translate-to-alien boolean (type-spec boolean &optional copy) |
| 602 | (declare (ignore type-spec copy)) |
| 603 | `(if ,boolean 1 0)) |
| 604 | |
| 605 | (deftype-method translate-from-alien boolean (type-spec int &optional alloc) |
| 606 | (declare (ignore type-spec alloc)) |
| 607 | `(not (zerop ,int))) |
| 608 | |
| 609 | |
| 610 | (deftype-method translate-type-spec or (union-type) |
| 611 | (let* ((member-types (cdr (type-expand-to 'or union-type))) |
| 612 | (alien-type (translate-type-spec (first member-types)))) |
| 613 | (dolist (type (cdr member-types)) |
| 614 | (unless (eq alien-type (translate-type-spec type)) |
| 615 | (error "No common alien type specifier for union type: ~A" union-type))) |
| 616 | alien-type)) |
| 617 | |
| 618 | (deftype-method size-of or (union-type) |
| 619 | (size-of (first (cdr (type-expand-to 'or union-type))))) |
| 620 | |
| 621 | (deftype-method translate-to-alien or (union-type-spec expr &optional copy) |
| 622 | (destructuring-bind (name &rest type-specs) |
| 623 | (type-expand-to 'or union-type-spec) |
| 624 | (declare (ignore name)) |
| 625 | `(let ((value ,expr)) |
| 626 | (etypecase value |
| 627 | ,@(map |
| 628 | 'list |
| 629 | #'(lambda (type-spec) |
| 630 | (list type-spec (translate-to-alien type-spec 'value copy))) |
| 631 | type-specs))))) |
| 632 | |
| 633 | |
| 634 | (deftype-method translate-type-spec system-area-pointer (type-spec) |
| 635 | (declare (ignore type-spec)) |
| 636 | 'system-area-pointer) |
| 637 | |
| 638 | (deftype-method size-of system-area-pointer (type-spec) |
| 639 | (declare (ignore type-spec)) |
| 640 | +size-of-sap+) |
| 641 | |
| 642 | (deftype-method translate-to-alien system-area-pointer |
| 643 | (type-spec sap &optional copy) |
| 644 | (declare (ignore type-spec copy)) |
| 645 | sap) |
| 646 | |
| 647 | (deftype-method translate-from-alien system-area-pointer |
| 648 | (type-spec sap &optional alloc) |
| 649 | (declare (ignore type-spec alloc)) |
| 650 | sap) |
| 651 | |
| 652 | |
| 653 | (deftype-method translate-type-spec null (type-spec) |
| 654 | (declare (ignore type-spec)) |
| 655 | 'system-area-pointer) |
| 656 | |
| 657 | (deftype-method translate-to-alien null (type-spec expr &optional copy) |
| 658 | (declare (ignore type-spec expr copy)) |
| 659 | `(make-pointer 0)) |
| 660 | |
| 661 | |
| 662 | (deftype-method translate-type-spec nil (type-spec) |
| 663 | (declare (ignore type-spec)) |
| 664 | 'void) |
| 665 | |
| 666 | |
| 667 | (deftype-method transalte-type-spec static (type-spec) |
| 668 | (translate-type-spec (second type-spec))) |
| 669 | |
| 670 | (deftype-method size-of static (type-spec) |
| 671 | (size-of type-spec)) |
| 672 | |
| 673 | (deftype-method translate-to-alien static (type-spec expr &optional copy) |
| 674 | (declare (ignore copy)) |
| 675 | (translate-to-alien (second type-spec) expr nil)) |
| 676 | |
| 677 | (deftype-method translate-from-alien static (type-spec alien &optional alloc) |
| 678 | (declare (ignore alloc)) |
| 679 | (translate-from-alien (second type-spec) alien nil)) |
| 680 | |
| 681 | (deftype-method cleanup-alien static (type-spec alien &optional copied) |
| 682 | (declare (ignore copied)) |
| 683 | (cleanup-alien type-spec alien nil)) |
| 684 | |
| 685 | |
| 686 | |
| 687 | ;;;; Enum and flags type |
| 688 | |
| 689 | (defun map-mappings (args op) |
| 690 | (let ((current-value 0)) |
| 691 | (map |
| 692 | 'list |
| 693 | #'(lambda (mapping) |
| 694 | (destructuring-bind (symbol &optional (value current-value)) |
| 695 | (mklist mapping) |
| 696 | (setf current-value (1+ value)) |
| 697 | (case op |
| 698 | (:enum-int (list symbol value)) |
| 699 | (:flags-int (list symbol (ash 1 value))) |
| 700 | (:int-enum (list value symbol)) |
| 701 | (:int-flags (list (ash 1 value) symbol)) |
| 702 | (:symbols symbol)))) |
| 703 | (if (integerp (first args)) |
| 704 | (rest args) |
| 705 | args)))) |
| 706 | |
| 707 | |
| 708 | (lisp:deftype enum (&rest args) |
| 709 | `(member ,@(map-mappings args :symbols))) |
| 710 | |
| 711 | (deftype-method translate-type-spec enum (type-spec) |
| 712 | (let ((args (cdr (type-expand-to 'enum type-spec)))) |
| 713 | (if (integerp (first args)) |
| 714 | (translate-type-spec `(signed ,(first args))) |
| 715 | (translate-type-spec 'signed)))) |
| 716 | |
| 717 | (deftype-method size-of enum (type-spec) |
| 718 | (let ((args (cdr (type-expand-to 'enum type-spec)))) |
| 719 | (if (integerp (first args)) |
| 720 | (size-of `(signed ,(first args))) |
| 721 | (size-of 'signed)))) |
| 722 | |
| 723 | (deftype-method translate-to-alien enum (type-spec expr &optional copy) |
| 724 | (declare (ignore copy)) |
| 725 | (let ((args (cdr (type-expand-to 'enum type-spec)))) |
| 726 | `(ecase ,expr |
| 727 | ,@(map-mappings args :enum-int)))) |
| 728 | |
| 729 | (deftype-method translate-from-alien enum (type-spec expr &optional alloc) |
| 730 | (declare (ignore alloc)) |
| 731 | (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec) |
| 732 | (declare (ignore name)) |
| 733 | `(ecase ,expr |
| 734 | ,@(map-mappings args :int-enum)))) |
| 735 | |
| 736 | |
| 737 | (lisp:deftype flags (&rest args) |
| 738 | `(or |
| 739 | null |
| 740 | (cons |
| 741 | (member ,@(map-mappings args :symbols)) |
| 742 | list))) |
| 743 | |
| 744 | (deftype-method translate-type-spec flags (type-spec) |
| 745 | (let ((args (cdr (type-expand-to 'flags type-spec)))) |
| 746 | (if (integerp (first args)) |
| 747 | (translate-type-spec `(signed ,(first args))) |
| 748 | (translate-type-spec 'signed)))) |
| 749 | |
| 750 | (deftype-method size-of flags (type-spec) |
| 751 | (let ((args (cdr (type-expand-to 'flags type-spec)))) |
| 752 | (if (integerp (first args)) |
| 753 | (size-of `(signed ,(first args))) |
| 754 | (size-of 'signed)))) |
| 755 | |
| 756 | (deftype-method translate-to-alien flags (type-spec expr &optional copy) |
| 757 | (declare (ignore copy)) |
| 758 | (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec) |
| 759 | (declare (ignore name)) |
| 760 | (let ((mappings (map-mappings args :flags-int)) |
| 761 | (value (make-symbol "VALUE"))) |
| 762 | `(let ((,value 0)) |
| 763 | (dolist (flag ,expr ,value) |
| 764 | (setq ,value (logior ,value (second (assoc flag ',mappings))))))))) |
| 765 | |
| 766 | (deftype-method translate-from-alien flags (type-spec expr &optional alloc) |
| 767 | (declare (ignore alloc)) |
| 768 | (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec) |
| 769 | (declare (ignore name)) |
| 770 | (let ((mappings (map-mappings args :int-flags)) |
| 771 | (result (make-symbol "RESULT"))) |
| 772 | `(let ((,result nil)) |
| 773 | (dolist (mapping ',mappings ,result) |
| 774 | (unless (zerop (logand ,expr (first mapping))) |
| 775 | (push (second mapping) ,result))))))) |