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