← Back to branch summary

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

« back to all changes in this revision

Viewing changes to comp/wr.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:
comp/wr.lsp
 
1
(in-package "BCOMP")
 
2
(defmacro wr  (&rest l)
 
3
  `(progn ,@ (mapcar #'(lambda (x)
 
4
                         (if (stringp x) `(princ ,x *c-output*)
 
5
                           `(wr1 ,x)))
 
6
                     l
 
7
                     )))
 
8
(defmacro wr-nl (&rest l)
 
9
  `(wr "
 
10
        " ,@l))
 
11
 
 
12
(defmacro wr-h  (&rest l)
 
13
  `(progn (princ "
 
14
        " *h-output*)
 
15
          ,@ (mapcar #'(lambda (x)
 
16
                         (if (stringp x) `(princ ,x *h-output*)
 
17
                           `(wr1-h ,x)))
 
18
                     l)))
 
19
 
 
20
(defun wr1 (x )
 
21
  (cond ((or (typep x 'fixnum)(stringp x)) (princ x *c-output*))
 
22
        ((consp x)
 
23
         (or (symbolp (car x)) (wfs-error))
 
24
         (let ((fd (get (car x) 'wr)))
 
25
           (or fd (wfs-error))
 
26
           (funcall fd x)))
 
27
        ((typep x 'var)
 
28
         (cond ((var-clb x)
 
29
                (wr "ClosRef(" (list 'closure-var-loc x) ")"))
 
30
               ((var-special-p x)
 
31
                (or (var-ind x) (wfs-error))
 
32
                (cond ((= *safety* 0)
 
33
                       (wr "("(var-ind x)")->s.Bind" ))
 
34
                      (t (wr "symbol_value("(var-ind x)")" ))))
 
35
               (t (or (var-ind x) (next-cvar x))
 
36
                  (cond ((stringp (var-ind x)) (wr (var-ind x)))
 
37
                        (t (wr "V" (var-ind x)))))))
 
38
        ((eq t x)(wr "Ct"))
 
39
        ((eq nil x)(wr "Cnil"))
 
40
        ((typep x 'label)
 
41
         (or (label-ind x) (setf (label-ind x) (next-label)))
 
42
         (wr (label-ind x)))
 
43
        ((typep x 'fdata)
 
44
         (let ((i (fdata-ind x)))
 
45
           (if (stringp i) (wr i) (wr "L" i))))
 
46
        (t (wfs-error))))
 
47
 
 
48
(defun wr1-h (x &aux (*c-output* *h-output*))
 
49
  (wr1 x))
 
50
 
 
51
(setf (get 'dv 'wr) 'wr-dv)
 
52
(setf (get 'd_eval 'wr) 'wr-dv)
 
53
 
 
54
(defun add-data (x &aux tem)
 
55
  (or (and (consp x) (or (eq (car x) 'dv)
 
56
                         (eq (car x) 'd_eval)))
 
57
      (wfs-error))
 
58
  (let ((item (third x)))
 
59
    (unless (second x)
 
60
            (cond
 
61
             ((and (symbolp item)
 
62
                   (setq tem (get item 'dv)))
 
63
              (setf (second x) tem))
 
64
             ((and (typep item 'fixnum)
 
65
               (eql 0 (logand #. (lognot 1023) (the fixnum item))))
 
66
              (setf (cadr x)
 
67
                    (format nil "small_fixnum(~a)" item)))
 
68
             (t (setf (second x) *next-data*)
 
69
                (push-data (car x) (third x)))))
 
70
    x))
 
71
 
 
72
;; Some things namely the keyword mechanism REQUIRES a constant which
 
73
;; has an index.   This means that named ones will have to get an index
 
74
;; We could smash this place
 
75
(defun get-dv-index (x)
 
76
  ;; a (dv which may have a string.   We put an index in the fourth place.)
 
77
  (cond ((typep (second x) 'fixnum) (second x))
 
78
        ((cdddr x) (fourth x))
 
79
        (t (setq x (nconc x (list *next-data*)))
 
80
           (push-data (car x) (third x)))))
 
81
      
 
82
(defun wr-dv (x)
 
83
  (let ((tem (second x)))
 
84
    (cond (tem
 
85
           (cond ((typep tem 'fixnum) (wr "VV[" tem"]"))
 
86
                 (t (wr tem))))
 
87
          (t (add-data x)
 
88
             (wr-dv x)))))
 
89
 
 
90
 
 
91
(setf (get 'var 'wr) 'wr-var)
 
92
(defun wr-var (x)
 
93
  (cond ((and (consp x) (eq (car x) 'var))
 
94
         (wr-vind (second x)))
 
95
        (t (wfs-error))))
 
96
 
 
97
(defun wr-vind (x)
 
98
    (if (stringp x) (wr x) (wr "V" x)))
 
99
 
 
100
(setf (get 'closure-var-loc 'wr) 'wr-closure-var-loc)
 
101
(defun wr-closure-var-loc (x &aux (var (second x)))
 
102
  (cond ((member var *closure-vars*)
 
103
         (wr "CLvars->")
 
104
         (or (and (consp (var-ind var)) (eq (car (var-ind var)) 'kw))
 
105
             (wfs-error))
 
106
         (wr-vind (second (var-ind var))))
 
107
        (t (wr-vind (var-ind var)))))
 
108
 
 
109
(setf (get 'key-var 'wr) 'wr-key-var)
 
110
(defun wr-key-var (x &aux (v (second x)) tem)
 
111
  (or (typep v 'var) (wfs-error))
 
112
  (cond ((setq tem (var-special-p v))
 
113
         (wr tem))
 
114
        (t
 
115
         (wr-vind (var-ind v)))))
 
116
        
 
117
         
 
118
 
 
119
(setf (get 'vcs 'wr) 'wr-vcs)
 
120
(defun wr-vcs(x)
 
121
  (wr "cs[" (second x)"]"))
 
122
 
 
123
(setf (get 'kw 'wr) 'wr-kw)
 
124
(defun wr-kw(x)
 
125
  (wr "k.")
 
126
  (wr-vind (second x)))
 
127
 
 
128
(setf (get 'vk 'wr) 'wr-vk)
 
129
(defun wr-vk (x)
 
130
  (wr "&VK" (second x) "key"))
 
131
 
 
132
(defun wr-comment (message &optional (symbol nil))
 
133
  (wr "
 
134
/*      "  message)
 
135
   (and symbol (wr (mangle symbol)))
 
136
  
 
137
  (wr " */
 
138
")      
 
139
  nil)
 
140
 
 
141
(setf (get 'label 'wr) 'wr-label)
 
142
(defun wr-label (n &aux)
 
143
  (when  (consp n)
 
144
    (or (eq (car n) 'label) (wfs-error))
 
145
    (setq n (second n)))
 
146
         (wr "
 
147
 LA" n ": "))
 
148
           
 
149
(defun wr-go (n)
 
150
  (if (typep n 'label)
 
151
      (or (label-ind n) (setq n (setf (label-ind n) (next-label)))))
 
152
  (wr "goto LA" n ";"))
 
153
 
 
154
(defun wr-list (l)
 
155
  (do ((v l (cdr v)))
 
156
      ((null v))
 
157
      (wr (car v))
 
158
      (or (null (cdr v)) (wr ","))))  
 
159
 
 
160
(setf (get 'next-var-arg 'wr) 'wr-next-var-arg)
 
161
(defun wr-next-var-arg (x)
 
162
  x  (wr "va_arg(Iap,object)"))
 
163
 
 
164
 
 
165
(setf (get 'call 'wr) 'wr-call)
 
166
(defun wr-call (x)
 
167
  (let* ((cdat (second x))
 
168
         (fname (call-data-fname cdat))
 
169
         (name (if (symbolp fname) (symbol-name fname)
 
170
                 (format nil "L~a" (fdata-ind fname)))))
 
171
    (wr "CA_" name   "(")
 
172
    (wr-list (third x))
 
173
    (wr ")"))
 
174
  )
 
175
 
 
176
(defmacro var-implementation-type (x)
 
177
  `(cond ((and (plain-var-p ,x)
 
178
               (not (and (consp (var-ind ,x)) (eq (car (var-ind ,x)) 'kw))))
 
179
          (var-type ,x))
 
180
         (t t)))
 
181
    
 
182
(defun wr-set-inline-loc (a b &aux type)
 
183
  (cond ((eq a b) (wr ";")(return-from wr-set-inline-loc nil)))
 
184
  (cond((atom a)
 
185
         (or (typep a 'var) (wfs-error))
 
186
         (cond ((var-special-p a)
 
187
                (setq type 'special)
 
188
                (wr-nl "(" (var-ind a) ")->s.Bind = "))
 
189
               (t (setq type (var-implementation-type a)))))
 
190
        ((and (consp a) (eq (car a) 'var))
 
191
         (setq type (third a)))
 
192
        (t (wfs-error)))
 
193
  
 
194
  (cond ((eq type 'integer)
 
195
         (let ((val-type (value-type b)))
 
196
           (case val-type
 
197
             (fixnum (wr-nl "ISETQ_FIX(") )
 
198
             (integer (wr-nl "SETQ_II(") )
 
199
             (otherwise (wr-nl "SETQ_IO(") (setq val-type t)))
 
200
           (setq b (list 'inline-loc val-type b))
 
201
           (wr  a","a"__alloc," b ");")
 
202
           (return-from wr-set-inline-loc nil)))
 
203
        ((eq type 'special)
 
204
         (setq type t))
 
205
        (t  (wr-nl a "=")))
 
206
  (case type
 
207
    (fixnum (wr-fixnum-loc b))
 
208
    (character (wr-character-loc b))
 
209
    (gen (wr-integer-loc b))
 
210
    (double-float (wr-double-float-loc b))
 
211
    (double_ptr (wr-double_ptr-loc b))
 
212
    (short-float (wr-short-float-loc b))
 
213
    (boolean (wr-boolean-loc b))
 
214
    (t (wr-obj-loc b)))
 
215
  (wr ";")
 
216
  )
 
217
 
 
218
(defun wr-integer-loc (x)
 
219
  (cond ((and (dv-p x) (typep (third x) 'fixnum))
 
220
         (setq x (list 'inline-loc 'fixnum x))))
 
221
  (case (value-type x)
 
222
    (integer (wr x))
 
223
    (fixnum (wr "stoi(" x ")"))
 
224
    (t  (wr "otoi(" x ")"))))
 
225
 
 
226
 
 
227
 
 
228
(defun value-type (x &aux tem)
 
229
  ;; returns the representation type of form x
 
230
  (setq tem
 
231
        (cond ((consp x)
 
232
               (cond ((eq (car x) 'dv) t)
 
233
                     
 
234
                     ((eq (car x) 'var) (or (third x) t))
 
235
                     ((eq (car x) 'inline-call) (nth 3 x))
 
236
                     ((eq (car x) 'inline-loc) (nth 1 x))
 
237
                     ((eq (car x) 'let-control-stack)
 
238
                      (value-type (second x)))
 
239
                     ((eq (car x) 'next-var-arg) t)
 
240
                     ))
 
241
              ((typep x 'var)
 
242
               (var-implementation-type x))))
 
243
 
 
244
  (unless tem
 
245
          (comp-warn "Don't know type of ~a.  Assuming type t" x))
 
246
  (or (memq tem '(fixnum integer  short-float double-float character boolean double_ptr))
 
247
      (setq tem t))
 
248
  tem)
 
249
 
 
250
 
 
251
(setf (get 'inline-loc 'wr) 'wr-inline-loc)
 
252
 
 
253
(defun wr-inline-loc (x &aux (y (third x)) (type (second x)))
 
254
  (case type
 
255
    (fixnum (wr-fixnum-loc y))
 
256
    (short-float (wr-short-float-loc y))
 
257
    (double-float (wr-double-float-loc y))
 
258
    (double_ptr (wr-double_ptr-loc y))
 
259
    (character (wr-character-loc y))
 
260
    ((gen integer) (wr-integer-loc y))
 
261
    (boolean (wr-boolean-loc y))
 
262
    (t (wr-obj-loc y))))
 
263
    
 
264
(setf (get 'fixnum 'loc) 'wr-fixnum)
 
265
 
 
266
(defun wr-boolean-loc (x)
 
267
  (let ((type (value-type x)))
 
268
    (case type
 
269
      (boolean (wr x))
 
270
      ((short-float double_ptr character long-float integer) (wr "1"))
 
271
      (t       (wr "(" x ")!=sLnil" )))))
 
272
         
 
273
 
 
274
(defun wr-fixnum-loc (b)
 
275
  (case (value-type b)
 
276
    (fixnum (wr b))
 
277
    ((short-float long-float) (wr "(int)(" b")" ))
 
278
    (double_ptr (wr "(int)(*(" b "))"))
 
279
    (integer (wr "itos(" b")"))
 
280
    (t
 
281
     (cond ((and (consp b) (eq (car b) 'dv))
 
282
            (cond ((typep (third b) 'fixnum)
 
283
                   (wr  (third b)) (return-from wr-fixnum-loc nil))
 
284
                  (t  (comp-warn "Not a fixnum ~a "(third b))))))
 
285
     (wr "fix(" b ")"))))
 
286
 
 
287
(defun wr-character-loc (b)
 
288
  (case (value-type b)
 
289
    (character (wr b))
 
290
    ((short-float long-float)
 
291
     (comp-error "Cant coerce float to character")
 
292
     (wr "(int)(" b")" ))
 
293
    (integer (wfs-todo))
 
294
    (t
 
295
     (cond ((and (consp b) (eq (car b) 'dv))
 
296
            (cond ((typep (third b) 'character)
 
297
                   (wr  (char-code (third b))) (return-from wr-character-loc nil))
 
298
                  (t  (comp-warn "Not a character ~a "(third b))))))
 
299
     (wr "char_code(" b ")"))))
 
300
 
 
301
 
 
302
(defun wr-double-float-loc (b)
 
303
  (case (value-type b)
 
304
    ((short-float fixnum) (wr "(double)(" b ")"))
 
305
    (double-float (wr b))
 
306
    (double_ptr (wr "*(" b ")"))
 
307
    (integer (wfs-todo))
 
308
    (t  (wr "DFloat(" b ")"))))
 
309
 
 
310
(defun wr-short-float-loc (b)
 
311
  (case (value-type b)
 
312
    ((short-float fixnum double-float) (wr "(float)(" b ")"))
 
313
    (double_ptr (wr "(float)(*(" b "))"))
 
314
    (integer (wfs-todo))
 
315
    (t  (wr "SFloat(" b ")"))))
 
316
 
 
317
(defun wr-double_ptr-loc (b &aux tem)
 
318
  (case (value-type b)
 
319
    ((short-float fixnum)
 
320
     (setq tem (get-temp 'double_ptr))
 
321
     (wr "*"tem" = (double)(" b ")") )
 
322
    (double (wr "*("b")"))
 
323
    (integer (wfs-todo))
 
324
    (t 
 
325
       ;;wrong
 
326
     (object (wr "&(DFloat(" b "))")))))
 
327
 
 
328
 
 
329
(defun wr-obj-loc (x)
 
330
  (case (value-type x)
 
331
    (short-float (wr "make_shortfloat(" x ")"))
 
332
    (double-float (wr "Imake_doublefloat(" x ")"))
 
333
    (double_ptr (wr "Imake_doublefloat(*(" x "))"))
 
334
    (fixnum (wr "make_fixnum(" x ")"))
 
335
    (integer
 
336
     (wr "make_integer(" x ")"))
 
337
    (character (wr "code_char(" x ")"))
 
338
    (boolean (wr "(" x "? sLt : sLnil)"))
 
339
    (t (wr x))))
 
340
    
 
341
(setf (get 'inline-call 'wr) 'wr-inline-call)
 
342
 
 
343
(defun wr-inline-call (x )
 
344
;  (desetq (sform iargs arg-types res flags fstring) x)
 
345
  (wr-inline-call1 (cadr x) (opt template (cddr x))))
 
346
 
 
347
(defun wr-link-call (lnk iargs &aux nochange)
 
348
  (let* ((argd (link-argd lnk))
 
349
         (n (length iargs)))
 
350
    (declare (fixnum argd ))
 
351
    (cond ((< n (argd-minargs argd))
 
352
           (setf (argd-minargs argd) n))
 
353
          ((> n  (argd-maxargs argd))
 
354
           (setf (argd-maxargs argd) n))
 
355
          (t (setq nochange t))
 
356
          (setf (argd-minargs (link-argd lnk))))
 
357
    (unless nochange
 
358
            (setf (link-argd lnk) argd))
 
359
    (or (link-ind lnk) (setf (link-ind lnk) (mangle-name (link-fname lnk) 'function)))
 
360
    (cond ((argd-flag-p argd requires-nargs)
 
361
           (wr "(VFUN_NARGS=" n ",")))
 
362
    
 
363
    (wr "(*LnK" (link-ind lnk) ")(")
 
364
    (wr-list iargs)
 
365
    (wr ")")
 
366
    (cond ((argd-flag-p   argd requires-nargs)
 
367
           (wr ")")))))
 
368
 
 
369
(defun wr-inline-call1 (iargs fstring &aux
 
370
                         (leng 0) wrote-paren
 
371
                          (ch #\space) (ind 0) (start 0)
 
372
                         (out *c-output*))
 
373
;; $@i : write out all (nthcdr i args) in a comma separated list.
 
374
;; $i : write out arg i  ( 0<= i < 10)
 
375
;; $# : write out (length iargs)
 
376
;; @i,j,..; i,j,.. are multiple eval'd.
 
377
;; $*i : push args starting at the ith onto value stack and pass the pointer
 
378
;;       to the place where you start.        
 
379
  (declare (character ch) (fixnum ind leng start)
 
380
           (string fstring))
 
381
  (cond ((stringp fstring))
 
382
        ((typep fstring 'link)
 
383
         (wr-link-call fstring iargs) (return-from wr-inline-call1 nil))
 
384
        (t  (return-from wr-inline-call1 (funcall fstring iargs))))
 
385
  (setq leng (length fstring))
 
386
  ;; save multiple eval'd args.  @0,3; means args 0 and 3 need temps.
 
387
  (cond ((eql (aref fstring 0) #\@)
 
388
         (sloop for i from 1 below leng 
 
389
            until (eql (setq ch (aref fstring i)) #\;)
 
390
            when (digit-char-p ch)
 
391
            do (let ((tem (nth (setq ind (-  (char-code ch )(char-code #\0)))
 
392
                               iargs)))
 
393
                 (unless (or (typep tem 'var)
 
394
                             (and (consp tem)
 
395
                                  (or (eq (car tem) 'dv)
 
396
                                      (eq (car tem) 'var))))
 
397
                         (let ((v (get-temp (value-type
 
398
                                             (nth ind iargs)))))
 
399
                           (setf (nth ind iargs) v)
 
400
                           (unless wrote-paren
 
401
                                   (setq wrote-paren t)
 
402
                                   (wr "("))
 
403
                           (wr  v "= " tem ","))))
 
404
            finally (setq start (+ 1 i)))))
 
405
         
 
406
  ;; write out the template.
 
407
  (sloop for i from start below leng with l = (length iargs)
 
408
     declare (fixnum l)
 
409
     do (setq ch (aref (the string fstring) i))
 
410
     (cond
 
411
      ((or (eql ch #\$)
 
412
           (eql ch #\#);; compatibility with akcl
 
413
           )
 
414
       (setq i (+ i 1))
 
415
       (setq ch (aref (the string fstring) i))
 
416
       (setq ind (- (char-code ch) (char-code #\0)))
 
417
       (cond ((and (< ind 10) (>= ind 0))
 
418
              (if (>= ind l)
 
419
                  (comp-error "Bad inline template ~a" fstring))
 
420
              (wr (nth ind iargs)))
 
421
             ((eql ch #\@)
 
422
              (setq i (+ i 1))
 
423
              (let ((n (- (char-code (aref fstring i)) (char-code #\0))))
 
424
                (declare (fixnum n))
 
425
                (wr-list (nthcdr n  iargs))))
 
426
             ((eql ch #\*)
 
427
              (setq i (+ i 1))
 
428
              (let* ((n (- (char-code (aref fstring i)) (char-code #\0)))
 
429
                     (m (- (length iargs) n))
 
430
                     (p (get-temp "object *")))
 
431
                (declare (fixnum n m))
 
432
                (wr "(" p "= (vs_top+=" m"),")
 
433
                (sloop for v in (reverse (nthcdr n iargs))
 
434
                   do (wr "*--"p" =" v","))
 
435
                (wr p ")")))
 
436
             ((eql ch #\# ) (wr (length iargs)))
 
437
             (t (comp-error "Bad inline string ~s" fstring))))
 
438
      (t (write-char ch out))))
 
439
  ;
 
440
  (if wrote-paren (wr ")"))
 
441
  )
 
442
(defun write-out-links( &aux lnk)
 
443
  (dolist (v *file-inline-templates*)
 
444
    (or (typep (setq lnk (nth 4 v)) 'link) (wfs-error))
 
445
  (let ((ind (link-ind lnk))
 
446
        (rett (rep-type (third v))))
 
447
      (wr "
 
448
static " rett "LnKT" ind "(va_alist)va_dcl
 
449
{va_list Iap; va_start(Iap); return ("rett ")Icall_proc"
 
450
  (if (eq (third v) 'short-float) "_float(" "(")
 
451
  (get-object (link-fname lnk)) ","
 
452
             (link-argd lnk)
 
453
             ",&LnK"  (link-ind lnk ) ",Iap);}")
 
454
      (wr-h "static "rett "LnKT"ind"(),(*LnK"
 
455
            ind ")()=LnKT" ind ";")
 
456
      )
 
457
    ))
 
458
 
 
459
(defun  write-out-address-and-data ()
 
460
  (let ((*c-output* *h-output*))
 
461
  (wr"
 
462
static object VV["  (max 1 (length *address-vector*) *next-data*) "]={")
 
463
  (let ((l (length *address-vector*))
 
464
        (i 0))
 
465
    (declare (fixnum i l))
 
466
    (sloop while (< i l)
 
467
       do (wr-nl "(void *)" (aref *address-vector* i))
 
468
       when (< (setq i (+ i 1)) l)
 
469
       do (wr ","))
 
470
    (if (eql i 0) (wr 0))
 
471
    (wr "};")))
 
472
  (wt-data-file))
 
473
 
 
474
(setf (get 'address 'wr) 'wr-address)
 
475
(defun wr-address (x)
 
476
  (wr "&" (second x)))
 
 
b'\\ No newline at end of file'