/[gcl]/gcl/pcl/gcl_pcl_dlisp2.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_dlisp2.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:56 2005 UTC revision 1.2 by camm, Sat May 7 02:52:30 2005 UTC
# Line 0  Line 1 
1    ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
2    ;;;
3    ;;; *************************************************************************
4    ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5    ;;; All rights reserved.
6    ;;;
7    ;;; Use and copying of this software and preparation of derivative works
8    ;;; based upon this software are permitted.  Any distribution of this
9    ;;; software or derivative works must comply with all applicable United
10    ;;; States export control laws.
11    ;;;
12    ;;; This software is made available AS IS, and Xerox Corporation makes no
13    ;;; warranty about the software, its performance or its conformity to any
14    ;;; specification.
15    ;;;
16    ;;; Any person obtaining a copy of this software is requested to send their
17    ;;; name and post office or electronic mail address to:
18    ;;;   CommonLoops Coordinator
19    ;;;   Xerox PARC
20    ;;;   3333 Coyote Hill Rd.
21    ;;;   Palo Alto, CA 94304
22    ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23    ;;;
24    ;;; Suggestions, comments and requests for improvements are also welcome.
25    ;;; *************************************************************************
26    ;;;
27    
28    (in-package :pcl)
29    
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       nil))
48    
49    (defun emit-one-or-n-index-reader/writer-function
50        (reader/writer cached-index-p class-slot-p)
51      (values
52       (ecase reader/writer
53         (:reader (if cached-index-p
54                      (if class-slot-p
55                          (emit-one-or-n-index-reader/writer-macro :reader t t)
56                          (emit-one-or-n-index-reader/writer-macro :reader t nil))
57                      (if class-slot-p
58                          (emit-one-or-n-index-reader/writer-macro :reader nil t)
59                          (emit-one-or-n-index-reader/writer-macro :reader nil nil))))
60         (:writer (if cached-index-p
61                      (if class-slot-p
62                          (emit-one-or-n-index-reader/writer-macro :writer t t)
63                          (emit-one-or-n-index-reader/writer-macro :writer t nil))
64                      (if class-slot-p
65                          (emit-one-or-n-index-reader/writer-macro :writer nil t)
66                          (emit-one-or-n-index-reader/writer-macro :writer nil nil)))))
67       nil))
68    
69    (eval-when (compile load eval)
70    (defparameter checking-or-caching-list
71      '()
72      #||
73      '((T NIL (CLASS) NIL)
74        (T NIL (CLASS CLASS) NIL)
75        (T NIL (CLASS CLASS CLASS) NIL)
76        (T NIL (CLASS CLASS T) NIL)
77        (T NIL (CLASS CLASS T T) NIL)
78        (T NIL (CLASS CLASS T T T) NIL)
79        (T NIL (CLASS T) NIL)
80        (T NIL (CLASS T T) NIL)
81        (T NIL (CLASS T T T) NIL)
82        (T NIL (CLASS T T T T) NIL)
83        (T NIL (CLASS T T T T T) NIL)
84        (T NIL (CLASS T T T T T T) NIL)
85        (T NIL (T CLASS) NIL)
86        (T NIL (T CLASS T) NIL)
87        (T NIL (T T CLASS) NIL)
88        (T NIL (CLASS) T)
89        (T NIL (CLASS CLASS) T)
90        (T NIL (CLASS T) T)
91        (T NIL (CLASS T T) T)
92        (T NIL (CLASS T T T) T)
93        (T NIL (T CLASS) T)
94        (T T (CLASS) NIL)
95        (T T (CLASS CLASS) NIL)
96        (T T (CLASS CLASS CLASS) NIL)
97        (NIL NIL (CLASS) NIL)
98        (NIL NIL (CLASS CLASS) NIL)
99        (NIL NIL (CLASS CLASS T) NIL)
100        (NIL NIL (CLASS CLASS T T) NIL)
101        (NIL NIL (CLASS T) NIL)
102        (NIL NIL (T CLASS T) NIL)
103        (NIL NIL (CLASS) T)
104        (NIL NIL (CLASS CLASS) T)) ||# ))
105    
106    (defmacro make-checking-or-caching-function-list ()
107      `(list ,@(mapcar #'(lambda (key)
108                           `(cons ',key (emit-checking-or-caching-macro ,@key)))
109                       checking-or-caching-list)))
110    
111    (defvar checking-or-caching-function-list)
112    
113    (defun initialize-checking-or-caching-function-list ()
114      (setq checking-or-caching-function-list
115            (make-checking-or-caching-function-list)))
116    
117    (initialize-checking-or-caching-function-list)
118    
119    (defmacro emit-checking-or-caching-function-precompiled ()
120      `(cdr (assoc (list cached-emf-p return-value-p metatypes applyp)
121                   checking-or-caching-function-list
122                   :test #'equal)))
123    
124    (defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp)
125      (let ((fn (emit-checking-or-caching-function-precompiled)))
126        (if fn
127            (values fn nil)
128            (values (emit-checking-or-caching-function-preliminary
129                     cached-emf-p return-value-p metatypes applyp)
130                    t))))
131    
132    (defvar not-in-cache (make-symbol "not in cache"))
133    
134    (defun emit-checking-or-caching-function-preliminary
135        (cached-emf-p return-value-p metatypes applyp)
136      (declare (ignore applyp))
137      (if cached-emf-p
138          #'(lambda (cache miss-fn)
139              (declare (type function miss-fn))
140              (fin-lambda-fn (&rest args)
141                (declare #.*optimize-speed*)
142                #+copy-&rest-arg (setq args (copy-list args))
143                (with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p)
144                    (apply miss-fn args)
145                  (if invalid-wrapper-p
146                      (apply miss-fn args)
147                      (let ((emf (probe-cache cache dfun-wrappers not-in-cache)))
148                        (if (eq emf not-in-cache)
149                            (apply miss-fn args)
150                            (if return-value-p
151                                emf
152                                (invoke-emf emf args))))))))
153          #'(lambda (cache emf miss-fn)
154              (declare (type function miss-fn))
155              (fin-lambda-fn (&rest args)
156                (declare #.*optimize-speed*)
157                #+copy-&rest-arg (setq args (copy-list args))
158                (with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p)
159                    (apply miss-fn args)
160                  (if invalid-wrapper-p
161                      (apply miss-fn args)
162                      (let ((found-p (not (eq not-in-cache
163                                              (probe-cache cache dfun-wrappers
164                                                           not-in-cache)))))
165                        (if found-p
166                            (invoke-emf emf args)
167                            (if return-value-p
168                                t
169                                (apply miss-fn args))))))))))
170    
171    
172    (defun emit-default-only-function (metatypes applyp)
173      (declare (ignore metatypes applyp))
174      (values #'(lambda (emf)
175                  #'(lambda (&rest args)
176                      #+copy-&rest-arg (setq args (copy-list args))
177                      (invoke-emf emf args)))
178              t))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26