src/code/host-alieneval.lisp

   1 ;;;; the part of the Alien implementation which is needed at
   2 ;;;; cross-compilation time
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!ALIEN")
  14
  15 (/show0 "host-alieneval.lisp 15")
  16 \f
  17 ;;;; utility functions
  18
  19 (defun align-offset (offset alignment)
  20   (let ((extra (rem offset alignment)))
  21     (if (zerop extra) offset (+ offset (- alignment extra)))))
  22
  23 (defun guess-alignment (bits)
  24   (cond ((null bits) nil)
  25         #!-(or (and x86 (not win32)) (and ppc darwin)) ((> bits 32) 64)
  26         ((> bits 16) 32)
  27         ((> bits 8) 16)
  28         ((> bits 1) 8)
  29         (t 1)))
  30 \f
  31 ;;;; ALIEN-TYPE-INFO stuff
  32
  33 ;;; We define a keyword "BOA" constructor so that we can reference the
  34 ;;; slot names in init forms.
  35 (defmacro define-alien-type-class ((name &key include include-args) &rest slots)
  36   (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE")))
  37     (multiple-value-bind (include include-defstruct overrides)
  38         (etypecase include
  39           (null
  40            (values nil 'alien-type nil))
  41           (symbol
  42            (values
  43             include
  44             (alien-type-class-defstruct-name
  45              (alien-type-class-or-lose include))
  46             nil))
  47           (list
  48            (values
  49             (car include)
  50             (alien-type-class-defstruct-name
  51              (alien-type-class-or-lose (car include)))
  52             (cdr include))))
  53       `(progn
  54          (eval-when (:compile-toplevel :load-toplevel :execute)
  55            (create-alien-type-class-if-necessary ',name ',defstruct-name
  56                                                  ',(or include 'root)))
  57          (setf (info :source-location :alien-type ',name)
  58                (sb!c:source-location))
  59          (def!struct (,defstruct-name
  60                         (:include ,include-defstruct
  61                                   (class ',name)
  62                                   ,@overrides)
  63                         (:copier nil)
  64                         (:constructor
  65                          ,(symbolicate "MAKE-" defstruct-name)
  66                          (&key class bits alignment
  67                                ,@(mapcar (lambda (x)
  68                                            (if (atom x) x (car x)))
  69                                          slots)
  70                                ,@include-args
  71                                ;; KLUDGE
  72                                &aux (alignment (or alignment (guess-alignment bits))))))
  73            ,@slots)))))
  74
  75 (defmacro define-alien-type-method ((class method) lambda-list &rest body)
  76   (let ((defun-name (symbolicate class "-" method "-METHOD")))
  77     `(progn
  78        (defun ,defun-name ,lambda-list
  79          ,@body)
  80        (setf (,(method-slot method) (alien-type-class-or-lose ',class))
  81              #',defun-name))))
  82 \f
  83 ;;;; type parsing and unparsing
  84
  85 ;;; CMU CL used COMPILER-LET to bind *AUXILIARY-TYPE-DEFINITIONS*, and
  86 ;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we
  87 ;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve
  88 ;;; a similar effect.
  89 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  90   (defun auxiliary-type-definitions (env)
  91     (multiple-value-bind (result expanded-p)
  92         (%macroexpand '&auxiliary-type-definitions& env)
  93       (if expanded-p
  94           result
  95           ;; This is like having the global symbol-macro definition be
  96           ;; NIL, but global symbol-macros make me vaguely queasy, so
  97           ;; I do it this way instead.
  98           nil))))
  99
 100 ;;; Parse TYPE as an alien type specifier and return the resultant
 101 ;;; ALIEN-TYPE structure.
 102 (defun parse-alien-type (type env)
 103   (declare (type sb!kernel:lexenv-designator env))
 104   (if (consp type)
 105       (let ((translator (info :alien-type :translator (car type))))
 106         (unless translator
 107           (error "unknown alien type: ~/sb!impl:print-type-specifier/"
 108                  type))
 109         (funcall translator type env))
 110       (ecase (info :alien-type :kind type)
 111         (:primitive
 112          (let ((translator (info :alien-type :translator type)))
 113            (unless translator
 114              (error "no translator for primitive alien type ~
 115                       ~/sb!impl:print-type-specifier/"
 116                     type))
 117            (funcall translator (list type) env)))
 118         (:defined
 119          (or (info :alien-type :definition type)
 120              (error "no definition for alien type ~/sb!impl:print-type-specifier/"
 121                     type)))
 122         (:unknown
 123          (error "unknown alien type: ~/sb!impl:print-type-specifier/"
 124                 type)))))
 125
 126 (defun auxiliary-alien-type (kind name env)
 127   (declare (type sb!kernel:lexenv-designator env))
 128   (flet ((aux-defn-matches (x)
 129            (and (eq (first x) kind) (eq (second x) name))))
 130     (let ((in-auxiliaries
 131            (or (find-if #'aux-defn-matches *new-auxiliary-types*)
 132                (find-if #'aux-defn-matches (auxiliary-type-definitions env)))))
 133       (if in-auxiliaries
 134           (values (third in-auxiliaries) t)
 135           (info :alien-type kind name)))))
 136
 137 (defun (setf auxiliary-alien-type) (new-value kind name env)
 138   (declare (type sb!kernel:lexenv-designator env))
 139   (flet ((aux-defn-matches (x)
 140            (and (eq (first x) kind) (eq (second x) name))))
 141     (when (find-if #'aux-defn-matches *new-auxiliary-types*)
 142       (error "attempt to multiply define ~A ~S" kind name))
 143     (when (find-if #'aux-defn-matches (auxiliary-type-definitions env))
 144       (error "attempt to shadow definition of ~A ~S" kind name)))
 145   (push (list kind name new-value) *new-auxiliary-types*)
 146   new-value)
 147
 148 (defun verify-local-auxiliaries-okay ()
 149   (dolist (info *new-auxiliary-types*)
 150     (destructuring-bind (kind name defn) info
 151       (declare (ignore defn))
 152       (when (info :alien-type kind name)
 153         (error "attempt to shadow definition of ~A ~S" kind name)))))
 154
 155 (defun unparse-alien-type (type)
 156   "Convert the alien-type structure TYPE back into a list specification of
 157    the type."
 158   (declare (type alien-type type))
 159   (let ((*record-types-already-unparsed* nil))
 160     (%unparse-alien-type type)))
 161
 162 ;;; Does all the work of UNPARSE-ALIEN-TYPE. It's separate because we
 163 ;;; need to recurse inside the binding of
 164 ;;; *RECORD-TYPES-ALREADY-UNPARSED*.
 165 (defun %unparse-alien-type (type)
 166   (invoke-alien-type-method :unparse type))
 167 \f
 168 ;;;; alien type defining stuff
 169
 170 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 171   (defun %define-alien-type-translator (name translator)
 172     (setf (info :alien-type :kind name) :primitive)
 173     (setf (info :alien-type :translator name) translator)
 174     (clear-info :alien-type :definition name)
 175     name))
 176
 177 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 178   (defun %def-auxiliary-alien-types (types source-location)
 179     (dolist (info types)
 180       ;; Clear up the type we're about to define from the toplevel
 181       ;; *new-auxiliary-types* (local scopes take care of themselves).
 182       ;; Unless this is done we never actually get back the full type
 183       ;; from INFO, since the *new-auxiliary-types* have precendence.
 184       (setf *new-auxiliary-types*
 185             (remove info *new-auxiliary-types*
 186                     :test (lambda (a b)
 187                             (and (eq (first a) (first b))
 188                                  (eq (second a) (second b))))))
 189       (destructuring-bind (kind name defn) info
 190         (let ((old (info :alien-type kind name)))
 191           (unless (or (null old) (alien-type-= old defn))
 192             (warn "redefining ~A ~S to be:~%  ~S,~%was:~%  ~S"
 193                   kind name defn old)))
 194         (setf (info :alien-type kind name) defn
 195               (info :source-location :alien-type name) source-location))))
 196
 197   (defun %define-alien-type (name new source-location)
 198     (ecase (info :alien-type :kind name)
 199       (:primitive
 200        (error "~/sb!impl:print-type-specifier/ is a built-in alien type."
 201               name))
 202       (:defined
 203        (let ((old (info :alien-type :definition name)))
 204          (unless (or (null old) (alien-type-= new old))
 205            (warn "redefining ~S to be:~% ~
 206                    ~/sb!impl:print-type-specifier/,~%was~% ~
 207                    ~/sb!impl:print-type-specifier/"
 208                  name
 209                  (unparse-alien-type new)
 210                  (unparse-alien-type old)))))
 211       (:unknown))
 212     (setf (info :alien-type :definition name) new)
 213     (setf (info :alien-type :kind name) :defined)
 214     (setf (info :source-location :alien-type name) source-location)
 215     name))
 216 \f
 217 ;;;; the root alien type
 218
 219 (eval-when (:compile-toplevel :load-toplevel :execute)
 220   (create-alien-type-class-if-necessary 'root 'alien-type nil))
 221
 222 (defmethod print-object ((type alien-type) stream)
 223   (print-unreadable-object (type stream :type t)
 224     (sb!ext:print-type-specifier stream (unparse-alien-type type))))
 225 \f
 226 ;;;; the SAP type
 227
 228 (define-alien-type-class (system-area-pointer))
 229
 230 (define-alien-type-translator system-area-pointer ()
 231   (make-alien-system-area-pointer-type
 232    :bits sb!vm:n-machine-word-bits))
 233
 234 (define-alien-type-method (system-area-pointer :unparse) (type)
 235   (declare (ignore type))
 236   'system-area-pointer)
 237
 238 (define-alien-type-method (system-area-pointer :lisp-rep) (type)
 239   (declare (ignore type))
 240   'system-area-pointer)
 241
 242 (define-alien-type-method (system-area-pointer :alien-rep) (type context)
 243   (declare (ignore type context))
 244   'system-area-pointer)
 245
 246 (define-alien-type-method (system-area-pointer :naturalize-gen) (type alien)
 247   (declare (ignore type))
 248   alien)
 249
 250 (define-alien-type-method (system-area-pointer :deport-gen) (type object)
 251   (declare (ignore type))
 252   (/noshow "doing alien type method SYSTEM-AREA-POINTER :DEPORT-GEN" object)
 253   object)
 254
 255 (define-alien-type-method (system-area-pointer :extract-gen) (type sap offset)
 256   (declare (ignore type))
 257   `(sap-ref-sap ,sap (/ ,offset sb!vm:n-byte-bits)))
 258 \f
 259 ;;;; the ALIEN-VALUE type
 260
 261 (define-alien-type-class (alien-value :include system-area-pointer))
 262
 263 (define-alien-type-method (alien-value :lisp-rep) (type)
 264   (declare (ignore type))
 265   nil)
 266
 267 (define-alien-type-method (alien-value :naturalize-gen) (type alien)
 268   `(%sap-alien ,alien ',type))
 269
 270 (define-alien-type-method (alien-value :deport-gen) (type value)
 271   (declare (ignore type))
 272   (/noshow "doing alien type method ALIEN-VALUE :DEPORT-GEN" value)
 273   `(alien-sap ,value))
 274 \f
 275 ;;; HEAP-ALIEN-INFO -- defstruct.
 276 ;;;
 277 (defmethod print-object ((info heap-alien-info) stream)
 278   (print-unreadable-object (info stream :type t)
 279     (format stream "~S ~S~@[ (data)~]"
 280             (heap-alien-info-alien-name info)
 281             (unparse-alien-type (heap-alien-info-type info))
 282             (heap-alien-info-datap info))))
 283
 284 ;;; The form to evaluate to produce the SAP pointing to where in the heap
 285 ;;; it is.
 286 (defun heap-alien-info-sap-form (info)
 287   `(foreign-symbol-sap ,(heap-alien-info-alien-name info)
 288                        ,(heap-alien-info-datap info)))
 289
 290 #-sb-xc-host ; No FOREIGN-SYMBOL-SAP
 291 (defun heap-alien-info-sap (info)
 292   (foreign-symbol-sap (heap-alien-info-alien-name info)
 293                       (heap-alien-info-datap info)))
 294 \f
 295 ;;;; Interfaces to the different methods
 296
 297 (defun alien-type-= (type1 type2)
 298   "Return T iff TYPE1 and TYPE2 describe equivalent alien types."
 299   (or (eq type1 type2)
 300       (and (eq (alien-type-class type1)
 301                (alien-type-class type2))
 302            (invoke-alien-type-method :type= type1 type2))))
 303
 304 (defun alien-subtype-p (type1 type2)
 305   "Return T iff the alien type TYPE1 is a subtype of TYPE2. Currently, the
 306    only supported subtype relationships are is that any pointer type is a
 307    subtype of (* t), and any array type first dimension will match
 308    (array <eltype> nil ...). Otherwise, the two types have to be
 309    ALIEN-TYPE-=."
 310   (or (eq type1 type2)
 311       (invoke-alien-type-method :subtypep type1 type2)))
 312
 313 (defun compute-naturalize-lambda (type)
 314   `(lambda (alien ignore)
 315      (declare (ignore ignore))
 316      ,(invoke-alien-type-method :naturalize-gen type 'alien)))
 317
 318 (defun compute-deport-lambda (type)
 319   (declare (type alien-type type))
 320   (/noshow "entering COMPUTE-DEPORT-LAMBDA" type)
 321   (multiple-value-bind (form value-type)
 322       (invoke-alien-type-method :deport-gen type 'value)
 323     `(lambda (value ignore)
 324        (declare (type ,(or value-type
 325                            (compute-lisp-rep-type type)
 326                            `(alien ,type))
 327                       value)
 328                 (ignore ignore))
 329        ,form)))
 330
 331 (defun compute-deport-alloc-lambda (type)
 332   `(lambda (value ignore)
 333      (declare (ignore ignore))
 334      ,(invoke-alien-type-method :deport-alloc-gen type 'value)))
 335
 336 (defun compute-extract-lambda (type)
 337   (let ((extract (invoke-alien-type-method :extract-gen type 'sap 'offset)))
 338     `(lambda (sap offset ignore)
 339        (declare (type system-area-pointer sap)
 340                 (type unsigned-byte offset)
 341                 (ignore ignore))
 342        ,(if (eq (alien-type-class type) 'integer)
 343             extract
 344             `(naturalize ,extract ',type)))))
 345
 346 (defun compute-deposit-lambda (type)
 347   (declare (type alien-type type))
 348   `(lambda (value sap offset ignore)
 349      (declare (type system-area-pointer sap)
 350               (type unsigned-byte offset)
 351               (ignore ignore))
 352      (let ((alloc-tmp (deport-alloc value ',type)))
 353        (maybe-with-pinned-objects (alloc-tmp) (,type)
 354          (let ((value (deport alloc-tmp  ',type)))
 355            ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
 356            ;; Note: the reason we don't just return the pre-deported value
 357            ;; is because that would inhibit any (deport (naturalize ...))
 358            ;; optimizations that might have otherwise happen. Re-naturalizing
 359            ;; the value might cause extra consing, but is flushable, so probably
 360            ;; results in better code.
 361            (naturalize value ',type))))))
 362
 363 (defun compute-lisp-rep-type (type)
 364   (invoke-alien-type-method :lisp-rep type))
 365
 366 ;;; CONTEXT is either :NORMAL (the default) or :RESULT (alien function
 367 ;;; return values).  See the :ALIEN-REP method for INTEGER for
 368 ;;; details.
 369 (defun compute-alien-rep-type (type &optional (context :normal))
 370   (invoke-alien-type-method :alien-rep type context))
 371 \f
 372 ;;;; default methods
 373
 374 (defun missing-alien-operation-error (type operation)
 375   (error "Cannot ~A aliens of type ~/sb!impl:print-type-specifier/."
 376          operation type))
 377
 378 (define-alien-type-method (root :unparse) (type)
 379   `(<unknown-alien-type> ,(type-of type)))
 380
 381 (define-alien-type-method (root :type=) (type1 type2)
 382   (declare (ignore type1 type2))
 383   t)
 384
 385 (define-alien-type-method (root :subtypep) (type1 type2)
 386   (alien-type-= type1 type2))
 387
 388 (define-alien-type-method (root :lisp-rep) (type)
 389   (declare (ignore type))
 390   nil)
 391
 392 (define-alien-type-method (root :alien-rep) (type context)
 393   (declare (ignore type context))
 394   '*)
 395
 396 (define-alien-type-method (root :naturalize-gen) (type alien)
 397   (declare (ignore alien))
 398   (missing-alien-operation-error "represent" type))
 399
 400 (define-alien-type-method (root :deport-gen) (type object)
 401   (declare (ignore object))
 402   (missing-alien-operation-error "represent" type))
 403
 404 (define-alien-type-method (root :deport-alloc-gen) (type object)
 405   (declare (ignore type))
 406   object)
 407
 408 (define-alien-type-method (root :deport-pin-p) (type)
 409   (declare (ignore type))
 410   ;; Override this method to return T for classes which take a SAP to a
 411   ;; GCable lisp object when deporting.
 412   nil)
 413
 414 (define-alien-type-method (root :extract-gen) (type sap offset)
 415   (declare (ignore sap offset))
 416   (missing-alien-operation-error "represent" type))
 417
 418 (define-alien-type-method (root :deposit-gen) (type sap offset value)
 419   `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value))
 420
 421 (define-alien-type-method (root :arg-tn) (type state)
 422   (declare (ignore state))
 423   (missing-alien-operation-error "pass as argument to CALL-OUT"
 424                                  (unparse-alien-type type)))
 425
 426 (define-alien-type-method (root :result-tn) (type state)
 427   (declare (ignore state))
 428   (missing-alien-operation-error "return from CALL-OUT"
 429                                  (unparse-alien-type type)))
 430 \f
 431 ;;;; the INTEGER type
 432
 433 (define-alien-type-class (integer)
 434   (signed t :type (member t nil)))
 435
 436 (define-alien-type-translator signed (&optional (bits sb!vm:n-word-bits))
 437   (make-alien-integer-type :bits bits))
 438
 439 (define-alien-type-translator integer (&optional (bits sb!vm:n-word-bits))
 440   (make-alien-integer-type :bits bits))
 441
 442 (define-alien-type-translator unsigned (&optional (bits sb!vm:n-word-bits))
 443   (make-alien-integer-type :bits bits :signed nil))
 444
 445 (define-alien-type-method (integer :unparse) (type)
 446   (list (if (alien-integer-type-signed type) 'signed 'unsigned)
 447         (alien-integer-type-bits type)))
 448
 449 (define-alien-type-method (integer :type=) (type1 type2)
 450   (and (eq (alien-integer-type-signed type1)
 451            (alien-integer-type-signed type2))
 452        (= (alien-integer-type-bits type1)
 453           (alien-integer-type-bits type2))))
 454
 455 (define-alien-type-method (integer :lisp-rep) (type)
 456   (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
 457         (alien-integer-type-bits type)))
 458
 459 (define-alien-type-method (integer :alien-rep) (type context)
 460   ;; When returning integer values that are narrower than a machine
 461   ;; register from a function, some platforms leave the higher bits of
 462   ;; the register uninitialized.  On those platforms, we use an
 463   ;; alien-rep of the full register width when checking for purposes
 464   ;; of return values and override the naturalize method to perform
 465   ;; the sign extension (in compiler/target/c-call.lisp).
 466   (ecase context
 467     ((:normal #!-(or alpha x86 x86-64) :result)
 468      (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
 469            (alien-integer-type-bits type)))
 470     #!+(or alpha x86 x86-64)
 471     (:result
 472      (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
 473            (max (alien-integer-type-bits type)
 474                 sb!vm:n-machine-word-bits)))))
 475
 476 ;;; As per the comment in the :ALIEN-REP method above, this is defined
 477 ;;; elsewhere for alpha and x86oids.
 478 #!-(or alpha x86 x86-64)
 479 (define-alien-type-method (integer :naturalize-gen) (type alien)
 480   (declare (ignore type))
 481   alien)
 482
 483 (define-alien-type-method (integer :deport-gen) (type value)
 484   (declare (ignore type))
 485   value)
 486
 487 (define-alien-type-method (integer :extract-gen) (type sap offset)
 488   (declare (type alien-integer-type type))
 489   (let ((ref-fun
 490          (if (alien-integer-type-signed type)
 491           (case (alien-integer-type-bits type)
 492             (8 'signed-sap-ref-8)
 493             (16 'signed-sap-ref-16)
 494             (32 'signed-sap-ref-32)
 495             (64 'signed-sap-ref-64))
 496           (case (alien-integer-type-bits type)
 497             (8 'sap-ref-8)
 498             (16 'sap-ref-16)
 499             (32 'sap-ref-32)
 500             (64 'sap-ref-64)))))
 501     (if ref-fun
 502         `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits))
 503         (error "cannot extract ~W-bit integers"
 504                (alien-integer-type-bits type)))))
 505 \f
 506 ;;;; the BOOLEAN type
 507
 508 (define-alien-type-class (boolean :include integer :include-args (signed)))
 509
 510 ;;; FIXME: Check to make sure that we aren't attaching user-readable
 511 ;;; stuff to CL:BOOLEAN in any way which impairs ANSI compliance.
 512 (define-alien-type-translator boolean (&optional (bits sb!vm:n-word-bits))
 513   (make-alien-boolean-type :bits bits :signed nil))
 514
 515 (define-alien-type-method (boolean :unparse) (type)
 516   `(boolean ,(alien-boolean-type-bits type)))
 517
 518 (define-alien-type-method (boolean :lisp-rep) (type)
 519   (declare (ignore type))
 520   `(member t nil))
 521
 522 (define-alien-type-method (boolean :naturalize-gen) (type alien)
 523   (let ((bits (alien-boolean-type-bits type)))
 524     (if (= bits sb!vm:n-word-bits)
 525         `(not (zerop ,alien))
 526         `(logtest ,alien ,(ldb (byte bits 0) -1)))))
 527
 528 (define-alien-type-method (boolean :deport-gen) (type value)
 529   (declare (ignore type))
 530   `(if ,value 1 0))
 531 \f
 532 ;;;; the ENUM type
 533
 534 (define-alien-type-class (enum :include (integer (bits 32))
 535                                :include-args (signed))
 536   name          ; name of this enum (if any)
 537   from          ; alist from symbols to integers
 538   to            ; alist or vector from integers to symbols
 539   kind          ; kind of from mapping, :VECTOR or :ALIST
 540   offset)       ; offset to add to value for :VECTOR from mapping
 541
 542 (define-alien-type-translator enum (&whole
 543                                  type name
 544                                  &rest mappings
 545                                  &environment env)
 546   (cond (mappings
 547          (let ((result (parse-enum name mappings)))
 548            (when name
 549              (multiple-value-bind (old old-p)
 550                  (auxiliary-alien-type :enum name env)
 551                (when old-p
 552                  (unless (alien-type-= result old)
 553                    (cerror "Continue, clobbering the old definition"
 554                            "Incompatible alien enum type definition: ~S" name)
 555                    (setf (alien-enum-type-from old) (alien-enum-type-from result)
 556                          (alien-enum-type-to old) (alien-enum-type-to result)
 557                          (alien-enum-type-kind old) (alien-enum-type-kind result)
 558                          (alien-enum-type-offset old) (alien-enum-type-offset result)
 559                          (alien-enum-type-signed old) (alien-enum-type-signed result)))
 560                  (setf result old))
 561                (unless old-p
 562                  (setf (auxiliary-alien-type :enum name env) result))))
 563            result))
 564         (name
 565          (multiple-value-bind (result found)
 566              (auxiliary-alien-type :enum name env)
 567            (unless found
 568              (error "unknown enum type: ~S" name))
 569            result))
 570         (t
 571          (error "empty enum type: ~S" type))))
 572
 573 (defun parse-enum (name elements)
 574   (when (null elements)
 575     (error "An enumeration must contain at least one element."))
 576   (let ((min nil)
 577         (max nil)
 578         (from-alist ())
 579         (prev -1))
 580     (declare (list from-alist))
 581     (dolist (el elements)
 582       (multiple-value-bind (sym val)
 583           (if (listp el)
 584               (values (first el) (second el))
 585               (values el (1+ prev)))
 586         (setf prev val)
 587         (unless (symbolp sym)
 588           (error "The enumeration element ~S is not a symbol." sym))
 589         (unless (integerp val)
 590           (error "The element value ~S is not an integer." val))
 591         (unless (and max (> max val)) (setq max val))
 592         (unless (and min (< min val)) (setq min val))
 593         (when (rassoc val from-alist)
 594           (style-warn "The element value ~S is used more than once." val))
 595         (when (assoc sym from-alist :test #'eq)
 596           (error "The enumeration element ~S is used more than once." sym))
 597         (push (cons sym val) from-alist)))
 598     (let* ((signed (minusp min))
 599            (min-bits (if signed
 600                          (1+ (max (integer-length min)
 601                                   (integer-length max)))
 602                          (integer-length max))))
 603       (when (> min-bits 32)
 604         (error "can't represent enums needing more than 32 bits"))
 605       (setf from-alist (sort from-alist #'< :key #'cdr))
 606       (cond
 607        ;; If range is at least 20% dense, use vector mapping. Crossover
 608        ;; point solely on basis of space would be 25%. Vector mapping
 609        ;; is always faster, so give the benefit of the doubt.
 610        ((< 0.2 (/ (float (length from-alist)) (float (1+ (- max min)))))
 611         ;; If offset is small and ignorable, ignore it to save time.
 612         (when (< 0 min 10) (setq min 0))
 613         (let ((to (make-array (1+ (- max min)))))
 614           (dolist (el from-alist)
 615             (setf (svref to (- (cdr el) min)) (car el)))
 616           (make-alien-enum-type :name name :signed signed
 617                                 :from from-alist :to to :kind
 618                                 :vector :offset (- min))))
 619        (t
 620         (make-alien-enum-type :name name :signed signed
 621                               :from from-alist
 622                               :to (mapcar (lambda (x) (cons (cdr x) (car x)))
 623                                           from-alist)
 624                               :kind :alist))))))
 625
 626 (define-alien-type-method (enum :unparse) (type)
 627   `(enum ,(alien-enum-type-name type)
 628          ,@(let ((prev -1))
 629              (mapcar (lambda (mapping)
 630                        (let ((sym (car mapping))
 631                              (value (cdr mapping)))
 632                          (prog1
 633                              (if (= (1+ prev) value)
 634                                  sym
 635                                  `(,sym ,value))
 636                            (setf prev value))))
 637                      (alien-enum-type-from type)))))
 638
 639 (define-alien-type-method (enum :type=) (type1 type2)
 640   (and (eq (alien-enum-type-name type1)
 641            (alien-enum-type-name type2))
 642        (equal (alien-enum-type-from type1)
 643               (alien-enum-type-from type2))))
 644
 645 (define-alien-type-method (enum :lisp-rep) (type)
 646   `(member ,@(mapcar #'car (alien-enum-type-from type))))
 647
 648 (define-alien-type-method (enum :naturalize-gen) (type alien)
 649   (ecase (alien-enum-type-kind type)
 650     (:vector
 651      `(svref ',(alien-enum-type-to type)
 652              (+ ,alien ,(alien-enum-type-offset type))))
 653     (:alist
 654      `(ecase ,alien
 655         ,@(mapcar (lambda (mapping)
 656                     `(,(car mapping) ',(cdr mapping)))
 657                   (alien-enum-type-to type))))))
 658
 659 (define-alien-type-method (enum :deport-gen) (type value)
 660   `(ecase ,value
 661      ,@(mapcar (lambda (mapping)
 662                  `(,(car mapping) ,(cdr mapping)))
 663                (alien-enum-type-from type))))
 664 \f
 665 ;;;; the FLOAT types
 666
 667 (define-alien-type-class (float)
 668   (type (missing-arg) :type symbol))
 669
 670 (define-alien-type-method (float :unparse) (type)
 671   (alien-float-type-type type))
 672
 673 (define-alien-type-method (float :lisp-rep) (type)
 674   (alien-float-type-type type))
 675
 676 (define-alien-type-method (float :alien-rep) (type context)
 677   (declare (ignore context))
 678   (alien-float-type-type type))
 679
 680 (define-alien-type-method (float :naturalize-gen) (type alien)
 681   (declare (ignore type))
 682   alien)
 683
 684 (define-alien-type-method (float :deport-gen) (type value)
 685   (declare (ignore type))
 686   value)
 687
 688 (define-alien-type-class (single-float :include (float (bits 32))
 689                                        :include-args (type)))
 690
 691 (define-alien-type-translator single-float ()
 692   (make-alien-single-float-type :type 'single-float))
 693
 694 (define-alien-type-method (single-float :extract-gen) (type sap offset)
 695   (declare (ignore type))
 696   `(sap-ref-single ,sap (/ ,offset sb!vm:n-byte-bits)))
 697
 698 (define-alien-type-class (double-float :include (float (bits 64))
 699                                        :include-args (type)))
 700
 701 (define-alien-type-translator double-float ()
 702   (make-alien-double-float-type :type 'double-float))
 703
 704 (define-alien-type-method (double-float :extract-gen) (type sap offset)
 705   (declare (ignore type))
 706   `(sap-ref-double ,sap (/ ,offset sb!vm:n-byte-bits)))
 707
 708 \f
 709 ;;;; the POINTER type
 710
 711 (define-alien-type-class (pointer :include (alien-value (bits
 712                                                          sb!vm:n-machine-word-bits)))
 713   (to nil :type (or alien-type null)))
 714
 715 (define-alien-type-translator * (to &environment env)
 716   (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to env))))
 717
 718 (define-alien-type-method (pointer :unparse) (type)
 719   (let ((to (alien-pointer-type-to type)))
 720     `(* ,(if to
 721              (%unparse-alien-type to)
 722              t))))
 723
 724 (define-alien-type-method (pointer :type=) (type1 type2)
 725   (let ((to1 (alien-pointer-type-to type1))
 726         (to2 (alien-pointer-type-to type2)))
 727     (if to1
 728         (if to2
 729             (alien-type-= to1 to2)
 730             nil)
 731         (null to2))))
 732
 733 (define-alien-type-method (pointer :subtypep) (type1 type2)
 734   (and (alien-pointer-type-p type2)
 735        (let ((to1 (alien-pointer-type-to type1))
 736              (to2 (alien-pointer-type-to type2)))
 737          (if to1
 738              (if to2
 739                  (alien-subtype-p to1 to2)
 740                  t)
 741              (null to2)))))
 742
 743 (define-alien-type-method (pointer :deport-gen) (type value)
 744   (/noshow "doing alien type method POINTER :DEPORT-GEN" type value)
 745   (values
 746    ;; FIXME: old version, highlighted a bug in xc optimization
 747    `(etypecase ,value
 748       (null
 749        (int-sap 0))
 750       (system-area-pointer
 751        ,value)
 752       ((alien ,type)
 753        (alien-sap ,value)))
 754    ;; new version, works around bug in xc optimization
 755    #+nil
 756    `(etypecase ,value
 757       (system-area-pointer
 758        ,value)
 759       ((alien ,type)
 760        (alien-sap ,value))
 761       (null
 762        (int-sap 0)))
 763    `(or null system-area-pointer (alien ,type))))
 764 \f
 765 ;;;; the MEM-BLOCK type
 766
 767 (define-alien-type-class (mem-block :include alien-value))
 768
 769 (define-alien-type-method (mem-block :extract-gen) (type sap offset)
 770   (declare (ignore type))
 771   `(sap+ ,sap (truncate ,offset sb!vm:n-byte-bits)))
 772
 773 (define-alien-type-method (mem-block :deposit-gen) (type sap offset value)
 774   (let ((bits (alien-mem-block-type-bits type)))
 775     (unless bits
 776       (error "can't deposit aliens of type ~S (unknown size)" type))
 777     `(sb!kernel:system-area-ub8-copy ,value 0 ,sap
 778       (truncate ,offset sb!vm:n-byte-bits)
 779       ',(truncate bits sb!vm:n-byte-bits))))
 780 \f
 781 ;;;; the ARRAY type
 782
 783 (define-alien-type-class (array :include mem-block)
 784   (element-type (missing-arg) :type alien-type)
 785   (dimensions (missing-arg) :type list))
 786
 787 (define-alien-type-translator array (ele-type &rest dims &environment env)
 788
 789   (when dims
 790     (unless (typep (first dims) '(or index null))
 791       (error "The first dimension is not a non-negative fixnum or NIL: ~S"
 792              (first dims)))
 793     (let ((loser (find-if-not (lambda (x) (typep x 'index))
 794                               (rest dims))))
 795       (when loser
 796         (error "A dimension is not a non-negative fixnum: ~S" loser))))
 797
 798   (let ((parsed-ele-type (parse-alien-type ele-type env)))
 799     (make-alien-array-type
 800      :element-type parsed-ele-type
 801      :dimensions dims
 802      :alignment (alien-type-alignment parsed-ele-type)
 803      :bits (if (and (alien-type-bits parsed-ele-type)
 804                     (every #'integerp dims))
 805                (* (align-offset (alien-type-bits parsed-ele-type)
 806                                 (alien-type-alignment parsed-ele-type))
 807                   (reduce #'* dims))))))
 808
 809 (define-alien-type-method (array :unparse) (type)
 810   `(array ,(%unparse-alien-type (alien-array-type-element-type type))
 811           ,@(alien-array-type-dimensions type)))
 812
 813 (define-alien-type-method (array :type=) (type1 type2)
 814   (and (equal (alien-array-type-dimensions type1)
 815               (alien-array-type-dimensions type2))
 816        (alien-type-= (alien-array-type-element-type type1)
 817                      (alien-array-type-element-type type2))))
 818
 819 (define-alien-type-method (array :subtypep) (type1 type2)
 820   (and (alien-array-type-p type2)
 821        (let ((dim1 (alien-array-type-dimensions type1))
 822              (dim2 (alien-array-type-dimensions type2)))
 823          (and (= (length dim1) (length dim2))
 824               (or (and dim2
 825                        (null (car dim2))
 826                        (equal (cdr dim1) (cdr dim2)))
 827                   (equal dim1 dim2))
 828               (alien-subtype-p (alien-array-type-element-type type1)
 829                                (alien-array-type-element-type type2))))))
 830 \f
 831 ;;;; the RECORD type
 832
 833 (def!struct (alien-record-field (:copier nil))
 834   (name (missing-arg) :type symbol)
 835   (type (missing-arg) :type alien-type)
 836   (bits nil :type (or unsigned-byte null))
 837   (offset 0 :type unsigned-byte))
 838 (defmethod print-object ((field alien-record-field) stream)
 839   (print-unreadable-object (field stream :type t)
 840     (format stream
 841             "~S ~S~@[:~D~]"
 842             (alien-record-field-type field)
 843             (alien-record-field-name field)
 844             (alien-record-field-bits field))))
 845 (!set-load-form-method alien-record-field (:xc :target))
 846
 847 (define-alien-type-class (record :include mem-block)
 848   (kind :struct :type (member :struct :union))
 849   (name nil :type (or symbol null))
 850   (fields nil :type list))
 851
 852 (define-alien-type-translator struct (name &rest fields &environment env)
 853   (parse-alien-record-type :struct name fields env))
 854
 855 (define-alien-type-translator union (name &rest fields &environment env)
 856   (parse-alien-record-type :union name fields env))
 857
 858 ;;; FIXME: This is really pretty horrible: we avoid creating new
 859 ;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the
 860 ;;; system already. This way forward-references sans fields get
 861 ;;; "updated" for free to contain the field info. Maybe rename
 862 ;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use
 863 ;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729
 864 (defun parse-alien-record-type (kind name fields env)
 865   (declare (type sb!kernel:lexenv-designator env))
 866   (flet ((frob-type (type new-fields alignment bits)
 867            (setf (alien-record-type-fields type) new-fields
 868                  (alien-record-type-alignment type) alignment
 869                  (alien-record-type-bits type) bits)))
 870       (cond (fields
 871              (multiple-value-bind (new-fields alignment bits)
 872                  (parse-alien-record-fields kind fields env)
 873                (let* ((old (and name (auxiliary-alien-type kind name env)))
 874                       (old-fields (and old (alien-record-type-fields old))))
 875                  (when (and old-fields
 876                             (notevery #'record-fields-match-p old-fields new-fields))
 877                    (cerror "Continue, clobbering the old definition."
 878                            "Incompatible alien record type definition~%Old: ~S~%New: ~S"
 879                            (unparse-alien-type old)
 880                            `(,(unparse-alien-record-kind kind)
 881                               ,name
 882                              ,@(let ((*record-types-already-unparsed* '()))
 883                                  (mapcar #'unparse-alien-record-field new-fields))))
 884                    (frob-type old new-fields alignment bits))
 885                  (if old-fields
 886                      old
 887                      (let ((type (or old (make-alien-record-type :name name :kind kind))))
 888                        (when (and name (not old))
 889                          (setf (auxiliary-alien-type kind name env) type))
 890                        (frob-type type new-fields alignment bits)
 891                        type)))))
 892             (name
 893              (or (auxiliary-alien-type kind name env)
 894                  (setf (auxiliary-alien-type kind name env)
 895                        (make-alien-record-type :name name :kind kind))))
 896             (t
 897              (make-alien-record-type :kind kind)))))
 898
 899 ;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and union
 900 ;;; types. KIND is the kind we are paring the fields of, and FIELDS is the
 901 ;;; list of field specifications.
 902 ;;;
 903 ;;; Result is a list of field objects, overall alignment, and number of bits
 904 (defun parse-alien-record-fields (kind fields env)
 905   (declare (type list fields))
 906   (let ((total-bits 0)
 907         (overall-alignment 1)
 908         (parsed-fields nil))
 909     (dolist (field fields)
 910       (destructuring-bind (var type &key alignment bits offset) field
 911         (declare (ignore bits))
 912         (let* ((field-type (parse-alien-type type env))
 913                (bits (alien-type-bits field-type))
 914                (parsed-field
 915                 (make-alien-record-field :type field-type
 916                                          :name var)))
 917           (unless alignment
 918             (setf alignment (alien-type-alignment field-type)))
 919           (push parsed-field parsed-fields)
 920           (when (null bits)
 921             (error "unknown size: ~S" (unparse-alien-type field-type)))
 922           (when (null alignment)
 923             (error "unknown alignment: ~S" (unparse-alien-type field-type)))
 924           (setf overall-alignment (max overall-alignment alignment))
 925           (ecase kind
 926             (:struct
 927              (let ((offset (or offset (align-offset total-bits alignment))))
 928                (setf (alien-record-field-offset parsed-field) offset)
 929                (setf total-bits (+ offset bits))))
 930             (:union
 931              (setf total-bits (max total-bits bits)))))))
 932     (values (nreverse parsed-fields)
 933             overall-alignment
 934             (align-offset total-bits overall-alignment))))
 935
 936 (define-alien-type-method (record :unparse) (type)
 937   `(,(unparse-alien-record-kind (alien-record-type-kind type))
 938     ,(alien-record-type-name type)
 939     ,@(unless (member type *record-types-already-unparsed* :test #'eq)
 940         (push type *record-types-already-unparsed*)
 941         (mapcar #'unparse-alien-record-field
 942                 (alien-record-type-fields type)))))
 943
 944 (defun unparse-alien-record-kind (kind)
 945   (case kind
 946     (:struct 'struct)
 947     (:union 'union)
 948     (t '???)))
 949
 950 (defun unparse-alien-record-field (field)
 951   `(,(alien-record-field-name field)
 952      ,(%unparse-alien-type (alien-record-field-type field))
 953      ,@(when (alien-record-field-bits field)
 954              (list :bits (alien-record-field-bits field)))
 955      ,@(when (alien-record-field-offset field)
 956              (list :offset (alien-record-field-offset field)))))
 957
 958 ;;; Test the record fields. Keep a hashtable table of already compared
 959 ;;; types to detect cycles.
 960 (defun record-fields-match-p (field1 field2)
 961   (and (eq (alien-record-field-name field1)
 962            (alien-record-field-name field2))
 963        (eql (alien-record-field-bits field1)
 964             (alien-record-field-bits field2))
 965        (eql (alien-record-field-offset field1)
 966             (alien-record-field-offset field2))
 967        (alien-type-= (alien-record-field-type field1)
 968                      (alien-record-field-type field2))))
 969
 970 (defvar *alien-type-matches* nil
 971   "A hashtable used to detect cycles while comparing record types.")
 972
 973 (define-alien-type-method (record :type=) (type1 type2)
 974   (and (eq (alien-record-type-name type1)
 975            (alien-record-type-name type2))
 976        (eq (alien-record-type-kind type1)
 977            (alien-record-type-kind type2))
 978        (eql (alien-type-bits type1)
 979             (alien-type-bits type2))
 980        (eql (alien-type-alignment type1)
 981             (alien-type-alignment type2))
 982        (flet ((match-fields (&optional old)
 983                 (setf (gethash type1 *alien-type-matches*) (cons type2 old))
 984                 (every #'record-fields-match-p
 985                        (alien-record-type-fields type1)
 986                        (alien-record-type-fields type2))))
 987          (if *alien-type-matches*
 988              (let ((types (gethash type1 *alien-type-matches*)))
 989                (or (memq type2 types) (match-fields types)))
 990              (let ((*alien-type-matches* (make-hash-table :test #'eq)))
 991                (match-fields))))))
 992 \f
 993 ;;;; the FUNCTION and VALUES alien types
 994
 995 ;;; Calling-convention spec, typically one of predefined keywords.
 996 ;;; Add or remove as needed for target platform.  It makes sense to
 997 ;;; support :cdecl everywhere.
 998 ;;;
 999 ;;; Null convention is supposed to be platform-specific most-universal
1000 ;;; callout convention. For x86, SBCL calls foreign functions in a way
1001 ;;; allowing them to be either stdcall or cdecl; null convention is
1002 ;;; appropriate here, as it is for specifying callbacks that could be
1003 ;;; accepted by foreign code both in cdecl and stdcall form.
1004 (def!type calling-convention () `(or null (member :stdcall :cdecl)))
1005
1006 ;;; Convention could be a values type class, stored at result-type.
1007 ;;; However, it seems appropriate only for epilogue-related
1008 ;;; conventions, those not influencing incoming arg passing.
1009 ;;;
1010 ;;; As of x86's :stdcall and :cdecl, supported by now, both are
1011 ;;; epilogue-related, but future extensions (like :fastcall and
1012 ;;; miscellaneous non-x86 stuff) might affect incoming argument
1013 ;;; translation as well.
1014
1015 (define-alien-type-class (fun :include mem-block)
1016   (result-type (missing-arg) :type alien-type)
1017   (arg-types (missing-arg) :type list)
1018   ;; The 3rd-party CFFI library uses presence of &REST in an argument list
1019   ;; as indicative of "..." in the C prototype. We can record that too.
1020   (varargs nil :type (or boolean (eql :unspecified)))
1021   (stub nil :type (or null function))
1022   (convention nil :type calling-convention))
1023 ;;; The safe default is to assume that everything is varargs.
1024 ;;; On x86-64 we have to emit a spurious instruction because of it.
1025 ;;; So until all users fix their lambda lists to be explicit about &REST
1026 ;;; (which is never gonna happen), be backward-compatible, unless
1027 ;;; locally toggled to get rid of noise instructions if so inclined.
1028 (defglobal *alien-fun-type-varargs-default* :unspecified)
1029
1030 ;;; KLUDGE: non-intrusive, backward-compatible way to allow calling
1031 ;;; convention specification for function types is unobvious.
1032 ;;;
1033 ;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list
1034 ;;; starting with a convention keyword; its second item is a real
1035 ;;; result-type in this case. If convention is ever to become a part
1036 ;;; of result-type, such a syntax can be retained.
1037
1038 (define-alien-type-translator function (result-type &rest arg-types
1039                                                     &environment env)
1040   (binding* (((bare-result-type calling-convention)
1041               (typecase result-type
1042                 ((cons calling-convention *)
1043                  (values (second result-type) (first result-type)))
1044                 (t result-type)))
1045              (varargs (eq (car (last arg-types)) '&rest)))
1046     (make-alien-fun-type
1047      :convention calling-convention
1048      :result-type (let ((*values-type-okay* t))
1049                     (parse-alien-type bare-result-type env))
1050      :varargs (or varargs *alien-fun-type-varargs-default*)
1051      :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
1052                         (if varargs (butlast arg-types) arg-types)))))
1053
1054 (define-alien-type-method (fun :unparse) (type)
1055   `(function ,(let ((result-type
1056                      (%unparse-alien-type (alien-fun-type-result-type type)))
1057                     (convention (alien-fun-type-convention type)))
1058                 (if convention (list convention result-type)
1059                     result-type))
1060              ,@(mapcar #'%unparse-alien-type
1061                        (alien-fun-type-arg-types type))
1062              ,@(when (alien-fun-type-varargs type)
1063                  '(&rest))))
1064
1065 (define-alien-type-method (fun :type=) (type1 type2)
1066   (and (alien-type-= (alien-fun-type-result-type type1)
1067                      (alien-fun-type-result-type type2))
1068        (eq (alien-fun-type-convention type1)
1069            (alien-fun-type-convention type2))
1070        (= (length (alien-fun-type-arg-types type1))
1071           (length (alien-fun-type-arg-types type2)))
1072        (every #'alien-type-=
1073               (alien-fun-type-arg-types type1)
1074               (alien-fun-type-arg-types type2))))
1075
1076 (define-alien-type-class (values)
1077   (values (missing-arg) :type list))
1078
1079 (define-alien-type-translator values (&rest values &environment env)
1080   (unless *values-type-okay*
1081     (error "cannot use values types here"))
1082   (let ((*values-type-okay* nil))
1083     (make-alien-values-type
1084      :values (mapcar (lambda (alien-type) (parse-alien-type alien-type env))
1085                      values))))
1086
1087 (define-alien-type-method (values :unparse) (type)
1088   `(values ,@(mapcar #'%unparse-alien-type
1089                      (alien-values-type-values type))))
1090
1091 (define-alien-type-method (values :type=) (type1 type2)
1092   (and (= (length (alien-values-type-values type1))
1093           (length (alien-values-type-values type2)))
1094        (every #'alien-type-=
1095               (alien-values-type-values type1)
1096               (alien-values-type-values type2))))
1097 \f
1098 ;;;; a structure definition needed both in the target and in the
1099 ;;;; cross-compilation host
1100
1101 ;;; information about local aliens. The WITH-ALIEN macro builds one of
1102 ;;; these structures and LOCAL-ALIEN and friends communicate
1103 ;;; information about how that local alien is represented.
1104 (def!struct (local-alien-info
1105              (:copier nil)
1106              (:constructor make-local-alien-info
1107                            (&key type force-to-memory-p
1108                             &aux (force-to-memory-p (or force-to-memory-p
1109                                                         (alien-array-type-p type)
1110                                                         (alien-record-type-p type))))))
1111   ;; the type of the local alien
1112   (type (missing-arg) :type alien-type)
1113   ;; Must this local alien be forced into memory? Using the ADDR macro
1114   ;; on a local alien will set this.
1115   (force-to-memory-p nil :type (member t nil)))
1116 (!set-load-form-method local-alien-info (:xc :target))
1117 (defmethod print-object ((info local-alien-info) stream)
1118   (print-unreadable-object (info stream :type t)
1119     (format stream
1120             "~:[~;(forced to stack) ~]~S"
1121             (local-alien-info-force-to-memory-p info)
1122             (unparse-alien-type (local-alien-info-type info)))))
1123 \f
1124 ;;;; the ADDR macro
1125
1126 (sb!xc:defmacro addr (expr &environment env)
1127   "Return an Alien pointer to the data addressed by Expr, which must be a call
1128    to SLOT or DEREF, or a reference to an Alien variable."
1129   (let ((form (%macroexpand expr env)))
1130     (or (typecase form
1131           (cons
1132            (case (car form)
1133              (slot
1134               (cons '%slot-addr (cdr form)))
1135              (deref
1136               (cons '%deref-addr (cdr form)))
1137              (%heap-alien
1138               (cons '%heap-alien-addr (cdr form)))
1139              (local-alien
1140               (let ((info (let ((info-arg (second form)))
1141                             (and (consp info-arg)
1142                                  (eq (car info-arg) 'quote)
1143                                  (second info-arg)))))
1144                 (unless (local-alien-info-p info)
1145                   (error "Something is wrong, LOCAL-ALIEN-INFO not found: ~S"
1146                          form))
1147                 (setf (local-alien-info-force-to-memory-p info) t))
1148               (cons '%local-alien-addr (cdr form)))))
1149           (symbol
1150            (let ((kind (info :variable :kind form)))
1151              (when (eq kind :alien)
1152                `(%heap-alien-addr ',(info :variable :alien-info form))))))
1153         (error "~S is not a valid L-value." form))))
1154
1155 (/show0 "host-alieneval.lisp end of file")