mescc: support -c, -o.
authorJan Nieuwenhuizen <janneke@gnu.org>
Wed, 17 May 2017 11:56:25 +0000 (13:56 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Wed, 17 May 2017 11:56:25 +0000 (13:56 +0200)
* module/language/c99/compiler.mes: Throughout: quote lambda's.
  (current-eval): New function.
  Thanks Andy!
  (object->list): New function.  Update callers.
  (c99-input->info): Dump a.o.
  (initzer->non-const, function:object->list): New functions.
  (info:object->list): New function.
  (c99-input->elf): Call it.
* module/mes/as-i386: Throughout: quote lambda's.
* scripts/mescc.mes (main): Rewrite.
* guile/mescc.scm (main): Likewise.

guile/mescc.scm
make/mescc-guile.make
make/mescc-mes.make
module/language/c99/compiler.mes
module/language/c99/compiler.scm
module/mes/elf-util.mes
module/mes/elf.mes
module/mes/libc-i386.mes
scripts/mescc.mes

index 83afbd9e1afe70bd1a634eac5f557208f3ef1e8e..ca29bbc32dcc7b2612cd8bb02143a8ab2ef5cb60 100755 (executable)
@@ -2,8 +2,8 @@
 # -*-scheme-*-
 GODIR=${GODIR-@GODIR@}
 GUILEDIR=${GUILEDIR-@GUILEDIR@}
-[ "$GODIR" = @"GODIR"@ ] && GODIR=guile
-[ "$GUILEDIR" = @"GUILEDIR"@ ] && GUILEDIR=guile
+[ "$GODIR" = @"GODIR"@ ] && GODIR=$(dirname $0)
+[ "$GUILEDIR" = @"GUILEDIR"@ ] && GUILEDIR=$(dirname $0)
 export GUILE_AUTO_COMPILE=${GUILE_AUTO_COMPILE-0}
 exec ${GUILE-guile} -L $GUILEDIR -C $GODIR -e '(mescc)' -s "$0" "$@"
 !#
@@ -36,8 +36,9 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' guile/mescc.scm
 
 (define-module (mescc)
   #:use-module (language c99 compiler)
-  #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 pretty-print)
+  #:use-module (ice-9 getopt-long)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:export (main))
 
 (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") "" "@PREFIX@"))
@@ -51,19 +52,76 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' guile/mescc.scm
 (module-define! (resolve-module '(language c99 compiler)) '%prefix %prefix)
 (module-define! (resolve-module '(language c99 compiler)) '%version %version)
 
-(define (main arguments)
-  (let* ((files (cdr arguments))
-         (file (if (null? files) (string-append %docdir "examples/main.c")
-                   (car files))))
-    (cond ((equal? file "--help")
-           (format (current-error-port) "Usage: mescc.scm [--help|--version|FILE] > a.out\n")
-           (exit 0))
-          ((equal? file "--version")
-           (format (current-error-port) "mescc.scm (mes) ~a\n" %version)
-           (exit 0)))
-    (format (current-error-port) "input: ~a\n" file)
+(define (parse-opts args)
+  (let* ((option-spec
+          '((c (single-char #\c))
+           (D (single-char #\D) (value #t))
+            (help (single-char #\h))
+           (I (single-char #\I) (value #t))
+           (o (single-char #\o) (value #t))
+           (version (single-char #\V) (value #t))))
+        (options (getopt-long args option-spec))
+        (help? (option-ref options 'help #f))
+        (files (option-ref options '() '()))
+        (usage? (and (not help?) (null? files)))
+         (version? (option-ref options 'version #f)))
+    (or
+     (and version?
+         (format (current-output-port) "mescc.scm (mes) ~a\n" %version))
+     (and (or help? usage?)
+          (format (or (and usage? (current-error-port)) (current-output-port)) "\
+Usage: mescc [OPTION]... FILE...
+  -c                 compile and assemble, but do not link
+  -D DEFINE          define DEFINE
+  -h, --help         display this help and exit
+  -I DIR             append DIR to include path
+  -o FILE            write output to FILE
+  -v, --version      display version and exit
+")
+          (exit (or (and usage? 2) 0)))
+     options)))
+
+(define (object->info file)
+  (let* ((string (with-input-from-file file read-string))
+         (module (resolve-module '(language c99 compiler))))
+    (eval-string string module)))
+
+(define (object->info file)
+  (let* ((lst (with-input-from-file file read))
+         (module (resolve-module '(language c99 compiler))))
+    (eval lst module)))
+
+(define (source->info defines includes)
+  (lambda (file)
     (with-input-from-file file
-      c99-input->elf)))
+      (lambda ()
+        ((c99-input->info #:defines defines #:includes includes))))))
 
-(format (current-error-port) "compiler loaded\n")
-(format (current-error-port) "calling ~s\n" (cons 'main (command-line)))
+(define (main args)
+  (let* ((options (parse-opts args))
+         (files (option-ref options '() '()))
+         (file (if (null? files) (string-append %docdir "examples/main.c")
+                   (car files)))
+         (compile? (option-ref options 'c #f))
+         (sources (filter (cut string-suffix? ".c" <>) files))
+         (objects (filter (negate (cut string-suffix? ".c" <>)) files))
+         (base (substring file (1+ (or (string-rindex file #\/) -1)) (- (string-length file) 2)))
+         (out (option-ref options 'o (if compile? (string-append base ".o") "a.out")))
+         (multi-opt (lambda (option) (lambda (o) (and (eq? (car o) option) (cdr o)))))
+         (defines (reverse (filter-map (multi-opt 'D) options)))
+         (includes (reverse (filter-map (multi-opt 'I) options))))
+    (when (getenv "MES_DEBUG") (format (current-error-port) "options=~s\n" options)
+          (format (current-error-port) "output: ~a\n" out))
+    (if (and (pair? sources) (pair? objects)) (error "cannot mix source and object files:" files))
+    (format (current-error-port) "inputs: ~a\n" files)
+    (with-output-to-file out
+      (lambda ()
+        (set-port-encoding! (current-output-port) "ISO-8859-1")
+        (if (pair? objects) (let ((infos (map object->info objects)))
+                              (if compile? (infos->object infos)
+                                  (infos->elf infos)))
+            (let ((infos (map (source->info defines includes) sources)))
+              (if compile? (infos->object infos)
+                  (infos->elf infos))))))
+    (if (not compile?)
+        (chmod out #o755))))
index 485f156a86b65187714705ab0cb942e74786b206..e0f84ea34d69851ff4cb273e282cd205a701e3a2 100644 (file)
@@ -5,6 +5,6 @@ $(OUT)/$(TARGET): $(INSTALL_GO_FILES)
 $(OUT)/$(TARGET): $(C_FILES)
        @echo " mescc.scm       $(notdir $<) -> $(notdir $@)"
        @rm -f $@
-       $(QUIET) INCLUDES=$(C_INCLUDE_PATH) guile/mescc.scm $< > $@ || rm -f $@
+       $(QUIET) guile/mescc.scm $(C_INCLUDE_PATH:%=-I %) -o $@ $< || rm -f $@
        @[ -f $@ ] && chmod +x $@ ||:
 include make/reset.make
index 49d754bb2dbacef752dbb1d40d996b8a1dfc1d9d..848217d740d58c0fffdcf205bc4ad3d8d328d6ea 100644 (file)
@@ -2,6 +2,7 @@ CLEAN+=$(OUT)/$(TARGET)
 ifneq ($(MES_MAX_ARENA),)
 $(OUT)/$(TARGET): MES_MAX_ARENA-flag:=MES_MAX_ARENA=$(MES_MAX_ARENA)
 endif
+$(OUT)/$(TARGET): C_INCLUDE_PATH:=$(INCLUDES)
 $(OUT)/$(TARGET): $(MAKEFILE_LIST)
 $(OUT)/$(TARGET): module/mes/read-0.mo
 $(OUT)/$(TARGET): module/mes/read-0-32.mo
@@ -10,6 +11,6 @@ $(OUT)/$(TARGET): scripts/mes
 $(OUT)/$(TARGET): $(C_FILES)
        @echo " mescc.mes       $(notdir $<) -> $(notdir $@)"
        @rm -f $@
-       $(QUIET)MES_DEBUG=$(MES_DEBUG) $(MES_MAX_ARENA-flag) MES_FLAGS=--load scripts/mescc.mes $< > $@ || rm -f $@
+       $(QUIET)MES_DEBUG=$(MES_DEBUG) $(MES_MAX_ARENA-flag) MES_FLAGS=--load scripts/mescc.mes $(C_INCLUDE_PATH:%=-I %) -o $@ $< || rm -f $@
        @[ -f $@ ] && chmod +x $@ ||:
 include make/reset.make
index e461004fdba4b8602db028d9c4e47526957f5b69..1bd8f1a118ad6be09a2c169577b5e5f4b0acd5fb 100644 (file)
@@ -54,9 +54,9 @@
 
 (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"
@@ -81,6 +81,7 @@
                 ,(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))))
index a99cfbc4bfa8704ed843c0ab007f9313ee15dbbb..569beb44c475abde28a333dcdb3d9eddcae747e3 100644 (file)
   #:use-module (mes elf)
   #:use-module (mes elf-util)
   #:use-module (mes as-i386)
-  #:use-module (mes libc-i386)
-  #:use-module (mes libc)
   #:use-module (nyacc lang c99 parser)
   #:export (c99-input->ast
             c99-input->elf
             c99-input->info
-            info->elf))
+            c99-input->object
+            infos->object
+            info->elf
+            infos->elf
+            object->elf))
 
 (cond-expand
  (guile-2)
index 1af8b21128fb5e558cbe85feed8310f13da98e28..5dfd2ecd7c07faf13228814714b2ad0f7386dd90 100644 (file)
@@ -46,7 +46,7 @@
         ((char? o) (number->string (char->integer o) 16))))
 
 (define (functions->lambdas functions)
-  (append-map cdr functions))
+  (append-map (lambda (f) (or (cdr f) '())) functions))
 
 (define (lambda/label->list f g ta t d)
   (lambda (l/l)
 (define data-offset
   (let ((cache '()))
     (lambda (name globals)
-      (or (assoc-ref cache name)
+      (or ;;(assoc-ref cache name)
           (let* ((prefix (member name (reverse globals)
                                  (lambda (a b)
                                    (equal? (car b) name)))))
index 5b914ca09081e3f705243f3092794193659db3fa..20f4c6c0bbeb9d999d77a11c55e34090b9f0172e 100644 (file)
     (define (symbol->table-entry o)
       (let* ((name (car o))
              (offset (function-offset name functions))
-             (len (length (text->list (cddr o))))
+             (len (if (not (cdr o)) 0 (length (text->list (cddr o)))))
              (str (append-map (lambda (x) (cons 0 (string->list x))) (cdr (member name (reverse (map car functions))))))
              (i (1+ (length str))))
         (symbol-table-entry i (+ vaddress text-offset offset) len stt-func 0 1)))
index 6f72f54b1cf6dcc84973131d202b8804227ce43a..2f2ccac538761169d563bfd34396abf903b6105e 100644 (file)
 
 ;;; Code:
 
-(define (i386:exit f g ta t d)
-  '(
-    #x5b                                ; pop    %ebx
-    #x5b                                ; pop    %ebx
-    #xb8 #x01 #x00 #x00 #x00            ; mov    $0x1,%eax
-    #xcd #x80                           ; int    $0x80
-    ))
-
-(define (i386:read f g ta t d)
-  '(
-    #x55                                ; push   %ebp
-    #x89 #xe5                           ; mov    %esp,%ebp
-
-    #x8b #x5d #x08                      ; mov    0x8(%ebp),%ebx
-    #x8b #x4d #x0c                      ; mov    0xc(%ebp),%ecx
-    #x8b #x55 #x10                      ; mov    0x10(%ebp),%edx
-
-    #xb8 #x03 #x00 #x00 #x00            ; mov    $0x3,%eax
-    #xcd #x80                           ; int    $0x80
-
-    #xc9                                ; leave
-    #xc3                                ; ret
-    ))
-
-(define (i386:write f g ta t d)
-  '(
-    #x55                                ; push   %ebp
-    #x89 #xe5                           ; mov    %esp,%ebp
-
-    #x8b #x5d #x08                      ; mov    0x8(%ebp),%ebx
-    #x8b #x4d #x0c                      ; mov    0xc(%ebp),%ecx
-    #x8b #x55 #x10                      ; mov    0x10(%ebp),%edx
-
-    #xb8 #x04 #x00 #x00 #x00            ; mov    $0x4,%eax
-    #xcd #x80                           ; int    $0x80
-
-    #xc9                                ; leave
-    #xc3                                ; ret
-    ))
-
-(define (i386:open f g ta t d)
-  '(
-    #x55                                ; push   %ebp
-    #x89 #xe5                           ; mov    %esp,%ebp
-
-    #x8b #x5d #x08                      ; mov    0x8(%ebp),%ebx
-    #x8b #x4d #x0c                      ; mov    0xc(%ebp),%ecx
-    #x8b #x55 #x10                      ; mov    0x10(%ebp),%edx
-
-    #xb8 #x05 #x00 #x00 #x00            ; mov    $0x5,%eax
-    #xcd #x80                           ; int    $0x80
-
-    #xc9                                ; leave
-    #xc3                                ; ret
-    ))
-
-(define (i386:access f g ta t d)
-  '(
-    #x55                                ; push   %ebp
-    #x89 #xe5                           ; mov    %esp,%ebp
-
-    #x8b #x5d #x08                      ; mov    0x8(%ebp),%ebx
-    #x8b #x4d #x0c                      ; mov    0xc(%ebp),%ecx
-
-    #xb8 #x21 #x00 #x00 #x00            ; mov    $0x21,%eax
-    #xcd #x80                           ; int    $0x80
-
-    #xc9                                ; leave
-    #xc3                                ; ret
-    ))
-
-(define (i386:brk f g ta t d)
-  '(
-    #x55                                ; push   %ebp
-    #x89 #xe5                           ; mov    %esp,%ebp
-
-    #x8b #x5d #x08                      ; mov    0x8(%ebp),%ebx
-    #xb8 #x2d #x00 #x00 #x00            ; mov    $0x2d,%eax
-    #xcd #x80                           ; int    $0x80
-
-    #xc9                                ; leave
-    #xc3                                ; ret
-    ))
-
-(define (i386:fsync f g ta t d)
-  '(
-    #x55                                ; push   %ebp
-    #x89 #xe5                           ; mov    %esp,%ebp
-
-    #x8b #x5d #x08                      ; mov    0x8(%ebp),%ebx
-    #xb8 #x76 #x00 #x00 #x00            ; mov    $0x76,%eax
-    #xcd #x80                           ; int    $0x80
-
-    #xc9                                ; leave
-    #xc3                                ; ret
-    ))
+(define i386:exit
+  '(lambda (f g ta t d)
+     (list
+      #x5b                                ; pop    %ebx
+      #x5b                                ; pop    %ebx
+      #xb8 #x01 #x00 #x00 #x00            ; mov    $0x1,%eax
+      #xcd #x80                           ; int    $0x80
+      )))
+
+(define i386:read
+  '(lambda (f g ta t d)
+     (list
+      #x55                                ; push   %ebp
+      #x89 #xe5                           ; mov    %esp,%ebp
+
+      #x8b #x5d #x08                      ; mov    0x8(%ebp),%ebx
+      #x8b #x4d #x0c                      ; mov    0xc(%ebp),%ecx
+      #x8b #x55 #x10                      ; mov    0x10(%ebp),%edx
+
+      #xb8 #x03 #x00 #x00 #x00            ; mov    $0x3,%eax
+      #xcd #x80                           ; int    $0x80
+
+      #xc9                                ; leave
+      #xc3                                ; ret
+      )))
+
+(define i386:write
+  '(lambda (f g ta t d)
+   (list
+     #x55                                ; push   %ebp
+     #x89 #xe5                           ; mov    %esp,%ebp
+
+     #x8b #x5d #x08                      ; mov    0x8(%ebp),%ebx
+     #x8b #x4d #x0c                      ; mov    0xc(%ebp),%ecx
+     #x8b #x55 #x10                      ; mov    0x10(%ebp),%edx
+
+     #xb8 #x04 #x00 #x00 #x00            ; mov    $0x4,%eax
+     #xcd #x80                           ; int    $0x80
+
+     #xc9                                ; leave
+     #xc3                                ; ret
+     )))
+
+(define i386:open
+  '(lambda (f g ta t d)
+     (list
+      #x55                                ; push   %ebp
+      #x89 #xe5                           ; mov    %esp,%ebp
+
+      #x8b #x5d #x08                      ; mov    0x8(%ebp),%ebx
+      #x8b #x4d #x0c                      ; mov    0xc(%ebp),%ecx
+      #x8b #x55 #x10                      ; mov    0x10(%ebp),%edx
+
+      #xb8 #x05 #x00 #x00 #x00            ; mov    $0x5,%eax
+      #xcd #x80                           ; int    $0x80
+
+      #xc9                                ; leave
+      #xc3                                ; ret
+      )))
+
+(define i386:access
+  '(lambda (f g ta t d)
+    (list
+      #x55                                ; push   %ebp
+      #x89 #xe5                           ; mov    %esp,%ebp
+
+      #x8b #x5d #x08                      ; mov    0x8(%ebp),%ebx
+      #x8b #x4d #x0c                      ; mov    0xc(%ebp),%ecx
+
+      #xb8 #x21 #x00 #x00 #x00            ; mov    $0x21,%eax
+      #xcd #x80                           ; int    $0x80
+
+      #xc9                                ; leave
+      #xc3                                ; ret
+      )))
+
+(define i386:brk
+  '(lambda (f g ta t d)
+     (list
+      #x55                                ; push   %ebp
+      #x89 #xe5                           ; mov    %esp,%ebp
+
+      #x8b #x5d #x08                      ; mov    0x8(%ebp),%ebx
+      #xb8 #x2d #x00 #x00 #x00            ; mov    $0x2d,%eax
+      #xcd #x80                           ; int    $0x80
+
+      #xc9                                ; leave
+      #xc3                                ; ret
+      )))
+
+(define i386:fsync
+  '(lambda (f g ta t d)
+     (list
+      #x55                                ; push   %ebp
+      #x89 #xe5                           ; mov    %esp,%ebp
+
+      #x8b #x5d #x08                      ; mov    0x8(%ebp),%ebx
+      #xb8 #x76 #x00 #x00 #x00            ; mov    $0x76,%eax
+      #xcd #x80                           ; int    $0x80
+
+      #xc9                                ; leave
+      #xc3                                ; ret
+      )))
 
 (define (i386:_start)
- (string-append ".byte"
 (string-append ".byte"
                 " 0x89 0xe8"      ; mov    %ebp,%eax
                 " 0x83 0xc0 0x08" ; add    $0x8,%eax
                 " 0x50"           ; push   %eax
index 23f4f03203b075b5e6b480a1138df9693244ab55..33b89e5c2ae3d45570112955dbfcfc8ddef5ed80 100755 (executable)
@@ -37,17 +37,11 @@ exit $r
 ;;(mes-use-module (language c compiler))
 ;;Nyacc
 
-(let* ((files (cddr (command-line)))
-       (file (if (pair? files) (car files))))
-    (cond ((equal? file "--help")
-           (format (current-error-port) "Usage: mescc.mes [--help|--version|FILE] > a.out\n")
-           (exit 0))
-          ((equal? file "--version")
-           (format (current-error-port) "mescc.mes (mes) ~a\n" %version)
-           (exit 0))))
-
 (mes-use-module (mes guile))
+(mes-use-module (mes getopt-long))
 (mes-use-module (language c99 compiler))
+(mes-use-module (srfi srfi-1))
+(mes-use-module (srfi srfi-26))
 
 (format (current-error-port) "mescc.mes...\n")
 
@@ -57,17 +51,76 @@ exit $r
 (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") "" "@PREFIX@"))
 (define %version (if (string-prefix? "@VERSION" "@VERSION@") "git" "@VERSION@"))
 
-(define (main arguments)
-  (let* ((mfiles (cddr arguments))
-         (mfiles (if (or (null? mfiles) (not (equal? (car mfiles) "--"))) mfiles
-                     (cdr mfiles)))
-         (mfile (if (null? mfiles) (string-append %docdir "examples/main.c")
-                    (car mfiles))))
-    (format (current-error-port) "input: ~a\n" mfile)
-    (with-input-from-file mfile
-      c99-input->elf)))
+(define (parse-opts args)
+  (let* ((option-spec
+          '((c (single-char #\c))
+           (D (single-char #\D) (value #t))
+            (help (single-char #\h))
+           (I (single-char #\I) (value #t))
+           (o (single-char #\o) (value #t))
+           (version (single-char #\V) (value #t))))
+        (options (getopt-long args option-spec))
+        (help? (option-ref options 'help #f))
+        (files (option-ref options '() '()))
+        (usage? (and (not help?) (null? files)))
+         (version? (option-ref options 'version #f)))
+    (or
+     (and version?
+         (format (current-output-port) "mescc.scm (mes) ~a\n" %version))
+     (and (or help? usage?)
+          (format (or (and usage? (current-error-port)) (current-output-port)) "\
+Usage: mescc [OPTION]... FILE...
+  -c                 compile and assemble, but do not link
+  -D DEFINE          define DEFINE
+  -h, --help         display this help and exit
+  -I DIR             append DIR to include path
+  -o FILE            write output to FILE
+  -v, --version      display version and exit
+")
+          (exit (or (and usage? 2) 0)))
+     options)))
+
+(define (object->info file)
+  (let* ((string (with-input-from-file file read-string))
+         (module (resolve-module '(language c99 compiler))))
+    (eval-string string module)))
+
+(define (object->info file)
+  (let* ((lst (with-input-from-file file read)))
+    (primitive-eval lst)))
+
+(define (source->info defines includes)
+  (lambda (file)
+    (with-input-from-file file
+      (lambda ()
+        ((c99-input->info #:defines defines #:includes includes))))))
+
+(define (main args)
+  (let* ((args (cons* (car args) (cdr (member "--" args))))
+         (options (parse-opts args))
+         (files (option-ref options '() '()))
+         (file (if (null? files) (string-append %docdir "examples/main.c")
+                   (car files)))
+         (compile? (option-ref options 'c #f))
+         (sources (filter (cut string-suffix? ".c" <>) files))
+         (objects (filter (negate (cut string-suffix? ".c" <>)) files))
+         (base (substring file (1+ (or (string-rindex file #\/) -1)) (- (string-length file) 2)))
+         (out (option-ref options 'o (if compile? (string-append base ".o") "a.out")))
+         (multi-opt (lambda (option) (lambda (o) (and (eq? (car o) option) (cdr o)))))
+         (defines (reverse (filter-map (multi-opt 'D) options)))
+         (includes (reverse (filter-map (multi-opt 'I) options))))
+    (when (getenv "MES_DEBUG") (format (current-error-port) "options=~s\n" options)
+          (format (current-error-port) "output: ~a\n" out))
+    (if (and (pair? sources) (pair? objects)) (error "cannot mix source and object files:" files))
+    (format (current-error-port) "inputs: ~a\n" files)
+    (with-output-to-port (open-output-file out (if compile? S_IRWXU))
+      (lambda ()
+        (if (pair? objects) (let ((infos (map object->info objects)))
+                              (if compile? (infos->object infos)
+                                  (infos->elf infos)))
+            (let ((infos (map (source->info defines includes) sources)))
+              (if compile? (infos->object infos)
+                  (infos->elf infos))))))))
 
-(format (current-error-port) "compiler loaded\n")
-(format (current-error-port) "calling ~s\n" (cons 'main (command-line)))
 (main (command-line))
 ()