src/compiler/deftype.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!IMPL")
  11
  12 (defun constant-type-body-p (forms)
  13   (destructuring-bind (&optional first . rest) forms
  14     (and first (not rest)
  15          (or (member first '(t nil))
  16              (and (consp first) (eq (car first) 'quote))))))
  17
  18 (defun constant-type-expander (expansion)
  19   (declare (optimize safety))
  20   (lambda (whole)
  21     (declare (sb!c::lambda-list ())) ; for introspection of DEFTYPE lambda-list
  22     (if (cdr whole)
  23         (error 'sb!kernel::arg-count-error
  24                :kind 'deftype :name (car whole) :args (cdr whole)
  25                :lambda-list '() :minimum 0 :maximum 0)
  26         expansion)))
  27
  28 (defvar !*xc-processed-deftypes* nil)
  29 (def!macro sb!xc:deftype (&whole form name lambda-list &body body)
  30   #!+sb-doc
  31   "Define a new type, with syntax like DEFMACRO."
  32   (unless (symbolp name)
  33     (bad-type name 'symbol "Type name is not a symbol:~%  ~S"
  34               form))
  35   (multiple-value-bind (expander-form doc source-location-form)
  36       (multiple-value-bind (forms decls doc) (parse-body body)
  37         ;; FIXME: We could use CONSTANTP here to deal with slightly more
  38         ;; complex deftypes using CONSTANT-TYPE-EXPANDER, but that XC:CONSTANTP
  39         ;; is not availble early enough.
  40         (if (and (not lambda-list) (not decls) (constant-type-body-p forms))
  41             (progn
  42               #-sb-xc-host (check-deprecated-type
  43                             (typecase forms
  44                               ((cons (cons (eql quote))) (cadar forms))
  45                               ((cons symbol)             (car forms))))
  46               (values `(constant-type-expander ,(car forms)) doc
  47                       '(sb!c:source-location)))
  48             ;; FIXME: it seems non-ANSI-compliant to pretend every lexenv
  49             ;; is nil. See also lp#309140.
  50             (make-macro-lambda `(type-expander ,name)
  51                                lambda-list body 'deftype name
  52                                :doc-string-allowed :external
  53                                :environment :ignore)))
  54     `(progn
  55        #+sb-xc-host
  56        (eval-when (:compile-toplevel)
  57          ;; This needs to be in the macroexpansion when building the xc,
  58          ;; but not when running the xc. But it's harmless in the latter.
  59          (pushnew ',name !*xc-processed-deftypes*))
  60        (eval-when (:compile-toplevel :load-toplevel :execute)
  61          (%compiler-deftype ',name ,expander-form ,source-location-form
  62                             ,@(when doc `(,doc)))))))