src/code/early-alieneval.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!ALIEN")
  11
  12 (defvar *alien-type-classes* (make-hash-table :test 'eq))
  13
  14 (defvar *new-auxiliary-types* nil)
  15
  16 ;;; the list of record types that have already been unparsed. This is
  17 ;;; used to keep from outputting the slots again if the same structure
  18 ;;; shows up twice.
  19 (defvar *record-types-already-unparsed*)
  20
  21 ;;; not documented in CMU CL:-(
  22 ;;;
  23 ;;; reverse engineering observations:
  24 ;;;   * seems to be set when translating return values
  25 ;;;   * seems to enable the translation of (VALUES), which is the
  26 ;;;     Lisp idiom for C's return type "void" (which is likely
  27 ;;;     why it's set when when translating return values)
  28 (defvar *values-type-okay* nil)
  29
  30 (defvar *default-c-string-external-format* nil)
  31
  32 ;;; Frame pointer, program counter conses. In each thread it's bound
  33 ;;; locally or not bound at all.
  34 (defvar *saved-fp-and-pcs*)
  35
  36 #!+c-stack-is-control-stack
  37 (declaim (inline invoke-with-saved-fp-and-pc))
  38 #!+c-stack-is-control-stack
  39 (defun invoke-with-saved-fp-and-pc (fn)
  40   (declare #-sb-xc-host (muffle-conditions compiler-note)
  41            (optimize (speed 3)))
  42   (let ((fp-and-pc (make-array 2 :element-type 'word)))
  43     (declare (truly-dynamic-extent fp-and-pc))
  44     (setf (aref fp-and-pc 0) (sb!kernel:get-lisp-obj-address
  45                               (sb!kernel:%caller-frame))
  46           (aref fp-and-pc 1) (sap-int (sb!kernel:%caller-pc)))
  47     (let ((*saved-fp-and-pcs* (if (boundp '*saved-fp-and-pcs*)
  48                                   (cons fp-and-pc *saved-fp-and-pcs*)
  49                                   (list fp-and-pc))))
  50       (declare (truly-dynamic-extent *saved-fp-and-pcs*))
  51       (funcall fn))))
  52
  53 (defun find-saved-fp-and-pc (fp)
  54   (when (boundp '*saved-fp-and-pcs*)
  55     (dolist (x *saved-fp-and-pcs*)
  56       (declare (type (simple-array word (2)) x))
  57       (when (#!+stack-grows-downward-not-upward
  58              sap>
  59              #!-stack-grows-downward-not-upward
  60              sap<
  61              (int-sap (aref x 0)) fp)
  62         (return (values (int-sap (aref x 0)) (int-sap (aref x 1))))))))
  63