/[gcl]/gcl/cmpnew/gcl_cmploc.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmploc.lsp

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

revision 1.1 by camm, Sun Sep 14 02:30:33 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:01 2003 UTC
# Line 0  Line 1 
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    

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