/[cmucl]/src/pcl/dlisp2.lisp
ViewVC logotype

Contents of /src/pcl/dlisp2.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Fri Mar 19 15:19:03 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.12: +2 -1 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
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 (file-comment
28 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/dlisp2.lisp,v 1.13 2010/03/19 15:19:03 rtoy Rel $")
29 ;;;
30
31 (in-package :pcl)
32 (intl:textdomain "cmucl")
33
34 (defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p)
35 (values
36 (ecase reader/writer
37 (:reader (ecase 1-or-2-class
38 (1 (if class-slot-p
39 (emit-reader/writer-macro :reader 1 t)
40 (emit-reader/writer-macro :reader 1 nil)))
41 (2 (if class-slot-p
42 (emit-reader/writer-macro :reader 2 t)
43 (emit-reader/writer-macro :reader 2 nil)))))
44 (:writer (ecase 1-or-2-class
45 (1 (if class-slot-p
46 (emit-reader/writer-macro :writer 1 t)
47 (emit-reader/writer-macro :writer 1 nil)))
48 (2 (if class-slot-p
49 (emit-reader/writer-macro :writer 2 t)
50 (emit-reader/writer-macro :writer 2 nil)))))
51 (:boundp (ecase 1-or-2-class
52 (1 (if class-slot-p
53 (emit-reader/writer-macro :boundp 1 t)
54 (emit-reader/writer-macro :boundp 1 nil)))
55 (2 (if class-slot-p
56 (emit-reader/writer-macro :boundp 2 t)
57 (emit-reader/writer-macro :boundp 2 nil))))))
58 nil))
59
60 (defun emit-one-or-n-index-reader/writer-function
61 (reader/writer cached-index-p class-slot-p)
62 (values
63 (ecase reader/writer
64 (:reader
65 (if cached-index-p
66 (if class-slot-p
67 (emit-one-or-n-index-reader/writer-macro :reader t t)
68 (emit-one-or-n-index-reader/writer-macro :reader t nil))
69 (if class-slot-p
70 (emit-one-or-n-index-reader/writer-macro :reader nil t)
71 (emit-one-or-n-index-reader/writer-macro :reader nil nil))))
72 (:writer
73 (if cached-index-p
74 (if class-slot-p
75 (emit-one-or-n-index-reader/writer-macro :writer t t)
76 (emit-one-or-n-index-reader/writer-macro :writer t nil))
77 (if class-slot-p
78 (emit-one-or-n-index-reader/writer-macro :writer nil t)
79 (emit-one-or-n-index-reader/writer-macro :writer nil nil))))
80 (:boundp
81 (if cached-index-p
82 (if class-slot-p
83 (emit-one-or-n-index-reader/writer-macro :boundp t t)
84 (emit-one-or-n-index-reader/writer-macro :boundp t nil))
85 (if class-slot-p
86 (emit-one-or-n-index-reader/writer-macro :boundp nil t)
87 (emit-one-or-n-index-reader/writer-macro :boundp nil nil)))))
88 nil))
89
90 (defun emit-checking-or-caching-function (cached-emf-p return-value-p
91 metatypes applyp)
92 (values (emit-checking-or-caching-function-preliminary
93 cached-emf-p return-value-p metatypes applyp)
94 t))
95
96 (defun emit-checking-or-caching-function-preliminary
97 (cached-emf-p return-value-p metatypes applyp)
98 (declare (ignore applyp))
99 (if cached-emf-p
100 (lambda (cache miss-fn)
101 (declare (type function miss-fn))
102 #'(kernel:instance-lambda (&rest args)
103 (declare #.*optimize-speed*)
104 (with-dfun-wrappers (args metatypes)
105 (dfun-wrappers invalid-wrapper-p)
106 (apply miss-fn args)
107 (if invalid-wrapper-p
108 (apply miss-fn args)
109 (let ((emf (probe-cache cache dfun-wrappers 'not-in-cache)))
110 (if (eq emf 'not-in-cache)
111 (apply miss-fn args)
112 (if return-value-p
113 emf
114 (invoke-emf emf args))))))))
115 (lambda (cache emf miss-fn)
116 (declare (type function miss-fn))
117 #'(kernel:instance-lambda (&rest args)
118 (declare #.*optimize-speed*)
119 (with-dfun-wrappers (args metatypes)
120 (dfun-wrappers invalid-wrapper-p)
121 (apply miss-fn args)
122 (if invalid-wrapper-p
123 (apply miss-fn args)
124 (let ((found-p (not (eq 'not-in-cache
125 (probe-cache cache dfun-wrappers
126 'not-in-cache)))))
127 (if found-p
128 (invoke-emf emf args)
129 (if return-value-p
130 t
131 (apply miss-fn args))))))))))
132
133
134 (defun emit-default-only-function (metatypes applyp)
135 (declare (ignore metatypes applyp))
136 (values (lambda (emf)
137 (lambda (&rest args)
138 (invoke-emf emf args)))
139 t))

  ViewVC Help
Powered by ViewVC 1.1.5