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 (sb-int:file-comment
  27   "$Header$")
  28 \f
  29 (defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p)
  30   (values
  31    (ecase reader/writer
  32      (:reader (ecase 1-or-2-class
  33                 (1 (if class-slot-p
  34                        (emit-reader/writer-macro :reader 1 t)
  35                        (emit-reader/writer-macro :reader 1 nil)))
  36                 (2 (if class-slot-p
  37                        (emit-reader/writer-macro :reader 2 t)
  38                        (emit-reader/writer-macro :reader 2 nil)))))
  39      (:writer (ecase 1-or-2-class
  40                 (1 (if class-slot-p
  41                        (emit-reader/writer-macro :writer 1 t)
  42                        (emit-reader/writer-macro :writer 1 nil)))
  43                 (2 (if class-slot-p
  44                        (emit-reader/writer-macro :writer 2 t)
  45                        (emit-reader/writer-macro :writer 2 nil))))))
  46    nil))
  47
  48 (defun emit-one-or-n-index-reader/writer-function
  49     (reader/writer cached-index-p class-slot-p)
  50   (values
  51    (ecase reader/writer
  52      (:reader (if cached-index-p
  53                   (if class-slot-p
  54                       (emit-one-or-n-index-reader/writer-macro :reader t t)
  55                       (emit-one-or-n-index-reader/writer-macro :reader t nil))
  56                   (if class-slot-p
  57                       (emit-one-or-n-index-reader/writer-macro :reader nil t)
  58                       (emit-one-or-n-index-reader/writer-macro :reader nil nil))))
  59      (:writer (if cached-index-p
  60                   (if class-slot-p
  61                       (emit-one-or-n-index-reader/writer-macro :writer t t)
  62                       (emit-one-or-n-index-reader/writer-macro :writer t nil))
  63                   (if class-slot-p
  64                       (emit-one-or-n-index-reader/writer-macro :writer nil t)
  65                       (emit-one-or-n-index-reader/writer-macro :writer nil nil)))))
  66    nil))
  67
  68 ;;; Note this list is setup in dlisp3.lisp when all the necessary
  69 ;;; macros have been loaded.
  70 (defvar *checking-or-caching-function-list* nil)
  71
  72 (defmacro emit-checking-or-caching-function-precompiled ()
  73   `(cdr (assoc (list cached-emf-p return-value-p metatypes applyp)
  74                *checking-or-caching-function-list*
  75                :test #'equal)))
  76
  77 (defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp)
  78   (let ((fn (emit-checking-or-caching-function-precompiled)))
  79     (if fn
  80         (values fn nil)
  81         (values (emit-checking-or-caching-function-preliminary
  82                  cached-emf-p return-value-p metatypes applyp)
  83                 t))))
  84
  85 (defvar *not-in-cache* (make-symbol "not in cache"))
  86
  87 (defun emit-checking-or-caching-function-preliminary
  88     (cached-emf-p return-value-p metatypes applyp)
  89   (declare (ignore applyp))
  90   (if cached-emf-p
  91       #'(lambda (cache miss-fn)
  92           (declare (type function miss-fn))
  93           #'(sb-kernel:instance-lambda (&rest args)
  94               (declare #.*optimize-speed*)
  95               (with-dfun-wrappers (args metatypes)
  96                 (dfun-wrappers invalid-wrapper-p)
  97                 (apply miss-fn args)
  98                 (if invalid-wrapper-p
  99                     (apply miss-fn args)
 100                     (let ((emf (probe-cache cache dfun-wrappers *not-in-cache*)))
 101                       (if (eq emf *not-in-cache*)
 102                           (apply miss-fn args)
 103                           (if return-value-p
 104                               emf
 105                               (invoke-emf emf args))))))))
 106       #'(lambda (cache emf miss-fn)
 107           (declare (type function miss-fn))
 108           #'(sb-kernel:instance-lambda (&rest args)
 109               (declare #.*optimize-speed*)
 110               (with-dfun-wrappers (args metatypes)
 111                 (dfun-wrappers invalid-wrapper-p)
 112                 (apply miss-fn args)
 113                 (if invalid-wrapper-p
 114                     (apply miss-fn args)
 115                     (let ((found-p (not (eq *not-in-cache*
 116                                             (probe-cache cache dfun-wrappers
 117                                                          *not-in-cache*)))))
 118                       (if found-p
 119                           (invoke-emf emf args)
 120                           (if return-value-p
 121                               t
 122                               (apply miss-fn args))))))))))
 123
 124 (defun emit-default-only-function (metatypes applyp)
 125   (declare (ignore metatypes applyp))
 126   (values #'(lambda (emf)
 127               #'(lambda (&rest args)
 128                   (invoke-emf emf args)))
 129           t))