(define mes? (pair? (current-module)))
-(define (c99-input->ast)
+(define* (c99-input->ast #:key (defines '()) (includes '()))
(parse-c99
- #:inc-dirs (cons* "." "libc/include" "libc" "src" "out" "out/src" (string-split (getenv "C_INCLUDE_PATH") #\:))
+ #:inc-dirs (append includes (cons* "." "libc/include" "libc" "src" "out" "out/src" (string-split (getenv "C_INCLUDE_PATH") #\:)))
#:cpp-defs `(
"POSIX=0"
"_POSIX_SOURCE=0"
,(string-append "PREFIX=\"" %prefix "\"")
,(string-append "MODULEDIR=\"" %moduledir "\"")
,(string-append "VERSION=\"" %version "\"")
+ ,@defines
)
#:mode 'code))
(define (push-global globals)
(lambda (o)
(list
- (lambda (f g ta t d)
- (i386:push-global (+ (data-offset o g) d))))))
+ `(lambda (f g ta t d)
+ (i386:push-global (+ (data-offset ,o g) d))))))
(define (push-local locals)
(lambda (o)
(define (push-global-address globals)
(lambda (o)
(list
- (lambda (f g ta t d)
- (i386:push-global-address (+ (data-offset o g) d))))))
+ `(lambda (f g ta t d)
+ (i386:push-global-address (+ (data-offset ,o g) d))))))
(define (push-local-address locals)
(lambda (o)
(size (if (= ptr 1) (type->size info type)
4)))
(case ptr
- ((-1) (list (lambda (f g ta t d)
- (i386:global->accu (+ (data-offset o g) d)))))
- ((1) (list (lambda (f g ta t d)
- (i386:global-address->accu (+ (data-offset o g) d)))))
-
- ((2) (list (lambda (f g ta t d)
- (append (i386:value->accu (+ (data-offset o g) d))))))
- (else (list (lambda (f g ta t d)
- (i386:global-address->accu (+ (data-offset o g) d)))))))
+ ((-1) (list `(lambda (f g ta t d)
+ (i386:global->accu (+ (data-offset ,o g) d)))))
+ ((1) (list `(lambda (f g ta t d)
+ (i386:global-address->accu (+ (data-offset ,o g) d)))))
+
+ ((2) (list `(lambda (f g ta t d)
+ (append (i386:value->accu (+ (data-offset ,o g) d))))))
+ (else (list `(lambda (f g ta t d)
+ (i386:global-address->accu (+ (data-offset ,o g) d)))))))
(if constant (wrap-as (i386:value->accu constant))
- (list (lambda (f g ta t d)
- (i386:global->accu (+ ta (function-offset o f)))))))))))
+ (list `(lambda (f g ta t d)
+ (i386:global->accu (+ ta (function-offset ,o f)))))))))))
(define (ident-address->accu info)
(lambda (o)
(let ((ptr (ident->pointer info o)))
(case ptr
;; ((1)
- ;; (list (lambda (f g ta t d)
- ;; (i386:global->accu (+ (data-offset o g) d)))))
- (else (list (lambda (f g ta t d)
- (append (i386:value->accu (+ (data-offset o g) d))))))))
- (list (lambda (f g ta t d)
- (i386:global->accu (+ ta (function-offset o f))))))))))
+ ;; (list `(lambda (f g ta t d)
+ ;; (i386:global->accu (+ (data-offset ,o g) d)))))
+ (else (list `(lambda (f g ta t d)
+ (append (i386:value->accu (+ (data-offset ,o g) d))))))))
+ (list `(lambda (f g ta t d)
+ (i386:global->accu (+ ta (function-offset ,o f))))))))))
(define (ident-address->base info)
(lambda (o)
(let ((ptr (ident->pointer info o)))
(case ptr
((1)
- (list (lambda (f g ta t d)
- (i386:global->base (+ (data-offset o g) d)))))
- (else (list (lambda (f g ta t d)
- (append (i386:value->base (+ (data-offset o g) d))))))))
+ (list `(lambda (f g ta t d)
+ (i386:global->base (+ (data-offset ,o g) d)))))
+ (else (list `(lambda (f g ta t d)
+ (append (i386:value->base (+ (data-offset ,o g) d))))))))
(error "TODO ident-address->base" o))))))
(define (value->accu v)
(case ptr
(else (wrap-as (i386:accu->local (local:id local))))))
(let ((ptr (ident->pointer info o)))
- (list (lambda (f g ta t d)
- (i386:accu->global (+ (data-offset o g) d)))))))))
+ (list `(lambda (f g ta t d)
+ (i386:accu->global (+ (data-offset ,o g) d)))))))))
(define (base->ident info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:base->local (local:id local)))
- (list (lambda (f g ta t d)
- (i386:base->global (+ (data-offset o g) d))))))))
+ (list `(lambda (f g ta t d)
+ (i386:base->global (+ (data-offset ,o g) d))))))))
(define (base->ident-address info)
(lambda (o)
(lambda (o value)
(let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:value->local (local:id local) value))
- (list (lambda (f g ta t d)
- (i386:value->global (+ (data-offset o g) d) value)))))))
+ (list `(lambda (f g ta t d)
+ (i386:value->global (+ (data-offset ,o g) d) value)))))))
(define (ident-add info)
(lambda (o n)
(let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:local-add (local:id local) n))
- (list (lambda (f g ta t d)
- (i386:global-add (+ (data-offset o g) d) n)))))))
+ (list `(lambda (f g ta t d)
+ (i386:global-add (+ (data-offset ,o g) d) ,n)))))))
(define (ident-address-add info)
(lambda (o n)
(i386:local->accu (local:id local))
(i386:accu-mem-add n)
(i386:pop-accu)))
- (list (lambda (f g ta t d)
+ (list `(lambda (f g ta t d)
(append (i386:push-accu)
- (i386:global->accu (+ (data-offset o g) d))
- (i386:accu-mem-add n)
+ (i386:global->accu (+ (data-offset ,o g) d))
+ (i386:accu-mem-add ,n)
(i386:pop-accu))))))))
;; FIXME: see ident->accu
(if global
(let ((ptr (ident->pointer info o)))
(case ptr
- ((-1) (list (lambda (f g ta t d)
- (i386:global->base (+ (data-offset o g) d)))))
- ((2) (list (lambda (f g ta t d)
- (i386:global->base (+ (data-offset o g) d)))))
- (else (list (lambda (f g ta t d)
- (i386:global-address->base (+ (data-offset o g) d)))))))
+ ((-1) (list `(lambda (f g ta t d)
+ (i386:global->base (+ (data-offset ,o g) d)))))
+ ((2) (list `(lambda (f g ta t d)
+ (i386:global->base (+ (data-offset ,o g) d)))))
+ (else (list `(lambda (f g ta t d)
+ (i386:global-address->base (+ (data-offset ,o g) d)))))))
(let ((constant (assoc-ref (.constants info) o)))
(if constant (wrap-as (i386:value->base constant))
- (list (lambda (f g ta t d)
- (i386:global->base (+ ta (function-offset o f)))))))))))))
+ (list `(lambda (f g ta t d)
+ (i386:global->base (+ ta (function-offset ,o f)))))))))))))
(define (expr->accu info)
(lambda (o)
((p-expr (string ,string))
(let* ((globals (append globals (list (string->global string))))
(info (clone info #:globals globals)))
- (append-text info (list (lambda (f g ta t d)
- (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d)))))))
+ (append-text info (list `(lambda (f g ta t d)
+ (i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))))
((p-expr (string . ,strings))
- (append-text info (list (lambda (f g ta t d)
- (i386:global->accu (+ (data-offset (add-s:-prefix (apply string-append strings)) globals) d))))))
+ (append-text info (list `(lambda (f g ta t d)
+ (i386:global->accu (+ (data-offset ,(add-s:-prefix (apply string-append strings)) g) d))))))
((p-expr (fixed ,value))
(append-text info (value->accu (cstring->number value))))
(loop (cdr expressions) ((expr->arg info) (car expressions))))))
(n (length expr-list)))
(if (and (not (assoc-ref locals name))
- (assoc-ref (.functions info) name))
- (append-text args-info (list (lambda (f g ta t d)
- (i386:call f g ta t d (+ t (function-offset name f)) n))))
+ (assoc name (.functions info)))
+ (append-text args-info (list `(lambda (f g ta t d)
+ (i386:call f g ta t d (+ t (function-offset ,name f)) ,n))))
(let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) `(p-expr (ident ,name)))))
(append-text args-info (append (.text accu)
- (list (lambda (f g ta t d)
- (i386:call-accu f g ta t d n))))))))))
+ (list `(lambda (f g ta t d)
+ (i386:call-accu f g ta t d ,n))))))))))
((fctn-call ,function (expr-list . ,expr-list))
(let* ((text-length (length text))
(empty (clone info #:text '()))
(accu ((expr->accu empty) function)))
(append-text args-info (append (.text accu)
- (list (lambda (f g ta t d)
- (i386:call-accu f g ta t d n)))))))
+ (list `(lambda (f g ta t d)
+ (i386:call-accu f g ta t d ,n)))))))
((cond-expr . ,cond-expr)
((ast->info info) `(expr-stmt ,o)))
(clone info #:text (append (.text info) text)))
(define (wrap-as o)
- (list (lambda (f g ta t d) o)))
+ (list `(lambda (f g ta t d) ,(cons 'list o))))
(define (expr->accu* info)
(lambda (o)
(_ (error "case test: unsupported: " test)))))
(lambda (n)
(append (wrap-as (i386:accu-cmp-value value))
- (jump-z (+ (length (text->list (jump 0)))
+ (jump-z (+ (length (object->list (jump 0)))
(if (= n 0) 0
- (* n (length (text->list ((test->text 0) 0)))))))))))
+ (* n (length (object->list ((test->text 0) 0)))))))))))
(define (cases+jump cases clause-length)
(append-text info
(append
(()
(let* ((cases-length (length (.text (cases+jump cases 0))))
(clause-text (list-tail (.text clause) cases-length))
- (clause-length (length (text->list clause-text))))
+ (clause-length (length (object->list clause-text))))
(clone clause #:text
(append (.text (cases+jump cases clause-length))
clause-text))))
(a-jump ((test->jump->info info) a))
(a-text (.text (a-jump 0)))
- (a-length (length (text->list a-text)))
+ (a-length (length (object->list a-text)))
(b-jump ((test->jump->info info) b))
(b-text (.text (b-jump 0)))
- (b-length (length (text->list b-text))))
+ (b-length (length (object->list b-text))))
(lambda (body-length)
(let* ((info (append-text info text))
(a-jump ((test->jump->info info) a))
(a-text (.text (a-jump 0)))
- (a-length (length (text->list a-text)))
+ (a-length (length (object->list a-text)))
(jump-text (wrap-as (i386:Xjump 0)))
- (jump-length (length (text->list jump-text)))
+ (jump-length (length (object->list jump-text)))
(b-jump ((test->jump->info info) b))
(b-text (.text (b-jump 0)))
- (b-length (length (text->list b-text)))
+ (b-length (length (object->list b-text)))
(jump-text (wrap-as (i386:Xjump b-length))))
(define (ast->info info)
(lambda (o)
- (let ((globals (.globals info))
+ (let ((functions (.functions info))
+ (globals (.globals info))
(locals (.locals info))
(constants (.constants info))
(text (.text info)))
(1+ (local:id (cdar locals)))))
(locals (cons (make-local name type pointer id) locals)))
locals))
+ (define (declare name)
+ (if (member name functions) info
+ (clone info #:functions (cons (cons name #f) functions))))
(pmatch o
(((trans-unit . _) . _)
((ast-list->info info) o))
info)
((break)
- (append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (text->list text)))))))
+ (append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (object->list text)))))))
;; FIXME: expr-stmt wrapper?
(trans-unit info)
(body-info ((ast->info test+jump-info) body))
(text-body-info (.text body-info))
(body-text (list-tail text-body-info test-length))
- (body-length (length (text->list body-text)))
+ (body-length (length (object->list body-text)))
(text+test-text (.text (test-jump->info body-length)))
(test-text (list-tail text+test-text text-length)))
(text-then-info (.text then-info))
(then-text (list-tail text-then-info test-length))
(then-jump-text (wrap-as (i386:Xjump 0)))
- (then-jump-length (length (text->list then-jump-text)))
- (then-length (+ (length (text->list then-text)) then-jump-length))
+ (then-jump-length (length (object->list then-jump-text)))
+ (then-length (+ (length (object->list then-text)) then-jump-length))
(then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
(else-info ((ast->info then+jump-info) else))
(text-else-info (.text else-info))
(else-text (list-tail text-else-info (length (.text then+jump-info))))
- (else-length (length (text->list else-text)))
+ (else-length (length (object->list else-text)))
(text+test-text (.text (test-jump->info then-length)))
(test-text (list-tail text+test-text text-length))
(then-info ((ast->info test+jump-info) then))
(text-then-info (.text then-info))
(then-text (list-tail text-then-info test-length))
- (then-length (length (text->list then-text)))
+ (then-length (length (object->list then-text)))
(jump-text (wrap-as (i386:Xjump 0)))
- (jump-length (length (text->list jump-text)))
+ (jump-length (length (object->list jump-text)))
(test+then+jump-info
(clone then-info
(else-info ((ast->info test+then+jump-info) else))
(text-else-info (.text else-info))
(else-text (list-tail text-else-info (length (.text test+then+jump-info))))
- (else-length (length (text->list else-text)))
+ (else-length (length (object->list else-text)))
(text+test-text (.text (test-jump->info (+ then-length jump-length))))
(test-text (list-tail text+test-text text-length))
(expr ((expr->accu info) expr))
(empty (clone info #:text '()))
(clause-infos (map (clause->jump-info empty) clauses))
- (clause-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) clause-infos))
+ (clause-lengths (map (lambda (c-j) (length (object->list (.text (c-j 0))))) clause-infos))
(clauses-info (let loop ((clauses clauses) (info expr) (lengths clause-lengths))
(if (null? clauses) info
(let ((c-j ((clause->jump-info info) (car clauses))))
(body-info ((ast->info info) body))
(body-text (.text body-info))
- (body-length (length (text->list body-text)))
+ (body-length (length (object->list body-text)))
(step-info ((expr->accu info) step))
(step-text (.text step-info))
- (step-length (length (text->list step-text)))
+ (step-length (length (object->list step-text)))
(test-jump->info ((test->jump->info info) test))
(test+jump-info (test-jump->info 0))
- (test-length (length (text->list (.text test+jump-info))))
+ (test-length (length (object->list (.text test+jump-info))))
(skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
(jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
- (jump-length (length (text->list jump-text)))
+ (jump-length (length (object->list jump-text)))
(test-text (.text (test-jump->info jump-length))))
(let* ((skip-info (lambda (body-length test-length)
(clone info
#:text (append text (wrap-as (i386:Xjump body-length)))
- #:break (cons (+ (length (text->list text)) body-length test-length
+ #:break (cons (+ (length (object->list text)) body-length test-length
(length (i386:Xjump 0)))
(.break info)))))
(text (.text (skip-info 0 0)))
((ast->info (skip-info body-length test-length)) body)))
(body-text (list-tail (.text (body-info 0 0)) text-length))
- (body-length (length (text->list body-text)))
+ (body-length (length (object->list body-text)))
(empty (clone info #:text '()))
(test-jump->info ((test->jump->info empty) test))
(test+jump-info (test-jump->info 0))
- (test-length (length (text->list (.text test+jump-info))))
+ (test-length (length (object->list (.text test+jump-info))))
(jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
- (jump-length (length (text->list jump-text)))
+ (jump-length (length (object->list jump-text)))
(test-text (.text (test-jump->info jump-length)))
- (body-info (body-info body-length (length (text->list test-text)))))
+ (body-info (body-info body-length (length (object->list test-text)))))
(clone info #:text
(append
(body-info ((ast->info info) body))
(body-text (list-tail (.text body-info) text-length))
- (body-length (length (text->list body-text)))
+ (body-length (length (object->list body-text)))
(empty (clone info #:text '()))
(test-jump->info ((test->jump->info empty) test))
(test+jump-info (test-jump->info 0))
- (test-length (length (text->list (.text test+jump-info))))
+ (test-length (length (object->list (.text test+jump-info))))
(jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
- (jump-length (length (text->list jump-text)))
+ (jump-length (length (object->list jump-text)))
(test-text (.text (test-jump->info jump-length))))
(clone info #:text
((goto (ident ,label))
(let* ((jump (lambda (n) (i386:XXjump n)))
- (offset (+ (length (jump 0)) (length (text->list text)))))
+ (offset (+ (length (jump 0)) (length (object->list text)))))
(append-text info (append
- (list (lambda (f g ta t d)
- (jump (- (label-offset (.function info) label f) offset))))))))
+ (list `(lambda (f g ta t d)
+ (i386:XXjump (- (label-offset ,(.function info) ,label f) ,offset))))))))
((return ,expr)
(let ((info ((expr->accu info) expr)))
(globals (append globals (list (string->global string))))
(info (clone info #:locals locals #:globals globals)))
(append-text info (append
- (list (lambda (f g ta t d)
+ (list `(lambda (f g ta t d)
(append
- (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
+ (i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))
((accu->ident info) name))))
(let* ((global (string->global string))
(globals (append globals (list global)))
(size 4)
(global (make-global name type 1 (string->list (make-string size #\nul))))
(globals (append globals (list global)))
- (info (clone info #:globals globals))
- (here (data-offset name globals)))
+ (info (clone info #:globals globals)))
(clone info #:init
(append
(.init info)
- (list (lambda (functions globals ta t d data)
- (append
- (list-head data here)
- (initzer->data info functions globals ta t d `(initzer (p-expr (string ,string))))
- (list-tail data (+ here size))))))))))
+ (list
+ `(lambda (f g ta t d data)
+ (let (((here (data-offset ,name g))))
+ (append
+ (list-head data here)
+ (initzer->data f g ta t d '(initzer (p-expr (string ,string))))
+ (list-tail data (+ here ,size)))))))))))
;; char const *p;
((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qualifier)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
((ident->accu info) b)
((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 2 0))))
- (here (data-offset name globals)))
+ (value (assoc-ref constants b)))
(clone info
#:globals globals
#:init (append (.init info)
- (list (lambda (functions globals ta t d data)
- (append
- (list-head data here)
- ;;(initzer->data info functions globals ta t d initzer)
- (initzer->data info functions globals ta t d `(p-expr (ident ,b)))
- (list-tail data (+ here 4))))))))
- ;;;(clone info #:globals (append globals (list (ident->global name type 1 0))))
- ))
+ (list
+ `(lambda (f g ta t d data)
+ (let ((here (data-offset ,name g)))
+ (append
+ (list-head data here)
+ (initzer->data f g ta t d '(p-expr (fixed ,value)))
+ (list-tail data (+ here 4)))))))))))
;; struct foo bar[2];
;; char arena[20000];
(append text
(.text accu)
((accu->ident info) name)
- (list (lambda (f g ta t d)
+ (list `(lambda (f g ta t d)
(append (i386:value->base ta)
(i386:accu+base)))))
#:locals locals)))
(info (clone info #:locals locals)))
(append-text info (append ((ident->accu info) value)
((accu->ident info) name))))
- (let* ((globals (append globals (list (ident->global name type 1 0))))
- (here (data-offset name globals))
- (there (data-offset value globals)))
+ (let* ((globals (append globals (list (ident->global name type 1 0)))))
(clone info
#:globals globals
#:init (append (.init info)
- (list (lambda (functions globals ta t d data)
- (append
- (list-head data here)
- ;;; FIXME: type
- ;;; char *x = arena;
- (int->bv32 (+ d (data-offset value globals)))
- ;;; char *y = x;
- ;;;(list-head (list-tail data there) 4)
- (list-tail data (+ here 4))))))))))
+ (list
+ `(lambda (f g ta t d data)
+ (let ((here (data-offset ,name g))
+ (there (data-offset ,value g)))
+ (append
+ (list-head data here)
+ ;; FIXME: type
+ ;; char *x = arena;
+ (int->bv32 (+ d (data-offset ,value g)))
+ ;; char *y = x;
+ ;;(list-head (list-tail data there) 4)
+ (list-tail data (+ here 4)))))))))))
;; char *p = g_cells;
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
(info (clone info #:locals locals)))
(append-text info (append ((ident->accu info) value)
((accu->ident info) name))))
- (let* ((globals (append globals (list (ident->global name type 1 0))))
- (here (data-offset name globals)))
+ (let* ((globals (append globals (list (ident->global name type 1 0)))))
(clone info
#:globals globals
#:init (append (.init info)
- (list (lambda (functions globals ta t d data)
- (append
- (list-head data here)
- ;;; FIXME: type
- ;;; char *x = arena;p
- (int->bv32 (+ d (data-offset value globals)))
- (list-tail data (+ here 4)))))))))))
+ (list `(lambda (f g ta t d data)
+ (let ((here (data-offset ,name g)))
+ (append
+ (list-head data here)
+ ;; FIXME: type
+ ;; char *x = arena;p
+ (int->bv32 (+ d (data-offset ,value g)))
+ (list-tail data (+ here 4))))))))))))
;; enum
((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
(let* ((type (decl->type type))
(entries (map initzer->global initzers))
(entry-size 4)
- (size (* (length entries) entry-size)))
+ (size (* (length entries) entry-size))
+ (initzers (map (initzer->non-const info) initzers)))
(if (.function info)
(error "TODO: <type> x[] = {};" o)
(let* ((global (make-global name type 2 (string->list (make-string size #\nul))))
(globals (append globals entries (list global)))
- (info (clone info #:globals globals))
- (here (data-offset name globals)))
+ (info (clone info #:globals globals)))
(clone info #:init
(append
(.init info)
- (list (lambda (functions globals ta t d data)
- (append
- (list-head data here)
- (append-map
- (lambda (i)
- (initzer->data info functions globals ta t d i))
- initzers)
- (list-tail data (+ here size)))))))))))
+ (list
+ `(lambda (f g ta t d data)
+ (let ((here (data-offset ,name g)))
+ (append
+ (list-head data here)
+ (append-map
+ (lambda (i)
+ (initzer->data f g ta t d i))
+ ',initzers)
+ (list-tail data (+ here ,size))))))))))))
;;
;; struct f = {...};
(let* ((type (decl->type type))
(fields (type->description info type))
(size (type->size info type))
- (field-size 4)) ;; FIXME:4, not fixed
+ (field-size 4) ;; FIXME:4, not fixed
+ (initzers (map (initzer->non-const info) initzers)))
(if (.function info)
(let* ((globals (append globals (filter-map initzer->global initzers)))
(locals (let loop ((fields (cdr fields)) (locals locals))
(let* ((globals (append globals (filter-map initzer->global initzers)))
(global (make-global name type -1 (string->list (make-string size #\nul))))
(globals (append globals (list global)))
- (here (data-offset name globals))
(info (clone info #:globals globals))
(field-size 4))
(let loop ((fields (iota (length fields))) (initzers initzers) (info info))
(clone info #:init
(append
(.init info)
- (list (lambda (functions globals ta t d data)
- (append
- (list-head data (+ here offset))
- (initzer->data info functions globals ta t d (car initzers))
- (list-tail data (+ here offset field-size)))))))))))))))
+ (list
+ `(lambda (f g ta t d data)
+ (let ((here (data-offset ,name g)))
+ (append
+ (list-head data (+ here ,offset))
+ (initzer->data f g ta t d ',(car initzers))
+ (list-tail data (+ here ,offset ,field-size))))))))))))))))
;;char cc = g_cells[c].cdr; ==> generic?
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
- (let ((type (decl->type type)))
+ (let ((type (decl->type type))
+ (initzer ((initzer->non-const info) initzer)))
(if (.function info)
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals)))
(clone info #:text
(append (.text ((expr->accu info) initzer))
((accu->ident info) name))))
- (let* ((globals (append globals (list (ident->global name type 1 0))))
- (here (data-offset name globals)))
+ (let* ((globals (append globals (list (ident->global name type 1 0)))))
(clone info
#:globals globals
#:init (append (.init info)
- (list (lambda (functions globals ta t d data)
- (append
- (list-head data here)
- (initzer->data info functions globals ta t d initzer)
- (list-tail data (+ here 4)))))))))))
+ (list
+ `(lambda (f g ta t d data)
+ (let ((here (data-offset ,name g)))
+ (append
+ (list-head data here)
+ (initzer->data f g ta t d ',initzer)
+ (list-tail data (+ here 4))))))))))))
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
- info)
+ (declare name))
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
- info)
+ (declare name))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
(let ((types (.types info)))
;; int foo ();
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
- info)
+ (declare name))
;; void foo ();
((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
- info)
+ (declare name))
;; void foo (*);
((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
- info)
+ (declare name))
;; char const* itoa ();
((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual)) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
- info)
+ (declare name))
;; char *strcpy ();
((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))))))
- info)
+ (declare name))
;; printf (char const* format, ...)
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
(_ (let ((info ((expr->accu info) o)))
(append-text info (wrap-as (i386:accu-zero?)))))))))
-(define (initzer->data info functions globals ta t d o)
+(define (initzer->non-const info)
+ (lambda (o)
+ (pmatch o
+ ((initzer (p-expr (ident ,name)))
+ (let ((value (assoc-ref (.constants info) name)))
+ `(initzer (p-expr (fixed ,(number->string value))))))
+ (_ o))))
+
+(define (initzer->data f g ta t d o)
(pmatch o
((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
((initzer (ref-to (p-expr (ident ,name))))
- (int->bv32 (+ ta (function-offset name functions))))
- ((initzer (p-expr (ident ,name)))
- (let ((value (assoc-ref (.constants info) name)))
- (int->bv32 value)))
+ (int->bv32 (+ ta (function-offset name f))))
((initzer (p-expr (string ,string)))
- (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
+ (int->bv32 (+ (data-offset (add-s:-prefix string) g) d)))
(_ (error "initzer->data: unsupported: " o))))
(define (.formals o)
(define (assert-return text)
(let ((return (wrap-as (i386:ret))))
(if (equal? (list-tail text (- (length text) (length return))) return) text
- (append text (wrap-as (i386:ret))))))
+ (append text return))))
(let* ((name (.name o))
(formals (.formals o))
(text (formals->text formals))
(format (current-error-port) "compiling: ~a\n" name)
(let loop ((statements (.statements o))
(info (clone info #:locals locals #:function (.name o) #:text text)))
- (if (null? statements) (assert-return (clone info
- #:function #f
- #:functions (append (.functions info) (list (cons name (assert-return (.text info)))))))
+ (if (null? statements) (clone info
+ #:function #f
+ #:functions (append (.functions info) (list (cons name (assert-return (.text info))))))
(let* ((statement (car statements)))
(loop (cdr statements)
((ast->info info) (car statements)))))))))
(if (null? elements) info
(loop (cdr elements) ((ast->info info) (car elements)))))))
-(define (c99-input->info)
- (let* ((info (make <info>
- #:functions i386:libc
- #:types i386:type-alist))
- (foo (stderr "compiling: mlibc\n"))
- (info (let loop ((info info) (libc libc))
- (if (null? libc) info
- (loop ((ast->info info) ((car libc))) (cdr libc)))))
- (foo (stderr "parsing: input\n"))
- (ast (c99-input->ast))
- (foo (stderr "compiling: input\n"))
- (info ((ast->info info) ast))
- (info ((ast->info info) (_start))))
- info))
+(define current-eval
+ (let ((module (current-module)))
+ (lambda (e) (eval e module))))
+
+(define (object->list object)
+ (text->list (map current-eval object)))
+
+(define (dec->xhex o)
+ (string-append "#x" (dec->hex (if (>= o 0) o (+ o #x100)))))
+
+(define (write-lambda o)
+ (newline)
+ (display " ")
+ (if (or (not (pair? o))
+ (not (eq? (caaddr o) 'list))) (write o)
+ (list (car o) (cadr o)
+ (display (string-append "(lambda (f g ta t d) (list "
+ (string-join (map dec->xhex (cdaddr o)) " ")
+ "))")))))
+
+(define (write-function o)
+ (stderr "function: ~s\n" (car o))
+ (newline)
+ (display " (")
+ (write (car o)) (display " ")
+ (if (not (cdr o)) (display ". #f")
+ (for-each write-lambda (cdr o)))
+ (display ")"))
+
+(define (write-info o)
+ (stderr "object:\n")
+ (display "(make <info>\n")
+ (display " #:types\n '") (pretty-print (.types o) #:width 80)
+ (display " #:constants\n '") (pretty-print (.constants o) #:width 80)
+ (display " #:functions '(") (for-each write-function (.functions o)) (display ")") (newline)
+ (stderr "globals:\n")
+ (display " #:globals\n '") (pretty-print (.globals o) #:width 80)
+ (stderr "init:\n")
+ (display " #:init\n '") (pretty-print (.init o) #:width 80)
+ (display ")\n"))
+
+(define* (c99-input->info #:key (defines '()) (includes '()))
+ (lambda ()
+ (let* ((info (make <info>
+ #:functions i386:libc
+ #:types i386:type-alist))
+ (foo (stderr "compiling: mlibc\n"))
+ (info (let loop ((info info) (libc libc))
+ (if (null? libc) info
+ (loop ((ast->info info) ((car libc))) (cdr libc)))))
+ (foo (stderr "parsing: input\n"))
+ (ast (c99-input->ast #:defines defines #:includes includes))
+ (foo (stderr "compiling: input\n"))
+ (info ((ast->info info) ast))
+ (info ((ast->info info) (_start)))
+ (info (clone info #:text '() #:locals '())))
+ info)))
(define (write-any x)
(write-char (cond ((char? x) x)
(define (info->elf info)
(display "dumping elf\n" (current-error-port))
- (for-each write-any (make-elf (.functions info) (.globals info) (.init info))))
-
-(define (c99-input->elf)
- ((compose info->elf c99-input->info)))
+ (for-each write-any (make-elf (filter cdr (.functions info)) (.globals info) (.init info))))
+
+(define (function:object->text o)
+ (cons (car o) (and (cdr o) (map current-eval (cdr o)))))
+
+(define (init:object->text o)
+ (current-eval o))
+
+(define (info:object->text o)
+ (clone o
+ #:functions (map function:object->text (.functions o))
+ #:init (map init:object->text (.init o))))
+
+(define* (c99-input->elf #:key (defines '()) (includes '()))
+ ((compose info->elf info:object->text (c99-input->info #:defines defines #:includes includes))))
+
+(define* (c99-input->object #:key (defines '()) (includes '()))
+ ((compose write-info (c99-input->info #:defines defines #:includes includes))))
+
+(define (object->elf info)
+ ((compose info->elf info:object->text) info))
+
+(define (infos->object infos)
+ ((compose write-info merge-infos) infos))
+
+(define (infos->elf infos)
+ ((compose object->elf merge-infos) infos))
+
+(define (merge-infos infos)
+ (let loop ((infos infos) (info (make <info>)))
+ (if (null? infos) info
+ (loop (cdr infos)
+ (clone info
+ #:types (alist-add (.types info) (.types (car infos)))
+ #:constants (alist-add (.constants info) (.constants (car infos)))
+ #:functions (alist-add (.functions info) (.functions (car infos)))
+ #:globals (alist-add (.globals info) (.globals (car infos)))
+ #:init (append (.init info) (.init (car infos))))))))
+
+(define (alist-add a b)
+ (let* ((b-keys (map car b))
+ (a (filter (lambda (f) (or (cdr f) (not (member f b-keys)))) a))
+ (a-keys (map car a)))
+ (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
projects / mes.git / blobdiff