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