src/pcl/dlisp2.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
  26 ;;;; The whole of this file is dead code as long as *optimize-cache-functions-p*
  27 ;;;; is true, which it currently _always_ is.
  28
  29 \f
  30 (defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p)
  31   (values
  32    (ecase reader/writer
  33      (:reader (ecase 1-or-2-class
  34                 (1 (if class-slot-p
  35                        (emit-reader/writer-macro :reader 1 t)
  36                        (emit-reader/writer-macro :reader 1 nil)))
  37                 (2 (if class-slot-p
  38                        (emit-reader/writer-macro :reader 2 t)
  39                        (emit-reader/writer-macro :reader 2 nil)))))
  40      (:writer (ecase 1-or-2-class
  41                 (1 (if class-slot-p
  42                        (emit-reader/writer-macro :writer 1 t)
  43                        (emit-reader/writer-macro :writer 1 nil)))
  44                 (2 (if class-slot-p
  45                        (emit-reader/writer-macro :writer 2 t)
  46                        (emit-reader/writer-macro :writer 2 nil)))))
  47      (:boundp (ecase 1-or-2-class
  48                 (1 (if class-slot-p
  49                        (emit-reader/writer-macro :boundp 1 t)
  50                        (emit-reader/writer-macro :boundp 1 nil)))
  51                 (2 (if class-slot-p
  52                        (emit-reader/writer-macro :boundp 2 t)
  53                        (emit-reader/writer-macro :boundp 2 nil))))))
  54    nil))
  55
  56 (defun emit-one-or-n-index-reader/writer-function
  57     (reader/writer cached-index-p class-slot-p)
  58   (values
  59    (ecase reader/writer
  60      (:reader (if cached-index-p
  61                   (if class-slot-p
  62                       (emit-one-or-n-index-reader/writer-macro :reader t t)
  63                       (emit-one-or-n-index-reader/writer-macro :reader t nil))
  64                   (if class-slot-p
  65                       (emit-one-or-n-index-reader/writer-macro :reader nil t)
  66                       (emit-one-or-n-index-reader/writer-macro :reader nil nil))))
  67      (:writer (if cached-index-p
  68                   (if class-slot-p
  69                       (emit-one-or-n-index-reader/writer-macro :writer t t)
  70                       (emit-one-or-n-index-reader/writer-macro :writer t nil))
  71                   (if class-slot-p
  72                       (emit-one-or-n-index-reader/writer-macro :writer nil t)
  73                       (emit-one-or-n-index-reader/writer-macro :writer nil nil))))
  74      (:boundp (if cached-index-p
  75                   (if class-slot-p
  76                       (emit-one-or-n-index-reader/writer-macro :boundp t t)
  77                       (emit-one-or-n-index-reader/writer-macro :boundp t nil))
  78                   (if class-slot-p
  79                       (emit-one-or-n-index-reader/writer-macro :boundp nil t)
  80                       (emit-one-or-n-index-reader/writer-macro :boundp nil nil)))))
  81    nil))
  82
  83 (defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp)
  84   (values (emit-checking-or-caching-function-preliminary
  85            cached-emf-p return-value-p metatypes applyp)
  86           t))
  87
  88 (defvar *not-in-cache* (make-symbol "not in cache"))
  89
  90 (defun emit-checking-or-caching-function-preliminary
  91     (cached-emf-p return-value-p metatypes applyp)
  92   (declare (ignore applyp))
  93   (if cached-emf-p
  94       (lambda (cache miss-fn)
  95         (declare (type function miss-fn))
  96         #'(lambda (&rest args)
  97             (declare #.*optimize-speed*)
  98             (with-dfun-wrappers (args metatypes)
  99               (dfun-wrappers invalid-wrapper-p)
 100               (apply miss-fn args)
 101               (if invalid-wrapper-p
 102                   (apply miss-fn args)
 103                   (let ((emf (probe-cache cache dfun-wrappers *not-in-cache*)))
 104                     (if (eq emf *not-in-cache*)
 105                         (apply miss-fn args)
 106                         (if return-value-p
 107                             emf
 108                             (invoke-emf emf args))))))))
 109       (lambda (cache emf miss-fn)
 110         (declare (type function miss-fn))
 111         #'(lambda (&rest args)
 112             (declare #.*optimize-speed*)
 113             (with-dfun-wrappers (args metatypes)
 114               (dfun-wrappers invalid-wrapper-p)
 115               (apply miss-fn args)
 116               (if invalid-wrapper-p
 117                   (apply miss-fn args)
 118                   (let ((found-p (not (eq *not-in-cache*
 119                                           (probe-cache cache dfun-wrappers
 120                                                        *not-in-cache*)))))
 121                     (if found-p
 122                         (invoke-emf emf args)
 123                         (if return-value-p
 124                             t
 125                             (apply miss-fn args))))))))))
 126
 127 (defun emit-default-only-function (metatypes applyp)
 128   (declare (ignore metatypes applyp))
 129   (values (lambda (emf)
 130             (lambda (&rest args)
 131               (invoke-emf emf args)))
 132           t))