src/interpreter/checkfuns.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-INTERPRETER")
  11
  12 ;;; The same as TYPE-ERROR but also show the variable name.
  13 (define-condition interpreter-type-error (type-error)
  14   ((operation :reader type-error-operation :initarg :operation)
  15    (symbol :reader type-error-symbol :initarg :symbol))
  16   (:report
  17    (lambda (condition stream)
  18      (format stream
  19              (ecase (type-error-operation condition)
  20                (write "~@<The value ~S for ~A is not of type ~2I~_~S.~:>")
  21                (read "~@<The value of ~*~A, ~0@*~S, is not of type ~2I~_~*~S.~:>"))
  22              (type-error-datum condition)
  23              (type-error-symbol condition)
  24              (type-error-expected-type condition)))))
  25
  26 ;;; We need a bidirectional mapping between "important" CTYPEs and
  27 ;;; functions that efficiently test the type, so that we aren't forced
  28 ;;; to redundantly store both.
  29 ;;; For example if X is declared of type INTEGER and we represented
  30 ;;; that as #'INTEGERP, it should be possible to locally declare
  31 ;;; that X is (MOD n) and compute that the intersection is just (MOD n),
  32 ;;; which requires that we know that #'INTEGERP is the test for INTEGER.
  33 ;;;
  34 ;;; We also need to ensure that TYPE is checkable at all,
  35 ;;; because FUNCTION types are not good for answering questions about
  36 ;;; the type of an object, only for declaring the type.
  37 ;;; Passing ":STRICT NIL" to %%TYPEP won't work, because interpreted functions
  38 ;;; know nothing about their type, and the non-strict test uses %FUN-TYPE.
  39 ;;;
  40 ;;; The easy way of simplifying hairy FUNCTION types, namely
  41 ;;; binding *UNPARSE-FUN-TYPE-SIMPLIFY* to T and then doing:
  42 ;;;   (VALUES-SPECIFIER-TYPE (TYPE-SPECIFIER x))
  43 ;;; does not work, because ALIEN-TYPE-TYPES are incompatibly altered -
  44 ;;; they fail to retain correct offsets that were manually specified.
  45 ;;; Probably nobody ever cared that round-tripping was not possible,
  46 ;;; because that is not an operation that the compiler needs to do,
  47 ;;; though that's surprising because plenty of code exists that normalizes
  48 ;;; types by unparsing and re-parsing.
  49 ;;;
  50 (defun type-checker (type)
  51   (labels
  52       ((get-unary-predicate (type)
  53          (dolist (entry sb-c::*backend-type-predicates*)
  54            ;; Slowish, because there's no hashtable for TYPE=, but better
  55            ;; than the alternative of not using these at all!
  56            (when (type= type (car entry))
  57              (return (symbol-function (cdr entry))))))
  58        (simplify (type)
  59          (etypecase type
  60            ((or named-type numeric-type member-type classoid
  61                 character-set-type unknown-type hairy-type
  62                 alien-type-type #+sb-simd-pack simd-pack-type)
  63             type)
  64            (fun-type (specifier-type 'function))
  65            (compound-type
  66             (let* ((original (compound-type-types type))
  67                    (new (mapcar #'simplify original)))
  68               (if (every #'eq original new)
  69                   type
  70                   (apply (if (union-type-p type) #'type-union #'type-intersection)
  71                          new))))
  72            (cons-type
  73             (let* ((old-car (cons-type-car-type type))
  74                    (new-car (simplify old-car))
  75                    (old-cdr (cons-type-cdr-type type))
  76                    (new-cdr (simplify old-cdr)))
  77               (if (and (eq old-car new-car) (eq old-cdr new-cdr))
  78                   type
  79                   (make-cons-type new-car new-cdr))))
  80            (values-type
  81             (let* ((old-req (values-type-required type))
  82                    (new-req (mapcar #'simplify old-req))
  83                    (old-opt (values-type-optional type))
  84                    (new-opt (mapcar #'simplify old-opt))
  85                    (old-rest (values-type-rest type))
  86                    (new-rest (when old-rest (simplify old-rest))))
  87               ;; VALUES types that are not fun-types can't have &KEY.
  88               (aver (and (null (sb-kernel::values-type-keyp type))
  89                          (null (sb-kernel::values-type-keywords type))
  90                          (null (sb-kernel::values-type-allowp type))))
  91               (if (and (every #'eq old-req new-req)
  92                        (every #'eq old-opt new-opt)
  93                        (eq old-rest new-rest))
  94                   type
  95                   (make-values-type :required new-req
  96                                     :optional new-opt
  97                                     :rest new-rest))))
  98            (array-type
  99             (let* ((original (array-type-element-type type))
 100                    (new (simplify original)))
 101               (cond ((eq new original) type)
 102                     (t
 103                      ;; It must have been an (ARRAY T).
 104                      (aver (eq (array-type-specialized-element-type type)
 105                                *universal-type*))
 106                      (sb-kernel::%make-array-type (array-type-dimensions type)
 107                                                   (array-type-complexp type)
 108                                                   new *universal-type*)))))
 109            (negation-type
 110             (let* ((original (negation-type-type type))
 111                    (new (simplify original)))
 112               (if (eq new original) type (make-negation-type new)))))))
 113     (or (get-unary-predicate type)
 114         ;; If we simplify, try again for a predicate.
 115         (let ((simplified (simplify type)))
 116           (or (get-unary-predicate simplified) simplified)))))
 117
 118 (defun specifier-from-checkfun (fun-or-ctype)
 119   (if (functionp fun-or-ctype)
 120       (or (gethash (%fun-name fun-or-ctype)
 121                    sb-c::*backend-predicate-types*)
 122           (bug "No type specifier for function ~S" fun-or-ctype))
 123       (type-specifier fun-or-ctype)))
 124
 125 (defun typecheck-fail (symbol value type)
 126   (error 'interpreter-type-error
 127          :datum value :expected-type (specifier-from-checkfun type)
 128          :symbol symbol :operation 'write))
 129
 130 (defun typecheck-fail/ref (symbol value type)
 131   (error 'interpreter-type-error
 132          :datum value :expected-type (specifier-from-checkfun type)
 133          :symbol symbol :operation 'read))
 134
 135 ;; Signal an error about a form that was expected to produce multiple values
 136 ;; that did not accord with their type restriction.
 137 (defun values-typecheck-fail (type &rest values)
 138   ;; Maybe want to say "Received N but the VALUES type specifies M" ?
 139   (let ((spec (type-specifier type)))
 140     (cond ((not values)
 141            (error 'simple-type-error
 142                   :format-control "Received no value for ~S"
 143                   :format-arguments (list spec)))
 144           ((not (cdr values))
 145            (error 'simple-type-error
 146                   :format-control
 147                   "The value ~S does not match the specifier ~_~S"
 148                   :format-arguments (list (car values) spec)))
 149           (t
 150            (error 'simple-type-error
 151                   :datum values
 152                   :expected-type spec
 153                   :format-control
 154                   "The values ~{~S~^, ~} do not match the specifier ~_~S"
 155                   :format-arguments (list values spec))))))
 156
 157 (declaim (inline itypep)) ; Interpreter TYPEP
 158 ;;; A test "function" can be be either genuinely a function, or a CTYPE.
 159 (defun itypep (object test)
 160   (if (functionp test)
 161       (funcall test object)
 162       (%%typep object test)))
 163
 164 ;; Check that VALUE is of the expected type and return it or signal an error.
 165 (declaim (inline enforce-type))
 166 (defun enforce-type (value type-vector index symbol-vector)
 167   (unless (eql type-vector +none+)
 168     (let ((type (svref type-vector index)))
 169       (unless (eql type +none+)
 170         (unless (itypep value type)
 171           (typecheck-fail (car (svref symbol-vector index)) value type)))))
 172   value)
 173
 174 ;;;; Copy-and-pasted from sb-eval:
 175
 176 ;;; We need separate conditions for the different *-TOO-COMPLEX-ERRORs to
 177 ;;; avoid spuriously triggering the handler in EVAL-IN-NATIVE-ENVIRONMENT
 178 ;;; on code like:
 179 ;;;
 180 ;;;   (let ((sb-ext:*evaluator-mode* :interpret))
 181 ;;;     (let ((fun (eval '(let ((a 1)) (lambda () a)))))
 182 ;;;         (eval `(compile nil ,fun))))
 183 ;;;
 184 ;;; FIXME: should these be exported?
 185 (define-condition interpreter-environment-too-complex-error (simple-error)
 186   ())
 187 (define-condition compiler-environment-too-complex-error (simple-error)
 188   ())
 189
 190 (defun ip-error (format-control &rest format-arguments)
 191   (error 'sb-int:simple-program-error
 192          :format-control format-control
 193          :format-arguments format-arguments))