src/code/late-alieneval.lisp

   1 ;;;; This file contains parts of the ALIEN implementation that
   2 ;;;; are not part of the compiler, but depend on it.
   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 (defmacro make-alien (type &optional size &environment env)
  16   #!+sb-doc
  17   "Allocate an alien of type TYPE and return an alien pointer to it. If SIZE
  18 is supplied, how it is interpreted depends on TYPE. If TYPE is an array type,
  19 SIZE is used as the first dimension for the allocated array. If TYPE is not an
  20 array, then SIZE is the number of elements to allocate. The memory is
  21 allocated using ``malloc'', so it can be passed to foreign functions which use
  22 ``free''."
  23   (let ((alien-type (if (alien-type-p type)
  24                         type
  25                         (parse-alien-type type env))))
  26     (multiple-value-bind (size-expr element-type)
  27         (if (alien-array-type-p alien-type)
  28             (let ((dims (alien-array-type-dimensions alien-type)))
  29               (cond
  30                 (size
  31                  (unless dims
  32                    (error
  33                     "cannot override the size of zero-dimensional arrays"))
  34                  (when (constantp size)
  35                    (setf alien-type (copy-alien-array-type alien-type))
  36                    (setf (alien-array-type-dimensions alien-type)
  37                          (cons (constant-form-value size) (cdr dims)))))
  38                 (dims
  39                  (setf size (car dims)))
  40                 (t
  41                  (setf size 1)))
  42               (values `(* ,size ,@(cdr dims))
  43                       (alien-array-type-element-type alien-type)))
  44             (values (or size 1) alien-type))
  45       (let ((bits (alien-type-bits element-type))
  46             (alignment (alien-type-alignment element-type)))
  47         (unless bits
  48           (error "The size of ~S is unknown."
  49                  (unparse-alien-type element-type)))
  50         (unless alignment
  51           (error "The alignment of ~S is unknown."
  52                  (unparse-alien-type element-type)))
  53         (let ((alloc-form `(%sap-alien (%make-alien (* ,(align-offset bits alignment)
  54                                                        ,size-expr))
  55                                        ',(make-alien-pointer-type :to alien-type))))
  56           (if (sb!c:policy env (> speed 1))
  57               alloc-form
  58               `(locally (declare (muffle-conditions compiler-note))
  59                  ,alloc-form)))))))