| 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.1 2000-08-14 16:44:38 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 translate-to-alien (type-spec expr &optional copy)) |
| 108 | (define-type-method-fun translate-from-alien (type-spec expr &optional alloc)) |
| 109 | (define-type-method-fun cleanup-alien (type-spec expr &optional copied))) |
| 110 | |
| 111 | |
| 112 | ;;;; |
| 113 | |
| 114 | (defvar *type-function-cache* (make-hash-table :test #'equal)) |
| 115 | |
| 116 | (defun get-cached-function (type-spec fname) |
| 117 | (cdr (assoc fname (gethash type-spec *type-function-cache*)))) |
| 118 | |
| 119 | (defun set-cached-function (type-spec fname function) |
| 120 | (push (cons fname function) (gethash type-spec *type-function-cache*)) |
| 121 | function) |
| 122 | |
| 123 | |
| 124 | ;; Creates a function to translate an object of the specified type |
| 125 | ;; from lisp to alien representation. |
| 126 | (defun get-to-alien-function (type-spec) |
| 127 | (or |
| 128 | (get-cached-function type-spec 'to-alien-function) |
| 129 | (set-cached-function type-spec 'to-alien-function |
| 130 | (compile |
| 131 | nil |
| 132 | `(lambda (object) |
| 133 | (declare (ignorable object)) |
| 134 | ,(translate-to-alien type-spec 'object)))))) |
| 135 | |
| 136 | ;; and the opposite |
| 137 | (defun get-from-alien-function (type-spec) |
| 138 | (or |
| 139 | (get-cached-function type-spec 'from-alien-function) |
| 140 | (set-cached-function type-spec 'from-alien-function |
| 141 | (compile |
| 142 | nil |
| 143 | `(lambda (alien) |
| 144 | (declare (ignorable alien)) |
| 145 | ,(translate-from-alien type-spec 'alien)))))) |
| 146 | |
| 147 | ;; and for cleaning up |
| 148 | (defun get-cleanup-function (type-spec) |
| 149 | (or |
| 150 | (get-cached-function type-spec 'cleanup-function) |
| 151 | (set-cached-function type-spec 'cleanup-function |
| 152 | (compile |
| 153 | nil |
| 154 | `(lambda (alien) |
| 155 | (declare (ignorable alien)) |
| 156 | ,(cleanup-alien type-spec 'alien)))))) |
| 157 | |
| 158 | |
| 159 | |
| 160 | ;; Creates a function to write an object of the specified type |
| 161 | ;; to the given memory location |
| 162 | (defun get-writer-function (type-spec) |
| 163 | (or |
| 164 | (get-cached-function type-spec 'writer-function) |
| 165 | (set-cached-function type-spec 'writer-function |
| 166 | (compile |
| 167 | nil |
| 168 | `(lambda (value sap offset) |
| 169 | (declare (ignorable value sap offset)) |
| 170 | (setf |
| 171 | (,(sap-ref-fname type-spec) sap offset) |
| 172 | ,(translate-to-alien type-spec 'value :copy))))))) |
| 173 | |
| 174 | ;; Creates a function to read an object of the specified type |
| 175 | ;; from the given memory location |
| 176 | (defun get-reader-function (type-spec) |
| 177 | (or |
| 178 | (get-cached-function type-spec 'reader-function) |
| 179 | (set-cached-function type-spec 'reader-function |
| 180 | (compile |
| 181 | nil |
| 182 | `(lambda (sap offset) |
| 183 | (declare (ignorable sap offset)) |
| 184 | ,(translate-from-alien |
| 185 | type-spec `(,(sap-ref-fname type-spec) sap offset) :copy)))))) |
| 186 | |
| 187 | |
| 188 | (defun get-destroy-function (type-spec) |
| 189 | (or |
| 190 | (get-cached-function type-spec 'destroy-function) |
| 191 | (set-cached-function type-spec 'destroy-function |
| 192 | (compile |
| 193 | nil |
| 194 | `(lambda (sap offset) |
| 195 | (declare (ignorable sap offset)) |
| 196 | ,(cleanup-alien |
| 197 | type-spec `(,(sap-ref-fname type-spec) sap offset) :copied)))))) |
| 198 | |
| 199 | |
| 200 | |
| 201 | ;;;; |
| 202 | |
| 203 | (defconstant +size-of-int+ 4) |
| 204 | (defconstant +size-of-sap+ 4) |
| 205 | (defconstant +size-of-float+ 4) |
| 206 | (defconstant +size-of-double+ 8) |
| 207 | |
| 208 | (defun sap-ref-unsigned (sap offset) |
| 209 | (sap-ref-32 sap offset)) |
| 210 | |
| 211 | (defun sap-ref-signed (sap offset) |
| 212 | (signed-sap-ref-32 sap offset)) |
| 213 | |
| 214 | (defun sap-ref-fname (type-spec) |
| 215 | (let ((alien-type-spec (mklist (translate-type-spec type-spec)))) |
| 216 | (ecase (first alien-type-spec) |
| 217 | (unsigned |
| 218 | (ecase (second alien-type-spec) |
| 219 | (8 'sap-ref-8) |
| 220 | (16 'sap-ref-16) |
| 221 | (32 'sap-ref-32) |
| 222 | (64 'sap-ref-64))) |
| 223 | (signed |
| 224 | (ecase (second alien-type-spec) |
| 225 | (8 'signed-sap-ref-8) |
| 226 | (16 'signed-sap-ref-16) |
| 227 | (32 'signed-sap-ref-32) |
| 228 | (64 'signed-sap-ref-64))) |
| 229 | (system-area-pointer 'sap-ref-sap) |
| 230 | (single-float 'sap-ref-single) |
| 231 | (double-float 'sap-ref-double)))) |
| 232 | |
| 233 | |
| 234 | (defun signed (size) |
| 235 | (if (eq size '*) |
| 236 | `(signed ,(* 8 +size-of-int+)) |
| 237 | `(signed ,size))) |
| 238 | |
| 239 | (defun unsigned (size) |
| 240 | (if (eq size '*) |
| 241 | `(unsigned ,(* 8 +size-of-int+)) |
| 242 | `(unsigned ,size))) |
| 243 | |
| 244 | (defun size-of (type-spec) |
| 245 | (let ((alien-type-spec (translate-type-spec type-spec))) |
| 246 | (ecase (first (mklist alien-type-spec)) |
| 247 | ((signed unsigned) (/ (second alien-type-spec) 8)) |
| 248 | ((system-area-pointer single-float) +size-of-sap+) |
| 249 | (single-float +size-of-float+) |
| 250 | (double-float +size-of-double+)))) |
| 251 | |
| 252 | |
| 253 | ;;;; Foreign function call interface |
| 254 | |
| 255 | (defvar *package-prefix* nil) |
| 256 | |
| 257 | (defun set-package-prefix (prefix &optional (package *package*)) |
| 258 | (let ((package (find-package package))) |
| 259 | (delete-if #'(lambda (assoc) (eq (car assoc) package)) *package-prefix*) |
| 260 | (push (cons package prefix) *package-prefix*)) |
| 261 | prefix) |
| 262 | |
| 263 | (defun package-prefix (&optional (package *package*)) |
| 264 | (let ((package (find-package package))) |
| 265 | (or |
| 266 | (cdr (assoc package *package-prefix*)) |
| 267 | (substitute #\_ #\- (string-downcase (package-name package)))))) |
| 268 | |
| 269 | (defmacro use-prefix (prefix &optional (package *package*)) |
| 270 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
| 271 | (set-package-prefix ,prefix ,package))) |
| 272 | |
| 273 | |
| 274 | (defun default-alien-func-name (lisp-name) |
| 275 | (let* ((lisp-name-string |
| 276 | (if (char= (char (the simple-string (string lisp-name)) 0) #\%) |
| 277 | (subseq (the simple-string (string lisp-name)) 1) |
| 278 | (string lisp-name))) |
| 279 | (prefix (package-prefix *package*)) |
| 280 | (name (substitute #\_ #\- (string-downcase lisp-name-string)))) |
| 281 | (if (or (not prefix) (string= prefix "")) |
| 282 | name |
| 283 | (format nil "~A_~A" prefix name)))) |
| 284 | |
| 285 | |
| 286 | (defmacro define-foreign (name lambda-list return-type-spec &rest docs/args) |
| 287 | (multiple-value-bind (c-name lisp-name) |
| 288 | (if (atom name) |
| 289 | (values (default-alien-func-name name) name) |
| 290 | (values-list name)) |
| 291 | (let ((supplied-lambda-list lambda-list) |
| 292 | (docs nil) |
| 293 | (args nil)) |
| 294 | (dolist (doc/arg docs/args) |
| 295 | (if (stringp doc/arg) |
| 296 | (push doc/arg docs) |
| 297 | (progn |
| 298 | (destructuring-bind (expr type &optional (style :in)) doc/arg |
| 299 | (unless (member style '(:in :out)) |
| 300 | (error "Bogus argument style ~S in ~S." style doc/arg)) |
| 301 | (when (and (not supplied-lambda-list) (namep expr) (eq style :in)) |
| 302 | (push expr lambda-list)) |
| 303 | (push |
| 304 | (list (if (namep expr) expr (gensym)) expr type style) args))))) |
| 305 | |
| 306 | (%define-foreign |
| 307 | c-name lisp-name (or supplied-lambda-list (nreverse lambda-list)) |
| 308 | return-type-spec (reverse docs) (reverse args))))) |
| 309 | |
| 310 | |
| 311 | #+cmu |
| 312 | (defun %define-foreign (foreign-name lisp-name lambda-list |
| 313 | return-type-spec docs args) |
| 314 | (ext:collect ((alien-types) (alien-bindings) (alien-parameters) |
| 315 | (alien-values) (alien-deallocatiors)) |
| 316 | (dolist (arg args) |
| 317 | (destructuring-bind (var expr type-spec style) arg |
| 318 | (let ((declaration (translate-type-spec type-spec)) |
| 319 | (deallocation (cleanup-alien type-spec expr))) |
| 320 | (cond |
| 321 | ((eq style :out) |
| 322 | (alien-types `(* ,declaration)) |
| 323 | (alien-parameters `(addr ,var)) |
| 324 | (alien-bindings `(,var ,declaration)) |
| 325 | (alien-values (translate-from-alien type-spec var))) |
| 326 | (deallocation |
| 327 | (alien-types declaration) |
| 328 | (alien-bindings |
| 329 | `(,var ,declaration ,(translate-to-alien type-spec expr))) |
| 330 | (alien-parameters var) |
| 331 | (alien-deallocatiors deallocation)) |
| 332 | (t |
| 333 | (alien-types declaration) |
| 334 | (alien-parameters (translate-to-alien type-spec expr))))))) |
| 335 | |
| 336 | (let ((alien-funcall `(alien-funcall ,lisp-name ,@(alien-parameters)))) |
| 337 | `(defun ,lisp-name ,lambda-list |
| 338 | ,@docs |
| 339 | (with-alien ((,lisp-name |
| 340 | (function |
| 341 | ,(translate-type-spec return-type-spec) |
| 342 | ,@(alien-types)) |
| 343 | :extern ,foreign-name) |
| 344 | ,@(alien-bindings)) |
| 345 | ,(if return-type-spec |
| 346 | `(let ((result |
| 347 | ,(translate-from-alien return-type-spec alien-funcall))) |
| 348 | ,@(alien-deallocatiors) |
| 349 | (values result ,@(alien-values))) |
| 350 | `(progn |
| 351 | ,alien-funcall |
| 352 | ,@(alien-deallocatiors) |
| 353 | (values ,@(alien-values))))))))) |
| 354 | |
| 355 | |
| 356 | |
| 357 | |
| 358 | ;;;; Translations for fundamental types |
| 359 | |
| 360 | (lisp:deftype long (&optional (min '*) (max '*)) `(integer ,min ,max)) |
| 361 | (lisp:deftype unsigned-long (&optional (min '*) (max '*)) `(integer ,min ,max)) |
| 362 | (lisp:deftype int (&optional (min '*) (max '*)) `(long ,min ,max)) |
| 363 | (lisp:deftype unsigned-int (&optional (min '*) (max '*)) `(unsigned-long ,min ,max)) |
| 364 | (lisp:deftype short (&optional (min '*) (max '*)) `(int ,min ,max)) |
| 365 | (lisp:deftype unsigned-short (&optional (min '*) (max '*)) `(unsigned-int ,min ,max)) |
| 366 | (lisp:deftype signed (&optional (size '*)) `(signed-byte ,size)) |
| 367 | (lisp:deftype unsigned (&optional (size '*)) `(signed-byte ,size)) |
| 368 | (lisp:deftype char () 'base-char) |
| 369 | (lisp:deftype pointer () 'system-area-pointer) |
| 370 | (lisp:deftype boolean (&optional (size '*)) |
| 371 | (declare (ignore size)) |
| 372 | `(member t nil)) |
| 373 | (lisp:deftype static (type) type) |
| 374 | (lisp:deftype invalid () nil) |
| 375 | |
| 376 | |
| 377 | (deftype-method cleanup-alien t (type-spec alien &optional copied) |
| 378 | (declare (ignore type-spec alien copied)) |
| 379 | nil) |
| 380 | |
| 381 | |
| 382 | (deftype-method translate-to-alien integer (type-spec number &optional copy) |
| 383 | (declare (ignore type-spec copy)) |
| 384 | number) |
| 385 | |
| 386 | (deftype-method translate-from-alien integer (type-spec number &optional alloc) |
| 387 | (declare (ignore type-spec alloc)) |
| 388 | number) |
| 389 | |
| 390 | |
| 391 | (deftype-method translate-type-spec fixnum (type-spec) |
| 392 | (declare (ignore type-spec)) |
| 393 | (signed '*)) |
| 394 | |
| 395 | (deftype-method translate-to-alien fixnum (type-spec number &optional copy) |
| 396 | (declare (ignore type-spec copy)) |
| 397 | number) |
| 398 | |
| 399 | (deftype-method translate-from-alien fixnum (type-spec number &optional alloc) |
| 400 | (declare (ignore type-spec alloc)) |
| 401 | number) |
| 402 | |
| 403 | |
| 404 | (deftype-method translate-type-spec long (type-spec) |
| 405 | (declare (ignore type-spec)) |
| 406 | (signed '*)) |
| 407 | |
| 408 | |
| 409 | (deftype-method translate-type-spec unsigned-long (type-spec) |
| 410 | (declare (ignore type-spec)) |
| 411 | (unsigned '*)) |
| 412 | |
| 413 | |
| 414 | (deftype-method translate-type-spec short (type-spec) |
| 415 | (declare (ignore type-spec)) |
| 416 | '(signed 16)) |
| 417 | |
| 418 | |
| 419 | (deftype-method translate-type-spec unsigned-short (type-spec) |
| 420 | (declare (ignore type-spec)) |
| 421 | '(unsigned 16)) |
| 422 | |
| 423 | |
| 424 | (deftype-method translate-type-spec signed-byte (type-spec) |
| 425 | (destructuring-bind (name &optional (size '*)) |
| 426 | (type-expand-to 'signed-byte type-spec) |
| 427 | (declare (ignore name)) |
| 428 | (signed size))) |
| 429 | |
| 430 | (deftype-method translate-to-alien signed-byte (type-spec number &optional copy) |
| 431 | (declare (ignore type-spec copy)) |
| 432 | number) |
| 433 | |
| 434 | (deftype-method |
| 435 | translate-from-alien signed-byte (type-spec number &optional alloc) |
| 436 | (declare (ignore type-spec alloc)) |
| 437 | number) |
| 438 | |
| 439 | |
| 440 | (deftype-method translate-type-spec unsigned-byte (type-spec) |
| 441 | (destructuring-bind (name &optional (size '*)) |
| 442 | (type-expand-to 'unsigned-byte type-spec) |
| 443 | (declare (ignore name)) |
| 444 | (unsigned size))) |
| 445 | |
| 446 | (deftype-method |
| 447 | translate-to-alien unsigned-byte (type-spec number &optional copy) |
| 448 | (declare (ignore type-spec copy)) |
| 449 | number) |
| 450 | |
| 451 | (deftype-method |
| 452 | translate-from-alien unsigned-byte (type-spec number &optional alloc) |
| 453 | (declare (ignore type-spec alloc)) |
| 454 | number) |
| 455 | |
| 456 | |
| 457 | (deftype-method translate-type-spec single-float (type-spec) |
| 458 | (declare (ignore type-spec)) |
| 459 | 'single-float) |
| 460 | |
| 461 | (deftype-method |
| 462 | translate-to-alien single-float (type-spec number &optional copy) |
| 463 | (declare (ignore type-spec copy)) |
| 464 | number) |
| 465 | |
| 466 | (deftype-method |
| 467 | translate-from-alien single-float (type-spec number &optional alloc) |
| 468 | (declare (ignore type-spec alloc)) |
| 469 | number) |
| 470 | |
| 471 | |
| 472 | (deftype-method translate-type-spec double-float (type-spec) |
| 473 | (declare (ignore type-spec)) |
| 474 | 'double-float) |
| 475 | |
| 476 | (deftype-method |
| 477 | translate-to-alien double-float (type-spec number &optional copy) |
| 478 | (declare (ignore type-spec copy)) |
| 479 | number) |
| 480 | |
| 481 | (deftype-method |
| 482 | translate-from-alien double-float (type-spec number &optional alloc) |
| 483 | (declare (ignore type-spec alloc)) |
| 484 | number) |
| 485 | |
| 486 | |
| 487 | (deftype-method translate-type-spec base-char (type-spec) |
| 488 | (declare (ignore type-spec)) |
| 489 | '(unsigned 8)) |
| 490 | |
| 491 | (deftype-method translate-to-alien base-char (type-spec char &optional copy) |
| 492 | (declare (ignore type-spec copy)) |
| 493 | `(char-code ,char)) |
| 494 | |
| 495 | (deftype-method translate-from-alien base-char (type-spec code &optional alloc) |
| 496 | (declare (ignore type-spec alloc)) |
| 497 | `(code-char ,code)) |
| 498 | |
| 499 | |
| 500 | (deftype-method translate-type-spec string (type-spec) |
| 501 | (declare (ignore type-spec)) |
| 502 | 'system-area-pointer) |
| 503 | |
| 504 | (deftype-method translate-to-alien string (type-spec string &optional copy) |
| 505 | (declare (ignore type-spec)) |
| 506 | (if copy |
| 507 | `(let ((string ,string)) |
| 508 | (copy-memory |
| 509 | (make-pointer (1+ (kernel:get-lisp-obj-address string))) |
| 510 | (1+ (length string)))) |
| 511 | `(make-pointer (1+ (kernel:get-lisp-obj-address ,string))))) |
| 512 | |
| 513 | (deftype-method |
| 514 | translate-from-alien string (type-spec sap &optional (alloc :dynamic)) |
| 515 | (declare (ignore type-spec)) |
| 516 | `(let ((sap ,sap)) |
| 517 | (unless (null-pointer-p sap) |
| 518 | (prog1 |
| 519 | (c-call::%naturalize-c-string sap) |
| 520 | ,(when (eq alloc :dynamic) `(deallocate-memory ,sap)))))) |
| 521 | |
| 522 | (deftype-method cleanup-alien string (type-spec sap &optional copied) |
| 523 | (declare (ignore type-spec)) |
| 524 | (when copied |
| 525 | `(let ((sap ,sap)) |
| 526 | (unless (null-pointer-p sap) |
| 527 | (deallocate-memory sap))))) |
| 528 | |
| 529 | |
| 530 | (deftype-method translate-type-spec boolean (type-spec) |
| 531 | (if (atom type-spec) |
| 532 | (unsigned '*) |
| 533 | (destructuring-bind (name &optional (size '*)) |
| 534 | (type-expand-to 'boolean type-spec) |
| 535 | (declare (ignore name)) |
| 536 | (unsigned size)))) |
| 537 | |
| 538 | (deftype-method translate-to-alien boolean (type-spec boolean &optional copy) |
| 539 | (declare (ignore type-spec copy)) |
| 540 | `(if ,boolean 1 0)) |
| 541 | |
| 542 | (deftype-method translate-from-alien boolean (type-spec int &optional alloc) |
| 543 | (declare (ignore type-spec alloc)) |
| 544 | `(not (zerop ,int))) |
| 545 | |
| 546 | |
| 547 | (deftype-method translate-type-spec or (union-type-spec) |
| 548 | (destructuring-bind (name &rest type-specs) |
| 549 | (type-expand-to 'or union-type-spec) |
| 550 | (declare (ignore name)) |
| 551 | (let ((type-spec-translations |
| 552 | (map 'list #'translate-type-spec type-specs))) |
| 553 | (unless (apply #'all-equal type-spec-translations) |
| 554 | (error |
| 555 | "No common alien type specifier for union type: ~A" union-type-spec)) |
| 556 | (first type-spec-translations)))) |
| 557 | |
| 558 | (deftype-method translate-to-alien or (union-type-spec expr &optional copy) |
| 559 | (destructuring-bind (name &rest type-specs) |
| 560 | (type-expand-to 'or union-type-spec) |
| 561 | (declare (ignore name)) |
| 562 | `(let ((value ,expr)) |
| 563 | (etypecase value |
| 564 | ,@(map |
| 565 | 'list |
| 566 | #'(lambda (type-spec) |
| 567 | (list type-spec (translate-to-alien type-spec 'value copy))) |
| 568 | type-specs))))) |
| 569 | |
| 570 | |
| 571 | |
| 572 | (deftype-method translate-type-spec system-area-pointer (type-spec) |
| 573 | (declare (ignore type-spec)) |
| 574 | 'system-area-pointer) |
| 575 | |
| 576 | (deftype-method |
| 577 | translate-to-alien system-area-pointer (type-spec sap &optional copy) |
| 578 | (declare (ignore type-spec copy)) |
| 579 | sap) |
| 580 | |
| 581 | (deftype-method |
| 582 | translate-from-alien system-area-pointer (type-spec sap &optional alloc) |
| 583 | (declare (ignore type-spec alloc)) |
| 584 | sap) |
| 585 | |
| 586 | |
| 587 | (deftype-method translate-type-spec null (type-spec) |
| 588 | (declare (ignore type-spec)) |
| 589 | 'system-area-pointer) |
| 590 | |
| 591 | (deftype-method translate-to-alien null (type-spec expr &optional copy) |
| 592 | (declare (ignore type-spec copy)) |
| 593 | `(make-pointer 0)) |
| 594 | |
| 595 | |
| 596 | (deftype-method translate-type-spec nil (type-spec) |
| 597 | (declare (ignore type-spec)) |
| 598 | 'void) |
| 599 | |
| 600 | |
| 601 | (deftype-method transalte-type-spec static (type-spec) |
| 602 | (translate-type-spec (second type-spec))) |
| 603 | |
| 604 | (deftype-method translate-to-alien static (type-spec expr &optional copy) |
| 605 | (declare (ignore copy)) |
| 606 | (translate-to-alien (second type-spec) expr nil)) |
| 607 | |
| 608 | (deftype-method translate-from-alien static (type-spec alien &optional alloc) |
| 609 | (declare (ignore alloc)) |
| 610 | (translate-from-alien (second type-spec) alien nil)) |
| 611 | |
| 612 | (deftype-method cleanup-alien static (type-spec alien &optional copied) |
| 613 | (declare (ignore copied)) |
| 614 | (cleanup-alien type-spec alien nil)) |
| 615 | |
| 616 | |
| 617 | |
| 618 | ;;;; Enum and flags type |
| 619 | |
| 620 | (defun map-mappings (args op) |
| 621 | (let ((current-value 0)) |
| 622 | (map |
| 623 | 'list |
| 624 | #'(lambda (mapping) |
| 625 | (destructuring-bind (symbol &optional (value current-value)) |
| 626 | (mklist mapping) |
| 627 | (setf current-value (1+ value)) |
| 628 | (case op |
| 629 | (:enum-int (list symbol value)) |
| 630 | (:flags-int (list symbol (ash 1 value))) |
| 631 | (:int-enum (list value symbol)) |
| 632 | (:int-flags (list (ash 1 value) symbol)) |
| 633 | (:symbols symbol)))) |
| 634 | (if (integerp (first args)) |
| 635 | (rest args) |
| 636 | args)))) |
| 637 | |
| 638 | (lisp:deftype enum (&rest args) |
| 639 | `(member ,@(map-mappings args :symbols))) |
| 640 | |
| 641 | (deftype-method translate-type-spec enum (type-spec) |
| 642 | (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec) |
| 643 | (declare (ignore name)) |
| 644 | (if (integerp (first args)) |
| 645 | `(signed ,(first args)) |
| 646 | '(signed 32)))) |
| 647 | |
| 648 | (deftype-method translate-to-alien enum (type-spec expr &optional copy) |
| 649 | (declare (ignore copy)) |
| 650 | (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec) |
| 651 | (declare (ignore name)) |
| 652 | `(ecase ,expr |
| 653 | ,@(map-mappings args :enum-int)))) |
| 654 | |
| 655 | (deftype-method translate-from-alien enum (type-spec expr &optional alloc) |
| 656 | (declare (ignore alloc)) |
| 657 | (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec) |
| 658 | (declare (ignore name)) |
| 659 | `(ecase ,expr |
| 660 | ,@(map-mappings args :int-enum)))) |
| 661 | |
| 662 | |
| 663 | (lisp:deftype flags (&rest args) |
| 664 | `(or |
| 665 | null |
| 666 | (cons |
| 667 | (member ,@(map-mappings args :symbols)) |
| 668 | list))) |
| 669 | |
| 670 | (deftype-method translate-type-spec flags (type-spec) |
| 671 | (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec) |
| 672 | (declare (ignore name)) |
| 673 | (if (integerp (first args)) |
| 674 | `(signed ,(first args)) |
| 675 | '(signed 32)))) |
| 676 | |
| 677 | (deftype-method translate-to-alien flags (type-spec expr &optional copy) |
| 678 | (declare (ignore copy)) |
| 679 | (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec) |
| 680 | (declare (ignore name)) |
| 681 | (let ((mappings (map-mappings args :flags-int))) |
| 682 | `(let ((value 0)) |
| 683 | (dolist (flag ,expr value) |
| 684 | (setq value (logior value (second (assoc flag ',mappings))))))))) |
| 685 | |
| 686 | (deftype-method translate-from-alien flags (type-spec expr &optional alloc) |
| 687 | (declare (ignore alloc)) |
| 688 | (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec) |
| 689 | (declare (ignore name)) |
| 690 | (let ((mappings (map-mappings args :int-flags))) |
| 691 | `(let ((result nil)) |
| 692 | (dolist (mapping ',mappings result) |
| 693 | (unless (zerop (logand ,expr (first mapping))) |
| 694 | (push (second mapping) result))))))) |