3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;; This file is part of Mes.
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;; GNU General Public License for more details.
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
23 ;;; compiler.mes produces an i386 binary from the C produced by
32 (mes-use-module (srfi srfi-1))
33 (mes-use-module (srfi srfi-26))
34 (mes-use-module (mes pmatch))
35 (mes-use-module (nyacc lang c99 parser))
36 (mes-use-module (nyacc lang c99 pprint))
37 (mes-use-module (mes as))
38 (mes-use-module (mes as-i386))
39 (mes-use-module (mes M1))
40 (mes-use-module (mes optargs))
41 (mes-use-module (language c99 info))))
43 (define (logf port string . rest)
44 (apply format (cons* port string rest))
48 (define (stderr string . rest)
49 (apply logf (cons* (current-error-port) string rest)))
52 (newline (current-error-port))
53 (display ";;; " (current-error-port))
54 (write stuff (current-error-port))
55 (newline (current-error-port))
56 (car (last-pair stuff)))
59 (car (last-pair stuff)))
61 (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") (or (getenv "PREFIX") "") "@PREFIX@"))
63 (define mes? (pair? (current-module)))
65 (define* (c99-input->full-ast #:key (defines '()) (includes '()))
66 (let ((sys-include (if (equal? %prefix "") "include" (string-append %prefix "/share/include"))))
68 #:inc-dirs (append includes (cons* sys-include "include" "lib" (or (and=> (getenv "C_INCLUDE_PATH") (cut string-split <> #\:)) '())))
76 ,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
80 (define (ast-strip-comment o)
82 ((comment . ,comment) #f)
83 (((comment . ,comment) . ,t) (filter-map ast-strip-comment t))
84 (((comment . ,comment) . ,cdr) cdr)
85 ((,car . (comment . ,comment)) car)
86 ((,h . ,t) (if (list? o) (filter-map ast-strip-comment o)
87 (cons (ast-strip-comment h) (ast-strip-comment t))))
90 (define (ast-strip-const o)
92 ((type-qual ,qual) (if (equal? qual "const") #f o))
93 ((pointer (type-qual-list (type-qual ,qual)) . ,rest)
94 (if (equal? qual "const") `(pointer ,@rest) o))
95 ((decl-spec-list (type-qual ,qual))
96 (if (equal? qual "const") #f
97 `(decl-spec-list (type-qual ,qual))))
98 ((decl-spec-list (type-qual ,qual) . ,rest)
99 (if (equal? qual "const") `(decl-spec-list ,@rest)
100 `(decl-spec-list (type-qual ,qual) ,@(map ast-strip-const rest))))
101 ((decl-spec-list (type-qual-list (type-qual ,qual)) . ,rest)
102 (if (equal? qual "const") `(decl-spec-list ,@rest)
103 `(decl-spec-list (type-qual-list (type-qual ,qual)) ,@(map ast-strip-const rest))))
104 ((,h . ,t) (if (list? o) (filter-map ast-strip-const o)
105 (cons (ast-strip-const h) (ast-strip-const t))))
108 (define (ast:function? o)
109 (and (pair? o) (eq? (car o) 'fctn-defn)))
113 ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
114 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
115 ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr (ident ,name) _)) _) name)
117 ((param-decl (decl-spec-list (type-spec (void)))) #f)
118 ((param-decl _ (param-declr (ident ,name))) name)
119 ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
120 ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
121 ((param-decl _ (param-declr (ptr-declr (pointer (pointer)) (ident ,name)))) name)
122 ((param-decl _ (param-declr (ptr-declr (pointer (pointer (pointer))) (ident ,name)))) name)
123 ((param-decl _ (param-declr (ptr-declr (pointer (decl-spec-list) (pointer)) (ident ,name)))) name)
124 ((param-decl _ (param-declr (ptr-declr (pointer (decl-spec-list)) (array-of (ident ,name))))) name)
125 ((param-decl _ (param-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,params)))) name)
127 (format (current-error-port) "SKIP: .name =~a\n" o))))
132 ((param-decl (decl-spec-list (type-spec (void)))) #f)
133 ((param-decl (decl-spec-list (type-spec ,type)) _) (decl->ast-type type))
134 ((param-decl ,type _) type)
136 (format (current-error-port) "SKIP: .type =~a\n" o))))
138 (define (.statements o)
140 ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
141 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)
142 ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)
143 (_ (error ".statements: unsupported: " o))))
145 (define (clone o . rest)
147 (let ((types (.types o))
148 (constants (.constants o))
149 (functions (.functions o))
150 (globals (.globals o))
152 (function (.function o))
155 (continue (.continue o)))
159 (constants constants)
160 (functions functions)
167 (make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:function function #:text text #:break break #:continue continue))))))
169 (define (ident->constant name value)
172 (define (enum->type-entry name fields)
173 (cons `("tag" ,name) (make-type 'enum 4 0 fields)))
175 (define (struct->type-entry name fields)
176 (cons `("tag" ,name) (make-type 'struct (apply + (map field:size fields)) 0 fields)))
178 (define (union->type-entry name fields)
179 (cons `("tag" ,name) (make-type 'union (apply + (map field:size fields)) 0 fields)))
181 (define i386:type-alist
182 `(("char" . ,(make-type 'builtin 1 0 #f))
183 ("short" . ,(make-type 'builtin 2 0 #f))
184 ("int" . ,(make-type 'builtin 4 0 #f))
185 ("long" . ,(make-type 'builtin 4 0 #f))
186 ;;("long long" . ,(make-type 'builtin 8 0 #f))
187 ;;("long long int" . ,(make-type 'builtin 8 0 #f))
189 ("long long" . ,(make-type 'builtin 4 0 #f)) ;; FIXME
190 ("long long int" . ,(make-type 'builtin 4 0 #f))
192 ("void" . ,(make-type 'builtin 1 0 #f))
194 ("unsigned char" . ,(make-type 'builtin 1 0 #f))
195 ("unsigned short" . ,(make-type 'builtin 2 0 #f))
196 ("unsigned short int" . ,(make-type 'builtin 2 0 #f))
197 ("unsigned" . ,(make-type 'builtin 4 0 #f))
198 ("unsigned int" . ,(make-type 'builtin 4 0 #f))
199 ("unsigned long" . ,(make-type 'builtin 4 0 #f))
201 ;; ("unsigned long long" . ,(make-type 'builtin 8 0 #f))
202 ;; ("unsigned long long int" . ,(make-type 'builtin 8 0 #f))
203 ("unsigned long long" . ,(make-type 'builtin 4 0 #f)) ;; FIXME
204 ("unsigned long long int" . ,(make-type 'builtin 4 0 #f))
207 (define (field:name o)
209 ((struct (,name ,type ,size ,pointer) . ,rest) name)
210 ((union (,name ,type ,size ,pointer) . ,rest) name)
211 ((,name ,type ,size ,pointer) name)
212 (_ (error "field:name not supported:" o))))
214 (define (field:pointer o)
216 ((struct (,name ,type ,size ,pointer) . ,rest) pointer)
217 ((union (,name ,type ,size ,pointer) . ,rest) pointer)
218 ((,name ,type ,size ,pointer) pointer)
219 (_ (error "field:name not supported:" o))))
221 (define (field:size o)
223 ((struct . ,fields) (apply + (map field:size fields)))
224 ((union . ,fields) (apply max (map field:size fields)))
225 ((,name ,type ,size ,pointer) size)
226 (_ (error (format #f "field:size: ~s\n" o)))))
228 (define (field:type o)
230 ((,name ,type ,size ,pointer) type)
231 (_ (error (format #f "field:type: ~s\n" o)))))
233 (define (get-type types o)
234 (let ((t (assoc-ref types o)))
236 ((typedef ,next) (get-type types next))
239 (define (ast-type->type info o)
241 ((p-expr ,expr) (ast-type->type info (expr->type info o)))
242 ((pre-inc ,expr) (ast-type->type info expr))
243 ((post-inc ,expr) (ast-type->type info expr))
244 ((decl-spec-list ,type-spec)
245 (ast-type->type info type-spec))
246 ((decl-spec-list (type-qual ,qual) (type-spec (fixed-type ,type)))
247 (ast-type->type info type))
248 ((array-ref ,index (p-expr (ident ,array)))
249 (ast-type->type info `(p-expr (ident ,array))))
250 ((struct-ref (ident ,type))
251 (or (get-type (.types info) type)
252 (let ((struct (if (pair? type) type `("tag" ,type))))
253 (ast-type->type info struct))))
254 ((union-ref (ident ,type))
255 (or (get-type (.types info) type)
256 (let ((struct (if (pair? type) type `("tag" ,type))))
257 (ast-type->type info struct))))
258 ((void) (ast-type->type info "void"))
259 ((type-spec ,type) (ast-type->type info type))
260 ((fixed-type ,type) (ast-type->type info type))
261 ((typename ,type) (ast-type->type info type))
263 (ast-type->type info expr))
264 ((d-sel (idend ,field) ,struct)
265 (let ((type0 (ast-type->type info struct)))
266 (field-type info type0 field)))
267 ((i-sel (ident ,field) ,struct)
268 (let ((type0 (ast-type->type info struct)))
269 (field-type info type0 field)))
270 (_ (let ((type (get-type (.types info) o)))
273 (stderr "types: ~s\n" (.types info))
274 (error "ast-type->type: unsupported: " o)))))))
276 (define (ast-type->description info o)
277 (let* ((type (ast-type->type info o))
278 (xtype (if (type? type) type
279 (ast-type->type info type))))
280 (type:description xtype)))
282 (define (ast-type->size info o)
283 (let* ((type (ast-type->type info o))
284 (xtype (if (type? type) type
285 (ast-type->type info type))))
288 (define (field-field info struct field)
289 (let* ((xtype (if (type? struct) struct
290 (ast-type->type info struct)))
291 (fields (type:description xtype)))
292 (let loop ((fields fields))
293 (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
294 (let ((f (car fields)))
295 (cond ((equal? (car f) field) f)
296 ((and (memq (car f) '(struct union))
297 (find (lambda (x) (equal? (car x) field)) (cdr f))))
298 (else (loop (cdr fields)))))))))
300 (define (field-offset info struct field)
301 (let ((xtype (if (type? struct) struct
302 (ast-type->type info struct))))
303 (if (eq? (type:type xtype) 'union) 0
304 (let ((fields (type:description xtype)))
305 (let loop ((fields fields) (offset 0))
306 (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
307 (let ((f (car fields)))
308 (cond ((equal? (car f) field) offset)
309 ((and (eq? (car f) 'struct)
310 (find (lambda (x) (equal? (car x) field)) (cdr f))
311 (apply + (cons offset
313 (member field (reverse (cdr f))
315 (equal? a (car b) field))))))))
316 ((and (eq? (car f) 'union)
317 (find (lambda (x) (equal? (car x) field)) (cdr f))
319 (else (loop (cdr fields) (+ offset (field:size f))))))))))))
321 (define (field-pointer info struct field)
322 (let ((field (field-field info struct field)))
323 (field:pointer field)))
325 (define (field-size info struct field)
326 (let ((xtype (if (type? struct) struct
327 (ast-type->type info struct))))
328 (if (eq? (type:type xtype) 'union) 0
329 (let ((field (field-field info struct field)))
330 (field:size field)))))
332 (define (field-type info struct field)
333 (let ((field (field-field info struct field)))
336 (define (ast->type o)
342 ((struct-ref (ident ,type))
344 (_ (stderr "SKIP: type=~s\n" o)
347 (define (decl->ast-type o)
349 ((fixed-type ,type) type)
350 ((struct-ref (ident (,name))) `("tag" ,name))
351 ((struct-ref (ident ,name)) `("tag" ,name))
352 ((struct-def (ident ,name) . ,fields) `("tag" ,name))
353 ((decl (decl-spec-list (type-spec (struct-ref (ident ,name))))) ;; "scm"
354 `("tag" ,name)) ;; FIXME
355 ((typename ,name) name)
357 (_ (error "decl->ast-type: unsupported: " o))))
359 (define (byte->hex.m1 o)
363 (let ((prefix ".byte "))
364 (if (not (string-prefix? prefix o)) (map (cut string-split <> #\space) (string-split o #\newline))
365 (let ((s (string-drop o (string-length prefix))))
366 (list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " ")))))))
368 (define (ident->decl info o)
369 (or (assoc-ref (.locals info) o)
370 (assoc-ref (.globals info) o)
371 (assoc-ref (.constants info) o)
373 (stderr "NO IDENT: ~a\n" o)
374 (assoc-ref (.functions info) o))))
376 (define (ident->type info o)
377 (let ((type (ident->decl info o)))
378 (cond ((global? type) (global:type type))
379 ((local? type) (local:type type))
380 ((assoc-ref (.constants info) o) "int")
381 (else (stderr "ident->type ~s => ~s\n" o type)
384 (define (ident->pointer info o)
385 (let ((local (assoc-ref (.locals info) o)))
386 (if local (local:pointer local)
387 (let ((global (assoc-ref (.globals info) o)))
389 (global:pointer (ident->decl info o))
392 (define (ident->type-size info o)
393 (let* ((type (ident->type info o))
394 (xtype (ast-type->type info type)))
405 (define (expr->pointer info o)
408 ((p-expr (char ,value)) 0)
409 ((p-expr (fixed ,value)) 0)
410 ((p-expr (ident ,name)) (ident->pointer info name))
411 ((de-ref ,expr) (ptr-dec (expr->pointer info expr)))
412 ((assn-expr ,lhs ,op ,rhs) (expr->pointer info lhs))
413 ((add ,a ,b) (expr->pointer info a))
414 ((div ,a ,b) (expr->pointer info a))
415 ((mod ,a ,b) (expr->pointer info a))
416 ((mul ,a ,b) (expr->pointer info a))
417 ((sub ,a ,b) (expr->pointer info a))
418 ((neg ,a) (expr->pointer info a))
419 ((pre-inc ,a) (expr->pointer info a))
420 ((pre-dec ,a) (expr->pointer info a))
421 ((post-inc ,a) (expr->pointer info a))
422 ((post-dec ,a) (expr->pointer info a))
423 ((ref-to ,expr) (ptr-inc (expr->pointer info expr)))
424 ((array-ref ,index ,array) (ptr-dec (expr->pointer info array)))
426 ((d-sel (ident ,field) ,struct)
427 (let ((type (expr->type info struct)))
428 (field-pointer info type field)))
430 ((i-sel (ident ,field) ,struct)
431 (let ((type (expr->type info struct)))
432 (field-pointer info type field)))
434 ((cast (type-name ,type) ,expr) ; FIXME: add expr?
435 (let* ((type (ast-type->type info type))
436 (pointer (type:pointer type)))
438 ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: add expr?
439 (let* ((type (ast-type->type info type))
440 (pointer0 (type:pointer type))
441 (pointer1 (ptr-declr->pointer pointer))
442 (pointer2 (expr->pointer info expr)))
443 (+ pointer0 pointer1)))
444 (_ (stderr "expr->pointer: unsupported: ~s\n" o) 0)))
447 (define %pointer-size %int-size)
449 (define (expr->type-size info o)
451 ((p-expr (char ,value)) 1)
452 ((p-expr (fixed ,name)) %int-size)
453 ((p-expr (ident ,name)) (ident->type-size info name))
455 ((array-ref ,index ,array)
456 (let ((type (expr->type info array)))
457 (ast-type->size info type)))
459 ((d-sel (ident ,field) ,struct)
460 (let* ((type (expr->type info struct))
461 (type (field-type info type field)))
462 (ast-type->size info type)))
464 ((i-sel (ident ,field) ,struct)
465 (let* ((type (expr->type info struct))
466 (type (field-type info type field)))
467 (ast-type->size info type)))
469 ((de-ref ,expr) (expr->type-size info expr))
470 ((ref-to ,expr) (expr->type-size info expr))
471 ((add ,a ,b) (expr->type-size info a))
472 ((div ,a ,b) (expr->type-size info a))
473 ((mod ,a ,b) (expr->type-size info a))
474 ((mul ,a ,b) (expr->type-size info a))
475 ((sub ,a ,b) (expr->type-size info a))
476 ((neg ,a) (expr->type-size info a))
477 ((pre-inc ,a) (expr->type-size info a))
478 ((pre-dec ,a) (expr->type-size info a))
479 ((post-inc ,a) (expr->type-size info a))
480 ((post-dec ,a) (expr->type-size info a))
481 ((cast (type-name ,type) ,expr) ; FIXME: ignore expr?
482 (let ((type (ast-type->type info type)))
484 ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr?
485 (let ((type (ast-type->type info type)))
487 (_ (stderr "expr->type-size: unsupported: ~s\n" o) 4)))
489 (define (expr->size info o)
490 (let ((ptr (expr->pointer info o)))
493 (expr->type-size info o)
496 (define (expr->type info o)
498 ((p-expr (char ,name)) "char")
499 ((p-expr (fixed ,value)) "int")
500 ((p-expr (ident ,name)) (ident->type info name))
501 ((array-ref ,index ,array)
502 (expr->type info array))
504 ((i-sel (ident ,field) ,struct)
505 (let ((type (expr->type info struct)))
506 (field-type info type field)))
508 ((d-sel (ident ,field) ,struct)
509 (let ((type (expr->type info struct)))
510 (field-type info type field)))
512 ((de-ref ,expr) (expr->type info expr))
513 ((ref-to ,expr) (expr->type info expr))
514 ((add ,a ,b) (expr->type info a))
515 ((div ,a ,b) (expr->type info a))
516 ((mod ,a ,b) (expr->type info a))
517 ((mul ,a ,b) (expr->type info a))
518 ((sub ,a ,b) (expr->type info a))
519 ((neg ,a) (expr->type info a))
520 ((pre-inc ,a) (expr->type info a))
521 ((pre-dec ,a) (expr->type info a))
522 ((post-inc ,a) (expr->type info a))
523 ((post-dec ,a) (expr->type info a))
524 ((cast (type-name ,type) ,expr) ; FIXME: ignore expr?
526 ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr?
528 ((fctn-call (p-expr (ident ,name)))
529 (stderr "TODO: expr->type: unsupported: ~s\n" o)
531 (_ ;;(error (format #f "expr->type: unsupported: ~s") o)
532 (stderr "TODO: expr->type: unsupported: ~s\n" o)
535 (define (append-text info text)
536 (clone info #:text (append (.text info) text)))
538 (define (push-global info)
540 (let ((ptr (ident->pointer info o)))
541 (cond ((< ptr 0) (list (i386:push-label `(#:address ,o))))
542 (else (list (i386:push-label-mem `(#:address ,o))))))))
544 (define (push-local locals)
546 (wrap-as (i386:push-local (local:id o)))))
548 (define (push-global-address info)
550 (list (i386:push-label o))))
552 (define (push-local-address locals)
554 (wrap-as (i386:push-local-address (local:id o)))))
556 (define push-global-de-ref push-global)
558 (define (push-local-de-ref info)
561 (ptr (local:pointer local))
562 (size (if (= ptr 1) (ast-type->size info (local:type o))
565 ((1) (wrap-as (i386:push-byte-local-de-ref (local:id o))))
566 ((2) (wrap-as (i386:push-word-local-de-ref (local:id o))))
567 ((4) (wrap-as (i386:push-local-de-ref (local:id o))))
568 (else (error (format #f "TODO: push size >4: ~a\n" size)))))))
570 (define (push-local-de-de-ref info)
573 (ptr (local:pointer local))
574 (size (if (= ptr 2) (ast-type->size info (local:type o));; URG
577 (wrap-as (i386:push-byte-local-de-de-ref (local:id o)))
578 (error "TODO int-de-de-ref")))))
580 (define (make-global-entry key type pointer value)
581 (cons key (make-global type pointer value)))
583 (define (string->global-entry string)
584 (make-global-entry `(#:string ,string) "string" 0 (append (string->list string) (list #\nul))))
586 (define (int->global-entry value)
587 (make-global-entry (number->string value) "int" 0 (int->bv32 value)))
589 (define (ident->global-entry name type pointer value)
590 (make-global-entry name type pointer (if (pair? value) value (int->bv32 value))))
592 (define (make-local-entry name type pointer id)
593 (cons name (make-local type pointer id)))
595 (define* (mescc:trace name #:optional (type ""))
596 (format (current-error-port) " :~a~a\n" name type))
598 (define (push-ident info)
600 (let ((local (assoc-ref (.locals info) o)))
603 (let* ((ptr (local:pointer local)))
604 (if (or (< ptr 0)) ((push-local-address (.locals info)) local)
605 ((push-local (.locals info)) local))))
606 (let ((global (assoc-ref (.globals info) o)))
608 ((push-global info) o) ;; FIXME: char*/int
609 (let ((constant (assoc-ref (.constants info) o)))
611 (wrap-as (append (i386:value->accu constant)
613 ((push-global-address #f) `(#:address ,o))))))))))
615 (define (push-ident-address info)
617 (let ((local (assoc-ref (.locals info) o)))
618 (if local ((push-local-address (.locals info)) local)
619 (let ((global (assoc-ref (.globals info) o)))
621 ((push-global-address info) o)
622 ((push-global-address #f) `(#:address ,o))))))))
624 (define (push-ident-de-ref info)
626 (let ((local (assoc-ref (.locals info) o)))
627 (if local ((push-local-de-ref info) local)
628 ((push-global-de-ref info) o)))))
630 (define (push-ident-de-de-ref info)
632 (let ((local (assoc-ref (.locals info) o)))
633 (if local ((push-local-de-de-ref info) local)
634 (error "TODO: global push-local-de-de-ref")))))
636 (define (expr->arg info)
638 (let ((info ((expr->accu info) o)))
639 (append-text info (wrap-as (i386:push-accu))))))
641 (define (globals:add-string globals)
643 (let ((string `(#:string ,o)))
644 (if (assoc-ref globals string) globals
645 (append globals (list (string->global-entry o)))))))
647 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
649 (let ((text (.text info)))
652 ((p-expr (string ,string))
653 (let* ((globals ((globals:add-string (.globals info)) string))
654 (info (clone info #:globals globals)))
655 (append-text info ((push-global-address info) `(#:string ,string)))))
657 ((p-expr (ident ,name))
658 (append-text info ((push-ident info) name)))
660 ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
661 (abs-declr (pointer)))
663 ((expr->arg info) cast))
665 ((cast (type-name (decl-spec-list (type-spec (fixed-type ,type)))) ,cast)
666 ((expr->arg info) cast))
668 ((de-ref (p-expr (ident ,name)))
669 (append-text info ((push-ident-de-ref info) name)))
671 ((de-ref (de-ref (p-expr (ident ,name))))
672 (append-text info ((push-ident-de-de-ref info) name)))
674 ((ref-to (p-expr (ident ,name)))
675 (append-text info ((push-ident-address info) name)))
677 (_ (append-text ((expr->accu info) o)
678 (wrap-as (i386:push-accu))))))))
680 (define (ident->accu info)
682 (let ((local (assoc-ref (.locals info) o))
683 (global (assoc-ref (.globals info) o))
684 (constant (assoc-ref (.constants info) o)))
686 (let* ((ptr (local:pointer local))
687 (type (ident->type info o))
688 (size (if (= ptr 0) (ast-type->size info type)
690 (cond ((< ptr 0) (wrap-as (i386:local-ptr->accu (local:id local))))
691 (else (wrap-as (case size
692 ((1) (i386:byte-local->accu (local:id local)))
693 ((2) (i386:word-local->accu (local:id local)))
694 (else (i386:local->accu (local:id local))))))))
696 (let* ((ptr (ident->pointer info o)))
697 (cond ((< ptr 0) (list (i386:label->accu `(#:address ,o))))
698 (else (list (i386:label-mem->accu `(#:address ,o))))))
699 (if constant (wrap-as (i386:value->accu constant))
700 (list (i386:label->accu `(#:address ,o)))))))))
702 (define (ident-address->accu info)
704 (let ((local (assoc-ref (.locals info) o))
705 (global (assoc-ref (.globals info) o))
706 (constant (assoc-ref (.constants info) o)))
707 (if local (wrap-as (i386:local-ptr->accu (local:id local)))
708 (if global (list (i386:label->accu `(#:address ,o)))
709 (list (i386:label->accu `(#:address ,o))))))))
711 (define (ident-address->base info)
713 (let ((local (assoc-ref (.locals info) o))
714 (global (assoc-ref (.globals info) o))
715 (constant (assoc-ref (.constants info) o)))
716 (if local (wrap-as (i386:local-ptr->base (local:id local)))
717 (if global (list (i386:label->base `(#:address ,o)))
718 (list (i386:label->base `(#:address ,o))))))))
720 (define (value->accu v)
721 (wrap-as (i386:value->accu v)))
723 (define (accu->ident info)
725 (let* ((local (assoc-ref (.locals info) o))
726 (ptr (ident->pointer info o))
727 (size (if (or (= ptr -1) (= ptr 0)) (ident->type-size info o)
729 (if local (if (<= size 4) (wrap-as (i386:accu->local (local:id local)))
730 (wrap-as (i386:accu*n->local (local:id local) size)))
731 (if (<= size 4) (wrap-as (i386:accu->label o))
732 (wrap-as (i386:accu*n->label o size)))))))
734 (define (value->ident info)
736 (let ((local (assoc-ref (.locals info) o)))
737 (if local (wrap-as (i386:value->local (local:id local) value))
738 (list (i386:value->label `(#:address ,o) value))))))
740 (define (ident-add info)
742 (let ((local (assoc-ref (.locals info) o)))
743 (if local (wrap-as (i386:local-add (local:id local) n))
744 (list (i386:label-mem-add `(#:address ,o) n))))))
746 (define (expr-add info)
748 (let* ((info ((expr->accu* info) o))
749 (info (append-text info (wrap-as (i386:accu-mem-add n)))))
752 (define (ident-address-add info)
754 (let ((local (assoc-ref (.locals info) o)))
755 (if local (wrap-as (append (i386:push-accu)
756 (i386:local->accu (local:id local))
757 (i386:accu-mem-add n)
759 (list (wrap-as (append (i386:push-accu)
760 (i386:label->accu `(#:address ,o))
761 (i386:accu-mem-add n)
762 (i386:pop-accu))))))))
764 (define (binop->accu info)
766 (let* ((info ((expr->accu info) a))
767 (info ((expr->base info) b)))
768 (append-text info (wrap-as c)))))
770 (define (wrap-as o . annotation)
773 (define (make-comment o)
774 (wrap-as `((#:comment ,o))))
776 (define (ast->comment o)
778 (let ((source (with-output-to-string (lambda () (pretty-print-c99 o)))))
779 (make-comment (string-join (string-split source #\newline) " ")))))
781 (define (accu*n info n)
782 (append-text info (wrap-as (case n
783 ((1) (i386:accu->base))
784 ((2) (i386:accu+accu))
785 ((3) (append (i386:accu->base)
788 ((4) (i386:accu-shl 2))
789 ((8) (append (i386:accu+accu)
791 ((12) (append (i386:accu->base)
795 ((16) (i386:accu-shl 4))
796 (else (append (i386:value->base n)
797 (i386:accu*base)))))))
799 (define (accu->base-mem*n- info n)
802 ((1) (i386:byte-accu->base-mem))
803 ((2) (i386:word-accu->base-mem))
804 ((4) (i386:accu->base-mem))
805 (else (append (let loop ((i 0))
807 (append (if (= i 0) '()
808 (append (i386:accu+value 4)
809 (i386:base+value 4)))
811 ((1) (append (i386:accu+value -3)
813 (i386:accu-mem->base-mem)))
814 ((2) (append (i386:accu+value -2)
816 (i386:accu-mem->base-mem)))
817 ((3) (append (i386:accu+value -1)
819 (i386:accu-mem->base-mem)))
820 (else (i386:accu-mem->base-mem)))
821 (loop (+ i 4))))))))))
823 (define (accu->base-mem*n info n)
824 (append-text info (accu->base-mem*n- info n)))
826 (define (accu->local+n info local)
828 (let* ((type (local:type local))
829 (ptr (local:pointer local))
830 (size (if (= ptr -2) (ast-type->size info type)
832 (id (local:id local)))
833 (append-text info (wrap-as (case size
834 ((1) (i386:byte-accu->local+n id n))
835 ((2) (i386:word-accu->local+n id n))
836 (else (i386:accu->local+n id n))))))))
838 (define (expr->accu* info)
842 ((p-expr (ident ,name))
843 (append-text info ((ident-address->accu info) name)))
846 ((expr->accu info) expr))
848 ((d-sel (ident ,field) ,struct)
849 (let* ((type (expr->type info struct))
850 (offset (field-offset info type field))
851 (info ((expr->accu* info) struct)))
852 (append-text info (wrap-as (i386:accu+value offset)))))
854 ((i-sel (ident ,field) ,struct)
855 (let* ((type (expr->type info struct))
856 (offset (field-offset info type field))
857 (info ((expr->accu* info) struct)))
858 (append-text info (append (wrap-as (i386:mem->accu))
859 (wrap-as (i386:accu+value offset))))))
861 ((array-ref ,index ,array)
862 (let* ((info ((expr->accu info) index))
863 (ptr (expr->pointer info array))
864 (size (if (or (= ptr 1) (= ptr -1) (= ptr -2)) (expr->type-size info array)
866 (info (accu*n info size))
867 (info ((expr->base info) array)))
868 (append-text info (wrap-as (i386:accu+base)))))
870 (_ (error "expr->accu*: unsupported: " o)))))
872 (define (expr->accu info)
874 (let ((locals (.locals info))
875 (constants (.constants info))
877 (globals (.globals info)))
878 (define (add-local locals name type pointer)
879 (let* ((id (if (or (null? locals) (not (local-var? (cdar locals)))) 1
880 (1+ (local:id (cdar locals)))))
881 (locals (cons (make-local-entry name type pointer id) locals)))
888 ((comma-expr ,a . ,rest)
889 (let ((info ((expr->accu info) a)))
890 ((expr->accu info) `(comma-expr ,@rest))))
892 ((p-expr (string ,string))
893 (let* ((globals ((globals:add-string globals) string))
894 (info (clone info #:globals globals)))
895 (append-text info (list (i386:label->accu `(#:string ,string))))))
897 ;; FIXME: FROM INFO ...only zero?!
898 ((p-expr (fixed ,value))
899 (let ((value (cstring->number value)))
900 (append-text info (wrap-as (i386:value->accu value)))))
902 ((p-expr (char ,char))
903 (let ((char (char->integer (car (string->list char)))))
904 (append-text info (wrap-as (i386:value->accu char)))))
906 ((p-expr (string . ,strings))
907 (append-text info (list (i386:label->accu `(#:string ,(apply string-append strings))))))
909 ((p-expr (ident ,name))
910 (append-text info ((ident->accu info) name)))
913 ((expr->accu info) initzer))
916 ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
917 (let* ((type (decl->ast-type struct))
918 (offset (field-offset info type field))
919 (base (cstring->number base)))
920 (append-text info (wrap-as (i386:value->accu (+ base offset))))))
923 ((ref-to (p-expr (ident ,name)))
924 (append-text info ((ident-address->accu info) name)))
927 ((ref-to (de-ref ,expr))
928 ((expr->accu info) expr))
931 ((expr->accu* info) expr))
933 ((sizeof-expr (p-expr (ident ,name)))
934 (let* ((type (ident->type info name))
935 (size (ast-type->size info type)))
936 (append-text info (wrap-as (i386:value->accu size)))))
938 ((sizeof-expr (p-expr (string ,string)))
939 (append-text info (wrap-as (i386:value->accu (1+ (string-length string))))))
941 ((sizeof-expr (i-sel (ident ,field) (p-expr (ident ,struct))))
942 (let* ((type (ident->type info struct))
943 (size (field-size info type field)))
944 (append-text info (wrap-as (i386:value->accu size)))))
946 ((sizeof-expr (d-sel (ident ,field) (p-expr (ident ,struct))))
947 (let* ((type (ident->type info struct))
948 (size (field-size info type field)))
949 (append-text info (wrap-as (i386:value->accu size)))))
951 ((sizeof-type (type-name (decl-spec-list (type-spec (fixed-type ,name)))))
953 (size (ast-type->size info type)))
954 (append-text info (wrap-as (i386:value->accu size)))))
956 ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,type))))))
957 (let* ((type `("tag" ,type))
958 (size (ast-type->size info type)))
959 (append-text info (wrap-as (i386:value->accu size)))))
961 ((sizeof-type (type-name (decl-spec-list (type-spec (typename ,type)))))
962 (let ((size (ast-type->size info type)))
963 (append-text info (wrap-as (i386:value->accu size)))))
965 ((sizeof-type (type-name (decl-spec-list ,type) (abs-declr (pointer))))
967 (append-text info (wrap-as (i386:value->accu size)))))
970 ((array-ref ,index ,array)
971 (let* ((info ((expr->accu* info) o))
972 (ptr (expr->pointer info array))
973 (size (if (or (= ptr 1) (= ptr -1) (= ptr -2)) (expr->type-size info array)
975 (append-text info (wrap-as (case size
976 ((1) (i386:byte-mem->accu))
977 ((2) (i386:word-mem->accu))
978 ((4) (i386:mem->accu))
981 ((d-sel ,field ,struct)
982 (let* ((info ((expr->accu* info) o))
983 (info (append-text info (ast->comment o)))
984 (ptr (expr->pointer info o))
985 (size (if (= ptr 0) (expr->type-size info o)
987 (if (or (= -2 ptr) (= -1 ptr)) info
988 (append-text info (wrap-as (case size
989 ((1) (i386:byte-mem->accu))
990 ((2) (i386:word-mem->accu))
991 ((4) (i386:mem->accu))
994 ((i-sel ,field ,struct)
995 (let* ((info ((expr->accu* info) o))
996 (info (append-text info (ast->comment o)))
997 (ptr (expr->pointer info o))
998 (size (if (= ptr 0) (expr->type-size info o)
1000 (if (or (= -2 ptr) (= ptr -1)) info
1001 (append-text info (wrap-as (case size
1002 ((1) (i386:byte-mem->accu))
1003 ((2) (i386:word-mem->accu))
1004 ((4) (i386:mem->accu))
1008 (let* ((info ((expr->accu info) expr))
1009 (ptr (expr->pointer info expr))
1010 (size (expr->size info o)))
1011 (append-text info (wrap-as (case size
1012 ((1) (i386:byte-mem->accu))
1013 ((2) (i386:word-mem->accu))
1014 ((4) (i386:mem->accu))
1017 ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
1018 (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
1019 (append-text info (wrap-as (asm->m1 arg0))))
1020 (let* ((text-length (length text))
1021 (args-info (let loop ((expressions (reverse expr-list)) (info info))
1022 (if (null? expressions) info
1023 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1024 (n (length expr-list)))
1025 (if (not (assoc-ref locals name))
1027 (if (and (not (assoc name (.functions info)))
1028 (not (assoc name globals))
1029 (not (equal? name (.function info))))
1030 (stderr "warning: undeclared function: ~a\n" name))
1031 (append-text args-info (list (i386:call-label name n))))
1032 (let* ((empty (clone info #:text '()))
1033 (accu ((expr->accu empty) `(p-expr (ident ,name)))))
1034 (append-text args-info (append (.text accu)
1035 (list (i386:call-accu n)))))))))
1037 ((fctn-call ,function (expr-list . ,expr-list))
1038 (let* ((text-length (length text))
1039 (args-info (let loop ((expressions (reverse expr-list)) (info info))
1040 (if (null? expressions) info
1041 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1042 (n (length expr-list))
1043 (empty (clone info #:text '()))
1044 (accu ((expr->accu empty) function)))
1045 (append-text args-info (append (.text accu)
1046 (list (i386:call-accu n))))))
1048 ((cond-expr . ,cond-expr)
1049 ((ast->info info) `(expr-stmt ,o)))
1052 (let* ((info (append ((expr->accu info) expr)))
1053 (info (append-text info (wrap-as (i386:push-accu))))
1054 (ptr (expr->pointer info expr))
1055 (size (cond ((= ptr 1) (expr->type-size info expr))
1058 (info ((expr-add info) expr size))
1059 (info (append-text info (wrap-as (i386:pop-accu)))))
1063 (let* ((info (append ((expr->accu info) expr)))
1064 (info (append-text info (wrap-as (i386:push-accu))))
1065 (ptr (expr->pointer info expr))
1066 (size (cond ((= ptr 1) (expr->type-size info expr))
1069 (info ((expr-add info) expr (- size)))
1070 (info (append-text info (wrap-as (i386:pop-accu)))))
1074 (let* ((ptr (expr->pointer info expr))
1075 (size (cond ((= ptr 1) (expr->type-size info expr))
1078 (info ((expr-add info) expr size))
1079 (info (append ((expr->accu info) expr))))
1083 (let* ((ptr (expr->pointer info expr))
1084 (size (cond ((= ptr 1) (expr->type-size info expr))
1087 (info ((expr-add info) expr (- size)))
1088 (info (append ((expr->accu info) expr))))
1093 ((add ,a (p-expr (fixed ,value)))
1094 ;;(stderr "add ~s\n"(with-output-to-string (lambda () (pretty-print-c99 o))))
1095 (let* ((ptr (pke "ptr" (expr->pointer info a)))
1096 (type0 (expr->type info a))
1097 (struct? (pke "struct" (memq (type:type (ast-type->type info type0)) '(struct union))))
1098 (size (cond ((= ptr 1) (expr->type-size info a))
1100 ((and struct? (= ptr -2)) 4)
1101 ((and struct? (= ptr 2)) 4)
1103 (info ((expr->accu info) a))
1104 (value (cstring->number value))
1105 (value (pke "VALUE" (* size value))))
1107 (append-text info (wrap-as (i386:accu+value value)))))
1110 (let* ((ptr (expr->pointer info a))
1111 (ptr-b (expr->pointer info b))
1112 (type0 (expr->type info a))
1113 (struct? (memq (type:type (ast-type->type info type0)) '(struct union)))
1114 (size (cond ((= ptr 1) (expr->type-size info a))
1116 ((and struct? (= ptr -2)) 4)
1117 ((and struct? (= ptr 2)) 4)
1119 (if (or (= size 1)) ((binop->accu info) a b (i386:accu+base))
1120 (let* ((info ((expr->accu info) b))
1121 (info (append-text info (wrap-as (append (i386:value->base size)
1123 (i386:accu->base)))))
1124 (info ((expr->accu info) a)))
1125 (append-text info (wrap-as (i386:accu+base)))))))
1127 ((sub ,a (p-expr (fixed ,value)))
1128 (let* ((ptr (expr->pointer info a))
1129 (type0 (expr->type info a))
1130 (struct? (memq (type:type (ast-type->type info type0)) '(struct union)))
1131 (size (cond ((= ptr 1) (expr->type-size info a))
1133 ((and struct? (= ptr -2)) 4)
1134 ((and struct? (= ptr 2)) 4)
1136 (info ((expr->accu info) a))
1137 (value (cstring->number value))
1138 (value (* size value)))
1139 (append-text info (wrap-as (i386:accu+value (- value))))))
1142 ;;(stderr "sub ~s\n"(with-output-to-string (lambda () (pretty-print-c99 o))))
1143 (let* ((ptr (pke "ptr" (expr->pointer info a)))
1144 (ptr-b (pke "ptr-b" (expr->pointer info b)))
1145 (type0 (expr->type info a))
1146 (struct? (pke "struct?" (memq (type:type (ast-type->type info type0)) '(struct union))))
1147 (size (cond ((= ptr 1) (expr->type-size info a))
1149 ((and struct? (= ptr -2)) 4)
1150 ((and struct? (= ptr 2)) 4)
1153 (if (or (= size 1) (or (= ptr-b -2) (= ptr-b 1)))
1154 (let ((info ((binop->accu info) a b (i386:accu-base))))
1155 (if (and (not (= ptr-b -2)) (not (= ptr-b 1))) info
1156 (append-text info (wrap-as (append (i386:value->base size)
1157 (i386:accu/base))))))
1158 (let* ((info ((expr->accu info) b))
1159 (info (append-text info (wrap-as (append (i386:value->base size)
1161 (i386:accu->base)))))
1162 (info ((expr->accu info) a)))
1163 (append-text info (wrap-as (i386:accu-base)))))))
1165 ((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base)))
1166 ((bitwise-not ,expr)
1167 (let ((info ((ast->info info) expr)))
1168 (append-text info (wrap-as (i386:accu-not)))))
1169 ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base)))
1170 ((bitwise-xor ,a ,b) ((binop->accu info) a b (i386:accu-xor-base)))
1171 ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<<base)))
1172 ((rshift ,a ,b) ((binop->accu info) a b (i386:accu>>base)))
1173 ((div ,a ,b) ((binop->accu info) a b (i386:accu/base)))
1174 ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base)))
1175 ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base)))
1178 (let* ((test-info ((ast->info info) expr)))
1180 (append (.text test-info)
1181 (wrap-as (i386:accu-negate)))
1182 #:globals (.globals test-info))))
1185 (let ((info ((expr->base info) expr)))
1186 (append-text info (append (wrap-as (i386:value->accu 0))
1187 (wrap-as (i386:sub-base))))))
1189 ((eq ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:z->accu))))
1190 ((ge ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:ge?->accu))))
1191 ((gt ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:g?->accu) (i386:accu-test))))
1193 ;; FIXME: set accu *and* flags
1194 ((ne ,a ,b) ((binop->accu info) a b (append (i386:push-accu)
1202 ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:xor-zf))))
1203 ((le ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:le?->accu))))
1204 ((lt ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:l?->accu))))
1207 (let* ((info ((expr->accu info) a))
1208 (here (number->string (length (.text info))))
1209 (skip-b-label (string-append "_" (.function info) "_" here "_or_skip_b"))
1210 (info (append-text info (wrap-as (i386:accu-test))))
1211 (info (append-text info (wrap-as (i386:jump-nz skip-b-label))))
1212 (info (append-text info (wrap-as (i386:accu-test))))
1213 (info ((expr->accu info) b))
1214 (info (append-text info (wrap-as (i386:accu-test))))
1215 (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
1219 (let* ((info ((expr->accu info) a))
1220 (here (number->string (length (.text info))))
1221 (skip-b-label (string-append "_" (.function info) "_" here "_and_skip_b"))
1222 (info (append-text info (wrap-as (i386:accu-test))))
1223 (info (append-text info (wrap-as (i386:jump-z skip-b-label))))
1224 (info (append-text info (wrap-as (i386:accu-test))))
1225 (info ((expr->accu info) b))
1226 (info (append-text info (wrap-as (i386:accu-test))))
1227 (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
1231 ((expr->accu info) expr))
1233 ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
1234 (let* ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b)))
1235 (type (ident->type info name))
1236 (ptr (ident->pointer info name))
1237 (size (if (> ptr 1) 4 1)))
1238 (append-text info ((ident-add info) name size))))
1240 ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
1241 (let* ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b)))
1242 (type (ident->type info name))
1243 (ptr (ident->pointer info name))
1244 (size (if (> ptr 1) 4 1)))
1245 (append-text info ((ident-add info) name (- size)))))
1247 ((assn-expr ,a (op ,op) ,b)
1248 (let* ((info (append-text info (ast->comment o)))
1249 (ptr-a (expr->pointer info a))
1250 (ptr-b (expr->pointer info b))
1251 (size-a (expr->size info a))
1252 (size-b (expr->size info b))
1253 (info ((expr->accu info) b))
1254 (info (if (equal? op "=") info
1255 (let* ((ptr (expr->pointer info a))
1256 (ptr-b (expr->pointer info b))
1257 (type0 (expr->type info a))
1258 (struct? (memq (type:type (ast-type->type info type0)) '(struct union)))
1259 (size (cond ((= ptr 1) (expr->type-size info a))
1261 ((and struct? (= ptr -2)) 4)
1262 ((and struct? (= ptr 2)) 4)
1264 (info (if (or (= size 1) (= ptr-b 1)) info
1265 (let ((info (append-text info (wrap-as (i386:value->base size)))))
1266 (append-text info (wrap-as (i386:accu*base))))))
1267 (info (append-text info (wrap-as (i386:push-accu))))
1268 (info ((expr->accu info) a))
1269 (info (append-text info (wrap-as (i386:pop-base))))
1270 (info (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base)))
1271 ((equal? op "-=") (wrap-as (i386:accu-base)))
1272 ((equal? op "*=") (wrap-as (i386:accu*base)))
1273 ((equal? op "/=") (wrap-as (i386:accu/base)))
1274 ((equal? op "%=") (wrap-as (i386:accu%base)))
1275 ((equal? op "&=") (wrap-as (i386:accu-and-base)))
1276 ((equal? op "|=") (wrap-as (i386:accu-or-base)))
1277 ((equal? op "^=") (wrap-as (i386:accu-xor-base)))
1278 ((equal? op ">>=") (wrap-as (i386:accu>>base)))
1279 ((equal? op "<<=") (wrap-as (i386:accu<<base)))
1280 (else (error (format #f "mescc: op ~a not supported: ~a\n" op o)))))))
1281 (cond ((not (and (= ptr 1) (= ptr-b 1))) info)
1282 ((equal? op "-=") (append-text info (wrap-as (append (i386:value->base size)
1283 (i386:accu/base)))))
1284 (else (error (format #f "invalid operands to binary ~s (have ~s* and ~s*)" op type0 (expr->type info b)))))))))
1285 (when (and (equal? op "=")
1286 (not (= size-a size-b))
1287 (not (and (or (= size-a 1) (= size-a 2))
1289 (not (and (= size-a 2)
1291 (not (and (= size-a 4)
1292 (or (= size-b 1) (= size-b 2)))))
1293 (stderr "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o))))
1294 (stderr " size[~a]:~a != size[~a]:~a\n" ptr-a size-a ptr-b size-b))
1296 ((p-expr (ident ,name))
1297 (if (or (<= size-a 4) ;; FIXME: long long = int
1298 (<= size-b 4)) (append-text info ((accu->ident info) name))
1299 (let ((info ((expr->base* info) a)))
1300 (accu->base-mem*n info size-a))))
1301 (_ (let ((info ((expr->base* info) a)))
1302 (accu->base-mem*n info (min size-a (max 4 size-b)))))))) ;; FIXME: long long = int
1304 (_ (error "expr->accu: unsupported: " o))))))
1306 (define (expr->base info)
1308 (let* ((info (append-text info (wrap-as (i386:push-accu))))
1309 (info ((expr->accu info) o))
1310 (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
1313 (define (expr->base* info)
1315 (let* ((info (append-text info (wrap-as (i386:push-accu))))
1316 (info ((expr->accu* info) o))
1317 (info (append-text info (wrap-as (i386:accu->base))))
1318 (info (append-text info (wrap-as (i386:pop-accu)))))
1321 (define (clause->info info i label last?)
1322 (define clause-label
1323 (string-append label "clause" (number->string i)))
1325 (string-append label "body" (number->string i)))
1326 (define (jump label)
1327 (wrap-as (i386:jump label)))
1328 (define (jump-nz label)
1329 (wrap-as (i386:jump-nz label)))
1330 (define (jump-z label)
1331 (wrap-as (i386:jump-z label)))
1332 (define (test->text test)
1333 (let ((value (pmatch test
1335 ((p-expr (char ,value)) (char->integer (car (string->list value))))
1336 ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
1337 ((p-expr (fixed ,value)) (cstring->number value))
1338 ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
1339 (_ (error "case test: unsupported: " test)))))
1340 (append (wrap-as (i386:accu-cmp-value value))
1341 (jump-z body-label))))
1342 (define (cases+jump info cases)
1343 (let* ((info (append-text info (wrap-as `((#:label ,clause-label)))))
1344 (next-clause-label (if last? (string-append label "break")
1345 (string-append label "clause" (number->string (1+ i)))))
1346 (info (append-text info (apply append cases)))
1347 (info (if (null? cases) info
1348 (append-text info (jump next-clause-label))))
1349 (info (append-text info (wrap-as `((#:label ,body-label))))))
1353 (let loop ((o o) (cases '()) (clause #f))
1355 ((case ,test ,statement)
1356 (loop statement (append cases (list (test->text test))) clause))
1357 ((default ,statement)
1358 (loop statement cases clause))
1359 ((default . ,statements)
1360 (loop `(compd-stmt (block-item-list ,@statements)) cases clause))
1361 ((compd-stmt (block-item-list))
1362 (loop '() cases clause))
1363 ((compd-stmt (block-item-list . ,elements))
1364 (let ((clause (or clause (cases+jump info cases))))
1365 (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
1366 ((ast->info clause) (car elements)))))
1368 (let ((clause (or clause (cases+jump info cases))))
1370 (let ((next-body-label (string-append label "body"
1371 (number->string (1+ i)))))
1372 (append-text clause (wrap-as (i386:jump next-body-label)))))))
1374 (let ((clause (or clause (cases+jump info cases))))
1376 ((ast->info clause) o))))))))
1378 (define (test-jump-label->info info label)
1379 (define (jump type . test)
1381 (let* ((info ((ast->info info) o))
1382 (info (append-text info (make-comment "jmp test LABEL")))
1383 (jump-text (wrap-as (type label))))
1384 (append-text info (append (if (null? test) '() (car test))
1390 ;; ((le ,a ,b) ((jump i386:jump-ncz) o)) ; ja
1391 ;; ((lt ,a ,b) ((jump i386:jump-nc) o)) ; jae
1392 ;; ((ge ,a ,b) ((jump i386:jump-ncz) o))
1393 ;; ((gt ,a ,b) ((jump i386:jump-nc) o))
1395 ((le ,a ,b) ((jump i386:jump-g) o))
1396 ((lt ,a ,b) ((jump i386:jump-ge) o))
1397 ((ge ,a ,b) ((jump i386:jump-l) o))
1398 ((gt ,a ,b) ((jump i386:jump-le) o))
1400 ((ne ,a ,b) ((jump i386:jump-nz) o))
1401 ((eq ,a ,b) ((jump i386:jump-nz) o))
1402 ((not _) ((jump i386:jump-z) o))
1405 (let* ((info ((test-jump-label->info info label) a))
1406 (info ((test-jump-label->info info label) b)))
1410 (let* ((here (number->string (length (.text info))))
1411 (skip-b-label (string-append label "_skip_b_" here))
1412 (b-label (string-append label "_b_" here))
1413 (info ((test-jump-label->info info b-label) a))
1414 (info (append-text info (wrap-as (i386:jump skip-b-label))))
1415 (info (append-text info (wrap-as `((#:label ,b-label)))))
1416 (info ((test-jump-label->info info label) b))
1417 (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
1420 ((array-ref ,index ,expr) (let* ((ptr (expr->pointer info expr))
1421 (size (if (= ptr 1) (ast-type->size info expr)
1423 ((jump (if (= size 1) i386:jump-byte-z
1425 (wrap-as (i386:accu-zero?))) o)))
1427 ((de-ref ,expr) (let* ((ptr (expr->pointer info expr))
1428 (size (if (= ptr 1) (ast-type->size info expr)
1430 ((jump (if (= size 1) i386:jump-byte-z
1432 (wrap-as (i386:accu-zero?))) o)))
1434 ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1436 (append ((ident->accu info) name)
1437 (wrap-as (i386:accu-zero?)))) o))
1439 (_ ((jump i386:jump-z (wrap-as (i386:accu-zero?))) o)))))
1441 (define (cstring->number s)
1442 (let ((s (cond ((string-suffix? "ULL" s) (string-drop-right s 3))
1443 ((string-suffix? "UL" s) (string-drop-right s 2))
1444 ((string-suffix? "LL" s) (string-drop-right s 2))
1445 ((string-suffix? "L" s) (string-drop-right s 1))
1447 (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1448 ((string-prefix? "0b" s) (string->number (string-drop s 2) 2))
1449 ((string-prefix? "0" s) (string->number s 8))
1450 (else (string->number s)))))
1452 (define (expr->number info o)
1454 ((p-expr (fixed ,a))
1455 (cstring->number a))
1457 (- (expr->number info a)))
1459 (+ (expr->number info a) (expr->number info b)))
1460 ((bitwise-and ,a ,b)
1461 (logand (expr->number info a) (expr->number info b)))
1463 (lognot (expr->number info a)))
1465 (logior (expr->number info a) (expr->number info b)))
1467 (quotient (expr->number info a) (expr->number info b)))
1469 (* (expr->number info a) (expr->number info b)))
1471 (- (expr->number info a) (expr->number info b)))
1472 ((sizeof-type (type-name (decl-spec-list (type-spec ,type))))
1473 (ast-type->size info type))
1474 ((sizeof-expr (d-sel (ident ,field) (p-expr (ident ,struct))))
1475 (let ((type (ident->type info struct)))
1476 (field-size info type field)))
1477 ((sizeof-expr (i-sel (ident ,field) (p-expr (ident ,struct))))
1478 (let ((type (ident->type info struct)))
1479 (field-size info type field)))
1481 (ash (expr->number info x) (expr->number info y)))
1483 (ash (expr->number info x) (- (expr->number info y))))
1484 ((p-expr (ident ,name))
1485 (let ((value (assoc-ref (.constants info) name)))
1487 (error (format #f "expr->number: undeclared identifier: ~s\n" o)))))
1488 ((cast ,type ,expr) (expr->number info expr))
1489 ((cond-expr ,test ,then ,else)
1490 (if (p-expr->bool info test) (expr->number info then) (expr->number info else)))
1491 (_ (error (format #f "expr->number: not supported: ~s\n" o)))))
1493 (define (p-expr->bool info o)
1495 ((eq ,a ,b) (eq? (expr->number info a) (expr->number info b)))))
1497 (define (struct-field info)
1500 ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1501 (comp-declr-list (comp-declr (ident ,name))))
1502 (list name `("tag" ,type) 4 0))
1503 ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1504 (list name type (ast-type->size info type) 0))
1505 ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1506 (list name type (ast-type->size info type) 0))
1507 ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1508 (list name type 4 2))
1509 ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,param-list)))))
1510 (list name type 4 1))
1511 ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1512 (list name type 4 1))
1513 ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1514 (list name type 4 2))
1515 ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1516 (list name "void" 4 2))
1517 ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1518 (list name "void" 4 1))
1519 ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,param-list)))))
1520 (list name "void" 4 1))
1521 ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1522 (list name type 4 1))
1524 ;; FIXME: array: -1,-2-3, name??
1525 ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (array-of (ident ,name) ,count)))))
1527 (count (expr->number info count)))
1528 (list name type (* count size) -2)))
1530 ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (array-of (ident ,name) ,count))))
1531 (let ((size (ast-type->size info type))
1532 (count (expr->number info count)))
1533 (list name type (* count size) -1)))
1535 ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1536 (list name `("tag" ,type) 4 2))
1538 ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1539 (list name `("tag" ,type) 4 1))
1541 ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
1542 (let ((size (ast-type->size info `("tag" ,type))))
1543 (list name `("tag" ,type) size 0)))
1545 ((comp-decl (decl-spec-list (type-spec (struct-def (field-list . ,fields)))))
1546 `(struct ,@(map (struct-field info) fields)))
1548 ((comp-decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
1549 (let ((size (ast-type->size info `("tag" ,type))))
1550 (list name `("tag" ,type) size 0)))
1552 ((comp-decl (decl-spec-list (type-spec (union-def (field-list . ,fields)))))
1553 `(union ,@(map (struct-field info) fields)))
1555 (_ (error "struct-field: unsupported: " o)))))
1557 (define (local-var? o) ;; formals < 0, locals > 0
1558 (positive? (local:id o)))
1560 (define (ptr-declr->pointer o)
1563 ((pointer (pointer)) 2)
1564 ((pointer (pointer (pointer))) 3)
1565 (_ (error "ptr-declr->pointer unsupported: " o))))
1567 (define (init-declr->name o)
1569 ((ident ,name) name)
1570 ((ptr-declr ,pointer (ident ,name)) name)
1571 ((array-of (ident ,name)) name)
1572 ((array-of (ident ,name) ,index) name)
1573 ((ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,params)) name)
1574 ((ptr-declr (pointer) (array-of (ident ,name))) name)
1575 ((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) name)
1576 (_ (error "init-declr->name unsupported: " o))))
1578 (define (init-declr->count info o)
1580 ((array-of (ident ,name) ,count) (expr->number info count))
1583 (define (init-declr->pointer o)
1586 ((ptr-declr ,pointer (ident ,name)) (ptr-declr->pointer pointer))
1587 ((array-of (ident ,name) ,index) -2)
1588 ((array-of (ident ,name)) -2)
1589 ((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) (param-list . ,params)) (ptr-declr->pointer pointer))
1590 ((ptr-declr (pointer) (array-of (ident ,name))) -2)
1591 ((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) -2)
1592 (_ (error "init-declr->pointer unsupported: " o))))
1594 (define (statements->clauses statements)
1595 (let loop ((statements statements) (clauses '()))
1596 (if (null? statements) clauses
1597 (let ((s (car statements)))
1599 ((case ,test (compd-stmt (block-item-list . _)))
1600 (loop (cdr statements) (append clauses (list s))))
1601 ((case ,test (break))
1602 (loop (cdr statements) (append clauses (list s))))
1603 ((case ,test) (loop (cdr statements) (append clauses (list s))))
1605 ((case ,test ,statement)
1606 (let loop2 ((statement statement) (heads `((case ,test))))
1607 (define (heads->case heads statement)
1608 (if (null? heads) statement
1609 (append (car heads) (list (heads->case (cdr heads) statement)))))
1611 ((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
1612 ((default ,s2) (loop2 s2 (append heads `((default)))))
1613 ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
1614 (_ (let loop3 ((statements (cdr statements)) (c (list statement)))
1615 (if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
1616 (let ((s (car statements)))
1618 ((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1619 ((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1620 ((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
1621 (_ (loop3 (cdr statements) (append c (list s))))))))))))
1622 ((default (compd-stmt (block-item-list _)))
1623 (loop (cdr statements) (append clauses (list s))))
1624 ((default . ,statement)
1625 (let loop2 ((statements (cdr statements)) (c statement))
1626 (if (null? statements) (loop statements (append clauses (list `(default ,@c))))
1627 (let ((s (car statements)))
1629 ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
1630 ((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1631 ((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1632 ((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
1634 (_ (loop2 (cdr statements) (append c (list s)))))))))
1635 (_ (error "statements->clauses: unsupported:" s)))))))
1637 (define (decl->info info)
1639 (let ((functions (.functions info))
1640 (globals (.globals info))
1641 (locals (.locals info))
1642 (constants (.constants info))
1643 (types (.types info))
1644 (text (.text info)))
1645 (define (add-local locals name type pointer)
1646 (let* ((id (if (or (null? locals) (not (local-var? (cdar locals)))) 1
1647 (1+ (local:id (cdar locals)))))
1648 (locals (cons (make-local-entry name type pointer id) locals)))
1650 (define (declare name)
1651 (if (member name functions) info
1652 (clone info #:functions (cons (cons name #f) functions))))
1655 ;; FIXME: Nyacc sometimes produces extra parens: (ident (<struct-name>))
1656 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1659 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1660 (clone info #:types (cons (cons name (get-type types type)) types)))
1663 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1667 ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1671 ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1675 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1678 ;; printf (char const* format, ...)
1679 ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
1683 ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1686 ;; extern type foo ()
1687 ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1691 ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))))
1694 ;; extern type global;
1695 ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ident ,name))))
1698 ((decl (decl-spec-list (stor-spec (static)) ,type) (init-declr-list (init-declr (ident ,name))))
1699 ((decl->info info) `(decl (decl-spec-list ,type) (init-declr-list (init-declr (ident ,name)))))
1703 ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
1706 ((decl (decl-spec-list (stor-spec (static)) ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
1707 ((decl->info info) `(decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))))
1709 ;; ST_DATA int ch, tok; -- TCC, why oh why so difficult?
1710 ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
1713 ;; ST_DATA Section *text_section, *data_section, *bss_section; /* predefined sections */
1714 ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name))) . ,rest))
1717 ;; ST_DATA CType char_pointer_type, func_old_type, int_type, size_type;
1718 ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
1721 ;; ST_DATA SValue __vstack[1+/*to make bcheck happy*/ VSTACK_SIZE], *vtop;
1722 ;; Yay, let's hear it for the T-for Tiny in TCC!?
1723 ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (array-of (ident ,name) (add (p-expr (fixed ,a)) (p-expr (fixed ,b))))) (init-declr (ptr-declr (pointer) (ident ,name2)))))
1726 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1727 (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("tag" ,type)))) types)))
1729 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1730 (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("tag" ,type)))) types)))
1732 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1733 (clone info #:types (cons (cons name (or (get-type types type) `(typedef ,type))) types)))
1735 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (array-of (ident ,name) ,value))))
1736 (let* ((type (get-type types type))
1737 (value (expr->number info value))
1740 (type (make-type 'array size pointer type)))
1741 (clone info #:types (cons (cons name type) types))))
1743 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
1744 (let* ((pointer (expr->pointer info pointer))
1745 (type (or (get-type types type) `(typedef ,type)))
1747 (type (make-type 'typedef size pointer type)))
1748 (clone info #:types (cons (cons name type) types))))
1750 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
1751 ((decl->info info) `(decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def (ident ,name) ,field-list))) (init-declr-list (init-declr (ident ,name))))))
1753 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
1754 ((decl->info info) `(decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,name) ,field-list))) (init-declr-list (init-declr (ident ,name))))))
1756 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name))))
1757 (let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) ,field-list))))))
1758 (types (.types info)))
1759 (clone info #:types (cons (cons name (or (get-type types `("tag" ,type)) `(typedef ,type))) types))))
1761 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name))))
1762 (let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,field-list))))))
1763 (types (.types info)))
1764 (clone info #:types (cons (cons name (or (get-type types `("tag" ,type)) `(typedef ,type))) types))))
1766 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1767 (let* ((type (get-type types type))
1768 (type (make-type (type:type type)
1770 (1+ (type:pointer type))
1771 (type:description type)))
1772 (type-entry (cons name type)))
1773 (clone info #:types (cons type-entry types))))
1776 ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1777 (let ((type-entry (struct->type-entry name (map (struct-field info) fields))))
1778 (clone info #:types (cons type-entry types))))
1781 ((decl (decl-spec-list (type-spec (union-def (ident ,name) (field-list . ,fields)))))
1782 (let ((type-entry (union->type-entry name (map (struct-field info) fields))))
1783 (clone info #:types (cons type-entry types))))
1786 ((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1787 (let ((type "int")) ;; FIXME
1788 (if (.function info)
1789 (clone info #:locals (add-local locals name type 0))
1790 (clone info #:globals (append globals (list (ident->global-entry name type 0 0)))))))
1792 ;; struct foo bar[2];
1793 ;; char arena[20000];
1794 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) ,count))))
1795 (let ((type (ast->type type)))
1796 (if (.function info)
1797 (let* ((local (car (add-local locals name type -1)))
1798 (count (expr->number info count))
1799 (size (ast-type->size info type))
1800 (pointer (expr->pointer info `(type-spec ,type)))
1801 (pointer (- -1 pointer))
1802 (local (pke "0local: " (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4)))))
1803 (locals (cons local locals))
1804 (info (clone info #:locals locals)))
1806 (let* ((foo (mescc:trace name " <g>"))
1807 (globals (.globals info))
1808 (count (expr->number info count))
1809 (size (ast-type->size info type))
1810 (pointer (expr->pointer info `(type-spec ,type)))
1811 (pointer (- -1 pointer))
1812 (array (pke "0global: " (make-global-entry name type pointer (string->list (make-string (* count size) #\nul)))))
1813 (globals (append globals (list array))))
1814 (clone info #:globals globals)))))
1816 ;; struct foo *bar[2];
1817 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) ,count)))))
1818 (let ((type (ast->type type)))
1819 (if (.function info)
1820 (let* ((local (car (add-local locals name type -1)))
1821 (count (expr->number info count))
1823 (pointer (expr->pointer info `(type-spec ,type)))
1824 (pointer (- -3 pointer))
1825 (local (pke "1local:" (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4)))))
1826 (locals (cons local locals))
1827 (info (clone info #:locals locals)))
1829 (let* ((foo (mescc:trace name " <g>"))
1830 (globals (.globals info))
1831 (count (expr->number info count))
1833 (pointer (expr->pointer info `(type-spec ,type)))
1834 (pointer (- -3 pointer))
1835 (global (pke "1global: " (make-global-entry name type pointer (string->list (make-string (* count size) #\nul)))))
1836 (globals (append globals (list global))))
1837 (clone info #:globals globals)))))
1839 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,size))) (initzer (p-expr (string ,string))))))
1840 (if (.function info)
1842 (let* ((foo (mescc:trace name " <g>"))
1843 (globals (.globals info))
1844 ;; (count (cstring->number count))
1845 ;; (size (ast-type->size info type))
1846 (array (make-global-entry name type -1 (string->list string)))
1847 (globals (append globals (list array))))
1848 (clone info #:globals globals))))
1850 ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1851 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,param-list)) (initzer ,initzer))))
1852 (let* ((locals (add-local locals name type 1))
1853 (info (clone info #:locals locals))
1854 (empty (clone info #:text '()))
1855 (accu ((expr->accu empty) initzer)))
1860 ((accu->ident info) name)
1861 (wrap-as (append (i386:label->base `(#:address "_start"))
1865 ;; char *p = g_cells;
1866 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1867 (let ((info (append-text info (ast->comment o)))
1868 (type (decl->ast-type type)))
1869 (if (.function info)
1870 (let* ((locals (add-local locals name type 1))
1871 (info (clone info #:locals locals)))
1872 (append-text info (append ((ident->accu info) value)
1873 ((accu->ident info) name))))
1874 (let ((globals (append globals (list (ident->global-entry name type 1 `(,value #f #f #f))))))
1875 (clone info #:globals globals)))))
1878 ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1879 (let ((type-entry (enum->type-entry name fields))
1880 (constants (enum-def-list->constants constants fields)))
1882 #:types (cons type-entry types)
1883 #:constants (append constants (.constants info)))))
1886 ((decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields)))))
1887 (let ((constants (enum-def-list->constants constants fields)))
1889 #:constants (append constants (.constants info)))))
1891 ((decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))
1892 (init-declr-list (init-declr (ident ,name))))
1893 (let ((info ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
1894 ((decl->info info) `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1896 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,type) ,fields))) (init-declr-list (init-declr (ident ,name))))
1897 (let ((info ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,fields)))))))
1898 ((decl->info info) `(decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1900 ;; struct f = {...};
1902 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1903 (if (not (.function info)) (mescc:trace name " <g>"))
1904 (let* ((info (append-text info (ast->comment o)))
1905 (type (decl->ast-type type))
1906 (fields (ast-type->description info type))
1907 (xtype (ast-type->type info type))
1908 (fields (if (not (eq? (type:type xtype) 'union)) fields
1909 (list-head fields 1)))
1910 (size (ast-type->size info type))
1911 (initzers (map (initzer->non-const info) initzers)))
1912 (if (.function info)
1913 (let* ((initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
1914 (global-names (map car globals))
1915 (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1916 (globals (append globals initzer-globals))
1917 (local (car (add-local locals name type -1)))
1918 (local (make-local-entry name type -1 (+ (local:id (cdr local)) (quotient (+ size 3) 4))))
1919 (locals (cons local locals))
1920 (info (clone info #:locals locals #:globals globals))
1921 (empty (clone info #:text '())))
1922 (let loop ((fields fields) (initzers initzers) (info info))
1923 (if (null? fields) info
1924 (let ((offset (field-offset info type (field:name (car fields))))
1925 (size (field:size (car fields)))
1926 (initzer (if (null? initzers) '(p-expr (fixed "0")) (car initzers))))
1927 (loop (cdr fields) (if (null? initzers) '() (cdr initzers))
1931 ((ident->accu info) name)
1932 (wrap-as (append (i386:accu->base)))
1933 (.text ((expr->accu empty) initzer))
1935 ((1) (i386:byte-accu->base-mem+n offset))
1936 ((2) (i386:word-accu->base-mem+n offset))
1937 (else (i386:accu->base-mem+n offset)))))))))))
1938 (let* ((initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
1939 (global-names (map car globals))
1940 (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1941 (globals (append globals initzer-globals))
1942 (global (make-global-entry name type -1 (append-map (initzer->data info) initzers)))
1943 (globals (append globals (list global))))
1944 (clone info #:globals globals)))))
1947 ;; char *bla[] = {"a", "b"};
1948 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name))) (initzer (initzer-list . ,initzers)))))
1949 (if (not (.function info)) (mescc:trace name " <g>"))
1950 (let* ((type (decl->ast-type type))
1951 (pointer (pke "2pointer: " (expr->pointer info `(type-spec ,type))))
1952 (pointer (pke "pointer: " (- -3 pointer)))
1953 (entries (filter identity (append-map (initzer->globals globals) initzers)))
1954 (global-names (map car globals))
1955 (entries (filter (lambda (g) (and g (not (member (car g) global-names)))) entries))
1956 (globals (append globals entries))
1958 (size (* (length entries) entry-size))
1959 (initzers (map (initzer->non-const info) initzers)))
1960 (if (.function info)
1961 (let* ((count (length initzers))
1962 (local (car (add-local locals name type -1)))
1963 (local (pke "2local: " (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (1+ count)))))
1964 (locals (cons local locals))
1965 (info (clone info #:locals locals))
1966 (info (clone info #:globals globals))
1967 (empty (clone info #:text '())))
1968 (let loop ((index 0) (initzers initzers) (info info))
1969 (if (null? initzers) info
1970 (let ((offset (* index 4))
1971 (initzer (car initzers)))
1972 (loop (1+ index) (cdr initzers)
1976 ((ident->accu info) name)
1977 (wrap-as (append (i386:accu->base)))
1978 (.text ((expr->accu empty) initzer))
1979 (wrap-as (i386:accu->base-mem+n offset)))))))))
1980 (let* ((global (pke "2global: " (make-global-entry name type pointer (append-map (initzer->data info) initzers))))
1981 (globals (append globals (list global))))
1982 (clone info #:globals globals)))))
1984 ;; int foo[2] = { ... }
1985 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) ,count) (initzer (initzer-list . ,initzers)))))
1986 (if (not (.function info)) (mescc:trace name " <g>"))
1987 (let* ((info (type->info info type))
1989 (type (decl->ast-type type))
1990 (pointer (expr->pointer info `(type-spec ,type)))
1991 (pointer (- -2 pointer))
1992 (initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
1993 (global-names (map car globals))
1994 (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1995 (initzers ((initzer->non-const info) initzers))
1996 (info (append-text info (ast->comment o)))
1997 (globals (append globals initzer-globals))
1998 (info (clone info #:globals globals))
1999 (type-size (if (<= pointer 0) (ast-type->size info type)
2001 (count (expr->number info count))
2002 (size (* count type-size)))
2003 (if (.function info)
2004 (let* ((local (car (add-local locals name type 1)))
2005 (local (pke "3local: " (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4)))))
2006 (locals (cons local locals))
2008 (info (clone info #:locals locals))
2009 (info (let loop ((info info) (initzers initzers) (n 0))
2010 (if (null? initzers) info
2011 (let* ((info ((initzer->accu info) (car initzers)))
2012 (info ((accu->local+n info local) n)))
2013 (loop info (cdr initzers) (+ n type-size)))))))
2015 (let* ((global (pke "3global:" (make-global-entry name type pointer (append-map (initzer->data info) initzers))))
2016 (globals (append globals (list global))))
2017 (clone info #:globals globals)))))
2019 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr ,init . ,initzer)))
2020 (let* ((info (type->info info type))
2022 (type (decl->ast-type type))
2023 (name (init-declr->name init))
2024 (foo (if (not (.function info)) (mescc:trace name " <g>")))
2025 (pointer (init-declr->pointer init))
2026 (initzer-globals (if (null? initzer) '()
2027 (filter identity (append-map (initzer->globals globals) initzer))))
2028 (global-names (map car globals))
2029 (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
2030 (initzer (if (null? initzer) '() ((initzer->non-const info) initzer)))
2031 ;;FIXME: ridiculous performance hit with mes
2032 (info (append-text info (ast->comment o)))
2033 (globals (append globals initzer-globals))
2034 (info (clone info #:globals globals))
2035 (struct? (and (zero? pointer)
2036 (or (and (pair? type) (equal? (car type) "tag"))
2037 (memq (type:type (ast-type->type info xtype)) '(struct union)))))
2038 (pointer (if struct? -1 pointer))
2039 (size (if (<= pointer 0) (ast-type->size info type)
2041 (count (init-declr->count info init)) ; array... split me up?
2042 (size (if count (* count size) size)))
2043 (if (.function info)
2044 (let* ((locals (if (or (> pointer 0) (<= size 4)) (add-local locals name type pointer)
2045 (let* ((local (car (add-local locals name type 1)))
2046 (local (pke "4local:" (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))))
2047 (cons local locals))))
2048 (info (clone info #:locals locals))
2049 (info (if (null? initzer) info ((initzer->accu info) (car initzer))))
2050 ;; FIXME array...struct?
2051 (info (if (null? initzer) info (append-text info ((accu->ident info) name)))))
2053 (let* ((global (pke "4global:" (make-global-entry name type pointer (if (null? initzer) (string->list (make-string size #\nul))
2054 (append-map (initzer->data info) initzer)))))
2055 (globals (append globals (list global))))
2056 (clone info #:globals globals)))))
2058 ;; int i = 0, j = 0;
2059 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
2060 (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
2061 (if (null? inits) info
2064 `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,(car inits))))))))
2066 ;; int *i = 0, j ..;
2067 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)) . ,initzer) . ,rest))
2068 (let loop ((inits `((init-declr (ptr-declr ,pointer (ident ,name)) ,@initzer) ,@rest)) (info info))
2069 (if (null? inits) info
2072 `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,(car inits))))))))
2074 ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2075 (format (current-error-port) "SKIP: typedef=~s\n" o)
2079 (format (current-error-port) "SKIP: at=~s\n" o)
2082 ((decl . _) (error "decl->info: unsupported: " o))))))
2084 (define (ast->info info)
2086 (let ((functions (.functions info))
2087 (globals (.globals info))
2088 (locals (.locals info))
2089 (constants (.constants info))
2090 (types (.types info))
2091 (text (.text info)))
2093 (((trans-unit . _) . _)
2094 ((ast-list->info info) o))
2095 ((trans-unit . ,elements)
2096 ((ast-list->info info) elements))
2097 ((fctn-defn . _) ((function->info info) o))
2098 ((cpp-stmt (define (name ,name) (repl ,value)))
2101 ((cast (type-name (decl-spec-list (type-spec (void)))) _)
2105 (let ((label (car (.break info))))
2106 (append-text info (wrap-as (i386:jump label)))))
2109 (let ((label (car (.continue info))))
2110 (append-text info (wrap-as (i386:jump label)))))
2112 ;; FIXME: expr-stmt wrapper?
2116 ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
2118 ((asm-expr ,gnuc (,null ,arg0 . string))
2119 (append-text info (wrap-as (asm->m1 arg0))))
2121 ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
2122 (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
2123 (append-text info (wrap-as (asm->m1 arg0))))
2124 (let* ((info (append-text info (ast->comment o)))
2125 (info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
2126 (append-text info (wrap-as (i386:accu-zero?))))))
2129 (let* ((info (append-text info (ast->comment `(if ,test (ellipsis)))))
2130 (here (number->string (length text)))
2131 (label (string-append "_" (.function info) "_" here "_"))
2132 (break-label (string-append label "break"))
2133 (else-label (string-append label "else"))
2134 (info ((test-jump-label->info info break-label) test))
2135 (info ((ast->info info) then))
2136 (info (append-text info (wrap-as (i386:jump break-label))))
2137 (info (append-text info (wrap-as `((#:label ,break-label))))))
2141 ((if ,test ,then ,else)
2142 (let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis)))))
2143 (here (number->string (length text)))
2144 (label (string-append "_" (.function info) "_" here "_"))
2145 (break-label (string-append label "break"))
2146 (else-label (string-append label "else"))
2147 (info ((test-jump-label->info info else-label) test))
2148 (info ((ast->info info) then))
2149 (info (append-text info (wrap-as (i386:jump break-label))))
2150 (info (append-text info (wrap-as `((#:label ,else-label)))))
2151 (info ((ast->info info) else))
2152 (info (append-text info (wrap-as `((#:label ,break-label))))))
2157 ((expr-stmt (cond-expr ,test ,then ,else))
2158 (let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis)))))
2159 (here (number->string (length text)))
2160 (label (string-append "_" (.function info) "_" here "_"))
2161 (else-label (string-append label "else"))
2162 (break-label (string-append label "break"))
2163 (info ((test-jump-label->info info else-label) test))
2164 (info ((ast->info info) then))
2165 (info (append-text info (wrap-as (i386:jump break-label))))
2166 (info (append-text info (wrap-as `((#:label ,else-label)))))
2167 (info ((ast->info info) else))
2168 (info (append-text info (wrap-as `((#:label ,break-label))))))
2171 ((switch ,expr (compd-stmt (block-item-list . ,statements)))
2172 (let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
2173 (here (number->string (length text)))
2174 (label (string-append "_" (.function info) "_" here "_"))
2175 (break-label (string-append label "break"))
2176 (clauses (statements->clauses statements))
2177 (info ((expr->accu info) expr))
2178 (info (clone info #:break (cons break-label (.break info))))
2179 (info (let loop ((clauses clauses) (i 0) (info info))
2180 (if (null? clauses) info
2181 (loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses))))))
2182 (info (append-text info (wrap-as `((#:label ,break-label))))))
2185 #:break (cdr (.break info)))))
2187 ((for ,init ,test ,step ,body)
2188 (let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis)))))
2189 (here (number->string (length text)))
2190 (label (string-append "_" (.function info) "_" here "_"))
2191 (break-label (string-append label "break"))
2192 (loop-label (string-append label "loop"))
2193 (continue-label (string-append label "continue"))
2194 (initial-skip-label (string-append label "initial_skip"))
2195 (info ((ast->info info) init))
2196 (info (clone info #:break (cons break-label (.break info))))
2197 (info (clone info #:continue (cons continue-label (.continue info))))
2198 (info (append-text info (wrap-as (i386:jump initial-skip-label))))
2199 (info (append-text info (wrap-as `((#:label ,loop-label)))))
2200 (info ((ast->info info) body))
2201 (info (append-text info (wrap-as `((#:label ,continue-label)))))
2202 (info ((expr->accu info) step))
2203 (info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
2204 (info ((test-jump-label->info info break-label) test))
2205 (info (append-text info (wrap-as (i386:jump loop-label))))
2206 (info (append-text info (wrap-as `((#:label ,break-label))))))
2209 #:break (cdr (.break info))
2210 #:continue (cdr (.continue info)))))
2212 ((while ,test ,body)
2213 (let* ((info (append-text info (ast->comment `(while ,test (ellipsis)))))
2214 (here (number->string (length text)))
2215 (label (string-append "_" (.function info) "_" here "_"))
2216 (break-label (string-append label "break"))
2217 (loop-label (string-append label "loop"))
2218 (continue-label (string-append label "continue"))
2219 (info (append-text info (wrap-as (i386:jump continue-label))))
2220 (info (clone info #:break (cons break-label (.break info))))
2221 (info (clone info #:continue (cons continue-label (.continue info))))
2222 (info (append-text info (wrap-as `((#:label ,loop-label)))))
2223 (info ((ast->info info) body))
2224 (info (append-text info (wrap-as `((#:label ,continue-label)))))
2225 (info ((test-jump-label->info info break-label) test))
2226 (info (append-text info (wrap-as (i386:jump loop-label))))
2227 (info (append-text info (wrap-as `((#:label ,break-label))))))
2230 #:break (cdr (.break info))
2231 #:continue (cdr (.continue info)))))
2233 ((do-while ,body ,test)
2234 (let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis)))))
2235 (here (number->string (length text)))
2236 (label (string-append "_" (.function info) "_" here "_"))
2237 (break-label (string-append label "break"))
2238 (loop-label (string-append label "loop"))
2239 (continue-label (string-append label "continue"))
2240 (info (clone info #:break (cons break-label (.break info))))
2241 (info (clone info #:continue (cons continue-label (.continue info))))
2242 (info (append-text info (wrap-as `((#:label ,loop-label)))))
2243 (info ((ast->info info) body))
2244 (info (append-text info (wrap-as `((#:label ,continue-label)))))
2245 (info ((test-jump-label->info info break-label) test))
2246 (info (append-text info (wrap-as (i386:jump loop-label))))
2247 (info (append-text info (wrap-as `((#:label ,break-label))))))
2250 #:break (cdr (.break info))
2251 #:continue (cdr (.continue info)))))
2253 ((labeled-stmt (ident ,label) ,statement)
2254 (let ((info (append-text info `(((#:label ,(string-append "_" (.function info) "_label_" label)))))))
2255 ((ast->info info) statement)))
2257 ((goto (ident ,label))
2258 (append-text info (wrap-as (i386:jump (string-append "_" (.function info) "_label_" label)))))
2261 (let ((info ((expr->accu info) expr)))
2262 (append-text info (append (wrap-as (i386:ret))))))
2265 ((decl->info info) o))
2268 ((gt . _) ((expr->accu info) o))
2269 ((ge . _) ((expr->accu info) o))
2270 ((ne . _) ((expr->accu info) o))
2271 ((eq . _) ((expr->accu info) o))
2272 ((le . _) ((expr->accu info) o))
2273 ((lt . _) ((expr->accu info) o))
2274 ((lshift . _) ((expr->accu info) o))
2275 ((rshift . _) ((expr->accu info) o))
2278 ((expr-stmt ,expression)
2279 (let ((info ((expr->accu info) expression)))
2280 (append-text info (wrap-as (i386:accu-zero?)))))
2282 ;; FIXME: why do we get (post-inc ...) here
2284 (_ (let ((info ((expr->accu info) o)))
2285 (append-text info (wrap-as (i386:accu-zero?)))))))))
2287 (define (enum-def-list->constants constants fields)
2288 (let loop ((fields fields) (i 0) (constants constants))
2290 (let ((field (car fields)))
2291 (mescc:trace (cadr (cadr field)) " <e>")))
2292 (if (null? fields) constants
2293 (let* ((field (car fields))
2295 ((enum-defn (ident ,name) . _) name)))
2297 ((enum-defn ,name) i)
2298 ((enum-defn ,name ,exp) (expr->number #f exp))
2299 (_ (error "not supported enum field=~s\n" field)))))
2302 (append constants (list (ident->constant name i))))))))
2304 (define (initzer->non-const info)
2307 ((initzer (p-expr (ident ,name)))
2308 (let ((value (assoc-ref (.constants info) name)))
2309 `(initzer (p-expr (fixed ,(number->string value))))))
2312 (define (initzer->value info)
2315 ((p-expr (fixed ,value)) (cstring->number value))
2316 (_ (error "initzer->value: " o)))))
2318 (define (initzer->data info)
2321 ((initzer (p-expr (char ,char))) (int->bv32 (char->integer (string-ref char 0))))
2322 ((initzer (p-expr (char ,char))) (list (char->integer (string-ref char 0))))
2323 ((initzer (p-expr (string ,string))) `((#:string ,string) #f #f #f))
2324 ((initzer (p-expr (string . ,strings))) `((#:string ,(string-join strings "")) #f #f #f))
2325 ((initzer (initzer-list . ,initzers)) (append-map (initzer->data info) initzers))
2326 ((initzer (ref-to (p-expr (ident ,name)))) `(,name #f #f #f))
2327 ((initzer (ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))))
2328 (let* ((type (decl->ast-type struct))
2329 (offset (field-offset info type field))
2330 (base (cstring->number base)))
2331 (int->bv32 (+ base offset))))
2334 (int->bv32 (expr->number info p-expr)))
2335 (_ (error "initzer->data: unsupported: " o)))))
2337 (define (initzer->accu info)
2340 ((initzer-list . ,initzers) (fold (lambda (i info) ((expr->accu info) i)) info initzers))
2341 ((initzer (initzer-list . ,initzers)) (fold (lambda (i info) ((expr->accu info) i)) info initzers))
2342 ((initzer ,initzer) ((expr->accu info) o))
2343 (() (append-text info (wrap-as (i386:value->accu 0))))
2344 (_ (error "initzer->accu: " o)))))
2346 (define (expr->global globals)
2349 ((p-expr (string ,string))
2350 (let ((g `(#:string ,string)))
2351 (or (assoc g globals)
2352 (string->global-entry string))))
2353 ((p-expr (string . ,strings))
2354 (let* ((string (string-join strings ""))
2355 (g `(#:string ,string)))
2356 (or (assoc g globals)
2357 (string->global-entry string))))
2358 ;;((p-expr (fixed ,value)) (int->global-entry (cstring->number value)))
2361 (define (initzer->globals globals)
2364 ((initzer (initzer-list . ,initzers)) (append-map (initzer->globals globals) initzers))
2365 ((initzer ,initzer) (list ((expr->global globals) initzer)))
2368 (define (type->info info o)
2370 ((struct-def (ident ,name) (field-list . ,fields))
2371 (mescc:trace name " <t>")
2372 (let ((type-entry (struct->type-entry name (map (struct-field info) fields))))
2373 (clone info #:types (cons type-entry (.types info)))))
2376 (define (.formals o)
2378 ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2379 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2380 ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
2381 ((fctn-defn _ (ptr-declr (pointer (pointer (pointer))) (ftn-declr _ ,formals)) _) formals)
2382 (_ (error ".formals: " o))))
2384 (define (formal->text n)
2390 (define (formals->text o)
2392 ((param-list . ,formals)
2393 (let ((n (length formals)))
2394 (wrap-as (append (i386:function-preamble)
2395 (append-map (formal->text n) formals (iota n))
2396 (i386:function-locals)))))
2397 (_ (error "formals->text: unsupported: " o))))
2399 (define (formal:ptr o)
2401 ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2403 ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
2405 ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
2407 ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2409 ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
2411 ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer (pointer))) (ident ,name))))
2415 (define (formals->locals o)
2417 ((param-list . ,formals)
2418 (let ((n (length formals)))
2419 (map make-local-entry (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2420 (_ (error "formals->locals: unsupported: " o))))
2422 (define (function->info info)
2424 (define (assert-return text)
2425 (let ((return (wrap-as (i386:ret))))
2426 (if (equal? (list-tail text (- (length text) (length return))) return) text
2427 (append text return))))
2428 (let* ((name (.name o))
2429 (formals (.formals o))
2430 (text (formals->text formals))
2431 (locals (formals->locals formals)))
2433 (let loop ((statements (.statements o))
2434 (info (clone info #:locals locals #:function (.name o) #:text text)))
2435 (if (null? statements) (let* ((locals (.locals info))
2436 (local (and (pair? locals) (car locals)))
2437 (count (and=> local (compose local:id cdr)))
2438 (stack (and count (* count 4))))
2439 (if (and stack (getenv "MESC_DEBUG")) (stderr " stack: ~a\n" stack))
2442 #:functions (append (.functions info) (list (cons name (assert-return (.text info)))))))
2443 (let* ((statement (car statements)))
2444 (loop (cdr statements)
2445 ((ast->info info) (car statements)))))))))
2449 (define (ast-list->info info)
2451 (let loop ((elements elements) (info info))
2452 (if (null? elements) info
2453 (loop (cdr elements) ((ast->info info) (car elements)))))))
2455 (define* (c99-ast->info ast)
2456 ((ast->info (make <info> #:types i386:type-alist)) ast))
2458 (define* (c99-input->ast #:key (defines '()) (includes '()))
2459 (stderr "parsing: input\n")
2460 ((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:defines defines #:includes includes)))
2462 (define* (c99-input->info #:key (defines '()) (includes '()))
2464 (let* ((info (make <info> #:types i386:type-alist))
2465 (ast (c99-input->ast #:defines defines #:includes includes))
2466 (foo (stderr "compiling: input\n"))
2467 (info ((ast->info info) ast))
2468 (info (clone info #:text '() #:locals '())))
2471 (define* (info->object o)
2472 (stderr "compiling: object\n")
2473 `((functions . ,(.functions o))
2474 (globals . ,(map (lambda (g) (cons (car g) (global:value (cdr g)))) (.globals o)))))
2476 (define* (c99-input->elf #:key (defines '()) (includes '()))
2477 ((compose object->elf info->object (c99-input->info #:defines defines #:includes includes))))
2479 (define* (c99-input->object #:key (defines '()) (includes '()))
2480 ((compose object->M1 info->object (c99-input->info #:defines defines #:includes includes))))