;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p) (values (ecase reader/writer (:reader (ecase 1-or-2-class (1 (if class-slot-p (emit-reader/writer-macro :reader 1 t) (emit-reader/writer-macro :reader 1 nil))) (2 (if class-slot-p (emit-reader/writer-macro :reader 2 t) (emit-reader/writer-macro :reader 2 nil))))) (:writer (ecase 1-or-2-class (1 (if class-slot-p (emit-reader/writer-macro :writer 1 t) (emit-reader/writer-macro :writer 1 nil))) (2 (if class-slot-p (emit-reader/writer-macro :writer 2 t) (emit-reader/writer-macro :writer 2 nil)))))) nil)) (defun emit-one-or-n-index-reader/writer-function (reader/writer cached-index-p class-slot-p) (values (ecase reader/writer (:reader (if cached-index-p (if class-slot-p (emit-one-or-n-index-reader/writer-macro :reader t t) (emit-one-or-n-index-reader/writer-macro :reader t nil)) (if class-slot-p (emit-one-or-n-index-reader/writer-macro :reader nil t) (emit-one-or-n-index-reader/writer-macro :reader nil nil)))) (:writer (if cached-index-p (if class-slot-p (emit-one-or-n-index-reader/writer-macro :writer t t) (emit-one-or-n-index-reader/writer-macro :writer t nil)) (if class-slot-p (emit-one-or-n-index-reader/writer-macro :writer nil t) (emit-one-or-n-index-reader/writer-macro :writer nil nil))))) nil)) (eval-when (compile load eval) (defparameter checking-or-caching-list '() #|| '((T NIL (CLASS) NIL) (T NIL (CLASS CLASS) NIL) (T NIL (CLASS CLASS CLASS) NIL) (T NIL (CLASS CLASS T) NIL) (T NIL (CLASS CLASS T T) NIL) (T NIL (CLASS CLASS T T T) NIL) (T NIL (CLASS T) NIL) (T NIL (CLASS T T) NIL) (T NIL (CLASS T T T) NIL) (T NIL (CLASS T T T T) NIL) (T NIL (CLASS T T T T T) NIL) (T NIL (CLASS T T T T T T) NIL) (T NIL (T CLASS) NIL) (T NIL (T CLASS T) NIL) (T NIL (T T CLASS) NIL) (T NIL (CLASS) T) (T NIL (CLASS CLASS) T) (T NIL (CLASS T) T) (T NIL (CLASS T T) T) (T NIL (CLASS T T T) T) (T NIL (T CLASS) T) (T T (CLASS) NIL) (T T (CLASS CLASS) NIL) (T T (CLASS CLASS CLASS) NIL) (NIL NIL (CLASS) NIL) (NIL NIL (CLASS CLASS) NIL) (NIL NIL (CLASS CLASS T) NIL) (NIL NIL (CLASS CLASS T T) NIL) (NIL NIL (CLASS T) NIL) (NIL NIL (T CLASS T) NIL) (NIL NIL (CLASS) T) (NIL NIL (CLASS CLASS) T)) ||# )) (defmacro make-checking-or-caching-function-list () `(list ,@(mapcar #'(lambda (key) `(cons ',key (emit-checking-or-caching-macro ,@key))) checking-or-caching-list))) (defvar checking-or-caching-function-list) (defun initialize-checking-or-caching-function-list () (setq checking-or-caching-function-list (make-checking-or-caching-function-list))) (initialize-checking-or-caching-function-list) (defmacro emit-checking-or-caching-function-precompiled () `(cdr (assoc (list cached-emf-p return-value-p metatypes applyp) checking-or-caching-function-list :test #'equal))) (defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp) (let ((fn (emit-checking-or-caching-function-precompiled))) (if fn (values fn nil) (values (emit-checking-or-caching-function-preliminary cached-emf-p return-value-p metatypes applyp) t)))) (defvar not-in-cache (make-symbol "not in cache")) (defun emit-checking-or-caching-function-preliminary (cached-emf-p return-value-p metatypes applyp) (declare (ignore applyp)) (if cached-emf-p #'(lambda (cache miss-fn) (declare (type function miss-fn)) (fin-lambda-fn (&rest args) (declare #.*optimize-speed*) #+copy-&rest-arg (setq args (copy-list args)) (with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p) (apply miss-fn args) (if invalid-wrapper-p (apply miss-fn args) (let ((emf (probe-cache cache dfun-wrappers not-in-cache))) (if (eq emf not-in-cache) (apply miss-fn args) (if return-value-p emf (invoke-emf emf args)))))))) #'(lambda (cache emf miss-fn) (declare (type function miss-fn)) (fin-lambda-fn (&rest args) (declare #.*optimize-speed*) #+copy-&rest-arg (setq args (copy-list args)) (with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p) (apply miss-fn args) (if invalid-wrapper-p (apply miss-fn args) (let ((found-p (not (eq not-in-cache (probe-cache cache dfun-wrappers not-in-cache))))) (if found-p (invoke-emf emf args) (if return-value-p t (apply miss-fn args)))))))))) (defun emit-default-only-function (metatypes applyp) (declare (ignore metatypes applyp)) (values #'(lambda (emf) #'(lambda (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (invoke-emf emf args))) t))