← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to cmpnew/gcl_cmploc.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
cmpnew/gcl_cmploc.lsp
 
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 "(long)")(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
  (declare (ignore type))
 
202
  (case first
 
203
    (inline-fixnum
 
204
     (wt "stoi(")
 
205
     (wt-inline-loc (caddr loc) (cadddr loc))
 
206
     (wt ")"))
 
207
    (INLINE-INTEGER (setq avma nil)  (wt-inline-loc (caddr loc) (cadddr loc)))
 
208
    (fixnum-value       (wt "stoi(" (caddr loc) ")"))
 
209
    (var
 
210
     (case (var-kind (cadr loc))
 
211
       (integer  (setq avma nil)   (wt "V" (var-loc (cadr loc))))
 
212
       (fixnum           (wt "stoi(V" (var-loc (cadr loc))")"))
 
213
       (otherwise (wt "otoi(" loc ")"))))
 
214
    (otherwise (wt "otoi(" loc ")")))
 
215
  (and avma (not *restore-avma*)(wfs-error))
 
216
  )
 
217
     
 
218
 
 
219
(defun fixnum-loc-p (loc)
 
220
  (and (consp loc)
 
221
       (or (and (eq (car loc) 'var)
 
222
                (eq (var-kind (cadr loc)) 'FIXNUM))
 
223
           (eq (car loc) 'INLINE-FIXNUM)
 
224
           (eq (car loc) 'fixnum-value))))
 
225
 
 
226
(defun wt-fixnum-value (vv fixnum-value)
 
227
  (if vv (wt "VV[" vv "]")
 
228
    (wt "small_fixnum(" fixnum-value ")")))
 
229
        
 
230
 
 
231
(defun wt-character-loc (loc)
 
232
  (cond ((and (consp loc)
 
233
              (eq (car loc) 'var)
 
234
              (eq (var-kind (cadr loc)) 'CHARACTER))
 
235
         (wt "V" (var-loc (cadr loc))))
 
236
        ((and (consp loc) (eq (car loc) 'INLINE-CHARACTER))
 
237
         (wt-inline-loc (caddr loc) (cadddr loc)))
 
238
        ((and (consp loc) (eq (car loc) 'CHARACTER-VALUE))
 
239
         (wt (caddr loc)))
 
240
        (t (wt "char_code(" loc ")"))))
 
241
 
 
242
(defun character-loc-p (loc)
 
243
  (and (consp loc)
 
244
       (or (and (eq (car loc) 'var)
 
245
                (eq (var-kind (cadr loc)) 'CHARACTER))
 
246
           (eq (car loc) 'INLINE-CHARACTER)
 
247
           (eq (car loc) 'character-value))))
 
248
 
 
249
(defun wt-character-value (vv character-code)
 
250
       (declare (ignore character-code))
 
251
       (wt "VV[" vv "]"))
 
252
 
 
253
(defun wt-long-float-loc (loc)
 
254
  (cond ((and (consp loc)
 
255
              (eq (car loc) 'var)
 
256
              (eq (var-kind (cadr loc)) 'LONG-FLOAT))
 
257
         (wt "V" (var-loc (cadr loc))))
 
258
        ((and (consp loc) (eq (car loc) 'INLINE-LONG-FLOAT))
 
259
         (wt-inline-loc (caddr loc) (cadddr loc)))
 
260
        ((and (consp loc) (eq (car loc) 'long-float-value))
 
261
         (wt (caddr loc)))
 
262
        (t (wt "lf(" loc ")"))))
 
263
 
 
264
(defun long-float-loc-p (loc)
 
265
  (and (consp loc)
 
266
       (or (and (eq (car loc) 'var)
 
267
                (eq (var-kind (cadr loc)) 'LONG-FLOAT))
 
268
           (eq (car loc) 'INLINE-LONG-FLOAT)
 
269
           (eq (car loc) 'long-float-value))))
 
270
 
 
271
(defun wt-long-float-value (vv long-float-value)
 
272
       (declare (ignore long-float-value))
 
273
       (wt "VV[" vv "]"))
 
274
 
 
275
(defun wt-short-float-loc (loc)
 
276
  (cond ((and (consp loc)
 
277
              (eq (car loc) 'var)
 
278
              (eq (var-kind (cadr loc)) 'SHORT-FLOAT))
 
279
         (wt "V" (var-loc (cadr loc))))
 
280
        ((and (consp loc) (eq (car loc) 'INLINE-SHORT-FLOAT))
 
281
         (wt-inline-loc (caddr loc) (cadddr loc)))
 
282
        ((and (consp loc) (eq (car loc) 'short-float-value))
 
283
         (wt (caddr loc)))
 
284
        (t (wt "sf(" loc ")"))))
 
285
 
 
286
(defun short-float-loc-p (loc)
 
287
  (and (consp loc)
 
288
       (or (and (eq (car loc) 'var)
 
289
                (eq (var-kind (cadr loc)) 'SHORT-FLOAT))
 
290
           (eq (car loc) 'INLINE-SHORT-FLOAT)
 
291
           (eq (car loc) 'short-float-value))))
 
292
 
 
293
(defun wt-short-float-value (vv short-float-value)
 
294
       (declare (ignore short-float-value))
 
295
       (wt "VV[" vv "]"))