mescc: Write object files in hex2 or hex3 format.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sun, 11 Jun 2017 11:11:40 +0000 (13:11 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sun, 11 Jun 2017 11:11:40 +0000 (13:11 +0200)
* stage0/elf32.hex2: New file.
* module/mes/hex2.mes: New file.
* module/mes/hex2.scm: New file.
* module/language/c99/compiler.mes: Eradicate object lamdas.
  (current-eval, dec-xhex, function:-object->text, object->elf,
  object->objects, merge-objects, alist-add): Remove.
* module/mes/elf.mes (object->elf): New function, move from compiler.mes.
* module/mes/elf.scm: Export it.
* guile/mescc.scm (parse-opts): Add -g.
  (main): Use it.
* scripts/mescc.mes: Likewise.
* scripts/mescc-guile.make (MESCC.scm, MESLD.scm): Add -g flag.
* scripts/mescc-mes.make (MESCC.mes, MESLD.mes): Likewise.
* scaffold/m.c: Add proper includes.
* scaffold/argv.c: New file.
* scaffold/hello.c: Simplify.
* scaffold/micro-mes.c: Add proper includes.
* scaffold/t.c: Add proper includes.

20 files changed:
guile/mescc.scm
make/mescc-guile.make
make/mescc-mes.make
module/language/c99/compiler.mes
module/language/c99/compiler.scm
module/mes/as-i386.mes
module/mes/as-i386.scm
module/mes/elf-util.mes
module/mes/elf-util.scm
module/mes/elf.mes
module/mes/elf.scm
module/mes/hex2.mes [new file with mode: 0644]
module/mes/hex2.scm [new file with mode: 0644]
scaffold/argv.c [new file with mode: 0644]
scaffold/hello.c
scaffold/m.c
scaffold/micro-mes.c
scaffold/t.c
scripts/mescc.mes
stage0/elf32.hex2 [new file with mode: 0644]

index fb6be718a17efd4444812c9386effb3be3f6182c..a00f349d4f0a4f47e57608ff231b086b07bb9c05 100755 (executable)
@@ -36,6 +36,8 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' guile/mescc.scm
 
 (define-module (mescc)
   #:use-module (language c99 compiler)
+  #:use-module (mes elf)
+  #:use-module (mes hex2)
   #:use-module (ice-9 getopt-long)
   #:use-module (ice-9 pretty-print)
   #:use-module (srfi srfi-1)
@@ -58,6 +60,7 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' guile/mescc.scm
           '((c (single-char #\c))
             (D (single-char #\D) (value #t))
             (E (single-char #\E))
+            (g (single-char #\g))
             (help (single-char #\h))
             (I (single-char #\I) (value #t))
             (o (single-char #\o) (value #t))
@@ -72,10 +75,11 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' guile/mescc.scm
           (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...
+Usage: mescc.scm [OPTION]... FILE...
   -c                 compile and assemble, but do not link
   -D DEFINE          define DEFINE
   -E                 preprocess only; do not compile, assemble or link
+  -g                 add debug info [GDB, objdump] using hex3 format
   -h, --help         display this help and exit
   -I DIR             append DIR to include path
   -o FILE            write output to FILE
@@ -84,10 +88,10 @@ Usage: mescc [OPTION]... FILE...
           (exit (or (and usage? 2) 0)))
      options)))
 
-(define (object->info file)
-  (let* ((lst (with-input-from-file file read))
-         (module (resolve-module '(language c99 compiler))))
-    (eval lst module)))
+(define (read-object file)
+  (let ((char (with-input-from-file file read-char)))
+    (if (eq? char #\#) (error "hex2 format not supported:" file)))
+  (with-input-from-file file read))
 
 (define (main:ast->info file)
   (let ((ast (with-input-from-file file read)))
@@ -122,6 +126,7 @@ Usage: mescc [OPTION]... FILE...
                    (car files)))
          (preprocess? (option-ref options 'E #f))
          (compile? (option-ref options 'c #f))
+         (debug-info? (option-ref options 'g #f))
          (asts (filter ast? files))
          (objects (filter object? files))
          (sources (filter (cut string-suffix? ".c" <>) files))
@@ -131,7 +136,8 @@ Usage: mescc [OPTION]... FILE...
                                            (else "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))))
+         (includes (reverse (filter-map (multi-opt 'I) options)))
+         (objects->hex (if debug-info? objects->hex3 objects->hex2)))
     (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))
@@ -139,16 +145,18 @@ Usage: mescc [OPTION]... FILE...
       (lambda ()
         (if (and (not compile?)
                  (not preprocess?)) (set-port-encoding! (current-output-port) "ISO-8859-1"))
-        (cond ((pair? objects) (let ((infos (map object->info objects)))
-                                 (if compile? (infos->object infos)
-                                     (infos->elf infos))))
-              ((pair? asts) (let ((infos (map main:ast->info asts)))
-                              (if compile? (infos->object infos)
-                                  (infos->elf infos))))
+        (cond ((pair? objects) (let ((objects (map read-object objects)))
+                                 (if compile? (objects->hex objects)
+                                     (objects->elf objects))))
+              ((pair? asts) (let* ((infos (map main:ast->info asts))
+                                   (objects (map info->object infos)))
+                              (if compile? (objects->hex objects)
+                                  (objects->elf objects))))
               ((pair? sources) (if preprocess? (map (source->ast defines includes) sources)
-                                   (let ((infos (map (source->info defines includes) sources)))
-                                     (if compile? (infos->object infos)
-                                         (infos->elf infos))))))))
+                                   (let* ((infos (map (source->info defines includes) sources))
+                                          (objects (map info->object infos)))
+                                     (if compile? (objects->hex objects)
+                                         (objects->elf objects))))))))
     (if (and (not compile?)
              (not preprocess?))
         (chmod out #o755))))
index 76aa21d431a563ed835fdbc9f17a535c5597a35b..74e393f3800a83d942b2a7ee83957257782a059b 100644 (file)
@@ -15,8 +15,8 @@ CLEAN+=$(O_FILES) $(OUT)/$(TARGET)
 CLEAN+=$(OUT)/$(TARGET)
 
 INCLUDES+=mlibc/include mlibc $(OUT)/$(DIR)
-MESCC.scm:=guile/mescc.scm
-MESLD.scm:=guile/mescc.scm
+MESCC.scm:=guile/mescc.scm -g
+MESLD.scm:=guile/mescc.scm -g
 
 $(OUT)/$(TARGET): ld:=MESLD.scm
 $(OUT)/$(TARGET): LD:=$(MESLD.scm)
index 6f182f165ae75a10d4b4bacb546f9dc16581d9df..c55bd842a01609dcf8732cac0cf76914ff186328 100644 (file)
@@ -14,8 +14,8 @@ CLEAN+=$(O_FILES) $(OUT)/$(TARGET)
 CLEAN+=$(OUT)/$(TARGET)
 
 INCLUDES+=mlibc/include mlibc $(OUT)/$(DIR)
-MESCC.mes:=scripts/mescc.mes
-MESLD.mes:=scripts/mescc.mes
+MESCC.mes:=scripts/mescc.mes -g
+MESLD.mes:=scripts/mescc.mes -g
 
 $(OUT)/$(TARGET): ld:=MESLD.mes
 $(OUT)/$(TARGET): LD:=$(MESLD.mes)
index 979c1b8bba41b75df99749da1e93b56574303512..e37c17d8bf254c98eeab59f16396815ae0414a52 100644 (file)
 ;;; Code:
 
 (cond-expand
- (guile-2
-  (set-port-encoding! (current-output-port) "ISO-8859-1"))
+ (guile-2)
  (guile)
  (mes
   (mes-use-module (srfi srfi-26))
   (mes-use-module (mes pmatch))
   (mes-use-module (nyacc lang c99 parser))
+  (mes-use-module (nyacc lang c99 pprint))
   (mes-use-module (mes elf-util))
-  (mes-use-module (mes elf))
   (mes-use-module (mes as-i386))
+  (mes-use-module (mes hex2))
   (mes-use-module (mes optargs))))
 
 (define (logf port string . rest)
 (define <constants> '<constants>)
 (define <functions> '<functions>)
 (define <globals> '<globals>)
-(define <init> '<init>)
 (define <locals> '<locals>)
 (define <function> '<function>)
 (define <text> '<text>)
 (define <break> '<break>)
 
-(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (init '()) (locals '()) (function #f) (text '()) (break '()))
+(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (function #f) (text '()) (break '()))
   (pmatch o
     (<info> (list <info>
                   (cons <types> types)
                   (cons <constants> constants)
                   (cons <functions> functions)
                   (cons <globals> globals)
-                  (cons <init> init)
                   (cons <locals> locals)
                   (cons <function> function)
                   (cons <text> text)
   (pmatch o
     ((<info> . ,alist) (assq-ref alist <globals>))))
 
-(define (.init o)
-  (pmatch o
-    ((<info> . ,alist) (assq-ref alist <init>))))
-
 (define (.locals o)
   (pmatch o
     ((<info> . ,alist) (assq-ref alist <locals>))))
                (constants (.constants o))
                (functions (.functions o))
                (globals (.globals o))
-               (init (.init o))
                (locals (.locals o))
                (function (.function o))
                (text (.text o))
                           (constants constants)
                           (functions functions)
                           (globals globals)
-                          (init init)
                           (locals locals)
                           (function function)
                           (text text)
                           (break break))
-                         (make <info> #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text #:break break))))))
+                         (make <info> #:types types #:constants constants #:functions functions #:globals globals  #:locals locals #:function function #:text text #:break break))))))
 
 (define (push-global globals)
   (lambda (o)
-    (list
-     `(lambda (f g ta t d)
-        (i386:push-global (+ (data-offset ,o g) d))))))
+    (list (i386:push-label-mem o))))
 
 (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))))))
+    (list (i386:push-label o))))
 
 (define (push-local-address locals)
   (lambda (o)
   (make-global (add-s:-prefix (number->string value)) "int" 0 (int->bv32 value)))
 
 (define (ident->global name type pointer value)
-  (make-global name type pointer (int->bv32 value)))
+  (make-global name type pointer (if (pair? value) value (int->bv32 value))))
 
 (define (make-local name type pointer id)
   (cons name (list type pointer id)))
                   (if constant
                       (wrap-as (append (i386:value->accu constant)
                                        (i386:push-accu)))
-                      (error "TODO:push-function: " o)))))))))
+                      ((push-global-address #f) `(address ,o))))))))))
 
 (define (push-ident-address info)
   (lambda (o)
     (let ((local (assoc-ref (.locals info) o)))
       (if local ((push-local-address (.locals info)) local)
-          ((push-global-address (.globals info)) o)))))
+          (let ((global (assoc-ref (.globals info) o)))
+          (if global
+              ((push-global-address (.globals info)) o)
+              ((push-global-address #f) `(address ,o))))))))
 
 (define (push-ident-de-ref info)
   (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 (i386:label->accu o)))
+                  ((1) (list (i386:label-mem->accu o)))
+                  ((2) (list (i386:label->accu o)))
+                  (else (list (i386:label-mem->accu o)))))
               (if constant (wrap-as (i386:value->accu constant))
-                  (list `(lambda (f g ta t d)
-                           (i386:global->accu (+ ta (function-offset ,o f)))))))))))
+                  (list (i386:label->accu `(address ,o)))))))))
 
 (define (ident-address->accu info)
   (lambda (o)
     (let ((local (assoc-ref (.locals info) o))
           (global (assoc-ref (.globals info) o))
           (constant (assoc-ref (.constants info) o)))
-      (if local
-          (let* ((ptr (local:pointer local))
-                 (type (ident->type info o))
-                 (size (if (= ptr 1) (type->size info type)
-                           4)))
-            ;;(stderr "ident->accu ~a => ~a\n" o ptr)
+      (if local (let* ((ptr (local:pointer local))
+                       (type (ident->type info o))
+                       (size (if (= ptr 1) (type->size info type)
+                                 4)))
             (wrap-as (i386:local-ptr->accu (local:id local))))
-          (if global
-              (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))))))))))
+          (if global (list (i386:label->accu o))
+              (list (i386:label->accu `(address ,o))))))))
 
 (define (ident-address->base info)
   (lambda (o)
                  (size (if (= ptr 1) (type->size info type)
                            4)))
             (wrap-as (i386:local-ptr->base (local:id local))))
-          (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)))))
-                  (else (list `(lambda (f g ta t d)
-                                (append (i386:value->base (+ (data-offset ,o g) d))))))))
-              (error "TODO ident-address->base" o))))))
+          (if global (list (i386:label->base o))
+              (list (i386:label->accu `(address ,o))))))))
 
 (define (value->accu v)
   (wrap-as (i386:value->accu v)))
 (define (accu->ident info)
   (lambda (o)
     (let ((local (assoc-ref (.locals info) o)))
-      (if local
-          (let ((ptr (local:pointer local)))
-            (case ptr
-              (else (wrap-as (i386:accu->local (local:id local))))))
+      (if local (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 (i386:accu->label o)))))))
 
 (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 (i386:base->label o))))))
 
 (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 (i386:value->label o 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 (i386:label-mem-add o 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)
-                  (append (i386:push-accu)
-                          (i386:global->accu (+ (data-offset ,o g) d))
-                          (i386:accu-mem-add ,n)
-                          (i386:pop-accu))))))))
+          (list (wrap-as (append (i386:push-accu)
+                                 (i386:label->accu o)
+                                 (i386:accu-mem-add n)
+                                 (i386:pop-accu))))))))
 
 ;; FIXME: see ident->accu
 (define (ident->base info)
             (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 (i386:label->base o)))
+                    ((2) (list (i386:label->base o)))
+                    (else (list (i386:label-mem->base o)))))
                 (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 (i386:label->base `(address ,o)))))))))))
 
 (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) g) d)))))))
+           (append-text info (list (i386:label->accu (add-s:-prefix string))))))
 
         ((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)) g) d))))))
