1 |
|
;;; CMPLOC Set-loc and Wt-loc. |
2 |
|
;;; |
3 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
4 |
|
|
5 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
6 |
|
;; |
7 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
8 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
9 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
10 |
|
;; any later version. |
11 |
|
;; |
12 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
13 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
14 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
15 |
|
;; License for more details. |
16 |
|
;; |
17 |
|
;; You should have received a copy of the GNU Library General Public License |
18 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
19 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
20 |
|
|
21 |
|
|
22 |
|
(in-package 'compiler) |
23 |
|
|
24 |
|
(defvar *value-to-go*) |
25 |
|
|
26 |
|
;;; Valid locations are: |
27 |
|
;;; NIL |
28 |
|
;;; T |
29 |
|
;;; 'FUN-VAL' |
30 |
|
;;; ( 'VS' vs-address ) |
31 |
|
;;; ( 'VS*' vs-address ) |
32 |
|
;;; ( 'CCB-VS' ccb-vs ) |
33 |
|
;;; ( 'VAR' var-object ccb ) |
34 |
|
;;; ( 'VV' vv-index ) |
35 |
|
;;; ( 'CVAR' cvar ) |
36 |
|
;;; ( 'INLINE' side-effect-p fun/string locs ) |
37 |
|
;;; ( 'INLINE-COND' side-effect-p fun/string locs ) |
38 |
|
;;; ( 'INLINE-FIXNUM' side-effect-p fun/string locs ) |
39 |
|
;;; ( 'INLINE-CHARACTER' side-effect-p fun/string locs ) |
40 |
|
;;; ( 'INLINE-LONG-FLOAT' side-effect-p fun/string locs ) |
41 |
|
;;; ( 'INLINE-SHORT-FLOAT' side-effect-p fun/string locs ) |
42 |
|
;;; ( 'SIMPLE-CALL { SYMLISPCALL-NO-EVENT |
43 |
|
;;; | LISPCALL-NO-EVENT |
44 |
|
;;; | SYMLISPCALL |
45 |
|
;;; | LISPCALL } |
46 |
|
;;; vs-index number-of-arguments [ vv-index ] ) |
47 |
|
;;; ( 'VS-BASE' offset ) |
48 |
|
;;; ( 'CAR' cvar ) |
49 |
|
;;; ( 'CADR' cvar ) |
50 |
|
;;; ( 'SYMBOL-FUNCTION' vv-index ) |
51 |
|
;;; ( 'MAKE-CCLOSURE' cfun cllink ) |
52 |
|
;;; ( 'FIXNUM-VALUE' vv-index fixnum-value ) |
53 |
|
;;; ( 'FIXNUM-LOC' loc ) |
54 |
|
;;; ( 'CHARACTER-VALUE' vv-index character-code ) |
55 |
|
;;; ( 'CHARACTER-LOC' loc ) |
56 |
|
;;; ( 'LONG-FLOAT-VALUE' vv-index long-float-value ) |
57 |
|
;;; ( 'LONG-FLOAT-LOC' loc ) |
58 |
|
;;; ( 'SHORT-FLOAT-VALUE' vv-index short-float-value ) |
59 |
|
;;; ( 'SHORT-FLOAT-LOC' loc ) |
60 |
|
|
61 |
|
|
62 |
|
;;; Valid *value-to-go* locations are: |
63 |
|
;;; |
64 |
|
;;; 'RETURN' The value is returned from the current function. |
65 |
|
;;; 'RETURN-FIXNUM' |
66 |
|
;;; 'RETURN-CHARACTER' |
67 |
|
;;; 'RETURN-LONG-FLOAT' |
68 |
|
;;; 'RETURN-SHORT-FLOAT' |
69 |
|
;;; 'RETURN-OBJECT |
70 |
|
;;; 'TRASH' The value may be thrown away. |
71 |
|
;;; 'TOP' The value should be set at the top of vs as if it were |
72 |
|
;;; a resulted value of a function call. |
73 |
|
;;; ( 'VS' vs-address ) |
74 |
|
;;; ( 'VS*' vs-address ) |
75 |
|
;;; ( 'CCB-VS' ccb-vs ) |
76 |
|
;;; ( 'VAR' var-object ccb ) |
77 |
|
;;; ( 'JUMP-TRUE' label ) |
78 |
|
;;; ( 'JUMP-FALSE' label ) |
79 |
|
;;; ( 'BDS-BIND' vv-index ) |
80 |
|
;;; ( 'PUSH-CATCH-FRAME' ) |
81 |
|
;;; ( 'DBIND' symbol-name-vv ) |
82 |
|
|
83 |
|
(si:putprop 'cvar 'wt-cvar 'wt-loc) |
84 |
|
(si:putprop 'vv 'wt-vv 'wt-loc) |
85 |
|
(si:putprop 'car 'wt-car 'wt-loc) |
86 |
|
(si:putprop 'cdr 'wt-cdr 'wt-loc) |
87 |
|
(si:putprop 'cadr 'wt-cadr 'wt-loc) |
88 |
|
(si:putprop 'vs-base 'wt-vs-base 'wt-loc) |
89 |
|
(si:putprop 'fixnum-value 'wt-fixnum-value 'wt-loc) |
90 |
|
(si:putprop 'fixnum-loc 'wt-fixnum-loc 'wt-loc) |
91 |
|
(si:putprop 'integer-loc 'wt-integer-loc 'wt-loc) |
92 |
|
(si:putprop 'character-value 'wt-character-value 'wt-loc) |
93 |
|
(si:putprop 'character-loc 'wt-character-loc 'wt-loc) |
94 |
|
(si:putprop 'long-float-value 'wt-long-float-value 'wt-loc) |
95 |
|
(si:putprop 'long-float-loc 'wt-long-float-loc 'wt-loc) |
96 |
|
(si:putprop 'short-float-value 'wt-short-float-value 'wt-loc) |
97 |
|
(si:putprop 'short-float-loc 'wt-short-float-loc 'wt-loc) |
98 |
|
(si::putprop 'next-var-arg 'wt-next-var-arg 'wt-loc) |
99 |
|
(si::putprop 'first-var-arg 'wt-first-var-arg 'wt-loc) |
100 |
|
|
101 |
|
(defun wt-first-var-arg () |
102 |
|
(wt "first")) |
103 |
|
|
104 |
|
(defun wt-next-var-arg () |
105 |
|
(wt "va_arg(ap,object)")) |
106 |
|
|
107 |
|
(defun set-loc (loc &aux fd) |
108 |
|
(cond ((eq *value-to-go* 'return) (set-return loc)) |
109 |
|
((eq *value-to-go* 'trash) |
110 |
|
(cond ((and (consp loc) |
111 |
|
(member (car loc) |
112 |
|
'(INLINE INLINE-COND INLINE-FIXNUM inline-integer |
113 |
|
INLINE-CHARACTER INLINE-LONG-FLOAT |
114 |
|
INLINE-SHORT-FLOAT)) |
115 |
|
(cadr loc)) |
116 |
|
(wt-nl "(void)(") (wt-inline t (caddr loc) (cadddr loc)) |
117 |
|
(wt ");")) |
118 |
|
((and (consp loc) (eq (car loc) 'SIMPLE-CALL)) |
119 |
|
(wt-nl "(void)" loc ";")))) |
120 |
|
((eq *value-to-go* 'top) |
121 |
|
(unless (eq loc 'fun-val) (set-top loc))) |
122 |
|
((eq *value-to-go* 'return-fixnum) (set-return-fixnum loc)) |
123 |
|
((eq *value-to-go* 'return-character) (set-return-character loc)) |
124 |
|
((eq *value-to-go* 'return-long-float) (set-return-long-float loc)) |
125 |
|
((eq *value-to-go* 'return-short-float) (set-return-short-float loc)) |
126 |
|
((or (not (consp *value-to-go*)) |
127 |
|
(not (symbolp (car *value-to-go*)))) |
128 |
|
(baboon)) |
129 |
|
((setq fd (get (car *value-to-go*) 'set-loc)) |
130 |
|
(apply fd loc (cdr *value-to-go*))) |
131 |
|
((setq fd (get (car *value-to-go*) 'wt-loc)) |
132 |
|
(wt-nl) (apply fd (cdr *value-to-go*)) (wt "= " loc ";")) |
133 |
|
(t (baboon))) |
134 |
|
) |
135 |
|
|
136 |
|
(defun wt-loc (loc) |
137 |
|
(cond ((eq loc nil) (wt "Cnil")) |
138 |
|
((eq loc t) (wt "Ct")) |
139 |
|
((eq loc 'fun-val) (wt "vs_base[0]")) |
140 |
|
((or (not (consp loc)) |
141 |
|
(not (symbolp (car loc)))) |
142 |
|
(baboon)) |
143 |
|
(t (let ((fd (get (car loc) 'wt-loc))) |
144 |
|
(when (null fd) (baboon)) |
145 |
|
(apply fd (cdr loc))))) |
146 |
|
) |
147 |
|
|
148 |
|
(defun set-return (loc) |
149 |
|
(cond ((eq loc 'fun-val)) |
150 |
|
((and (consp loc) (eq (car loc) 'vs) (= (caadr loc) *level*)) |
151 |
|
(wt-nl "vs_top=(vs_base=base+" (cdadr loc) ")+1;") |
152 |
|
(base-used)) |
153 |
|
((and (consp loc) |
154 |
|
(eq (car loc) 'var) |
155 |
|
(eq (var-kind (cadr loc)) 'LEXICAL) |
156 |
|
(not (var-ref-ccb (cadr loc))) |
157 |
|
(eql (car (var-ref (cadr loc))) *level*)) |
158 |
|
(wt-nl "vs_top=(vs_base=base+" (cdr (var-ref (cadr loc))) ")+1;") |
159 |
|
(base-used)) |
160 |
|
(t (set-top loc))) |
161 |
|
) |
162 |
|
|
163 |
|
(defun set-top (loc) |
164 |
|
(let ((*vs* *vs*)) |
165 |
|
(wt-nl) (wt-vs (vs-push)) (wt "= " loc ";") |
166 |
|
(wt-nl "vs_top=(vs_base=base+" (1- *vs*) ")+1;") |
167 |
|
(base-used))) |
168 |
|
|
169 |
|
(defun wt-vs-base (offset) (wt "vs_base[" offset "]")) |
170 |
|
|
171 |
|
(defun wt-car (cvar) (wt "(V" cvar "->c.c_car)")) |
172 |
|
|
173 |
|
(defun wt-cdr (cvar) (wt "(V" cvar "->c.c_cdr)")) |
174 |
|
|
175 |
|
(defun wt-cadr (cvar) (wt "(V" cvar "->c.c_cdr->c.c_car)")) |
176 |
|
|
177 |
|
(defun wt-cvar (cvar &optional type) |
178 |
|
(if type (wt "/* " (symbol-name type) " */")) |
179 |
|
(wt "V" cvar)) |
180 |
|
|
181 |
|
(defun wt-vv (vv) (wt "VV[" vv "]")) |
182 |
|
|
183 |
|
(defun wt-fixnum-loc (loc) |
184 |
|
(cond ((and (consp loc) |
185 |
|
(eq (car loc) 'var) |
186 |
|
(eq (var-kind (cadr loc)) 'FIXNUM)) |
187 |
|
(wt "V" (var-loc (cadr loc)))) |
188 |
|
((and (consp loc) (eq (car loc) 'INLINE-FIXNUM)) |
189 |
|
(wt "(long)")(wt-inline-loc (caddr loc) (cadddr loc))) |
190 |
|
((and (consp loc) (eq (car loc) 'fixnum-value)) |
191 |
|
(wt (caddr loc))) |
192 |
|
((and (consp loc) (member (car loc) '(INLINE-SHORT-FLOAT |
193 |
|
INLINE-LONG-FLOAT))) |
194 |
|
(wt "((long)(") |
195 |
|
(wt-inline-loc (caddr loc) (cadddr loc)) |
196 |
|
(wt "))")) |
197 |
|
(t (wt "fix(" loc ")")))) |
198 |
|
|
199 |
|
(defun wt-integer-loc (loc &optional type |
200 |
|
&aux (avma t)(first (and (consp loc) (car loc)))) |
201 |
|
(case first |
202 |
|
(inline-fixnum |
203 |
|
(wt "stoi(") |
204 |
|
(wt-inline-loc (caddr loc) (cadddr loc)) |
205 |
|
(wt ")")) |
206 |
|
(INLINE-INTEGER (setq avma nil) (wt-inline-loc (caddr loc) (cadddr loc))) |
207 |
|
(fixnum-value (wt "stoi(" (caddr loc) ")")) |
208 |
|
(var |
209 |
|
(case (var-kind (cadr loc)) |
210 |
|
(integer (setq avma nil) (wt "V" (var-loc (cadr loc)))) |
211 |
|
(fixnum (wt "stoi(V" (var-loc (cadr loc))")")) |
212 |
|
(otherwise (wt "otoi(" loc ")")))) |
213 |
|
(otherwise (wt "otoi(" loc ")"))) |
214 |
|
(and avma (not *restore-avma*)(wfs-error)) |
215 |
|
) |
216 |
|
|
217 |
|
|
218 |
|
(defun fixnum-loc-p (loc) |
219 |
|
(and (consp loc) |
220 |
|
(or (and (eq (car loc) 'var) |
221 |
|
(eq (var-kind (cadr loc)) 'FIXNUM)) |
222 |
|
(eq (car loc) 'INLINE-FIXNUM) |
223 |
|
(eq (car loc) 'fixnum-value)))) |
224 |
|
|
225 |
|
(defun wt-fixnum-value (vv fixnum-value) |
226 |
|
(if vv (wt "VV[" vv "]") |
227 |
|
(wt "small_fixnum(" fixnum-value ")"))) |
228 |
|
|
229 |
|
|
230 |
|
(defun wt-character-loc (loc) |
231 |
|
(cond ((and (consp loc) |
232 |
|
(eq (car loc) 'var) |
233 |
|
(eq (var-kind (cadr loc)) 'CHARACTER)) |
234 |
|
(wt "V" (var-loc (cadr loc)))) |
235 |
|
((and (consp loc) (eq (car loc) 'INLINE-CHARACTER)) |
236 |
|
(wt-inline-loc (caddr loc) (cadddr loc))) |
237 |
|
((and (consp loc) (eq (car loc) 'CHARACTER-VALUE)) |
238 |
|
(wt (caddr loc))) |
239 |
|
(t (wt "char_code(" loc ")")))) |
240 |
|
|
241 |
|
(defun character-loc-p (loc) |
242 |
|
(and (consp loc) |
243 |
|
(or (and (eq (car loc) 'var) |
244 |
|
(eq (var-kind (cadr loc)) 'CHARACTER)) |
245 |
|
(eq (car loc) 'INLINE-CHARACTER) |
246 |
|
(eq (car loc) 'character-value)))) |
247 |
|
|
248 |
|
(defun wt-character-value (vv character-code) |
249 |
|
(declare (ignore character-code)) |
250 |
|
(wt "VV[" vv "]")) |
251 |
|
|
252 |
|
(defun wt-long-float-loc (loc) |
253 |
|
(cond ((and (consp loc) |
254 |
|
(eq (car loc) 'var) |
255 |
|
(eq (var-kind (cadr loc)) 'LONG-FLOAT)) |
256 |
|
(wt "V" (var-loc (cadr loc)))) |
257 |
|
((and (consp loc) (eq (car loc) 'INLINE-LONG-FLOAT)) |
258 |
|
(wt-inline-loc (caddr loc) (cadddr loc))) |
259 |
|
((and (consp loc) (eq (car loc) 'long-float-value)) |
260 |
|
(wt (caddr loc))) |
261 |
|
(t (wt "lf(" loc ")")))) |
262 |
|
|
263 |
|
(defun long-float-loc-p (loc) |
264 |
|
(and (consp loc) |
265 |
|
(or (and (eq (car loc) 'var) |
266 |
|
(eq (var-kind (cadr loc)) 'LONG-FLOAT)) |
267 |
|
(eq (car loc) 'INLINE-LONG-FLOAT) |
268 |
|
(eq (car loc) 'long-float-value)))) |
269 |
|
|
270 |
|
(defun wt-long-float-value (vv long-float-value) |
271 |
|
(declare (ignore long-float-value)) |
272 |
|
(wt "VV[" vv "]")) |
273 |
|
|
274 |
|
(defun wt-short-float-loc (loc) |
275 |
|
(cond ((and (consp loc) |
276 |
|
(eq (car loc) 'var) |
277 |
|
(eq (var-kind (cadr loc)) 'SHORT-FLOAT)) |
278 |
|
(wt "V" (var-loc (cadr loc)))) |
279 |
|
((and (consp loc) (eq (car loc) 'INLINE-SHORT-FLOAT)) |
280 |
|
(wt-inline-loc (caddr loc) (cadddr loc))) |
281 |
|
((and (consp loc) (eq (car loc) 'short-float-value)) |
282 |
|
(wt (caddr loc))) |
283 |
|
(t (wt "sf(" loc ")")))) |
284 |
|
|
285 |
|
(defun short-float-loc-p (loc) |
286 |
|
(and (consp loc) |
287 |
|
(or (and (eq (car loc) 'var) |
288 |
|
(eq (var-kind (cadr loc)) 'SHORT-FLOAT)) |
289 |
|
(eq (car loc) 'INLINE-SHORT-FLOAT) |
290 |
|
(eq (car loc) 'short-float-value)))) |
291 |
|
|
292 |
|
(defun wt-short-float-value (vv short-float-value) |
293 |
|
(declare (ignore short-float-value)) |
294 |
|
(wt "VV[" vv "]")) |
295 |
|
|