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