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-expander (name expansion)
  13   (declare (optimize safety))
  14   ;; Dummy implementation of SET-CLOSURE-NAME for the host.
  15   (flet (#+sb-xc-host (set-closure-name (f name) (declare (ignore name)) f))
  16     (set-closure-name
  17      (lambda (whole)
  18        ;; NB: It does not in general work to set the lambda-list of a closure,
  19        ;; but all constant-type-expanders have NIL as the lambda-list
  20        ;; because if they didn't, they wouldn't be constant.
  21        (declare (sb!c::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      `(type-expander ,name))))
  28
  29 ;; Can't have a function called SIMPLE-TYPE-ERROR or TYPE-ERROR...
  30 ;; FUNCTION returning NIL is as good as SFUNCTION returning NIL,
  31 ;; so we don't care that this can't use (FTYPE (SFUNCTION ...)).
  32 ;; But do we really need this? It's not highly useful.
  33 (declaim (ftype (function (t t t &rest t) #+(and sb-xc-host ccl) *
  34                                           #-(and sb-xc-host ccl) nil) bad-type))
  35 (defun bad-type (datum type control &rest arguments)
  36   (error 'simple-type-error
  37          :datum datum
  38          :expected-type type
  39          :format-control control
  40          :format-arguments arguments))
  41
  42 (defmacro sb!xc:deftype (&whole form name lambda-list &body body
  43                          &environment env)
  44   "Define a new type, with syntax like DEFMACRO."
  45   (declare (ignore env))
  46   (unless (symbolp name)
  47     (bad-type name 'symbol "Type name is not a symbol:~%  ~S"
  48               form))
  49   (multiple-value-bind (expander-form doc source-location-form)
  50       (multiple-value-bind (forms decls doc) (parse-body body t)
  51         (acond ((and (not lambda-list) (not decls)
  52                     (let ((expr `(progn ,@forms)))
  53                       ;; While CONSTANTP works early, %MACROEXPAND does not,
  54                       ;; so we can't pass ENV because it'd try to macroexpand.
  55                       (if (sb!xc:constantp expr) expr)))
  56                 #-sb-xc-host
  57                 (check-deprecated-type (constant-form-value it))
  58                 (values `(constant-type-expander ',name ,it) doc
  59                         '(sb!c:source-location)))
  60                (t
  61                 ;; FIXME: it seems non-ANSI-compliant to pretend every lexenv
  62                 ;; is nil. See also lp#309140.
  63                 ;; Source-location and docstring are associated with the lambda
  64                 ;; so we don't store them separately.
  65                 (make-macro-lambda `(type-expander ,name)
  66                                    lambda-list body 'deftype name
  67                                    :doc-string-allowed :external
  68                                    :environment :ignore))))
  69     ;; Maybe kill docstring, but only under the cross-compiler.
  70     #!+(and (not sb-doc) (host-feature sb-xc-host)) (setq doc nil)
  71     `(progn
  72        (eval-when (:compile-toplevel :load-toplevel :execute)
  73          (%compiler-deftype ',name ,expander-form ,source-location-form
  74                             ,@(when doc `(,doc)))))))