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