chiark - git - mdw - clg/blob - glib/gforeign.lisp

   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.7 2001-04-30 11:25:25 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 (defun mkbinding (name rettype &rest types)
 369   (declare (optimize (ext:inhibit-warnings 3)))
 370   (let* ((ftype
 371           `(function ,@(mapcar #'translate-type-spec (cons rettype types))))
 372          (alien
 373           (alien::%heap-alien
 374            (alien::make-heap-alien-info
 375             :type (alien::parse-alien-type ftype)
 376             :sap-form (system:foreign-symbol-address name))))
 377          (translate-arguments (mapcar #'intern-return-value-translator types))
 378          (translate-return-value (intern-return-value-translator rettype))
 379          (cleanup-arguments (mapcar #'intern-cleanup-function types)))
 380
 381     #'(lambda (&rest args)
 382         (map-into args #'funcall translate-arguments args)
 383         (prog1
 384             (funcall
 385              translate-return-value (apply #'alien:alien-funcall alien args))
 386           (mapc #'funcall cleanup-arguments args)))))
 387
 388
 389 ;;;; Definitons and translations of fundamental types
 390
 391 (deftype long (&optional (min '*) (max '*)) `(integer ,min ,max))
 392 (deftype unsigned-long (&optional (min '*) (max '*)) `(integer ,min ,max))
 393 (deftype int (&optional (min '*) (max '*)) `(long ,min ,max))
 394 (deftype unsigned-int (&optional (min '*) (max '*)) `(unsigned-long ,min ,max))
 395 (deftype short (&optional (min '*) (max '*)) `(int ,min ,max))
 396 (deftype unsigned-short (&optional (min '*) (max '*)) `(unsigned-int ,min ,max))
 397 (deftype signed (&optional (size '*)) `(signed-byte ,size))
 398 (deftype unsigned (&optional (size '*)) `(signed-byte ,size))
 399 (deftype char () 'base-char)
 400 (deftype pointer () 'system-area-pointer)
 401 (deftype boolean (&optional (size '*))
 402   (declare (ignore size))
 403   `(member t nil))
 404 (deftype static (type) type)
 405 (deftype invalid () nil)
 406
 407 (defun atomic-type-p (type-spec)
 408   (or
 409    (eq type-spec 'pointer)
 410    (not (eq (translate-type-spec type-spec) 'system-area-pointer))))
 411
 412
 413 (deftype-method cleanup-alien t (type-spec sap &optional weak-ref)
 414   (declare (ignore type-spec sap weak-ref))
 415   nil)
 416
 417
 418 (deftype-method translate-to-alien integer (type-spec number &optional weak-ref)
 419   (declare (ignore type-spec weak-ref))
 420   number)
 421
 422 (deftype-method translate-from-alien integer (type-spec number &optional weak-ref)
 423   (declare (ignore type-spec weak-ref))
 424   number)
 425
 426
 427 (deftype-method translate-type-spec fixnum (type-spec)
 428   (declare (ignore type-spec))
 429   (translate-type-spec 'signed))
 430
 431 (deftype-method size-of fixnum (type-spec)
 432   (declare (ignore type-spec))
 433   (size-of 'signed))
 434
 435 (deftype-method translate-to-alien fixnum (type-spec number &optional weak-ref)
 436   (declare (ignore type-spec weak-ref))
 437   number)
 438
 439 (deftype-method translate-from-alien fixnum (type-spec number &optional weak-ref)
 440   (declare (ignore type-spec weak-ref))
 441   number)
 442
 443
 444 (deftype-method translate-type-spec long (type-spec)
 445   (declare (ignore type-spec))
 446   `(signed ,(* +bits-per-unit+ +size-of-long+)))
 447
 448 (deftype-method size-of long (type-spec)
 449   (declare (ignore type-spec))
 450   +size-of-long+)
 451
 452
 453 (deftype-method translate-type-spec unsigned-long (type-spec)
 454   (declare (ignore type-spec))
 455   `(unsigned ,(* +bits-per-unit+ +size-of-long+)))
 456
 457 (deftype-method size-of unsigned-long (type-spec)
 458   (declare (ignore type-spec))
 459   +size-of-long+)
 460
 461
 462 (deftype-method translate-type-spec int (type-spec)
 463   (declare (ignore type-spec))
 464   `(signed ,(* +bits-per-unit+ +size-of-int+)))
 465
 466 (deftype-method size-of int (type-spec)
 467   (declare (ignore type-spec))
 468   +size-of-int+)
 469
 470
 471 (deftype-method translate-type-spec unsigned-int (type-spec)
 472   (declare (ignore type-spec))
 473   `(unsigned ,(* +bits-per-unit+ +size-of-int+)))
 474
 475 (deftype-method size-of unsigned-int (type-spec)
 476   (declare (ignore type-spec))
 477   +size-of-int+)
 478
 479
 480 (deftype-method translate-type-spec short (type-spec)
 481   (declare (ignore type-spec))
 482   `(signed ,(* +bits-per-unit+ +size-of-short+)))
 483
 484 (deftype-method size-of short (type-spec)
 485   (declare (ignore type-spec))
 486   +size-of-short+)
 487
 488
 489 (deftype-method translate-type-spec unsigned-short (type-spec)
 490   (declare (ignore type-spec))
 491   `(unsigned ,(* +bits-per-unit+ +size-of-short+)))
 492
 493 (deftype-method size-of unsigned-short (type-spec)
 494   (declare (ignore type-spec))
 495   +size-of-short+)
 496
 497
 498 (deftype-method translate-type-spec signed-byte (type-spec)
 499   (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
 500     `(signed
 501       ,(cond
 502         ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
 503         (t size)))))
 504
 505 (deftype-method size-of signed-byte (type-spec)
 506   (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
 507     (cond
 508      ((member size '(nil *)) +size-of-int+)
 509      (t (/ size +bits-per-unit+)))))
 510
 511 (deftype-method translate-to-alien signed-byte (type-spec number &optional weak-ref)
 512   (declare (ignore type-spec weak-ref))
 513   number)
 514
 515 (deftype-method translate-from-alien signed-byte
 516     (type-spec number &optional weak-ref)
 517   (declare (ignore type-spec weak-ref))
 518   number)
 519
 520
 521 (deftype-method translate-type-spec unsigned-byte (type-spec)
 522   (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
 523     `(signed
 524       ,(cond
 525         ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
 526         (t size)))))
 527
 528 (deftype-method size-of unsigned-byte (type-spec)
 529   (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
 530     (cond
 531      ((member size '(nil *)) +size-of-int+)
 532      (t (/ size +bits-per-unit+)))))
 533
 534 (deftype-method translate-to-alien unsigned-byte (type-spec number &optional weak-ref)
 535   (declare (ignore type-spec weak-ref))
 536   number)
 537
 538 (deftype-method translate-from-alien unsigned-byte
 539     (type-spec number &optional weak-ref)
 540   (declare (ignore type-spec weak-ref))
 541   number)
 542
 543
 544 (deftype-method translate-type-spec single-float (type-spec)
 545   (declare (ignore type-spec))
 546   'single-float)
 547
 548 (deftype-method size-of single-float (type-spec)
 549   (declare (ignore type-spec))
 550   +size-of-float+)
 551
 552 (deftype-method translate-to-alien single-float (type-spec number &optional weak-ref)
 553   (declare (ignore type-spec weak-ref))
 554   number)
 555
 556 (deftype-method translate-from-alien single-float
 557     (type-spec number &optional weak-ref)
 558   (declare (ignore type-spec weak-ref))
 559   number)
 560
 561
 562 (deftype-method translate-type-spec double-float (type-spec)
 563   (declare (ignore type-spec))
 564   'double-float)
 565
 566 (deftype-method size-of double-float (type-spec)
 567   (declare (ignore type-spec))
 568   +size-of-double+)
 569
 570 (deftype-method translate-to-alien double-float (type-spec number &optional weak-ref)
 571   (declare (ignore type-spec weak-ref))
 572   number)
 573
 574 (deftype-method translate-from-alien double-float
 575     (type-spec number &optional weak-ref)
 576   (declare (ignore type-spec weak-ref))
 577   number)
 578
 579
 580 (deftype-method translate-type-spec base-char (type-spec)
 581   (declare (ignore type-spec))
 582   `(unsigned ,+bits-per-unit+))
 583
 584 (deftype-method size-of base-char (type-spec)
 585   (declare (ignore type-spec))
 586   1)
 587
 588 (deftype-method translate-to-alien base-char (type-spec char &optional weak-ref)
 589   (declare (ignore type-spec weak-ref))
 590   `(char-code ,char))
 591
 592 (deftype-method translate-from-alien base-char (type-spec code &optional weak-ref)
 593   (declare (ignore type-spec weak-ref))
 594   `(code-char ,code))
 595
 596
 597 (deftype-method translate-type-spec string (type-spec)
 598   (declare (ignore type-spec))
 599   'system-area-pointer)
 600
 601 (deftype-method size-of string (type-spec)
 602   (declare (ignore type-spec))
 603   +size-of-sap+)
 604
 605 (deftype-method translate-to-alien string (type-spec string &optional weak-ref)
 606   (declare (ignore type-spec weak-ref))
 607   `(let ((string ,string))
 608      ;; Always copy strings to prevent seg fault due to GC
 609      (copy-memory
 610       (make-pointer (1+ (kernel:get-lisp-obj-address string)))
 611       (1+ (length string)))))
 612
 613 (deftype-method translate-from-alien string
 614     (type-spec c-string &optional weak-ref)
 615   (declare (ignore type-spec))
 616   `(let ((c-string ,c-string))
 617      (unless (null-pointer-p c-string)
 618        (prog1
 619            (c-call::%naturalize-c-string c-string)
 620          ;,(unless weak-ref `(deallocate-memory c-string))
 621          ))))
 622
 623 (deftype-method cleanup-alien string (type-spec c-string &optional weak-ref)
 624   (declare (ignore type-spec))
 625   (when weak-ref
 626     (unreference-alien type-spec c-string)))
 627
 628 (deftype-method unreference-alien string (type-spec c-string)
 629   (declare (ignore type-spec))
 630   `(let ((c-string ,c-string))
 631      (unless (null-pointer-p c-string)
 632        (deallocate-memory c-string))))
 633
 634
 635 (deftype-method translate-type-spec boolean (type-spec)
 636   (translate-type-spec
 637    (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
 638
 639 (deftype-method size-of boolean (type-spec)
 640   (size-of
 641    (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
 642
 643 (deftype-method translate-to-alien boolean (type-spec boolean &optional weak-ref)
 644   (declare (ignore type-spec weak-ref))
 645   `(if ,boolean 1 0))
 646
 647 (deftype-method translate-from-alien boolean (type-spec int &optional weak-ref)
 648   (declare (ignore type-spec weak-ref))
 649   `(not (zerop ,int)))
 650
 651
 652 (deftype-method translate-type-spec or (union-type)
 653   (let* ((member-types (cdr (type-expand-to 'or union-type)))
 654          (alien-type (translate-type-spec (first member-types))))
 655     (dolist (type (cdr member-types))
 656       (unless (eq alien-type (translate-type-spec type))
 657         (error "No common alien type specifier for union type: ~A" union-type)))
 658     alien-type))
 659
 660 (deftype-method size-of or (union-type)
 661   (size-of (first (cdr (type-expand-to 'or union-type)))))
 662
 663 (deftype-method translate-to-alien or (union-type-spec expr &optional weak-ref)
 664   (destructuring-bind (name &rest type-specs)
 665       (type-expand-to 'or union-type-spec)
 666     (declare (ignore name))
 667     `(let ((value ,expr))
 668        (etypecase value
 669          ,@(map
 670             'list
 671               #'(lambda (type-spec)
 672                   (list type-spec (translate-to-alien type-spec 'value weak-ref)))
 673               type-specs)))))
 674
 675
 676 (deftype-method translate-type-spec system-area-pointer (type-spec)
 677   (declare (ignore type-spec))
 678   'system-area-pointer)
 679
 680 (deftype-method size-of system-area-pointer (type-spec)
 681   (declare (ignore type-spec))
 682   +size-of-sap+)
 683
 684 (deftype-method translate-to-alien system-area-pointer (type-spec sap &optional weak-ref)
 685   (declare (ignore type-spec weak-ref))
 686   sap)
 687
 688 (deftype-method translate-from-alien system-area-pointer
 689     (type-spec sap &optional weak-ref)
 690   (declare (ignore type-spec weak-ref))
 691   sap)
 692
 693
 694 (deftype-method translate-type-spec null (type-spec)
 695   (declare (ignore type-spec))
 696   'system-area-pointer)
 697
 698 (deftype-method translate-to-alien null (type-spec expr &optional weak-ref)
 699   (declare (ignore type-spec expr weak-ref))
 700   `(make-pointer 0))
 701
 702
 703 (deftype-method translate-type-spec nil (type-spec)
 704   (declare (ignore type-spec))
 705   'void)
 706
 707 (deftype-method translate-from-alien nil (type-spec expr &optional weak-ref)
 708   (declare (ignore type-spec weak-ref))
 709   `(progn
 710      ,expr
 711      (values)))