src/pcl/dlisp3.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 software originally released by Xerox
   5 ;;;; Corporation. Copyright and release statements follow. Later modifications
   6 ;;;; to the software are in the public domain and are provided with
   7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
   8 ;;;; information.
   9
  10 ;;;; copyright information from original PCL sources:
  11 ;;;;
  12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  13 ;;;; All rights reserved.
  14 ;;;;
  15 ;;;; Use and copying of this software and preparation of derivative works based
  16 ;;;; upon this software are permitted. Any distribution of this software or
  17 ;;;; derivative works must comply with all applicable United States export
  18 ;;;; control laws.
  19 ;;;;
  20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  21 ;;;; warranty about the software, its performance or its conformity to any
  22 ;;;; specification.
  23
  24 (in-package "SB-PCL")
  25 \f
  26 (eval-when (:compile-toplevel :load-toplevel :execute)
  27 (defparameter *checking-or-caching-list*
  28   '((t nil (class) nil)
  29     (t nil (class class) nil)
  30     (t nil (class class class) nil)
  31     (t nil (class class t) nil)
  32     (t nil (class class t t) nil)
  33     (t nil (class class t t t) nil)
  34     (t nil (class t) nil)
  35     (t nil (class t t) nil)
  36     (t nil (class t t t) nil)
  37     (t nil (class t t t t) nil)
  38     (t nil (class t t t t t) nil)
  39     (t nil (class t t t t t t) nil)
  40     (t nil (t class) nil)
  41     (t nil (t class t) nil)
  42     (t nil (t t class) nil)
  43     (t nil (class) t)
  44     (t nil (class class) t)
  45     (t nil (class t) t)
  46     (t nil (class t t) t)
  47     (t nil (class t t t) t)
  48     (t nil (t class) t)
  49     (t t (class) nil)
  50     (t t (class class) nil)
  51     (t t (class class class) nil)
  52     (nil nil (class) nil)
  53     (nil nil (class class) nil)
  54     (nil nil (class class t) nil)
  55     (nil nil (class class t t) nil)
  56     (nil nil (class t) nil)
  57     (nil nil (t class t) nil)
  58     (nil nil (class) t)
  59     (nil nil (class class) t)))
  60 ) ; EVAL-WHEN
  61
  62 (defmacro make-checking-or-caching-function-list ()
  63   `(list ,@(mapcar (lambda (key)
  64                      `(cons ',key (emit-checking-or-caching-macro ,@key)))
  65                    *checking-or-caching-list*)))
  66
  67 ;;; Rather than compiling the constructors here, just tickle the range
  68 ;;; of shapes defined above, leaving the generation of the
  69 ;;; constructors to precompile-dfun-constructors.
  70 (dolist (key *checking-or-caching-list*)
  71   (destructuring-bind (cached-emf-p return-value-p metatypes applyp) key
  72     (multiple-value-bind (args generator)
  73         (if cached-emf-p
  74             (if return-value-p
  75                 (values (list metatypes) 'emit-constant-value)
  76                 (values (list metatypes applyp) 'emit-caching))
  77             (if return-value-p
  78                 (values (list metatypes) 'emit-in-checking-p)
  79                 (values (list metatypes applyp) 'emit-checking)))
  80       (apply #'get-dfun-constructor generator args))))