+         (append-text info (list (i386:label->accu (add-s:-prefix (apply string-append strings))))))
         ((p-expr (fixed ,value))
          (append-text info (value->accu (cstring->number value))))
 
                                  (if (null? expressions) info
                                      (loop (cdr expressions) ((expr->arg info) (car expressions))))))
                     (n (length expr-list)))
-               (if (and (not (assoc-ref locals name))
-                        (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))))
+               (if (not (assoc-ref locals name))
+                   (begin
+                     (if (and (not (assoc name (.functions info)))
+                              (not (assoc name globals)))
+                         (stderr "warning: undeclared function: ~a\n" name))
+                     (append-text args-info (list (i386:call-label name 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 (i386:call-accu 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 (i386:call-accu n))))))
 
         ((cond-expr . ,cond-expr)
          ((ast->info info) `(expr-stmt ,o)))
                      (ptr (ident->pointer info array))
                      (size (if (> ptr 1) 4 1)))
                 (append-text info (append (wrap-as (i386:accu->base))
-                                          ((base->ident-address info) array)
-                                          (i386:base->accu)))))
+                                          ((base->ident-address info) array)))))
              ((array-ref ,index (d-sel (ident ,field) (p-expr (ident ,struct))))
               (let* ((info (append-text info (wrap-as (i386:push-accu))))
                      (info ((expr->accu* info) a))
              ((array-ref ,index (p-expr (ident ,array)))
               (let* ((type (ident->type info array))
                      (size (type->size info type))
-                     (info (append-text info (wrap-as (append (i386:push-accu)))))
+                     (info (append-text info (wrap-as (i386:push-accu))))
                      (info ((expr->accu* info) a))
-                     (info (append-text info (wrap-as (append (i386:pop-base))))))
+                     (info (append-text info (wrap-as (i386:pop-base)))))
                 (append-text info
                              (append (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
                                          (if (<= size 4) (wrap-as (i386:base->accu-address))
 (define (append-text info text)
   (clone info #:text (append (.text info) text)))
 
-(define (wrap-as o)
-  (list `(lambda (f g ta t d) ,(cons 'list o))))
+(define (wrap-as o . annotation)
+  `(,@annotation ,o))
 
 (define (expr->accu* info)
   (lambda (o)
        (let* ((type (ident->type info array))
               (offset (field-offset info type field))
               (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
-         (append-text info (wrap-as (append (i386:accu+value offset))))))
+         (append-text info (wrap-as (i386:accu+value offset)))))
 
       ((d-sel (ident ,field) (p-expr (ident ,name)))
        (let* ((type (ident->type info name))
         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
         
         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
-         (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
-                                   (append-text info (wrap-as (asm->hex arg0))))
-             (let ((info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
-               (append-text info (wrap-as (i386:accu-zero?))))))
+         (let* ((source (with-output-to-string (lambda () (pretty-print-c99 o))))
+                (info (append-text info (wrap-as `(#:comment ,source)))))
+           (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
+                                     (append-text info (wrap-as (asm->hex arg0))))
+              (let ((info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
+                (append-text info (wrap-as (i386:accu-zero?)))))))
 
         ((if ,test ,body)
          (let* ((text-length (length text))
                   #:locals locals)))
 
         ((while ,test ,body)
-         (let* ((skip-info (lambda (body-length test-length)
+         (let* ((source (with-output-to-string (lambda () (pretty-print-c99 `(while ,test (ellipsis))))))
+                ;;(source (with-output-to-string (lambda () (pretty-print-c99 `(while ,test (compd-stmt (block-item-list)))))))
+                (skip-info (lambda (body-length test-length)
                              (clone info
                                     #:text (append text (wrap-as (i386:Xjump body-length)))
                                     #:break (cons (+ (length (object->list text)) body-length test-length
 
            (clone info #:text
                   (append
+                   (wrap-as `(#:comment ,source))
                    (.text body-info)
                    test-text
                    jump-text)
                   #:globals (.globals body-info))))
 
         ((labeled-stmt (ident ,label) ,statement)
-         (let ((info (append-text info (list label))))
+         (let ((info (append-text info `((#:label ,label)))))
            ((ast->info info) statement)))
 
         ((goto (ident ,label))
          (let* ((jump (lambda (n) (i386:XXjump n)))
                 (offset (+ (length (jump 0)) (length (object->list text)))))
-           (append-text info (append 
-                              (list `(lambda (f g ta t d)
-                                      (i386:XXjump (- (label-offset ,(.function info) ,label f) ,offset))))))))
+           (append-text info (list (i386:jump-label `(label ,label))))))
 
         ((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)
-                                          (append
-                                           (i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))
+                                  (list (i386:label->accu (add-s:-prefix string)))
                                   ((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)))
-               (clone info #:init
-                      (append
-                       (.init info)
-                       (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)))))))))))
+                    (global (make-global name type 1 (initzer->data `(initzer (p-expr (string ,string))))))
+                    (globals (append globals (list global))))
+               (clone info #:globals globals))))
         
         ;; char *p;
         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
              (let ((globals (append globals (list (ident->global name type 2 0)))))
                (clone info #:globals globals))))
 
-        ;; char **p = 0;
-        ;;((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (fixed ,value)))))))
-
         ;; char **p = g_environment;
         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (ident ,b)))))) ;; FIXME: initzer
          (if (.function info)
                (append-text info (append
                                   ((ident->accu info) b)
                                   ((accu->ident info) name))))
-             (let* ((globals (append globals (list (ident->global name type 2 0))))
-                    (value (assoc-ref constants b)))
-               (clone info
-                      #:globals globals
-                      #:init (append (.init info)
-                                     (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)))))))))))
+             (let* ((value (assoc-ref constants b))
+                    (global (ident->global name type 2 (initzer->data `(p-expr (fixed ,value)))))
+                    (globals (append globals (list global))))
+               (clone info #:globals globals))))
 
         ;; struct foo bar[2];
         ;; char arena[20000];
                   (append text
                           (.text accu)
                           ((accu->ident info) name)
-                          (list `(lambda (f g ta t d)
-                                  (append (i386:value->base ta)
-                                          (i386:accu+base)))))
+                          (wrap-as (append (i386:label->base '(address "_start"))
+                                           (i386:accu+base))))
                   #:locals locals)))
 
         ;; char *p = (char*)g_cells;
                     (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)))))
-               (clone info
-                      #:globals globals
-                      #:init (append (.init info)
-                                     (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)))))))))))
+             (let ((globals (append globals (list (ident->global name type 1 `(,value #f #f #f))))))
+               (clone info #:globals globals))))
 
         ;; 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)))))
-                 (clone info
-                        #:globals globals
-                        #:init (append (.init info)
-                                       (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))))))))))))
+               (let ((globals (append globals (list (ident->global name type 1 `(,value #f #f #f))))))
+                 (clone info #:globals globals)))))
 
         ;; enum foo { };
         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
                 (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)))
-                 (clone info #:init
-                        (append
-                         (.init info)
-                         (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))))))))))))
+               (let* (;;(global (make-global name type 2 (string->list (make-string size #\nul))))
+                      (global (make-global name type 2 (append-map initzer->data initzers)))
+                      (globals (append globals entries (list global))))
+                 (clone info #:globals globals)))))
 
         ;;
         ;; struct f = {...};
                                        (.text ((expr->accu empty) initzer))
                                        (wrap-as (i386:accu->base-address+n offset)))))))))
                (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)))
-                      (info (clone info #:globals globals)))
-                 (let loop ((fields fields) (initzers initzers) (info info))
-                   (if (null? fields) info
-                       (let ((offset (field-offset info type (caar fields)))
-                             (initzer (car initzers)))
-                         (loop (cdr fields) (cdr initzers)
-                               (clone info #:init
-                                      (append
-                                       (.init info)
-                                       (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 (car fields))))))))))))))))))
+                      (global (make-global name type 2 (append-map initzer->data initzers)))
+                      (globals (append globals (list global))))
+                 (clone info #:globals globals)))))
 
 
         ;;char cc = g_cells[c].cdr;  ==> generic?
                  (clone info #:text
                         (append (.text ((expr->accu info) initzer))
                                 ((accu->ident info) name))))
-               (let* ((globals (append globals (list (ident->global name type 1 0)))))
-                 (clone info
-                        #:globals globals
-                        #:init (append (.init info)
-                                       (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))))))))))))
-
+               (let* ((global (make-global name type 2 (initzer->data initzer)))
+                      (globals (append globals (list global))))
+                 (clone info #:globals globals)))))
 
         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
          (declare name))
          `(initzer (p-expr (fixed ,(number->string value))))))
       (_ o))))
 
-(define (initzer->data f g ta t d o)
+(define (initzer->data 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 f))))
-    ((initzer (p-expr (string ,string)))
-     (int->bv32 (+ (data-offset (add-s:-prefix string) g) d)))
+    ((initzer (ref-to (p-expr (ident ,name)))) `(,name #f #f #f))
+    ((initzer (p-expr (string ,string))) `(,(add-s:-prefix string) #f #f #f))
     (_ (error "initzer->data: unsupported: " o))))
 
 (define (.formals o)
       (if (null? elements) info
           (loop (cdr elements) ((ast->info info) (car elements)))))))
 
-(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"))
+  (apply append (filter (lambda (x) (and (pair? x) (not (member (car x) '(#:comment #:label))))) object)))
 
 (define* (c99-input->info #:key (defines '()) (includes '()))
   (lambda ()
            (info (clone info #:text '() #:locals '())))
       info)))
 
-(define (write-any x)
-  (write-char (cond ((char? x) x)
-                    ((and (number? x) (< (+ x 256) 0))
-                     (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
-                    ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
-                    ((procedure? x)
-                     (stderr "write-any: proc: ~a\n" x)
-                     (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
-                     (error "procedure: write-any:" x))
-                    (else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
-
-(define (info->elf info)
-  (display "dumping elf\n" (current-error-port))
-  (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* (info->object o)
+  `((functions . ,(.functions o))
+    (globals . ,(map (lambda (g) (cons (car g) (global:value (cdr g)))) (.globals o)))))
 
 (define* (c99-ast->info ast)
   ((ast->info (make <info> #:types i386:type-alist)) ast))
 
 (define* (c99-input->elf #:key (defines '()) (includes '()))
-  ((compose info->elf info:object->text (c99-input->info #:defines defines #:includes includes))))
+  ((compose object->elf info->object (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 (car f) b-keys)))) a))
-         (a-keys (map car a)))
-    (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
+  ((compose write-hex3 info->object (c99-input->info #:defines defines #:includes includes))))
index 32dd3df988cefbcc908fd2d9cbd35b578111f972..a62de5aeea1e926742eadfc259f517dac808abd1 100644 (file)
   #:use-module (system base pmatch)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 pretty-print)
-  #:use-module (mes elf)
   #:use-module (mes elf-util)
+  #:use-module (mes elf)
   #:use-module (mes as-i386)
+  #:use-module (mes hex2)
   #:use-module (nyacc lang c99 parser)
+  #:use-module (nyacc lang c99 pprint)
   #:export (c99-ast->info
             c99-input->ast
             c99-input->elf
             c99-input->info
             c99-input->object
-            infos->object
-            info->elf
-            infos->elf
-            object->elf))
+            info->object))
 
 (cond-expand
  (guile-2)
index 20432bc754008e8fec8e226c95d93391c73c0394..b2f8065f1bbdc1b194ad554aa8ef9214e4b9c2eb 100644 (file)
@@ -28,7 +28,7 @@
  (guile-2)
  (guile)
  (mes
-  (mes-use-module (mes elf))))
+  (mes-use-module (mes elf-util))))
 
 (define (i386:function-preamble)
   '(#x55                                ; push   %ebp
 (define (i386:function-locals)
   '(#x83 #xec #x40))              ; sub    $0x10,%esp -- 16 local vars
 
-(define (i386:push-global-address o)
-  (or o (error "invalid value: push-global-address: " o))
-  `(#x68 ,@(int->bv32 o)))              ; push  $0x<o>
+(define (i386:push-label label)
+  `(#x68 ,label #f #f #F))              ; push  $0x<o>
 
-(define (i386:push-global o)
-  (or o (error "invalid value: push-global: " o))
-  `(#xa1 ,@(int->bv32 o)                ; mov    0x804a000,%eax
+(define (i386:push-label-mem label)
+  `(#xa1 ,label #f #f #f                ; mov    0x804a000,%eax
          #x50))                         ; push  %eax
 
 (define (i386:push-local n)
   (or n (error "invalid value: base->local: " n))
   `(#x89 #x55 ,(- 0 (* 4 n))))          ; mov    %edx,-<0xn>(%ebp)
 
-(define (i386:base->global n)
-  (or n (error "invalid value: base->global: " n))
-  `(#x89 #x15 ,@(int->bv32 n)))         ; mov    %edx,0x0
-
-(define (i386:accu->global n)
-  (or n (error "invalid value: accu->global: " n))
-  `(#xa3 ,@(int->bv32 n)))              ; mov    %eax,0x0
-
-(define (i386:accu->global-address n)
-  (or n (error "invalid value: accu->global-address: " n))
-  `(#x8b #x15 ,@(int->bv32 n)           ; mov    0x<n>,%edx
-         #x89 #x02 ))                   ; mov    %eax,(%edx)
+(define (i386:accu->label label)
+  `(#xa3 ,label #f #f #f))
 
 (define (i386:accu-zero?)
   '(#x85 #xc0))                         ; cmpl   %eax,%eax
   `(#x89 #xea                           ; mov    %ebp,%edx
          #x83 #xc2 ,(- 0 (* 4 n))))     ; add    $0x<n>,%edx
 
-(define (i386:global->base n)
-  (or n (error "invalid value: global->base: " n))
-  `(#xba ,@(int->bv32 n)))              ; mov   $<n>,%edx
+(define (i386:label->accu label)
+  `(#xb8 ,label #f #f #f))              ; mov    $<>,%eax
+
+(define (i386:label->base label)
+  `(#xba ,label #f #f #f))              ; mov   $<n>,%edx
+
+(define (i386:label-mem->accu label)
+  `(#xa1 ,label #f #f #f))              ; mov    0x<n>,%eax
 
-(define (i386:global-address->accu n)
-  (or n (error "invalid value: global-address->accu: " n))
-  `(#xa1 ,@(int->bv32 n)))              ; mov    0x<n>,%eax
+(define (i386:label-mem->base label)
+  `(#x8b #x15 ,label #f #f #f))         ; mov    0x<n>,%edx
 
-(define (i386:global-address->base n)
-  (or n (error "invalid value: global-address->base: " n))
-  `(#x8b #x15 ,@(int->bv32 n)))         ; mov    0x<n>,%edx
+(define (i386:label-mem-add label v)
+  `(#x83 #x05 ,label #f #f #f ,v))      ; addl   $<v>,0x<n>
 
 (define (i386:byte-base-mem->accu)
   '(#x01 #xd0                           ; add    %edx,%eax
 (define (i386:accu-mem-add v)
   `(#x83 #x00 ,v))                      ; addl   $<v>,(%eax)
 
-(define (i386:global-add n v)
-  (or n (error "invalid value: i386:global-add: " n))
-  `(#x83 #x05 ,@(int->bv32 n) ,v))      ; addl   $<v>,0x<n>
-
-(define (i386:global->accu o)
-  (or o (error "invalid value: i386:global->accu: " o))
-  `(#xb8 ,@(int->bv32 o)))              ; mov    $<>,%eax
-
-(define (i386:value->global n v)
-  (or n (error "invalid value: value->global: " n))
-  `(#xc7 #x05 ,@(int->bv32 n)           ; movl   $<v>,(<n>)
+(define (i386:value->label label v)
+  (or v (error "invalid value: value->label: " v))
+  `(#xc7 #x05 ,label #f #f #f           ; movl   $<v>,(<n>)
          ,@(int->bv32 v)))
 
 (define (i386:value->local n v)
   (or n (error "invalid value: local-test: " n))
   `(#x83 #x7d ,(- 0 (* 4 n)) ,v))       ; cmpl   $<v>,0x<n>(%ebp)
 
-(define (i386:call f g ta t d address n)
-  (or address (error "invalid value: i386:call: " address))
-  `(#xe8 ,@(int->bv32 (- address 5))    ; call   relative $00
+(define (i386:call-label label n)
+  `(#xe8 ,label #f #f #f                ; call   relative $00
          #x83 #xc4 ,(* n 4)))           ; add    $00,%esp
 
-(define (i386:call-accu f g ta t d n)
+(define (i386:call-accu n)
   `(,@(i386:push-accu)
     ,@(i386:pop-accu)
     #xff #xd0                           ; call   *%eax
   (or n (error "invalid value: i386:XXjump: n: " n))
   `(#xe9 ,@(int->bv32 n)))              ; jmp . + <n>
 
+(define (i386:jump-label label)
+  `(#xe9 ,label #f #f #f))              ; jmp . + <n>
+
 (define (i386:Xjump-nz n)
   (or n (error "invalid value: i386:Xjump-nz: n: " n))
   `(#x0f #x85 ,@(int->bv32 n)))         ; jnz . + <n>
index a55ddac884a2ab16a1f6b0620693918fceb7cfb2..b52a24ff512f8432ff2b6cf1c1f00ec9a7a9fbc5 100644 (file)
 ;;; Code:
 
 (define-module (mes as-i386)
-  #:use-module (mes elf)
+  #:use-module (mes elf-util)
   #:export (
             i386:accu-not
             i386:accu-cmp-value
             i386:accu->base
             i386:accu->base-address
             i386:accu->base-address+n
-            i386:accu->global
-            i386:accu->global-address
+            i386:accu->label
             i386:accu->local
             i386:accu-non-zero?
             i386:accu-test
@@ -55,7 +54,7 @@
             i386:base->accu
             i386:base->accu-address
             i386:byte-accu->base-address
-            i386:base->global
+            i386:base->label
             i386:base->local
             i386:base-mem->accu
             i386:byte-base-sub
             i386:byte-mem->base
             i386:byte-test-base
             i386:byte-sub-base
-            i386:call
             i386:call-accu
+            i386:call-label
             i386:formal
             i386:function-locals
             i386:function-preamble
-            i386:global-add
-            i386:global->accu
-            i386:global->base
-            i386:global-address->accu
-            i386:global-address->base
-            i386:jump
+            i386:label-mem-add
+            i386:label->accu
+            i386:label->base
+            i386:label-mem->accu
+            i386:label-mem->base
             i386:jump
+            i386:jump-label
             i386:jump-byte-nz
             i386:jump-byte-z
             i386:jump-c
             i386:push-accu
             i386:pop-base
             i386:push-base
-            i386:push-global
-            i386:push-global-address
+            i386:push-label
+            i386:push-label-mem
             i386:push-local
             i386:push-byte-local-de-ref
             i386:push-byte-local-de-de-ref
             i386:value->accu
             i386:value->accu-address
             i386:value->accu-address+n
-            i386:value->global
+            i386:value->label
             i386:value->local
             i386:value->base
             i386:xor-accu
index 2bcaf55a86edb19cd26d37f3f7f9e5b1d92d9960..aa24720a2009f91c2087ff728b984f81ef00aed0 100644 (file)
  (guile)
  (guile-2)
  (mes
+  (mes-use-module (srfi srfi-1))
   (mes-use-module (srfi srfi-1))))
 
+
+(define (int->bv32 value)
+  (let ((bv (make-bytevector 4)))
+    (bytevector-u32-native-set! bv 0 value)
+    bv))
+
+(define (int->bv16 value)
+  (let ((bv (make-bytevector 2)))
+    (bytevector-u16-native-set! bv 0 value)
+    bv))
+
 (define (make-global name type pointer value)
   (cons name (list type pointer value)))
 
 
 (define (dec->hex o)
   (cond ((number? o) (number->string o 16))
-        ((char? o) (number->string (char->integer o) 16))))
+        ((char? o) (number->string (char->integer o) 16))
+        (else (format #f "~s" o))))
 
-(define (functions->lambdas functions)
-  (append-map (lambda (f) (or (cdr f) '())) functions))
-
-(define (lambda/label->list f g ta t d)
-  (lambda (l/l)
-    (if (not (procedure? l/l)) '() (l/l f g ta t d))))
+(define (functions->lines functions)
+  (filter (lambda (x) (not (and (pair? x) (pair? (car x)) (member (caar x) '(#:comment #:label))))) (append-map cdr functions))
+  ;;(append-map cdr functions)
+  )
 
 (define (text->list o)
-  (append-map (lambda/label->list '() '() 0 0 0) o))
+  (append-map cdr o))
 
 (define functions->text
   (let ((cache '()))
     (lambda (functions globals ta t d)
-      (or (assoc-ref cache (cons ta (map car functions)))
-          (let ((text (let loop ((lambdas/labels (functions->lambdas functions)) (text '()))
-                        (if (null? lambdas/labels) text
-                            (loop (cdr lambdas/labels)
-                                  (append text ((lambda/label->list functions globals ta (- (length text)) d) (car lambdas/labels))))))))
-            (set! cache (assoc-set! cache (cons ta (map car functions)) text))
-            text)))))
+      (let ((text (or (assoc-ref cache (cons ta (map car functions)))
+                      (let ((text (apply append (functions->lines functions))))
+                    (set! cache (assoc-set! cache (cons ta (map car functions)) text))
+                    text))))
+        (if (= ta 0) text
+            (let loop ((f functions))
+              (if (null? f) '()
+                  (append ((function->text functions globals ta t d) (car f))
+                          (loop (cdr f))))))))))
+
+(define (function->text functions globals ta t d)
+  (lambda (o)
+    (let ((text (apply append (cdr o)))
+          (offset (function-offset (car o) functions)))
+      (let loop ((text text) (off offset))
+        (if (null? text) '()
+            (let ((label (car text)))
+              (if (number? label) (cons label (loop (cdr text) (1+ off)))
+                  (if (and (pair? label) (member (car label) '(#:comment #:label))) ;;(cons #x90 (loop (cdr text) (1+ off)))
+                      (loop (cdr text) off)
+                   (let* ((prefix (if (and (pair? (cdr text))
+                                           (pair? (cddr text))
+                                           (boolean? (caddr text))) 4
+                                           2))
+                          ;;(foo (format (current-error-port) "LABEL=~s\n" label))
+                          ;; FiXME: address vs relative address
+                          (address? (and (pair? label) (member (car label) '(address))))
+                          (label (if address? (cadr label) label))
+                          (function-address (function-offset label functions))
+                          (data-address (data-offset label globals))
+                          (label-address (label-offset (car o) (and (pair? label)
+                                                                    `((#:label ,(cadr label)))) functions))
+                          ;; (foo (format (current-error-port) "  address?=~s\n" address?))
+                          ;; (foo (format (current-error-port) "  d=~s\n" data-address))
+                          ;; (foo (format (current-error-port) "  f=~s\n" function-address))
+                          ;; (foo (format (current-error-port) "  l=~s\n" label-address))
+                          (address (or (and=> data-address (lambda (a) (+ a d)))
+                                       (if address?
+                                           (and=> function-address (lambda (a) (+ a ta)))
+                                           (and=> function-address (lambda (a) (- a off prefix))))
+                                       (and=> label-address (lambda (a) (- a (- off offset) prefix)))
+                                       (error "unresolved label: " label))))
+                     (append ((if (= prefix 2) int->bv16 int->bv32) address)
+                             (loop (list-tail text prefix) (+ off prefix))))))))))))
 
 (define (function-prefix name functions)
   ;; FIXME
                                      (if (null? (cdr prefix)) 0
                                          (function-offset (caar prefix) functions)))))))
             (if (and offset (or (equal? name "_start") (> offset 0))) (set! cache (assoc-set! cache name offset)))
-            (or offset 0))))))
+            offset)))))
 
 (define label-offset
   (let ((cache '()))
             (if (not prefix) 0
                 (let* ((function-entry (car prefix))
                        (offset (let loop ((text (cdr function-entry)))
-                                 (if (or (equal? (car text) label) (null? text)) 0
-                                     (let* ((l/l (car text))
-                                            (t ((lambda/label->list '() '() 0 0 0) l/l))
-                                            (n (length t)))
+                                 ;; FIXME: unresolved label
+                                 ;;(if (null? text) (error "unresolved label:"))
+                                 (if (or (null? text) (equal? (car text) label)) 0
+                                     (let* ((t (car text))
+                                            (n (if (and (pair? (car t))
+                                                        (member (caar t) '(#:label #:comment))) 0 (length t))))
                                        (+ (loop (cdr text)) n))))))
                   (when (> offset 0)
                     (set! cache (assoc-set! cache (cons function label) offset)))
                   offset)))))))
 
-(define (globals->data globals)
-  (append-map (compose global:value cdr) globals))
+(define (globals->data functions globals t d)
+  (let loop ((text (append-map cdr globals)))
+    (if (null? text) '()
+        (let ((label (car text)))
+          (if (or (char? label) (number? label)) (cons label (loop (cdr text)))
+              (let* ((prefix (if (and (pair? (cdr text))
+                                      (pair? (cddr text))
+                                      (boolean? (caddr text))) 4
+                                      2))
+                     (function-address (function-offset label functions))
+                     (data-address (data-offset label globals))
+                     (address (or (and=> data-address (lambda (a) (+ a d)))
+                                  (and=> function-address (lambda (a) (+ a t)))
+                                  (error "unresolved label: " label))))
+                      (append ((if (= prefix 2) int->bv16 int->bv32) address)
+                              (loop (list-tail text prefix)))))))))
+
+(define (simple-globals->data globals)
+  (append-map cdr globals))
 
 (define data-offset
   (let ((cache '()))
     (lambda (name globals)
-      (or ;;(assoc-ref cache name)
-          (let* ((prefix (member name (reverse globals)
-                                 (lambda (a b)
-                                   (equal? (car b) name)))))
-            (if (not prefix) 0
-                (let ((offset (length (globals->data (cdr prefix)))))
-                 (set! cache (assoc-set! cache name offset))
-                 offset)))))))
+      (or (assoc-ref cache name)
+          (let ((prefix (member name (reverse globals)
+                                (lambda (a b)
+                                  (equal? (car b) name)))))
+            (and prefix
+                 (let ((offset (length (simple-globals->data (cdr prefix)))))
+                   (set! cache (assoc-set! cache name offset))
+                   offset)))))))
index 9ed6178bf925b4836669774b0e26ddf3fb7fe2e4..533ea1e5e406e35b823f172e05fd366ac6715eb9 100644 (file)
 
 (define-module (mes elf-util)
   #:use-module (srfi srfi-1)
+  #:use-module (mes bytevectors)
   #:export (data-offset
             dec->hex
             add-s:-prefix
             drop-s:-prefix
             function-offset
+            int->bv16
+            int->bv32
             label-offset
             functions->lambdas
             functions->text
index 20f4c6c0bbeb9d999d77a11c55e34090b9f0172e..779c74788582d20781452f55161584c6600b0fc3 100644 (file)
@@ -1,4 +1,4 @@
-;;; -*-scheme-*-
+<;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
 ;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
  (guile)
  (mes
   (mes-use-module (srfi srfi-1))
-  (mes-use-module (mes bytevectors))
   (mes-use-module (mes elf-util))))
 
-(define (int->bv32 value)
-  (let ((bv (make-bytevector 4)))
-    (bytevector-u32-native-set! bv 0 value)
-    bv))
-
-(define (int->bv16 value)
-  (let ((bv (make-bytevector 2)))
-    (bytevector-u16-native-set! bv 0 value)
-    bv))
-
 (define elf32-addr int->bv32)
 (define elf32-half int->bv16)
 (define elf32-off int->bv32)
   (define text-address (+ text-offset vaddress))
 
   (define data-length
-    (length (globals->data globals)))
+    (length (globals->data functions globals 0 0)))
 
   (define comment-length
     (length comment))
   (define SHF-STRINGS #x20)
 
   (let* ((text (functions->text functions globals text-address 0 data-address))
-         (raw-data (globals->data globals))
-         (data (let loop ((data raw-data) (init init))
-                 (if (null? init) data
-                     (loop ((car init) functions globals text-address 0 data-address data) (cdr init)))))
+         (raw-data (globals->data functions globals text-address data-address))
+         ;; (data (let loop ((data raw-data) (init init))
+         ;;         (if (null? init) data
+         ;;             (loop ((car init) functions globals text-address 0 data-address data) (cdr init)))))
+         (data raw-data)
          (entry (+ text-offset (function-offset "_start" functions)))
          (sym (sym functions globals))
          (str (str functions)))
      sym
      str
      (section-headers))))
+
+(define (logf port string . rest)
+  (apply format (cons* port string rest))
+  (force-output port)
+  #t)
+
+(define (stderr string . rest)
+  (apply logf (cons* (current-error-port) string rest)))
+
+(define (write-any x)
+  (write-char
+   (cond ((char? x) x)
+         ((and (number? x) (< (+ x 256) 0))
+          (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
+         ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
+         ((procedure? x)
+          (stderr "write-any: proc: ~a\n" x)
+          (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
+          (error "procedure: write-any:" x))
+         (else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
+
+(define (object->elf object)
+  (display "dumping elf\n" (current-error-port))
+  (for-each
+   write-any
+   (make-elf (filter cdr (assoc-ref object 'functions)) (assoc-ref object 'globals) (assoc-ref object 'inits))))
index d20e6a8e3053409a883d5b56d7d4fdafc8e896e3..bc12d969b6ae8e7347cef4f4035beb4d8f7fce66 100644 (file)
@@ -1,7 +1,7 @@
 ;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of Mes.
 ;;;
 
 (define-module (mes elf)
   #:use-module (srfi srfi-1)
-  #:use-module (mes bytevectors)
   #:use-module (mes elf-util)
-  #:export (int->bv16
-            int->bv32
-            make-elf))
+  #:export (make-elf
+            object->elf))
 
 (cond-expand
  (guile-2)
diff --git a/module/mes/hex2.mes b/module/mes/hex2.mes
new file mode 100644 (file)
index 0000000..5c0e9de
--- /dev/null
@@ -0,0 +1,194 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; hex2.mes produces stage0' hex2 object format
+
+;;; Code:
+
+(cond-expand
+ (guile)
+ (mes
+  (mes-use-module (srfi srfi-1))
+  (mes-use-module (srfi srfi-26))
+  (mes-use-module (mes elf-util))
+  (mes-use-module (mes elf))
+  (mes-use-module (mes optargs))))
+
+(define (logf port string . rest)
+  (apply format (cons* port string rest))
+  (force-output port)
+  #t)
+
+(define (stderr string . rest)
+  (apply logf (cons* (current-error-port) string rest)))
+
+(define (dec->xhex o)
+  (if (number? o) (string-append "#x" (dec->hex o))
+      (format #f "~s" o)))
+
+(define (write-hex3 o)
+  (define (write-line o)
+    (cond ((null? o))
+          ((not (pair? o))
+           (display (dec->xhex o)))
+          ((string? (car o))
+           (format #t ";; ~a\n" (car o))
+           (display (string-join (map dec->xhex (cdr o)) " ")))
+          ((number? (car o))
+           (display (string-join (map dec->xhex o) " ")))
+          ((member (car o) '(#:comment #:label))
+           (write o))
+          ((and (pair? (car o)) (member (caar o) '(#:comment #:label)))
+           (write (car o)))
+          (else (error "write-line LINE:" o))))
+  (define (write-function o)
+    (stderr "function: ~s\n" (car o))
+    (format #t "\n(~s " (car o))
+    (if (pair? (cadr o)) (for-each
+                          (lambda (x) (display "\n  (") (write-line x) (display ")"))
+                          (filter pair? (cdr o)))
+        (write-line o))
+    (display ")"))
+  (define (write-global o)
+    (stderr "global: ~s\n" (car o))
+    (format #t "\n(~s "(car o))
+    (display (string-join (map dec->xhex (cdr o)) " "))
+    (display ")"))
+  (define (write-init o)
+    (stderr "init: ~s\n" o)
+    (format #t "\n  (~s "(car o))
+    (display (string-join (map dec->xhex (global:value (cdr o))) " "))
+    (display ")"))
+  (stderr "object:\n")
+  (display ";;; hex3: hex2 in sexps with annotated labels\n")
+  (display "((functions ")
+  (for-each write-function (filter cdr (assoc-ref o 'functions)))
+  (display ")\n")
+  (display "(globals ")
+  (for-each write-global (assoc-ref o 'globals))
+  (display "))\n"))
+
+(define (objects->hex2 objects)
+  ((compose write-hex2 merge-objects) objects))
+
+(define (objects->hex3 objects)
+  ((compose write-hex3 merge-objects) objects))
+
+(define (objects->elf objects)
+  ((compose object->elf merge-objects) objects))
+
+(define (merge-objects objects)
+  (let loop ((objects (cdr objects)) (object (car objects)))
+    (if (null? objects) object
+        (loop (cdr objects)
+              `((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions)))
+                (globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals))))))))
+
+(define (alist-add a b)
+  (let* ((b-keys (map car b))
+         (a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
+         (a-keys (map car a)))
+    (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
+
+(define (write-hex2 o)
+  (let* ((functions (assoc-ref o 'functions))
+         (function-names (map car functions))
+         (globals (assoc-ref o 'globals))
+         (global-names (map car globals))
+         (strings (filter (cut string-prefix? "s:" <>) global-names)))
+    (define (string->label o)
+      (format #f "string_~a" (list-index (lambda (s) (equal? s o)) strings)))
+    (define (dec->hex o)
+      (cond ((number? o) (string-append (if (and (>= o 0) (< o 16)) "0" "")
+                                        (number->string
+                                         (if (>= o 0) o (+ o #x100))
+                                         16)))
+            ((char? o) (dec->hex (char->integer o)))
+            ((and (string? o) (string-prefix? "s:" o))
+             (format #f "&~a" (string->label o)))
+            ((string? o) (format #f "~a" o))
+            (else (format #f "~a" o))))
+    (define (write-line o)
+      (newline)
+      (cond ((not (pair? o))
+             (display (dec->hex o)))
+            ((number? (car o))
+             ;;(display (string-join (map dec->hex (filter identity o)) " "))
+             (let ((text (let loop ((text o))
+                           (if (null? text) '()
+                               (let ((label (car text)))
+                                 (if (number? label) (cons label (loop (cdr text)))
+                                     (if (and (pair? label) (member (car label) '(#:comment #:label))) (loop (cdr text))
+                                         (let* ((prefix (if (and (pair? (cdr text))
+                                                                 (pair? (cddr text))
+                                                                 (boolean? (caddr text))) 4
+                                                                 2))
+                                                (address? (and (pair? label) (member (car label) '(address))))
+                                                (label (if address? (cadr label) label))
+                                                (function? (member label function-names))
+                                                (string-label (string->label label))
+                                                (string? (not (equal? string-label "string_#f")))
+                                                (global? (member label global-names))
+                                                (label? (and (pair? label) (eq? (car label) #:label))))
+                                           (cons (cond
+                                                  ((eq? prefix 1) (format #f "!~a" label))
+                                                  ((eq? prefix 2) (format #f "@~a" label))
+                                                  (label? (format #f "%label_~a" label))
+                                                  (function? (format #f "%~a" label))
+                                                  (string? (format #f "&~a" string-label))
+                                                  (global? (format #f "&~a" label))
+                                                  (else (format #f "%~a" label)))
+                                                 (loop (list-tail text prefix)))))))))))
+               (display (string-join (map dec->hex text) " "))))
+            ((member (car o) '(#:comment))
+             (format #t "# ~a" (cadr o)))
+            ((eq? (car o) #:label)
+             (format #t ":~a\n" (cadr o)))
+            ((and (pair? (car o)) (eq? (caar o) #:label))
+             (format #t ":~a\n" (cadar o)))
+            ((and (pair? (car o)) (member (caar o) '(#:comment)))
+             (format #t "# ~a" (cadar o)))
+            ((and (pair? (car o)) (member (caar o) '(#:comment #:label)))
+             (write (car o)))
+            (else (error "write-line LINE:" o))))
+    (define (write-function o)
+      (format #t "\n\n:~a" (car o))
+      (if (pair? (cadr o)) (for-each write-line (cdr o))
+          (write-line (cdr o))))
+    (define (write-global o)
+      (let ((label (if (not (string-prefix? "s:" (car o))) (car o)
+                       (string->label (car o)))))
+        (format #t "\n:~a\n" label)
+        (display (string-join (map dec->hex (cdr o)) " "))
+        (newline)))
+    (display "### stage0's hex2 format for x86\n")
+    (display "###    !<label>          1 byte relative\n")
+    (display "###    $<label>          2 byte address\n")
+    (display "###    @<label>          2 byte relative\n")
+    (display "###    &<label>          4 byte address\n")
+    (display "###    %<label>          4 byte relative\n")
+    (display "###    label_<label>     function-local\n")
+    (display "###    string_<index>    string #<index>\n")
+    (display "\n##.text")
+    (for-each write-function (filter cdr functions))
+    (display "\n\n##.data\n")
+    (for-each write-global globals)))
diff --git a/module/mes/hex2.scm b/module/mes/hex2.scm
new file mode 100644 (file)
index 0000000..5f660e6
--- /dev/null
@@ -0,0 +1,42 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(define-module (mes hex2)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (mes elf-util)
+  #:use-module (mes elf)
+  #:export (objects->hex2
+            objects->hex3
+            objects->elf
+            write-hex2
+            write-hex3))
+
+(cond-expand
+ (guile-2)
+ (guile
+  (use-modules (ice-9 syncase)))
+ (mes))
+
+(include-from-path "mes/hex2.mes")
diff --git a/scaffold/argv.c b/scaffold/argv.c
new file mode 100644 (file)
index 0000000..c9558a8
--- /dev/null
@@ -0,0 +1,38 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
+ *
+ * This file is part of Mes.
+ *
+ * Mes is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 3 of the License, or (at
+ * your option) any later version.
+ *
+ * Mes is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include <stdio.h>
+
+int
+main (int argc, char *argv[])
+{
+  eputs ("Hi Mes!\n");
+#if __MESC_MES__
+  eputs ("MESC.MES\n");
+#else
+  puts ("MESC.GUILE\n");
+#endif
+  if (argc > 1 && !strcmp (argv[1], "--help"))
+    {
+      eputs ("argc > 1 && --help\n");
+      return argc;
+    }
+  return 42;
+}
index 2f704de83fc3388c4b2bb93e5f8798393a1b15f5..78b2478b2f974cc6fac77fecf50bf76b2eda8e32 100644 (file)
  * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  */
 
-#include <mlibc.h>
+#include <stdio.h>
 
 int
 main (int argc, char *argv[])
 {
-  puts ("Hi Mes!\n");
-#if __MESC_MES__
-  puts ("MESC.MES\n");
-#else
-  puts ("MESC.GUILE\n");
-#endif
-  if (argc > 1 && !strcmp (argv[1], "--help")) {puts ("argc > 1 && --help\n"); return argc;}
+  eputs ("Hello, Mescc!\n");
   return 42;
 }
index 80e5d963a73de337e07a100daf96ad3998b73df1..614aba70d729c3e7a146a05a7dbf9eaf02b9d69b 100644 (file)
@@ -18,7 +18,9 @@
  * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  */
 
+#include <fcntl.h>
 #include <stdio.h>
+#include <stdlib.h>
 
 int
 main (int argc, char *argv[])
index a057f0f5440178f6e4fbe179731e5785bd1b2db5..a019fd5c7b5f882d2420fe205f2fb2f327015170 100644 (file)
@@ -22,7 +22,7 @@
 #error "POSIX not supported"
 #endif
 
-#include <mlibc.h>
+#include <stdio.h>
 
 typedef int SCM;
 
index ae98cd48a1b022e6910d40060f8e3353d2f4c445..4771280e84604ae650961b3f1ba76e1a6e715eb7 100644 (file)
@@ -21,6 +21,8 @@
 #include <mlibc.h>
 #include <assert.h>
 #include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
 
 struct scm {
   int type;
index b8c6e169abb65ee07590ee904a7579b3a5686d3e..275ac17fcc771283f7053b6a0894c3d110bb5d6d 100755 (executable)
@@ -41,6 +41,8 @@ exit $r
 (mes-use-module (mes getopt-long))
 (mes-use-module (mes pretty-print))
 (mes-use-module (language c99 compiler))
+(mes-use-module (mes elf))
+(mes-use-module (mes hex2))
 (mes-use-module (srfi srfi-1))
 (mes-use-module (srfi srfi-26))
 
@@ -57,6 +59,7 @@ exit $r
           '((c (single-char #\c))
             (D (single-char #\D) (value #t))
             (E (single-char #\E))
+            (g (single-char #\g))
             (help (single-char #\h))
             (I (single-char #\I) (value #t))
             (o (single-char #\o) (value #t))
@@ -71,10 +74,11 @@ exit $r
           (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...
+Usage: mescc.mes [OPTION]... FILE...
   -c                 compile and assemble, but do not link
   -D DEFINE          define DEFINE
   -E                 preprocess only; do not compile, assemble or link
+  -g                 add debug info [GDB, objdump] using hex3 format
   -h, --help         display this help and exit
   -I DIR             append DIR to include path
   -o FILE            write output to FILE
@@ -83,9 +87,10 @@ Usage: mescc [OPTION]... FILE...
           (exit (or (and usage? 2) 0)))
      options)))
 
-(define (object->info file)
-  (let* ((lst (with-input-from-file file read)))
-    (primitive-eval lst)))
+(define (read-object file)
+  (let ((char (with-input-from-file file read-char)))
+    (if (eq? char #\#) (error "hex2 format not supported:" file)))
+  (with-input-from-file file read))
 
 (define (main:ast->info file)
   (let ((ast (with-input-from-file file read)))
@@ -121,6 +126,7 @@ Usage: mescc [OPTION]... FILE...
                    (car files)))
          (preprocess? (option-ref options 'E #f))
          (compile? (option-ref options 'c #f))
+         (debug-info? (option-ref options 'g #f))
          (asts (filter ast? files))
          (objects (filter object? files))
          (sources (filter (cut string-suffix? ".c" <>) files))
@@ -130,23 +136,26 @@ Usage: mescc [OPTION]... FILE...
                                            (else "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))))
+         (includes (reverse (filter-map (multi-opt 'I) options)))
+         (objects->hex (if debug-info? objects->hex3 objects->hex2)))
     (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))
     (with-output-to-port (open-output-file out (if (and (not compile?)
                                                         (not preprocess?)) S_IRWXU))
       (lambda ()
-        (cond ((pair? objects) (let ((infos (map object->info objects)))
-                                 (if compile? (infos->object infos)
-                                     (infos->elf infos))))
-              ((pair? asts) (let ((infos (map main:ast->info asts)))
-                              (if compile? (infos->object infos)
-                                  (infos->elf infos))))
+        (cond ((pair? objects) (let ((objects (map read-object objects)))
+                                 (if compile? (objects->hex objects)
+                                     (objects->elf objects))))
+              ((pair? asts) (let* ((infos (map main:ast->info asts))
+                                   (objects (map info->object infos)))
+                              (if compile? (objects->hex objects)
+                                  (objects->elf objects))))
               ((pair? sources) (if preprocess? (map (source->ast defines includes) sources)
-                                   (let ((infos (map (source->info defines includes) sources)))
-                                     (if compile? (infos->object infos)
-                                         (infos->elf infos))))))))))
+                                   (let* ((infos (map (source->info defines includes) sources))
+                                          (objects (map info->object infos)))
+                                     (if compile? (objects->hex objects)
+                                         (objects->elf objects))))))))))
 
 (main (command-line))
 ()
diff --git a/stage0/elf32.hex2 b/stage0/elf32.hex2
new file mode 100644 (file)
index 0000000..f09f0ec
--- /dev/null
@@ -0,0 +1,75 @@
+### Copyright (C) 2016 Jeremiah Orians
+### Copyright (C) 2017 Jan Nieuwenhuizen <janneke@gnu.org>
+### This file is part of stage0.
+###
+### stage0 is free software: you an redistribute it and/or modify
+### it under the terms of the GNU General Public License as published by
+### the Free Software Foundation, either version 3 of the License, or
+### (at your option) any later version.
+###
+### stage0 is distributed in the hope that it will be useful,
+### but WITHOUT ANY WARRANTY; without even the implied warranty of
+### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+### GNU General Public License for more details.
+###
+### You should have received a copy of the GNU General Public License
+### along with stage0.  If not, see <http://www.gnu.org/licenses/>.
+
+### elf32.hex2: 32 bit elf header in hex2
+
+## ELF Header
+7F 45 4C 46           # e_ident[EI_MAG0-3] ELF's magic number
+
+01                    # e_ident[EI_CLASS] Indicating 32 bit
+01                    # e_ident[EI_DATA] Indicating little endianness
+01                    # e_ident[EI_VERSION] Indicating original elf
+
+00                    # e_ident[EI_OSABI] Set at 0 because none cares
+00                    # e_ident[EI_ABIVERSION] See above
+
+00 00 00 00 00 00 00  # e_ident[EI_PAD]
+02 00                 # e_type Indicating Executable
+03 00                 # e_machine Indicating AMD64
+01 00 00 00           # e_version Indicating original elf
+
+54 80 04 08           # e_entry Address of the entry point
+34 00 00 00           # e_phoff Address of program header table
+00 00 00 00           # e_shoff Address of section header table
+
+00 00 00 00           # e_flags
+34 00                 # e_ehsize Indicating our 52 Byte header
+
+20 00                 # e_phentsize size of a program header table
+01 00                 # e_phnum number of entries in program table
+
+00 00                 # e_shentsize size of a section header table
+00 00                 # e_shnum number of entries in section table
+
+00 00                 # e_shstrndx index of the section names
+
+## Program Header
+01 00 00 00           # p_type
+00 00 00 00           # p_offset
+
+00 80 04 08           # p_vaddr
+00 80 04 08           # p_physaddr
+
+## FIXME!
+##60 00 00 00           # p_filesz
+##60 00 00 00           # p_memsz
+
+#65 01 00 00           # p_filesz
+#65 01 00 00           # p_memsz
+
+00 20 00 00           # p_filesz
+00 20 00 00           # p_memsz
+
+
+07 00 00 00           # p_flags
+01 00 00 00           # alignment
+
+## _start
+# exit (42) -- works!
+#bb 2a 00 00 00      # mov    $42,%ebx
+#b8 01 00 00 00      # mov    $0x1,%eax
+#cd 80               # int    $0x80