mescc: Produce M1 output instead of hex2.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sun, 2 Jul 2017 14:25:14 +0000 (16:25 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sun, 2 Jul 2017 14:25:14 +0000 (16:25 +0200)
Use: ./make.scm [TARGET]
     ./make.scm check

* stage0/x86.M1: New file.
* mlibc/mini-libc-mes.c (exit, write): Use M1 instead of .byte.
* mlibc/libc-mes.c (_start, exit, read, write, open, access, brk,
  fsync, printf): Use M1 instead of .byte.
* module/mes/as-i386.mes: Use M1.
* module/mes/make.scm: New file.
* make.scm: New file.
* guile/guix/records.scm: New File.
* guile/guix/shell-utils.scm: New file.
* module/mes/M1.mes: Rename from hex2.mes.
* module/mes/M1.scm: Rename from hex2.scm.
* scripts/mescc.mes: Update callers.
* guile/mescc.scm: Update callers.

25 files changed:
.gitignore
build-aux/compile-all.scm
build-aux/mes-snarf.scm
configure
guile/guix/make.scm [new file with mode: 0644]
guile/guix/records.scm [new file with mode: 0644]
guile/guix/shell-utils.scm [new file with mode: 0644]
guile/mescc.scm
make.scm [new file with mode: 0755]
mlibc/libc-gcc.c
mlibc/libc-mes.c
mlibc/mini-libc-mes.c
module/language/c99/compiler.mes
module/language/c99/compiler.scm
module/mes/M1.mes [new file with mode: 0644]
module/mes/M1.scm [new file with mode: 0644]
module/mes/as-i386.mes
module/mes/as-i386.scm
module/mes/elf.mes
module/mes/elf.scm
module/mes/hex2.mes [deleted file]
module/mes/hex2.scm [deleted file]
scaffold/t.c
scripts/mescc.mes
stage0/x86.M1 [new file with mode: 0644]

index 3aaec58a8751f51c9b6b46b69bd394545b624498..a06659f0c4f0e9ca848eca64e0ff18286061217d 100644 (file)
@@ -2,6 +2,21 @@
 *.go
 *~
 .#*
+*.E
+*.log
+*.gcc
+*.guile
+*.0-guile
+*.mini-guile
+*.mlibc-gcc
+*.mlibc-o
+*.hex2-o
+#*.M1
+
+/src/*.h
+/src/*.i
+
+*.o
 /.config.make
 /.tarball-version
 /ChangeLog
index e123bbb9b3c9d6e25f0b6854135febc8b55816cd..013904b052e76f14d189dd9f93ed1ec69b181a94 100644 (file)
@@ -69,9 +69,8 @@
     (string-append without-extension ".go")))
 
 (define (scm->mes file)
-  (let* ((relative (relative-file file))
-         (without-extension (string-drop-right relative 4)))
-    (string-append without-extension ".mes")))
+  (let ((base (string-drop-right file 4)))
+    (string-append base ".mes")))
 
 (define (file-needs-compilation? file)
   (let ((go (scm->go file)))
index be09704f5d575e585ef727033023b15ea7e50e07..024de29962f0b35b112d314eef6348ad83a2c131 100755 (executable)
@@ -155,7 +155,7 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
          (functions (filter (negate internal?) functions))
          (symbols (snarf-symbols string))
          (base-name (basename file-name ".c"))
-         (dir (or (getenv "OUT") "out"))
+         (dir (or (getenv "OUT") (dirname file-name)))
          (base-name (string-append dir "/" base-name))
          (base-name (if %gcc? base-name
                         (string-append base-name ".mes")))
index 2709aa275bf72a678ac7eee3e3689ccd24ddcc2f..aa5ca891b1da5004fe1b86b7291a5fb34c22f7b4 100755 (executable)
--- a/configure
+++ b/configure
@@ -214,7 +214,8 @@ Usage: ./configure [OPTION]...
          (prefix (option-ref options 'prefix PREFIX))
          (sysconfdir (option-ref options 'sysconfdir SYSCONFDIR))
          (verbose? (option-ref options 'verbose #f))
-         (with-courage? (option-ref options 'with-courage #f)))
+         (with-courage? (option-ref options 'with-courage #f))
+         (make? #f))
     (set! *verbose?* verbose?)
     (check-version 'guile '(2 0))
     (check-version HEX2 '(0 0))
@@ -231,7 +232,7 @@ Usage: ./configure [OPTION]...
       (check-header-c "limits.h" "linux-headers"))
     (if (not (check-version CC32 '(4 8) #:optional? #t))
         (set! CC32 #f))
-    (check-version 'make '(4 0))
+    (set! make? (check-version 'make '(4 0) #:optional? #t))
     (check-version 'perl '(5))
 
     (when (pair? required)
@@ -257,6 +258,9 @@ Usage: ./configure [OPTION]...
         (stdout "VERSION:=~a\n" VERSION)
         (stdout "PREFIX:=~a\n" (gulp-pipe (string-append "echo " prefix)))
         (stdout "SYSCONFDIR:=~a\n" sysconfdir)))
-    (stdout "\nRun:
-  make            to build mes
-  make help       for help on other targets\n")))
+    (format (current-output-port)
+            "\nRun:
+  ~a            to build mes
+  ~a help       for help on other targets\n"
+            (if make? "make" "./make.scm")
+            (if make? "make" "./make.scm"))))
diff --git a/guile/guix/make.scm b/guile/guix/make.scm
new file mode 100644 (file)
index 0000000..dc5362f
--- /dev/null
@@ -0,0 +1,482 @@
+;;; -*-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:
+
+;;; make
+
+;;; Code:
+
+(define-module (guix make)
+  #:use-module (ice-9 curried-definitions)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
+
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+
+  #:use-module (guix records)
+  #:use-module (guix shell-utils)
+
+  #:export (build
+            check
+            clean
+
+            cpp.mescc
+            compile.mescc
+            ld
+
+            bin.mescc
+            bin.gcc
+            snarf
+
+            libc-mes.E
+            mini-libc-mes.E
+            add-target
+            get-target
+
+            system**
+            target-file-name
+
+            target
+            %targets
+            %status))
+
+(define %status 0)
+(define %targets '())
+(define %store-dir ".store")
+(mkdir-p %store-dir)
+(define %command-log (open-output-file "script"))
+
+(define (base-name file-name suffix)
+  (string-drop-right file-name (string-length suffix)))
+
+(define (system** . command)
+  (format %command-log "~a\n" (string-join command " "))
+  (apply system* command))
+
+(define (gulp-pipe* . command)
+  (let* ((port (apply open-pipe* (cons OPEN_READ command)))
+         (foo (set-port-encoding! port "ISO-8859-1"))
+         (output (read-string port))
+         (status (close-pipe port)))
+    (format %command-log "~a\n" (string-join command " "))
+    (values output status)))
+
+(define (assert-gulp-pipe* . command)
+  (receive (output status)
+      (apply gulp-pipe* command)
+    (if (zero? status) (string-trim-right output #\newline)
+        (error (format #f "pipe failed: ~d ~s"
+                       (or (status:exit-val status)
+                           (status:term-sig status)) command)))))
+
+(define-record-type* <method>
+  method make-method
+  method?
+  (name       method-name)
+  (build      method-build (default (lambda _ #t)))
+  (inputs     method-inputs (default (list))))
+
+(define-record-type* <target>
+  target make-target
+  target?
+  (file-name  target-file-name (default #f))       ; string
+  (file-names target-file-names (default '()))     ; (string)
+  (hash       target-hash (default #f))            ; string
+  (method     target-method (default method-file)) ; <method>
+  (inputs     target-inputs (default (list)))      ; list
+                                                   ; For check targets
+  (exit       target-exit (default #f))            ; number
+  (signal     target-signal (default #f)))         ; number
+
+(define method-file (method (name "FILE")))
+(define method-check
+  (method (name "CHECK")
+          (build (lambda (o t)
+                   (let* ((inputs (target-inputs t))
+                          (file-name (target-file-name (build (car inputs))))
+                          (run file-name)
+                          (exit (target-exit t))
+                          (signal (target-signal t))
+                          (log (string-append file-name "-check.log")))
+                     (format (current-error-port) "  CHECK\t~a" (basename file-name))
+                     (receive (output result)
+                         ;; FIXME: quiet MES tests are not fun
+                         (if (string-prefix? "tests/" run) (values #f (system** run))
+                             (gulp-pipe* run))
+                       (let ((status (if (string? result) 0
+                                         (or (status:term-sig result) (status:exit-val result)))))
+                         (if output (with-output-to-file log (lambda _ (display output))))
+                         (store #:add-file log)
+                         (format (current-error-port) "\t[~a]\n"
+                                 (if (or (and signal (= status signal))
+                                         (and exit (= status exit))) "OK"
+                                         (begin (set! %status 1) "FAIL"))))))))))
+
+(define (hash-target o)
+  (let ((inputs (target-inputs o)))
+    (if (null? inputs) (or (target-hash o) (target-hash (store #:add o)))
+        (let ((input-shas (map hash-target inputs)))
+          (and (every identity input-shas)
+               (let ((method (target-method o)))
+                 (string-hash (format #f "~s" (cons* (target-file-name o)
+                                                     (method-build method)
+                                                     (map target-hash (method-inputs method))
+                                                     input-shas)))))))))
+
+(define (string-hash o)
+  (number->string (hash o (expt 2 63))))
+
+(define (file-hash o)
+  (string-hash (with-input-from-file o read-string)))
+
+(define (store-file-name o)
+  (string-append %store-dir "/" (if (string? o) o
+                                    (target-hash o))))
+
+(define (assert-link existing-file new-file)
+  (if (not (file-exists? new-file)) (link existing-file new-file)))
+
+(define store
+  (let ((*store* '()))
+    (define (prune? o)
+      (let ((t (cdr o)))
+        (pair? (target-inputs t))))
+    (define ((file-name? file-name) o)
+      (let ((t (cdr o)))
+        (equal? (target-file-name t) (target-file-name file-name))))
+    (lambda* (#:key add add-file delete get key print prune)
+      (cond ((and add key) (let ((value (target (inherit add) (hash key))))
+                             (set! *store* (assoc-set! (filter (negate (file-name? add)) *store*) key value))
+                             (let ((file-name (target-file-name value)))
+                               (if (and file-name (file-exists? file-name))
+                                   (assert-link file-name (store-file-name value))))
+                             value))
+            (add (let ((key (if (null? (target-inputs add)) (file-hash (target-file-name add))
+                                (hash-target add))))
+                   (if (not key) (error "store: no hash for:" add))
+                   (store #:add add #:key key)))
+            (add-file (and (file-exists? add-file)
+                           (store #:add (target (file-name add-file)))))
+            ((and get key)
+             (or (assoc-ref *store* key)
+                 (let ((store-file (store-file-name key))
+                       (file-name (target-file-name get)))
+                   (and (file-exists? store-file)
+                        (if (file-exists? file-name) (delete-file file-name))
+                        (link store-file file-name)
+                        (store #:add get #:key key)))))
+            (get (assoc-ref *store* get))
+            (delete (and (assoc-ref *store* delete)
+                         (set! *store* (filter (lambda (e) (not (equal? (car e) delete))) *store*))))
+            (print (pretty-print (map (lambda (e) (cons (target-file-name (cdr e)) (car e))) *store*)))
+            ((eq? prune 'file-system)
+             (set! *store* (filter prune? *store*)))
+            (else (error "store: dunno"))))))
+
+(define (build o)
+  (let ((hash (hash-target o)))
+    (or (and hash (store #:get o #:key hash))
+        (begin
+          ;;(format (current-error-port) "must rebuild hash=~s\n" hash)
+          (for-each build (target-inputs o))
+          (let ((method (target-method o)))
+            ((method-build method) method o))
+          (store #:add o #:key hash)))))
+
+(define* (check name #:key (exit 0) (signal #f) (dependencies '()))
+  (target (file-name (string-append "check-" name))
+                         (method method-check)
+                         (inputs (cons (get-target name) dependencies))
+                         (exit exit)
+                         (signal signal)))
+
+(define (target->input-files o)
+  (let ((inputs (target-inputs o)))
+    (if (null? inputs) '()
+        (append (cons (target-file-name o) (target-file-names o)) (append-map target->input-files inputs)))))
+
+(define* (clean #:optional targets)
+  (for-each
+   delete-file
+   (filter file-exists? (delete-duplicates (append-map (cut target->input-files <>) (or targets %targets))))))
+
+(define (tree o)
+  (let ((inputs (target-inputs o)))
+    (if (null? inputs) o
+        (cons o (append (map tree inputs) (map tree (method-inputs (target-method o))))))))
+
+
+(define (verbose fmt . o)
+  ;;(apply format (cons* (current-error-port) fmt o))
+  #t
+  )
+
+(define (PATH-search-path name)
+  (or (search-path (string-split (getenv "PATH") #\:) name)
+      (and (format (current-error-port) "warning: not found: ~a\n" name)
+           name)))
+
+(define %CC (PATH-search-path "gcc"))
+(define %CC32 (PATH-search-path "i686-unknown-linux-gnu-gcc"))
+(define %C-FLAGS
+  '("--std=gnu99"
+    "-O0"
+    "-g"
+    "-D"
+    "POSIX=1"
+    "-I" "src"
+    "-I" "mlibc/include"
+    "--include=mlibc/libc-gcc.c"
+    ))
+(define %C32-FLAGS
+  '("--std=gnu99"
+    "-O0"
+    "-g"
+    "-I" "src"
+    "-I" "mlibc/include"
+    "--include=mlibc/libc-gcc.c"
+    ))
+
+(define* (CC.gcc #:key (libc #t) (cc (if libc %CC %CC32)) (c-flags (if libc %C-FLAGS %C32-FLAGS)) (defines '()))
+  (method (name "CC.gcc")
+          (build (lambda (o t)
+                   (let* ((input-files (map target-file-name (target-inputs t)))
+                          (command `(,cc
+                                     "-c"
+                                     ,@(append-map (cut list "-D" <>) defines)
+                                     ,@(if libc '() '("-nostdinc" "-fno-builtin"))
+                                     ,@c-flags
+                                     "-o" ,(target-file-name t)
+                                     ,@input-files)))
+                     (format (current-error-port) "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
+                     (unless (zero? (apply system** command))
+                       (format (current-error-port) "FAILED:~s\n" command)
+                       (exit 1)))))
+          (inputs (list (store #:add-file "mlibc/libc-gcc.c"))))) ;; FIXME: FLAGS
+
+(define* (CPP.mescc #:key (cc %MESCC) (defines '()))
+  (method (name "CPP.mescc")
+          (build (lambda (o t)
+                   (let ((input-files (map target-file-name (target-inputs t))))
+                     (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
+                     (apply system**
+                            `(,cc
+                              "-E"
+                              ,@(append-map (cut list "-D" <>) defines)
+                              "-o" ,(target-file-name t)
+                              ,@input-files)))))))
+
+(define %MESCC "guile/mescc.scm")
+(define* (CC.mescc #:key (cc %MESCC))
+  (method (name "CC.mescc")
+          (build (lambda (o t)
+                   (let ((input-files (map target-file-name (target-inputs t))))
+                     (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
+                     (apply system**
+                            `("guile/mescc.scm" "-c"
+                              "-o" ,(target-file-name t)
+                              ,@input-files)))))
+          (inputs (list (store #:add-file "guile/language/c99/compiler.go")
+                        (store #:add-file "guile/mes/as.go")
+                        (store #:add-file "guile/mes/as-i386.go")
+                        (store #:add-file "guile/mes/M1.go")))))
+
+(define %M1 (PATH-search-path "M1"))
+(define %M1-FLAGS
+  '("--LittleEndian"
+    "--Architecture=1"
+    ;;"--BaseAddress=0x1000000"
+    ))
+(define* (M1.asm #:key (m1 %M1) (m1-flags %M1-FLAGS))
+  (method (name "M1")
+          (build (lambda (o t)
+                   (let* ((input-files (map target-file-name (target-inputs t)))
+                          (input-files (filter (lambda (f) (string-suffix? "M1" f))
+                                               input-files)))
+                     (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
+                     (with-output-to-file (target-file-name t)
+                       (lambda _
+                         (display
+                          (apply assert-gulp-pipe*
+                                 `(,m1
+                                   "-f"
+                                   "stage0/x86.M1"
+                                   ,@(append-map (cut list "-f" <>) input-files)
+                                   ,@m1-flags)))
+                         (newline))))))
+          (inputs (list (store #:add-file "stage0/x86.M1")))))
+
+(define %HEX2-FLAGS
+  '("--LittleEndian"
+    "--Architecture=1"
+    "--BaseAddress=0x1000000"))
+(define %HEX2 (PATH-search-path "hex2"))
+
+(define* (LINK.hex2 #:key (hex2 %HEX2) (hex2-flags %HEX2-FLAGS) debug?)
+  (method (name "LINK.hex2")
+          (build (lambda (o t)
+                   (let* ((input-files (map target-file-name (target-inputs t)))
+                          ;; FIXME: snarf inputs
+                          (input-files (filter (lambda (f) (string-suffix? "hex2" f))
+                                               input-files)))
+                     (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
+                     (with-output-to-file (target-file-name t)
+                       (lambda _
+                         (set-port-encoding! (current-output-port) "ISO-8859-1")
+                         (display
+                          (apply assert-gulp-pipe*
+                                 `(,hex2
+                                   ,@hex2-flags
+                                   "-f"
+                                   ,(if (not debug?) "stage0/elf32-0header.hex2"
+                                        "stage0/elf32-header.hex2")
+                                   ,@(append-map (cut list "-f" <>) input-files)
+                                   "-f"
+                                   ,(if (not debug?) "stage0/elf-0footer.hex2"
+                                        "stage0/elf32-footer-single-main.hex2"))))))
+                     (chmod (target-file-name t) #o755))))
+          (inputs (list (store #:add-file "stage0/elf32-0header.hex2")
+                        (store #:add-file "stage0/elf-0footer.hex2")))))
+
+(define* (LINK.gcc #:key (cc %CC) (c-flags %C-FLAGS) (libc #t))
+  (method (name "LINK.gcc")
+          (build (lambda (o t)
+                   (let* ((input-files (map target-file-name (target-inputs t)))
+                          (command `(,cc
+                                     ,@c-flags
+                                     ,@(if libc '() '("-nostdlib"))
+                                     "-o"
+                                     ,(target-file-name t)
+                                     ,@input-files)))
+                     (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
+                     (unless (zero? (apply system** command))
+                       (format (current-error-port) "FAILED:~s\n" command)
+                       (exit 1)))))))
+
+(define SNARF "build-aux/mes-snarf.scm")
+(define (SNARF.mes mes?)
+  (method (name "SNARF.mes")
+          (build (lambda (o t)
+                   (let* ((input-files (map target-file-name (target-inputs t)))
+                          (command `(,SNARF
+                                     ,@(if mes? '("--mes") '())
+                                     ,@input-files)))
+                     (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
+                     (unless (zero? (apply system** command))
+                       (format (current-error-port) "FAILED:~s\n" command)
+                       (exit 1)))))))
+
+(define* (cpp.mescc input-file-name #:key (cc %MESCC) (defines '()))
+  (let* ((c-target (target (file-name input-file-name)))
+         (base-name (base-name input-file-name ".c"))
+         (suffix ".E")
+         (target-file-name (string-append base-name suffix)))
+    (target (file-name target-file-name)
+            (inputs (list c-target))
+            (method (CPP.mescc #:cc cc #:defines defines)))))
+
+(define mini-libc-mes.E (cpp.mescc "mlibc/mini-libc-mes.c"))
+(define libc-mes.E (cpp.mescc "mlibc/libc-mes.c"))
+
+(define* (compile.gcc input-file-name #:key (libc #t) (cc (if libc %CC %CC32)) (defines '()))
+  (let* ((base-name (base-name input-file-name ".c"))
+         (cross (if libc "" "mlibc-"))
+         (suffix (string-append "." cross "o"))
+         (target-file-name (string-append base-name suffix))
+         (c-target (target (file-name input-file-name))))
+    (target (file-name target-file-name)
+            (inputs (list c-target))
+            (method (CC.gcc #:cc cc #:libc libc #:defines defines)))))
+
+(define* (compile.mescc input-file-name #:key (cc %CC) (libc libc-mes.E) (defines '()))
+  (let* ((base-name (base-name input-file-name ".c"))
+         ;;(foo (format (current-error-port) "COMPILE[~s .c] base=~s\n" input-file-name base-name))
+         (suffix (cond ((not libc) ".0-M1")
+                       ((eq? libc libc-mes.E) ".M1")
+                       (else ".mini-M1")))
+         (target-file-name (string-append base-name suffix))
+         (E-target (cpp.mescc input-file-name #:cc cc #:defines defines)))
+    (target (file-name target-file-name)
+            (inputs `(,@(if libc (list libc) '()) ,E-target))
+            (method (CC.mescc #:cc cc)))))
+
+(define* (m1-asm input-file-name #:key (cc %MESCC) (m1 %M1) (libc libc-mes.E) (defines '()))
+  (let* ((base-name (base-name input-file-name ".c"))
+         ;;(foo (format (current-error-port) "m1-asm[~s .m1] base=~s\n" input-file-name base-name))
+         (suffix (cond ((not libc) ".0-hex2")
+                       ((eq? libc libc-mes.E) ".hex2")
+                       (else ".mini-hex2")))
+         (target-file-name (string-append base-name suffix))
+         (m1-target (compile.mescc input-file-name #:cc cc #:libc libc #:defines defines))
+         (libc.m1 (cond ((eq? libc libc-mes.E)
+                         (compile.mescc "mlibc/libc-mes.c" #:libc #f #:defines defines))
+                        ((eq? libc mini-libc-mes.E)
+                         (compile.mescc "mlibc/mini-libc-mes.c" #:libc #f #:defines defines))
+                        (else #f))))
+    (target (file-name target-file-name)
+            ;;(inputs `(,@(if libc (list libc.m1) '()) ,m1-target))
+            (inputs `(,m1-target))
+            (method (M1.asm #:m1 m1)))))
+
+(define* (bin.mescc input-file-name #:key (cc %MESCC) (hex2 %HEX2) (m1 %M1) (libc libc-mes.E) (dependencies '()) (defines '()))
+  (let* ((base-name (base-name input-file-name ".c"))
+         ;;(foo (format (current-error-port) "bin[~s .c] base=~s\n" input-file-name base-name))
+         (suffix (cond ((not libc) ".0-guile")
+                       ((eq? libc libc-mes.E) ".guile")
+                       (else ".mini-guile")))
+         (target-file-name (string-append base-name suffix))
+         (hex2-target (m1-asm input-file-name #:m1 m1 #:cc cc #:libc libc #:defines defines)))
+    (target (file-name target-file-name)
+            (inputs (cons hex2-target dependencies))
+            (method (LINK.hex2 #:hex2 hex2 #:debug? (eq? libc libc-mes.E))))))
+
+(define* (bin.gcc input-file-name #:key (libc #t) (cc (if libc %CC %CC32)) (dependencies '()) (defines '()))
+  (let* ((base-name (base-name input-file-name ".c"))
+         (suffix (if libc ".gcc" ".mlibc-gcc"))
+         (target-file-name (string-append base-name suffix))
+         (o-target (compile.gcc input-file-name #:cc cc #:libc libc #:defines defines)))
+    (target (file-name target-file-name)
+            (inputs (list o-target))
+            (method (LINK.gcc #:cc cc #:libc libc)))))
+
+(define* (snarf input-file-name #:key (dependencies '()) (mes? #t))
+  (let* ((base-name (base-name input-file-name ".c"))
+         (suffixes '(".h" ".i" ".environment.i" ".symbol-names.i" ".symbols.i"  ".symbols.h"))
+         (suffixes (if mes? (map (cut string-append ".mes" <>) suffixes) suffixes))
+         (target-file-names (map (cut string-append base-name <>) suffixes))
+         (snarf-target (target (file-name input-file-name))))
+    (target (file-name (car target-file-names))
+            (file-names (cdr target-file-names))
+            (inputs (cons snarf-target dependencies))
+            ;;(inputs (list snarf-target))
+            (method (SNARF.mes mes?)))))
+
+(define (add-target o)
+  (set! %targets (append %targets (list o)))
+  o)
+(define (get-target o)
+  (find (lambda (t)
+          (equal? (target-file-name t) o)) %targets))
diff --git a/guile/guix/records.scm b/guile/guix/records.scm
new file mode 100644 (file)
index 0000000..7de5fcc
--- /dev/null
@@ -0,0 +1,378 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix records)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 rdelim)
+  #:export (define-record-type*
+            alist->record
+            object->fields
+            recutils->alist))
+
+;;; Commentary:
+;;;
+;;; Utilities for dealing with Scheme records.
+;;;
+;;; Code:
+
+(define-syntax record-error
+  (syntax-rules ()
+    "Report a syntactic error in use of CONSTRUCTOR."
+    ((_ constructor form fmt args ...)
+     (syntax-violation constructor
+                       (format #f fmt args ...)
+                       form))))
+
+(define (report-invalid-field-specifier name bindings)
+  "Report the first invalid binding among BINDINGS."
+  (let loop ((bindings bindings))
+    (syntax-case bindings ()
+      (((field value) rest ...)                   ;good
+       (loop #'(rest ...)))
+      ((weird _ ...)                              ;weird!
+       (syntax-violation name "invalid field specifier" #'weird)))))
+
+(define-syntax make-syntactic-constructor
+  (syntax-rules ()
+    "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
+expects all of EXPECTED fields to be initialized.  DEFAULTS is the list of
+FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
+fields, and DELAYED is the list of identifiers of delayed fields."
+    ((_ type name ctor (expected ...)
+        #:thunked thunked
+        #:delayed delayed
+        #:innate innate
+        #:defaults defaults)
+     (define-syntax name
+       (lambda (s)
+         (define (record-inheritance orig-record field+value)
+           ;; Produce code that returns a record identical to ORIG-RECORD,
+           ;; except that values for the FIELD+VALUE alist prevail.
+           (define (field-inherited-value f)
+             (and=> (find (lambda (x)
+                            (eq? f (car (syntax->datum x))))
+                          field+value)
+                    car))
+
+           ;; Make sure there are no unknown field names.
+           (let* ((fields     (map (compose car syntax->datum) field+value))
+                  (unexpected (lset-difference eq? fields '(expected ...))))
+             (when (pair? unexpected)
+               (record-error 'name s "extraneous field initializers ~a"
+                             unexpected)))
+
+           #`(make-struct type 0
+                          #,@(map (lambda (field index)
+                                    (or (field-inherited-value field)
+                                        (if (innate-field? field)
+                                            (wrap-field-value
+                                             field (field-default-value field))
+                                            #`(struct-ref #,orig-record
+                                                          #,index))))
+                                  '(expected ...)
+                                  (iota (length '(expected ...))))))
+
+         (define (thunked-field? f)
+           (memq (syntax->datum f) 'thunked))
+
+         (define (delayed-field? f)
+           (memq (syntax->datum f) 'delayed))
+
+         (define (innate-field? f)
+           (memq (syntax->datum f) 'innate))
+
+         (define (wrap-field-value f value)
+           (cond ((thunked-field? f)
+                  #`(lambda () #,value))
+                 ((delayed-field? f)
+                  #`(delay #,value))
+                 (else value)))
+
+         (define default-values
+           ;; List of symbol/value tuples.
+           (map (match-lambda
+                  ((f v)
+                   (list (syntax->datum f) v)))
+                #'defaults))
+
+         (define (field-default-value f)
+           (car (assoc-ref default-values (syntax->datum f))))
+
+         (define (field-bindings field+value)
+           ;; Return field to value bindings, for use in 'let*' below.
+           (map (lambda (field+value)
+                  (syntax-case field+value ()
+                    ((field value)
+                     #`(field
+                        #,(wrap-field-value #'field #'value)))))
+                field+value))
+
+         (syntax-case s (inherit expected ...)
+           ((_ (inherit orig-record) (field value) (... ...))
+            #`(let* #,(field-bindings #'((field value) (... ...)))
+                #,(record-inheritance #'orig-record
+                                      #'((field value) (... ...)))))
+           ((_ (field value) (... ...))
+            (let ((fields (map syntax->datum #'(field (... ...)))))
+              (define (field-value f)
+                (or (find (lambda (x)
+                            (eq? f (syntax->datum x)))
+                          #'(field (... ...)))
+                    (wrap-field-value f (field-default-value f))))
+
+              (let ((fields (append fields (map car default-values))))
+                (cond ((lset= eq? fields '(expected ...))
+                       #`(let* #,(field-bindings
+                                  #'((field value) (... ...)))
+                           (ctor #,@(map field-value '(expected ...)))))
+                      ((pair? (lset-difference eq? fields
+                                               '(expected ...)))
+                       (record-error 'name s
+                                     "extraneous field initializers ~a"
+                                     (lset-difference eq? fields
+                                                      '(expected ...))))
+                      (else
+                       (record-error 'name s
+                                     "missing field initializers ~a"
+                                     (lset-difference eq?
+                                                      '(expected ...)
+                                                      fields)))))))
+           ((_ bindings (... ...))
+            ;; One of BINDINGS doesn't match the (field value) pattern.
+            ;; Report precisely which one is faulty, instead of letting the
+            ;; "source expression failed to match any pattern" error.
+            (report-invalid-field-specifier 'name
+                                            #'(bindings (... ...))))))))))
+
+(define-syntax-rule (define-field-property-predicate predicate property)
+  "Define PREDICATE as a procedure that takes a syntax object and, when passed
+a field specification, returns the field name if it has the given PROPERTY."
+  (define (predicate s)
+    (syntax-case s (property)
+      ((field (property values (... ...)) _ (... ...))
+       #'field)
+      ((field _ properties (... ...))
+       (predicate #'(field properties (... ...))))
+      (_ #f))))
+
+(define-syntax define-record-type*
+  (lambda (s)
+    "Define the given record type such that an additional \"syntactic
+constructor\" is defined, which allows instances to be constructed with named
+field initializers, à la SRFI-35, as well as default values.  An example use
+may look like this:
+
+  (define-record-type* <thing> thing make-thing
+    thing?
+    (name  thing-name (default \"chbouib\"))
+    (port  thing-port
+           (default (current-output-port)) (thunked))
+    (loc   thing-location (innate) (default (current-source-location))))
+
+This example defines a macro 'thing' that can be used to instantiate records
+of this type:
+
+  (thing
+    (name \"foo\")
+    (port (current-error-port)))
+
+The value of 'name' or 'port' could as well be omitted, in which case the
+default value specified in the 'define-record-type*' form is used:
+
+  (thing)
+
+The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
+actually compute the field's value in the current dynamic extent, which is
+useful when referring to fluids in a field's value.
+
+A field can also be marked as \"delayed\" instead of \"thunked\", in which
+case its value is effectively wrapped in a (delay …) form.
+
+It is possible to copy an object 'x' created with 'thing' like this:
+
+  (thing (inherit x) (name \"bar\"))
+
+This expression returns a new object equal to 'x' except for its 'name'
+field and its 'loc' field---the latter is marked as \"innate\", so it is not
+inherited."
+
+    (define (field-default-value s)
+      (syntax-case s (default)
+        ((field (default val) _ ...)
+         (list #'field #'val))
+        ((field _ properties ...)
+         (field-default-value #'(field properties ...)))
+        (_ #f)))
+
+    (define-field-property-predicate delayed-field? delayed)
+    (define-field-property-predicate thunked-field? thunked)
+    (define-field-property-predicate innate-field? innate)
+
+    (define (wrapped-field? s)
+      (or (thunked-field? s) (delayed-field? s)))
+
+    (define (wrapped-field-accessor-name field)
+      ;; Return the name (an unhygienic syntax object) of the "real"
+      ;; getter for field, which is assumed to be a wrapped field.
+      (syntax-case field ()
+        ((field get properties ...)
+         (let* ((getter      (syntax->datum #'get))
+                (real-getter (symbol-append '% getter '-real)))
+           (datum->syntax #'get real-getter)))))
+
+    (define (field-spec->srfi-9 field)
+      ;; Convert a field spec of our style to a SRFI-9 field spec of the
+      ;; form (field get).
+      (syntax-case field ()
+        ((name get properties ...)
+         #`(name
+            #,(if (wrapped-field? field)
+                  (wrapped-field-accessor-name field)
+                  #'get)))))
+
+    (define (thunked-field-accessor-definition field)
+      ;; Return the real accessor for FIELD, which is assumed to be a
+      ;; thunked field.
+      (syntax-case field ()
+        ((name get _ ...)
+         (with-syntax ((real-get (wrapped-field-accessor-name field)))
+           #'(define-inlinable (get x)
+               ;; The real value of that field is a thunk, so call it.
+               ((real-get x)))))))
+
+    (define (delayed-field-accessor-definition field)
+      ;; Return the real accessor for FIELD, which is assumed to be a
+      ;; delayed field.
+      (syntax-case field ()
+        ((name get _ ...)
+         (with-syntax ((real-get (wrapped-field-accessor-name field)))
+           #'(define-inlinable (get x)
+               ;; The real value of that field is a promise, so force it.
+               (force (real-get x)))))))
+
+    (syntax-case s ()
+      ((_ type syntactic-ctor ctor pred
+          (field get properties ...) ...)
+       (let* ((field-spec #'((field get properties ...) ...))
+              (thunked    (filter-map thunked-field? field-spec))
+              (delayed    (filter-map delayed-field? field-spec))
+              (innate     (filter-map innate-field? field-spec))
+              (defaults   (filter-map field-default-value
+                                      #'((field properties ...) ...))))
+         (with-syntax (((field-spec* ...)
+                        (map field-spec->srfi-9 field-spec))
+                       ((thunked-field-accessor ...)
+                        (filter-map (lambda (field)
+                                      (and (thunked-field? field)
+                                           (thunked-field-accessor-definition
+                                            field)))
+                                    field-spec))
+                       ((delayed-field-accessor ...)
+                        (filter-map (lambda (field)
+                                      (and (delayed-field? field)
+                                           (delayed-field-accessor-definition
+                                            field)))
+                                    field-spec)))
+           #`(begin
+               (define-record-type type
+                 (ctor field ...)
+                 pred
+                 field-spec* ...)
+               thunked-field-accessor ...
+               delayed-field-accessor ...
+               (make-syntactic-constructor type syntactic-ctor ctor
+                                           (field ...)
+                                           #:thunked #,thunked
+                                           #:delayed #,delayed
+                                           #:innate #,innate
+                                           #:defaults #,defaults))))))))
+
+(define* (alist->record alist make keys
+                        #:optional (multiple-value-keys '()))
+  "Apply MAKE to the values associated with KEYS in ALIST.  Items in KEYS that
+are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple
+times in ALIST, and thus their value is a list."
+  (let ((args (map (lambda (key)
+                     (if (member key multiple-value-keys)
+                         (filter-map (match-lambda
+                                      ((k . v)
+                                       (and (equal? k key) v)))
+                                     alist)
+                         (assoc-ref alist key)))
+                   keys)))
+    (apply make args)))
+
+(define (object->fields object fields port)
+  "Write OBJECT (typically a record) as a series of recutils-style fields to
+PORT, according to FIELDS.  FIELDS must be a list of field name/getter pairs."
+  (let loop ((fields fields))
+    (match fields
+      (()
+       object)
+      (((field . get) rest ...)
+       (format port "~a: ~a~%" field (get object))
+       (loop rest)))))
+
+(define %recutils-field-charset
+  ;; Valid characters starting a recutils field.
+  ;; info "(recutils) Fields"
+  (char-set-union char-set:upper-case
+                  char-set:lower-case
+                  (char-set #\%)))
+
+(define (recutils->alist port)
+  "Read a recutils-style record from PORT and return it as a list of key/value
+pairs.  Stop upon an empty line (after consuming it) or EOF."
+  (let loop ((line   (read-line port))
+             (result '()))
+    (cond ((eof-object? line)
+           (reverse result))
+          ((string-null? line)
+           (if (null? result)
+               (loop (read-line port) result)     ; leading space: ignore it
+               (reverse result)))                 ; end-of-record marker
+          (else
+           ;; Now check the first character of LINE, since that's what the
+           ;; recutils manual says is enough.
+           (let ((first (string-ref line 0)))
+             (cond
+              ((char-set-contains? %recutils-field-charset first)
+               (let* ((colon (string-index line #\:))
+                      (field (string-take line colon))
+                      (value (string-trim (string-drop line (+ 1 colon)))))
+                 (loop (read-line port)
+                       (alist-cons field value result))))
+              ((eqv? first #\#)                   ;info "(recutils) Comments"
+               (loop (read-line port) result))
+              ((eqv? first #\+)                   ;info "(recutils) Fields"
+               (let ((new-line (if (string-prefix? "+ " line)
+                                   (string-drop line 2)
+                                   (string-drop line 1))))
+                (match result
+                  (((field . value) rest ...)
+                   (loop (read-line port)
+                         `((,field . ,(string-append value "\n" new-line))
+                           ,@rest))))))
+              (else
+               (error "unmatched line" line))))))))
+
+;;; records.scm ends here
diff --git a/guile/guix/shell-utils.scm b/guile/guix/shell-utils.scm
new file mode 100644 (file)
index 0000000..4e1dc5d
--- /dev/null
@@ -0,0 +1,93 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix shell-utils)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:export (dump-port
+            mkdir-p
+            with-directory-excursion))
+
+;;;
+;;; Directories.
+;;;
+
+(define (mkdir-p dir)
+  "Create directory DIR and all its ancestors."
+  (define absolute?
+    (string-prefix? "/" dir))
+
+  (define not-slash
+    (char-set-complement (char-set #\/)))
+
+  (let loop ((components (string-tokenize dir not-slash))
+             (root       (if absolute?
+                             ""
+                             ".")))
+    (match components
+      ((head tail ...)
+       (let ((path (string-append root "/" head)))
+         (catch 'system-error
+           (lambda ()
+             (mkdir path)
+             (loop tail path))
+           (lambda args
+             (if (= EEXIST (system-error-errno args))
+                 (loop tail path)
+                 (apply throw args))))))
+      (() #t))))
+
+(define-syntax-rule (with-directory-excursion dir body ...)
+  "Run BODY with DIR as the process's current directory."
+  (let ((init (getcwd)))
+   (dynamic-wind
+     (lambda ()
+       (chdir dir))
+     (lambda ()
+       body ...)
+     (lambda ()
+       (chdir init)))))
+
+(define* (dump-port in out
+                    #:key (buffer-size 16384)
+                    (progress (lambda (t k) (k))))
+  "Read as much data as possible from IN and write it to OUT, using chunks of
+BUFFER-SIZE bytes.  Call PROGRESS at the beginning and after each successful
+transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
+transferred and the continuation of the transfer as a thunk."
+  (define buffer
+    (make-bytevector buffer-size))
+
+  (define (loop total bytes)
+    (or (eof-object? bytes)
+        (let ((total (+ total bytes)))
+          (put-bytevector out buffer 0 bytes)
+          (progress total
+                    (lambda ()
+                      (loop total
+                            (get-bytevector-n! in buffer 0 buffer-size)))))))
+
+  ;; Make sure PROGRESS is called when we start so that it can measure
+  ;; throughput.
+  (progress 0
+            (lambda ()
+              (loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))
index 7e53951e635d87e524c0cbdb1dad6ffa2fa6f665..357ec3f47e518bb3ef2df6b9a677df616cae0f0a 100755 (executable)
@@ -37,7 +37,7 @@ 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 (mes M1)
   #:use-module (ice-9 getopt-long)
   #:use-module (ice-9 pretty-print)
   #:use-module (srfi srfi-1)
@@ -145,16 +145,16 @@ Usage: mescc.scm [OPTION]... FILE...
         (if (and (not compile?)
                  (not preprocess?)) (set-port-encoding! (current-output-port) "ISO-8859-1"))
         (cond ((pair? objects) (let ((objects (map read-object objects)))
-                                 (if compile? (objects->hex2 objects)
+                                 (if compile? (objects->M1 objects)
                                      (objects->elf objects))))
               ((pair? asts) (let* ((infos (map main:ast->info asts))
                                    (objects (map info->object infos)))
-                              (if compile? (objects->hex2 objects)
+                              (if compile? (objects->M1 objects)
                                   (objects->elf objects))))
               ((pair? sources) (if preprocess? (map (source->ast defines includes) sources)
                                    (let* ((infos (map (source->info defines includes) sources))
                                           (objects (map info->object infos)))
-                                     (if compile? (objects->hex2 objects)
+                                     (if compile? (objects->M1 objects)
                                          (objects->elf objects))))))))
     (if (and (not compile?)
              (not preprocess?))
diff --git a/make.scm b/make.scm
new file mode 100755 (executable)
index 0000000..52e57cd
--- /dev/null
+++ b/make.scm
@@ -0,0 +1,224 @@
+#! /usr/bin/env guile
+!#
+
+(set! %load-path (cons "guile" %load-path))
+(set! %load-path (cons "../guix" %load-path))
+(set! %load-compiled-path (cons "guile" %load-compiled-path))
+(set! %load-compiled-path (cons "../guix" %load-compiled-path))
+
+(use-modules (guix shell-utils))
+
+;; FIXME: .go dependencies
+;; workaround: always update .go before calculating hashes
+;;(use-modules ((mes make) #:select (sytem**)))
+(let* ((scm-files '("guix/make.scm"
+                    "guix/records.scm"
+                    "guix/shell-utils.scm"
+                    "language/c99/compiler.scm"
+                    "mes/as-i386.scm"
+                    "mes/as.scm"
+                    "mes/elf.scm"
+                    "mes/M1.scm")))
+  (setenv "srcdir" "guile")
+  (setenv "host" %host-type)
+  (with-directory-excursion "guile"
+    (apply system* `("guile"
+                     "--no-auto-compile"
+                     "-L" "."
+                     "-C" "."
+                     "-s"
+                     "../build-aux/compile-all.scm"
+                     ,@scm-files))))
+
+(use-modules (srfi srfi-1)
+             (srfi srfi-26)
+             (ice-9 match)
+             (guix make))
+
+(add-target (bin.mescc "stage0/exit-42.c" #:libc #f))
+(add-target (check "stage0/exit-42.0-guile" #:signal 11))  ; FIXME: segfault
+
+(add-target (bin.mescc "stage0/exit-42.c" #:libc mini-libc-mes.E))
+(add-target (check "stage0/exit-42.mini-guile" #:exit 42))
+
+(add-target (bin.mescc "stage0/exit-42.c"))
+(add-target (check "stage0/exit-42.guile" #:exit 42))
+
+
+(add-target (bin.gcc "scaffold/hello.c"))
+(add-target (check "scaffold/hello.gcc" #:exit 42))
+
+(add-target (bin.gcc "scaffold/hello.c" #:libc #f))
+(add-target (check "scaffold/hello.mlibc-gcc" #:exit 42))
+
+(add-target (bin.mescc "scaffold/hello.c" #:libc mini-libc-mes.E))
+(add-target (check "scaffold/hello.mini-guile" #:exit 42))
+
+(add-target (bin.mescc "scaffold/hello.c"))
+(add-target (check "scaffold/hello.guile" #:exit 42))
+
+
+(add-target (bin.gcc "scaffold/m.c"))
+(add-target (check "scaffold/m.gcc" #:exit 255))
+
+(add-target (bin.gcc "scaffold/m.c" #:libc #f))
+(add-target (check "scaffold/m.mlibc-gcc" #:exit 255))
+
+(add-target (bin.mescc "scaffold/m.c"))
+(add-target (check "scaffold/m.guile" #:exit 255))
+
+
+(add-target (bin.gcc "scaffold/t-tcc.c"))
+(add-target (check "scaffold/t-tcc.gcc"))
+
+(add-target (bin.gcc "scaffold/t-tcc.c" #:libc #f))
+(add-target (check "scaffold/t-tcc.mlibc-gcc"))
+
+(add-target (bin.mescc "scaffold/t-tcc.c"))
+(add-target (check "scaffold/t-tcc.guile"))
+
+
+(add-target (bin.gcc "scaffold/micro-mes.c" #:libc #f))
+(add-target (check "scaffold/micro-mes.mlibc-gcc" #:exit 1))
+
+(add-target (bin.mescc "scaffold/micro-mes.c"))
+(add-target (check "scaffold/micro-mes.guile" #:exit 1))
+
+
+(add-target (bin.gcc "scaffold/t.c"))
+(add-target (check "scaffold/t.gcc"))
+
+(add-target (bin.gcc "scaffold/t.c" #:libc #f))
+(add-target (check "scaffold/t.mlibc-gcc"))
+
+(add-target (bin.mescc "scaffold/t.c"))
+(add-target (check "scaffold/t.guile"))
+
+(define snarf-bases
+  '("gc" "lib" "math" "mes" "posix" "reader" "vector"))
+
+(define bla
+  `(,@(map (cut string-append "src/" <> ".c") snarf-bases)
+    ,@(map (cut string-append "src/" <> ".mes.h") snarf-bases)
+    ,@(map (cut string-append "src/" <> ".mes.i") snarf-bases)
+    ,@(map (cut string-append "src/" <> ".mes.environment.i") snarf-bases)))
+
+(define gcc-snarf-targets
+  (list
+   (add-target (snarf "src/gc.c" #:mes? #f))
+   (add-target (snarf "src/lib.c" #:mes? #f))
+   (add-target (snarf "src/math.c" #:mes? #f))
+   (add-target (snarf "src/mes.c" #:mes? #f))
+   (add-target (snarf "src/posix.c" #:mes? #f))
+   (add-target (snarf "src/reader.c" #:mes? #f))
+   (add-target (snarf "src/vector.c" #:mes? #f))))
+
+(define mes-snarf-targets
+  (list
+   (add-target (snarf "src/gc.c" #:mes? #t))
+   (add-target (snarf "src/lib.c" #:mes? #t))
+   (add-target (snarf "src/math.c" #:mes? #t))
+   (add-target (snarf "src/mes.c" #:mes? #t))
+   (add-target (snarf "src/posix.c" #:mes? #t))
+   (add-target (snarf "src/reader.c" #:mes? #t))
+   (add-target (snarf "src/vector.c" #:mes? #t))))
+
+(define VERSION "0.8")
+(define PREFIX (or (getenv "PREFIX") "/usr/local"))
+(define DATADIR (or (getenv "DATADIR") (string-append PREFIX " /share")))
+(define MODULEDIR (or (getenv "MODULEDIR") (string-append DATADIR "/module/")))
+
+(add-target (bin.gcc "src/mes.c" #:dependencies gcc-snarf-targets
+                     #:defines `("FIXED_PRIMITIVES=1"
+                                 "MES_FULL=1"
+                                 "POSIX=1"
+                                 ,(string-append "VERSION=\"" VERSION "\"")
+                                 ,(string-append "MODULEDIR=\"" MODULEDIR "\"")
+                                 ,(string-append "PREFIX=\"" PREFIX "\""))))
+
+(add-target (bin.gcc "src/mes.c" #:libc #f
+                     #:dependencies mes-snarf-targets
+                     #:defines `("FIXED_PRIMITIVES=1"
+                                 "MES_FULL=1"
+                                 ,(string-append "VERSION=\"" VERSION "\"")
+                                 ,(string-append "MODULEDIR=\"" MODULEDIR "\"")
+                                 ,(string-append "PREFIX=\"" PREFIX "\""))))
+
+(add-target (bin.mescc "src/mes.c" #:dependencies mes-snarf-targets
+                       #:defines `("FIXED_PRIMITIVES=1"
+                                   "MES_FULL=1"
+                                 ,(string-append "VERSION=\"" VERSION "\"")
+                                 ,(string-append "MODULEDIR=\"" MODULEDIR "\"")
+                                 ,(string-append "PREFIX=\"" PREFIX "\""))))
+
+(define mes-tests
+  '("tests/read.test"
+    "tests/base.test"
+    "tests/closure.test"
+    "tests/quasiquote.test"
+    "tests/let.test"
+    "tests/scm.test"
+    "tests/display.test"
+    "tests/cwv.test"
+    "tests/math.test"
+    "tests/vector.test"
+    "tests/srfi-1.test"
+    "tests/srfi-13.test"
+    "tests/srfi-14.test"
+    "tests/optargs.test"
+    "tests/fluids.test"
+    "tests/catch.test"
+    "tests/psyntax.test"
+    "tests/pmatch.test"
+    "tests/let-syntax.test"
+    "tests/guile.test"
+    "tests/record.test"
+    ;;sloooowwww
+    ;;"tests/match.test"
+    ;;"tests/peg.test"
+    ))
+
+(define (add-mes.gcc-test o)
+  (add-target (target (file-name o)))
+  (add-target (check o #:dependencies (list (get-target "src/mes.mlibc-gcc")))))
+
+(define (add-mes.guile-test o)
+  (add-target (target (file-name o)))
+  (add-target (check o #:dependencies (list (get-target "src/mes.guile")))))
+
+;; takes long, and should always pass if...
+;;(for-each add-mes.gcc-test mes-tests)
+
+;; ...mes.guile passes :-)
+(for-each add-mes.guile-test mes-tests)
+
+;; FIXME: run tests/base.test
+(setenv "MES" "src/mes.guile")
+
+(define (check-target? o)
+  (string-prefix? "check-" (target-file-name o)))
+
+(define (main args)
+  (cond ((member "clean" args) (clean))
+        ((member "help" args) (display "Usage: ./make.scm [TARGET]...
+
+Targets:
+    all
+    check
+    clean
+
+    stage0/exit42.mini-guile
+    scaffold/hello.guile
+    src/mes.guile
+"))
+        (else
+         (let ((targets (match args
+                          (() (filter (negate check-target?) %targets))
+                          ((? (cut member "all" <>)) (filter (negate check-target?) %targets))
+                          ((? (cut member "check" <>)) (filter check-target? %targets))
+                          (_ (filter-map (cut get-target <>) args)))))
+           (for-each build targets)
+           ;;((@@ (mes make) store) #:print 0)
+           (exit %status)))))
+
+(main (cdr (command-line)))
index 83a58f93eeb65e9c6a10b2cc52ac4c6b2631d367..8c31ed941c4c5d92751fd2bfd57c5792488367c1 100644 (file)
@@ -34,9 +34,9 @@ void
 exit (int code)
 {
   asm (
-       "movl %0,%%ebx\n\t"
-       "movl $1,%%eax\n\t"
-       "int  $0x80"
+       "mov    %0,%%ebx\n\t"
+       "mov    $1,%%eax\n\t"
+       "int    $0x80"
        : // no outputs "=" (r)
        : "" (code)
        );
@@ -50,14 +50,14 @@ read (int fd, void* buf, size_t n)
   int r;
   //syscall (SYS_write, fd, s, n));
   asm (
-       "movl %1,%%ebx\n\t"
-       "movl %2,%%ecx\n\t"
-       "movl %3,%%edx\n\t"
+       "mov    %1,%%ebx\n\t"
+       "mov    %2,%%ecx\n\t"
+       "mov    %3,%%edx\n\t"
 
        "movl $0x3,%%eax\n\t"
        "int  $0x80\n\t"
 
-       "mov %%eax,%0\n\t"
+       "mov    %%eax,%0\n\t"
        : "=r" (r)
        : "" (fd), "" (buf), "" (n)
        : "eax", "ebx", "ecx", "edx"
@@ -71,13 +71,13 @@ write (int fd, char const* s, int n)
   int r;
   //syscall (SYS_write, fd, s, n));
   asm (
-       "mov %1,%%ebx\n\t"
-       "mov %2,%%ecx\n\t"
-       "mov %3,%%edx\n\t"
+       "mov    %1,%%ebx\n\t"
+       "mov    %2,%%ecx\n\t"
+       "mov    %3,%%edx\n\t"
 
-       "mov $0x4, %%eax\n\t"
-       "int $0x80\n\t"
-       "mov %%eax,%0\n\t"
+       "mov    $0x4, %%eax\n\t"
+       "int    $0x80\n\t"
+       "mov    %%eax,%0\n\t"
        : "=r" (r)
        : "" (fd), "" (s), "" (n)
        : "eax", "ebx", "ecx", "edx"
@@ -90,22 +90,22 @@ open (char const *s, int flags, ...)
 {
   int mode;
   asm (
-       "mov %%ebp,%%eax\n\t"
-       "add $0x10,%%eax\n\t"
-       "mov (%%eax),%%eax\n\t"
-       "mov %%eax,%0\n\t"
+       "mov    %%ebp,%%eax\n\t"
+       "add    $0x10,%%eax\n\t"
+       "mov    (%%eax),%%eax\n\t"
+       "mov    %%eax,%0\n\t"
        : "=mode" (mode)
        : //no inputs ""
        );
   int r;
   //syscall (SYS_open, mode));
   asm (
-       "mov %1,%%ebx\n\t"
-       "mov %2,%%ecx\n\t"
-       "mov %3,%%edx\n\t"
-       "mov $0x5,%%eax\n\t"
-       "int $0x80\n\t"
-       "mov %%eax,%0\n\t"
+       "mov    %1,%%ebx\n\t"
+       "mov    %2,%%ecx\n\t"
+       "mov    %3,%%edx\n\t"
+       "mov    $0x5,%%eax\n\t"
+       "int    $0x80\n\t"
+       "mov    %%eax,%0\n\t"
        : "=r" (r)
        : "" (s), "" (flags), "" (mode)
        : "eax", "ebx", "ecx", "edx"
@@ -119,11 +119,11 @@ access (char const *s, int mode)
   int r;
   //syscall (SYS_access, mode));
   asm (
-       "mov %1,%%ebx\n\t"
-       "mov %2,%%ecx\n\t"
-       "mov $0x21,%%eax\n\t"
-       "int $0x80\n\t"
-       "mov %%eax,%0\n\t"
+       "mov    %1,%%ebx\n\t"
+       "mov    %2,%%ecx\n\t"
+       "mov    $0x21,%%eax\n\t"
+       "int    $0x80\n\t"
+       "mov    %%eax,%0\n\t"
        : "=r" (r)
        : "" (s), "" (mode)
        : "eax", "ebx", "ecx"
@@ -136,12 +136,12 @@ brk (void *p)
 {
   void *r;
   asm (
-       "mov %1,%%ebx\n\t"
+       "mov    %1,%%ebx\n\t"
 
-       "mov $0x2d,%%eax\n\t"
-       "int $0x80\n\t"
+       "mov    $0x2d,%%eax\n\t"
+       "int    $0x80\n\t"
 
-       "mov %%eax,%0\n\t"
+       "mov    %%eax,%0\n\t"
        : "=r" (r)
        : "" (p)
        : "eax", "ebx"
@@ -155,11 +155,11 @@ fsync (int fd)
   int r;
   //syscall (SYS_fsync, fd));
   asm (
-       "mov %1,%%ebx\n\t"
+       "mov    %1,%%ebx\n\t"
 
-       "mov $0x76, %%eax\n\t"
-       "int $0x80\n\t"
-       "mov %%eax,%0\n\t"
+       "mov    $0x76, %%eax\n\t"
+       "int    $0x80\n\t"
+       "mov    %%eax,%0\n\t"
        : "=r" (r)
        : "" (fd)
        : "eax", "ebx"
index cfc930c8ee4e1fb58d872b29cd225c372beb9de3..dfddccb89ed50125541371a8aade876e0cebb8f4 100644 (file)
@@ -27,25 +27,27 @@ int main(int,char*[]);
 int
 _start ()
 {
-  asm (".byte 0x89 0xe8");      // mov    %ebp,%eax
-  asm (".byte 0x83 0xc0 0x08"); // add    $0x8,%eax
-  asm (".byte 0x50");           // push   %eax
-
-  asm (".byte 0x89 0xe8");      // mov    %ebp,%eax
-  asm (".byte 0x83 0xc0 0x04"); // add    $0x4,%eax
-  asm (".byte 0x0f 0xb6 0x00"); // movzbl (%eax),%eax
-  asm (".byte 0x50");           // push   %eax
-
-  asm (".byte 0x89 0xe8");      // mov    %ebp,%eax
-  asm (".byte 0x83 0xc0 0x04"); // add    $0x4,%eax
-  asm (".byte 0x0f 0xb6 0x00"); // movzbl (%eax),%eax
-  asm (".byte 0x83 0xc0 0x03"); // add    $0x3,%eax
-  asm (".byte 0xc1 0xe0 0x02"); // shl    $0x2,%eax
-  asm (".byte 0x01 0xe8");      // add    %ebp,%eax
-  asm (".byte 0x50");           // push   %eax
+  asm ("mov____%ebp,%eax");      // mov    %ebp,%eax
+  asm ("add____$i8,%eax !8");    // add    $0x8,%eax
+  asm ("push___%eax");           // push   %eax
+
+  asm ("mov____%ebp,%eax");      // mov    %ebp,%eax
+  asm ("add____$i8,%eax !4");    // add    $0x4,%eax
+  asm ("movzbl_(%eax),%eax");    // movzbl (%eax),%eax
+  asm ("push___%eax");           // push   %eax
+
+  asm ("mov____%ebp,%eax");      // mov    %ebp,%eax
+  asm ("add____$i8,%eax !4");    // add    $0x4,%eax
+
+  asm ("movzbl_(%eax),%eax");    // movzbl (%eax),%eax
+  asm ("add____$i8,%eax !3");    // add    $0x3,%eax
+
+  asm ("shl____$i8,%eax !0x02"); // shl    $0x2,%eax
+  asm ("add____%ebp,%eax");      // add    %ebp,%eax
+  asm ("push___%eax");           // push   %eax
 
   g_environment = _env ();
-  asm (".byte 0x58");
+  asm ("pop____%eax");           // pop   %eax
   int r = main ();
   exit (r);
 }
@@ -59,68 +61,71 @@ _env (char **e)
 void
 exit ()
 {
-  asm (".byte 0x8b 0x5d 0x08");                    // mov    0x8(%ebp),%ebx
-  asm (".byte 0xb8 0x01 0x00 0x00 0x00");          // mov    $0x1,%eax
-  asm (".byte 0xcd 0x80");                         // int    $0x80
+  asm ("mov____0x8(%ebp),%ebx !8");               // mov    0x8(%ebp),%ebx
+
+  asm ("mov____$i32,%eax SYS_exit");              // mov    $0x1,%eax
+  asm ("int____$0x80");                           // int    $0x80
 }
 
 void
 read ()
 {
-  asm (".byte 0x8b 0x5d 0x08");                    // mov    0x8(%ebp),%ebx
-  asm (".byte 0x8b 0x4d 0x0c");                    // mov    0xc(%ebp),%ecx
-  asm (".byte 0x8b 0x55 0x10");                    // mov    0x10(%ebp),%edx
+  asm ("mov____0x8(%ebp),%ebx !8");               // mov    0x8(%ebp),%ebx
+  asm ("mov____0x8(%ebp),%ecx !12");              // mov    0x8(%ebp),%ecx
+  asm ("mov____0x8(%ebp),%edx !16");              // mov    0x8(%ebp),%edx
 
-  asm (".byte 0xb8 0x03 0x00 0x00 0x00");          // mov    $0x3,%eax
-  asm (".byte 0xcd 0x80");                         // int    $0x80
+  asm ("mov____$i32,%eax SYS_read");              // mov    $0x3,%eax
+  asm ("int____$0x80");                           // int    $0x80
 }
 
 void
 write ()
 {
-  asm (".byte 0x8b 0x5d 0x08");                   // mov    0x8(%ebp),%ebx
-  asm (".byte 0x8b 0x4d 0x0c");                   // mov    0xc(%ebp),%ecx
-  asm (".byte 0x8b 0x55 0x10");                   // mov    0x10(%ebp),%edx
+  asm ("mov____0x8(%ebp),%ebx !8");               // mov    0x8(%ebp),%ebx
+  asm ("mov____0x8(%ebp),%ecx !12");              // mov    0x8(%ebp),%ecx
+  asm ("mov____0x8(%ebp),%edx !16");              // mov    0x8(%ebp),%edx
 
-  asm (".byte 0xb8 0x04 0x00 0x00 0x00");         // mov    $0x4,%eax
-  asm (".byte 0xcd 0x80");                        // int    $0x80
+  asm ("mov____$i32,%eax SYS_write");             // mov    $0x4,%eax
+  asm ("int____$0x80");                           // int    $0x80
 }
 
 void
 open ()
 {
-  asm (".byte 0x8b 0x5d 0x08");                    // mov    0x8(%ebp),%ebx
-  asm (".byte 0x8b 0x4d 0x0c");                    // mov    0xc(%ebp),%ecx
-  asm (".byte 0x8b 0x55 0x10");                    // mov    0x10(%ebp),%edx
+  asm ("mov____0x8(%ebp),%ebx !8");               // mov    0x8(%ebp),%ebx
+  asm ("mov____0x8(%ebp),%ecx !12");              // mov    0x8(%ebp),%ecx
+  asm ("mov____0x8(%ebp),%edx !16");              // mov    0x8(%ebp),%edx
 
-  asm (".byte 0xb8 0x05 0x00 0x00 0x00");          // mov    $0x5,%eax
-  asm (".byte 0xcd 0x80");                         // int    $0x80
+  asm ("mov____$i32,%eax SYS_open");              // mov    $0x5,%eax
+  asm ("int____$0x80");                           // int    $0x80
 }
 
 void
 access ()
 {
-  asm (".byte 0x8b 0x5d 0x08");                    // mov    0x8(%ebp),%ebx
-  asm (".byte 0x8b 0x4d 0x0c");                    // mov    0xc(%ebp),%ecx
+  asm ("mov____0x8(%ebp),%ebx !8");               // mov    0x8(%ebp),%ebx
+  asm ("mov____0x8(%ebp),%ecx !12");              // mov    0x8(%ebp),%ecx
 
-  asm (".byte 0xb8 0x21 0x00 0x00 0x00");          // mov    $0x21,%eax
-  asm (".byte 0xcd 0x80");                         // int    $0x80
+  asm ("mov____$i32,%eax SYS_access");            // mov    $0x21,%eax
+  asm ("int____$0x80");                           // int    $0x80
 }
 
 void
 brk ()
 {
-  asm (".byte 0x8b 0x5d 0x08");                    // mov    0x8(%ebp),%ebx
-  asm (".byte 0xb8 0x2d 0x00 0x00 0x00");          // mov    $0x2d,%eax
-  asm (".byte 0xcd 0x80");                         // int    $0x80
+  asm ("mov____0x8(%ebp),%ebx !8");               // mov    0x8(%ebp),%ebx
+
+  asm ("mov____$i32,%eax SYS_brk");               // mov    $0x2d,%eax
+  asm ("int____$0x80");                           // int    $0x80
 }
 
 void
 fsync ()
 {
-  asm (".byte 0x8b 0x5d 0x08");                    // mov    0x8(%ebp),%ebx
-  asm (".byte 0xb8 0x76 0x00 0x00 0x00");          // mov    $0x76,%eax
-  asm (".byte 0xcd 0x80");                         // int    $0x80
+  asm ("mov____0x8(%ebp),%ebx !8");               // mov    0x8(%ebp),%ebx
+
+  asm ("mov____$i32,%eax SYS_fsync");             // mov    $0x7c,%eax
+  asm ("int____$0x80");                           // int    $0x80
 }
 
 int
@@ -183,6 +188,7 @@ assert_fail (char* s)
 
 int ungetc_char = -1;
 char ungetc_buf[2];
+
 int
 getchar ()
 {
@@ -231,6 +237,7 @@ strcmp (char const* a, char const* b)
   return *a - *b;
 }
 
+
 char *
 strcpy (char *dest, char const *src)
 {
@@ -342,6 +349,7 @@ getenv (char const* s)
   return 0;
 }
 
+
 #if 0
 
 // !__MESC__
@@ -349,17 +357,17 @@ getenv (char const* s)
 // works fine with Guile, but let's keep a single input source
 
 #define pop_va_arg \
-  asm (".byte 0x8b 0x45 0xfc"); /* mov   -<0x4>(%ebp),%eax :va_arg */ \
-  asm (".byte 0xc1 0xe0 0x02"); /* shl   $0x2,%eax */ \
-  asm (".byte 0x01 0xe8");      /* add   %ebp,%eax */ \
-  asm (".byte 0x83 0xc0 0x0c"); /* add   $0xc,%eax */ \
-  asm (".byte 0x8b 0x00");      /* mov   (%eax),%eax */ \
-  asm (".byte 0x89 0x45 0xf8"); /* mov   %eax,-0x8(%ebp) :va */ \
-  asm (".byte 0x50")            /* push   %eax */
+  asm ("mov____0x8(%ebp),%eax !-4");  /* mov   -<0x4>(%ebp),%eax :va_arg */ \
+  asm ("shl____$i8,%eax !2");         /* shl   $0x2,%eax */ \
+  asm ("add____%ebp,%eax");           /* add   %ebp,%eax */ \
+  asm ("add____$i8,%eax !12");        /* add   $0xc,%eax */ \
+  asm ("mov____(%eax),%eax");         /* mov   (%eax),%eax */ \
+  asm ("mov____%eax,0x8(%ebp) !-8");  /* mov   %eax,-0x8(%ebp) :va */ \
+  asm ("push___%eax");                /* push   %eax */
 
 #else // __MESC__
 
-#define pop_va_arg asm (".byte 0x8b 0x45 0xfc 0xc1 0xe0 0x02 0x01 0xe8 0x83 0xc0 0x0c 0x8b 0x00 0x89 0x45 0xf8 0x50")
+#define pop_va_arg asm ("mov____0x8(%ebp),%eax !-4\nshl____$i8,%eax !2\nadd____%ebp,%eax add____$i8,%eax !12\nmov____(%eax),%eax\nmov____%eax,0x8(%ebp) !-8\npush___%eax")
 
 #endif
 
@@ -388,3 +396,4 @@ printf (char const* format, int va_args)
       }
   return 0;
 }
+
index 3b88e4ddf9059dff6b7926bf02c41783183ec1e7..2478f50aeed7f6cfaa3ad4f7fc2a66ff1ca57db2 100644 (file)
  * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  */
 
-int g_stdin = 0;
-char **g_environment;
-int _env ();
 int exit ();
 int main(int,char*[]);
 
 int
 _start ()
 {
-#if 0
-  asm (".byte 0x89 0xe8");      // mov    %ebp,%eax
-  asm (".byte 0x83 0xc0 0x08"); // add    $0x8,%eax
-  asm (".byte 0x50");           // push   %eax
-
-  asm (".byte 0x89 0xe8");      // mov    %ebp,%eax
-  asm (".byte 0x83 0xc0 0x04"); // add    $0x4,%eax
-  asm (".byte 0x0f 0xb6 0x00"); // movzbl (%eax),%eax
-  asm (".byte 0x50");           // push   %eax
-
-  asm (".byte 0x89 0xe8");      // mov    %ebp,%eax
-  asm (".byte 0x83 0xc0 0x04"); // add    $0x4,%eax
-  asm (".byte 0x0f 0xb6 0x00"); // movzbl (%eax),%eax
-  asm (".byte 0x83 0xc0 0x03"); // add    $0x3,%eax
-  asm (".byte 0xc1 0xe0 0x02"); // shl    $0x2,%eax
-  asm (".byte 0x01 0xe8");      // add    %ebp,%eax
-  asm (".byte 0x50");           // push   %eax
-
-  g_environment = _env ();
-  asm (".byte 0x58");
-  int r = main ();
-  exit (r);
-#else
   int r = main ();
   exit (r);
-#endif
-}
-
-char **
-_env (char **e)
-{
-  return e;
 }
 
 void
 exit ()
 {
-  asm (".byte 0x8b 0x5d 0x08");                    // mov    0x8(%ebp),%ebx
-  asm (".byte 0xb8 0x01 0x00 0x00 0x00");          // mov    $0x1,%eax
-  asm (".byte 0xcd 0x80");                         // int    $0x80
+  asm ("mov____0x8(%ebp),%ebx !8");               // mov    0x8(%ebp),%ebx
+
+  asm ("mov____$i32,%eax SYS_exit");              // mov    $0x1,%eax
+  asm ("int____$0x80");                           // int    $0x80
 }
 
 void
 write ()
 {
-  asm (".byte 0x8b 0x5d 0x08");                   // mov    0x8(%ebp),%ebx
-  asm (".byte 0x8b 0x4d 0x0c");                   // mov    0xc(%ebp),%ecx
-  asm (".byte 0x8b 0x55 0x10");                   // mov    0x10(%ebp),%edx
+  asm ("mov____0x8(%ebp),%ebx !8");               // mov    0x8(%ebp),%ebx
+  asm ("mov____0x8(%ebp),%ecx !12");              // mov    0x8(%ebp),%ecx
+  asm ("mov____0x8(%ebp),%edx !16");              // mov    0x8(%ebp),%edx
 
-  asm (".byte 0xb8 0x04 0x00 0x00 0x00");         // mov    $0x4,%eax
-  asm (".byte 0xcd 0x80");                        // int    $0x80
+  asm ("mov____$i32,%eax SYS_write");             // mov    $0x4,%eax
+  asm ("int____$0x80");                           // int    $0x80
 }
 
 int
index 42cf683edb2fbf3de251368baa0d22b5e5663bd6..0b2c9c6c39d4543a6d6aeff9993f804a0a2a349c 100644 (file)
@@ -35,7 +35,7 @@
   (mes-use-module (nyacc lang c99 pprint))
   (mes-use-module (mes as))
   (mes-use-module (mes as-i386))
-  (mes-use-module (mes hex2))
+  (mes-use-module (mes M1))
   (mes-use-module (mes optargs))))
 
 (define (logf port string . rest)
 
         ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
-                                   (append-text info (wrap-as (asm->hex arg0))))
+                                   (append-text info (wrap-as (asm->m1 arg0))))
              (let* ((text-length (length text))
                     (args-info (let loop ((expressions (reverse expr-list)) (info info))
                                  (if (null? expressions) info
                 (info (append-text info (wrap-as (i386:accu-test))))
                 (info ((expr->accu info) b))
                 (info (append-text info (wrap-as (i386:accu-test))))
-                (info (append-text info (wrap-as `(#:label ,skip-b-label)))))
+                (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
            info))
 
         ((and ,a ,b)
                 (info (append-text info (wrap-as (i386:accu-test))))
                 (info ((expr->accu info) b))
                 (info (append-text info (wrap-as (i386:accu-test))))
-                (info (append-text info (wrap-as `(#:label ,skip-b-label)))))
+                (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
            info))
 
         ((cast ,cast ,o)
   `(,@annotation ,o))
 
 (define (make-comment o)
-  (wrap-as `(#:comment ,o)))
+  (wrap-as `((#:comment ,o))))
 
 (define (ast->comment o)
   (let ((source (with-output-to-string (lambda () (pretty-print-c99 o)))))
        (let ((g `(#:string ,string)))
          (or (assoc g globals)
              (string->global string))))
-      ((p-expr (fixed ,value)) (int->global (cstring->number value)))
+      ;;((p-expr (fixed ,value)) (int->global (cstring->number value)))
       (_ #f))))
 
 (define (initzer->global globals)
       ((initzer ,initzer) ((expr->global globals) initzer))
       (_ #f))))
 
-(define (byte->hex o)
-  (string->number (string-drop o 2) 16))
+(define (byte->hex.m1 o)
+  (string-drop o 2))
 
-(define (asm->hex o)
+(define (asm->m1 o)
   (let ((prefix ".byte "))
-    (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
+    (if (not (string-prefix? prefix o)) (map (cut string-split <> #\space) (string-split o #\newline))
         (let ((s (string-drop o (string-length prefix))))
-          (map byte->hex (string-split s #\space))))))
+          (list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " ")))))))
 
 (define (clause->info info i label last?)
   (define clause-label
       (append (wrap-as (i386:accu-cmp-value value))
               (jump-z body-label))))
   (define (cases+jump info cases)
-    (let* ((info (append-text info (wrap-as `(#:label ,clause-label))))
+    (let* ((info (append-text info (wrap-as `((#:label ,clause-label)))))
            (next-clause-label (if last? (string-append label "break")
                                   (string-append label "clause" (number->string (1+ i)))))
            (info (append-text info (apply append cases)))
            (info (if (null? cases) info
                      (append-text info (jump next-clause-label))))
-           (info (append-text info (wrap-as `(#:label ,body-label)))))
+           (info (append-text info (wrap-as `((#:label ,body-label))))))
       info))
 
   (lambda (o)
               (b-label (string-append label "_b_" here))
               (info ((test-jump-label->info info b-label) a))
               (info (append-text info (wrap-as (i386:jump skip-b-label))))
-              (info (append-text info (wrap-as `(#:label ,b-label))))
+              (info (append-text info (wrap-as `((#:label ,b-label)))))
               (info ((test-jump-label->info info label) b))
-              (info (append-text info (wrap-as `(#:label ,skip-b-label)))))
+              (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
          info))
 
       ((array-ref . _) ((jump i386:jump-byte-z
         
         ((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))))
+                                   (append-text info (wrap-as (asm->m1 arg0))))
              (let* ((info (append-text info (ast->comment o)))
                     (info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
                (append-text info (wrap-as (i386:accu-zero?))))))
                 (info ((test-jump-label->info info break-label) test))
                 (info ((ast->info info) then))
                 (info (append-text info (wrap-as (i386:jump break-label))))
-                (info (append-text info (wrap-as `(#:label ,break-label)))))
+                (info (append-text info (wrap-as `((#:label ,break-label))))))
            (clone info
                   #:locals locals)))
 
                 (info ((test-jump-label->info info else-label) test))
                 (info ((ast->info info) then))
                 (info (append-text info (wrap-as (i386:jump break-label))))
-                (info (append-text info (wrap-as `(#:label ,else-label))))
+                (info (append-text info (wrap-as `((#:label ,else-label)))))
                 (info ((ast->info info) else))
-                (info (append-text info (wrap-as `(#:label ,break-label)))))
+                (info (append-text info (wrap-as `((#:label ,break-label))))))
            (clone info
                   #:locals locals)))
 
                 (info ((test-jump-label->info info else-label) test))
                 (info ((ast->info info) then))
                 (info (append-text info (wrap-as (i386:jump break-label))))
-                (info (append-text info (wrap-as `(#:label ,else-label))))
+                (info (append-text info (wrap-as `((#:label ,else-label)))))
                 (info ((ast->info info) else))
-                (info (append-text info (wrap-as `(#:label ,break-label)))))
+                (info (append-text info (wrap-as `((#:label ,break-label))))))
            info))
 
         ((switch ,expr (compd-stmt (block-item-list . ,statements)))
                 (info (let loop ((clauses clauses) (i 0) (info info))
                         (if (null? clauses) info
                             (loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses))))))
-                (info (append-text info (wrap-as `(#:label ,break-label)))))
+                (info (append-text info (wrap-as `((#:label ,break-label))))))
            (clone info
                   #:locals locals
                   #:break (cdr (.break info)))))
                 (info (clone info #:break (cons break-label (.break info))))
                 (info (clone info #:continue (cons continue-label (.continue info))))
                 (info (append-text info (wrap-as (i386:jump initial-skip-label))))
-                (info (append-text info (wrap-as `(#:label ,loop-label))))
+                (info (append-text info (wrap-as `((#:label ,loop-label)))))
                 (info ((ast->info info) body))
-                (info (append-text info (wrap-as `(#:label ,continue-label))))
+                (info (append-text info (wrap-as `((#:label ,continue-label)))))
                 (info ((expr->accu info) step))
-                (info (append-text info (wrap-as `(#:label ,initial-skip-label))))
+                (info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
                 (info ((test-jump-label->info info break-label) test))
                 (info (append-text info (wrap-as (i386:jump loop-label))))
-                (info (append-text info (wrap-as `(#:label ,break-label)))))
+                (info (append-text info (wrap-as `((#:label ,break-label))))))
            (clone info
                   #:locals locals
                   #:break (cdr (.break info))
                 (info (append-text info (wrap-as (i386:jump continue-label))))
                 (info (clone info #:break (cons break-label (.break info))))
                 (info (clone info #:continue (cons continue-label (.continue info))))
-                (info (append-text info (wrap-as `(#:label ,loop-label))))
+                (info (append-text info (wrap-as `((#:label ,loop-label)))))
                 (info ((ast->info info) body))
-                (info (append-text info (wrap-as `(#:label ,continue-label))))
+                (info (append-text info (wrap-as `((#:label ,continue-label)))))
                 (info ((test-jump-label->info info break-label) test))
                 (info (append-text info (wrap-as (i386:jump loop-label))))
-                (info (append-text info (wrap-as `(#:label ,break-label)))))
+                (info (append-text info (wrap-as `((#:label ,break-label))))))
            (clone info
                   #:locals locals
                   #:break (cdr (.break info))
                 (continue-label (string-append label "continue"))
                 (info (clone info #:break (cons break-label (.break info))))
                 (info (clone info #:continue (cons continue-label (.continue info))))
-                (info (append-text info (wrap-as `(#:label ,loop-label))))
+                (info (append-text info (wrap-as `((#:label ,loop-label)))))
                 (info ((ast->info info) body))
-                (info (append-text info (wrap-as `(#:label ,continue-label))))
+                (info (append-text info (wrap-as `((#:label ,continue-label)))))
                 (info ((test-jump-label->info info break-label) test))
                 (info (append-text info (wrap-as (i386:jump loop-label))))
-                (info (append-text info (wrap-as `(#:label ,break-label)))))
+                (info (append-text info (wrap-as `((#:label ,break-label))))))
            (clone info
                   #:locals locals
                   #:break (cdr (.break info))
                   #:continue (cdr (.continue info)))))
 
         ((labeled-stmt (ident ,label) ,statement)
-         (let ((info (append-text info `((#:label ,(string-append (.function info) "_label_" label))))))
+         (let ((info (append-text info `(((#:label ,(string-append (.function info) "_label_" label)))))))
            ((ast->info info) statement)))
 
         ((goto (ident ,label))
                (let* (;;(global (make-global name type 2 (string->list (make-string size #\nul))))
                       (global (make-global name type 2 (append-map initzer->data initzers)))
                       (global-names (map car globals))
-                      (entries (filter (lambda (g) (not (member (car g) global-names))) entries))
+                      (entries (filter (lambda (g) (and g (not (member (car g) global-names)))) entries))
                       (globals (append globals entries (list global))))
                  (clone info #:globals globals)))))
 
            (if (.function info)
                (let* ((initzer-globals (filter-map (initzer->global globals) initzers))
                       (global-names (map car globals))
-                      (initzer-globals (filter (lambda (g) (not (member (car g) global-names))) initzer-globals))
+                      (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
                       (globals (append globals initzer-globals))
                       (locals (let loop ((fields (cdr fields)) (locals locals))
                                 (if (null? fields) locals
                                        (wrap-as (i386:accu->base-address+n offset)))))))))
                (let* ((initzer-globals (filter-map (initzer->global globals) initzers))
                       (global-names (map car globals))
-                      (initzer-globals (filter (lambda (g) (not (member (car g) global-names))) initzer-globals))
+                      (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
                       (globals (append globals initzer-globals))
                       (global (make-global name type 2 (append-map initzer->data initzers)))
                       (globals (append globals (list global))))
       (if (null? elements) info
           (loop (cdr elements) ((ast->info info) (car elements)))))))
 
-(define (object->list object)
-  (apply append (filter (lambda (x) (and (pair? x) (not (member (car x) '(#:comment #:label))))) object)))
-
 (define* (c99-input->info #:key (defines '()) (includes '()))
   (lambda ()
     (let* ((info (make <info> #:types i386:type-alist))
   ((compose object->elf info->object (c99-input->info #:defines defines #:includes includes))))
 
 (define* (c99-input->object #:key (defines '()) (includes '()))
-  ((compose object->hex2 info->object (c99-input->info #:defines defines #:includes includes))))
+  ((compose object->M1 info->object (c99-input->info #:defines defines #:includes includes))))
index 95be83fd88c8fd08417673e93f8b0eb451209dad..0735eda42ea7357a9093cc98570496a1f402ac38 100644 (file)
@@ -31,7 +31,7 @@
   #:use-module (mes as)
   #:use-module (mes as-i386)
   #:use-module (mes elf)
-  #:use-module (mes hex2)
+  #:use-module (mes M1)
   #:use-module (nyacc lang c99 parser)
   #:use-module (nyacc lang c99 pprint)
   #:export (c99-ast->info
diff --git a/module/mes/M1.mes b/module/mes/M1.mes
new file mode 100644 (file)
index 0000000..931eb51
--- /dev/null
@@ -0,0 +1,154 @@
+;;; -*-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:
+
+;;; M1.mes produces stage0' M1 object format
+
+;;; Code:
+
+(cond-expand
+ (guile)
+ (mes
+  (mes-use-module (srfi srfi-1))
+  (mes-use-module (srfi srfi-26))
+  (mes-use-module (mes as))
+  (mes-use-module (mes elf))
+  (mes-use-module (mes optargs))
+  (mes-use-module (mes pmatch))))
+
+(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 (objects->M1 objects)
+  ((compose object->M1 merge-objects) objects))
+
+(define (object->elf o)
+  ((compose M1->elf object->M1) o))
+
+(define (objects->elf objects)
+  ((compose M1->elf object->M1 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 (hex2:address o)
+  (string-append "&" o))
+
+(define (hex2:offset o)
+  (string-append "%" o))
+
+(define (hex2:offset1 o)
+  (string-append "!" o))
+
+(define (hex2:immediate o)
+  (string-append "%0x" (dec->hex o)))
+
+(define (hex2:immediate1 o)
+  (string-append "!0x" (dec->hex o)))
+
+(define (object->M1 o)
+  (let* ((functions (assoc-ref o 'functions))
+         (function-names (map car functions))
+         (globals (assoc-ref o 'globals))
+         (global-names (map car globals))
+         (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
+    (define (string->label o)
+      (let ((index (list-index (lambda (s) (equal? s o)) strings)))
+       (format #f "string_~a" index)))
+    (define (text->M1 o)
+      (pmatch o
+        ;; FIXME
+        ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
+        ((#:string (#:address ,address)) (hex2:address address))
+        ((#:address (#:address ,address)) (hex2:address address))
+
+        ((#:string ,string) (hex2:address (string->label o)))
+        ((#:address ,address) (hex2:address address))
+        ((#:offset ,offset) (hex2:offset offset))
+        ((#:offset1 ,offset1) (hex2:offset1 offset1))
+        ((#:immediate ,immediate) (hex2:immediate immediate))
+        ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
+        (_ (cond ((char? o) (text->M1 (char->integer o)))
+                 ((string? o) (format #f "~a" o))
+                 ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
+                                (string-append "!0x"
+                                               (if (and (>= o 0) (< o 16)) "0" "")
+                                               (number->string o 16))))
+                 (else (format #f "~a" o))))))
+    (define (write-function o)
+      (let ((name (car o))
+            (text (cdr o)))
+        (define (line->M1 o)
+          (cond ((eq? (car o) #:label)
+                 (format #t ":~a" (cadr o)))
+                ((eq? (car o) #:comment)
+                 (format #t "\t\t\t\t\t# ~a" (cadr o)))
+                ((or (string? (car o)) (symbol? (car o)))
+                 (format #t "\t~a" (string-join (map text->M1 o) " ")))
+                (else (error "line->M1 invalid line:" o)))
+          (newline))
+        (format #t "\n\n:~a\n" name)
+        (for-each line->M1 (apply append text))))
+    (define (write-global o)
+      (define (labelize o)
+        (if (not (string? o)) o
+            (let* ((label o)
+                   (function? (member label function-names))
+                   (string-label (string->label label))
+                   (string? (not (equal? string-label "string_#f")))
+                   (global? (member label global-names)))
+              (if (or global? string?) (format #f "&~a" label)
+                  (begin (if (not function?) (stderr "warning: unresolved label: ~s\n" label))
+                         (format #f "&~a" label))))))
+      (let* ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
+                       (string->label (car o))))
+             (data (cdr o))
+             (data (filter-map labelize data)))
+        (format #t "\n:~a\n" label)
+        (cond ((and (char? (car data))
+                    ;; FIXME: 0 in M1 strings
+                    (not (find (cut eq? #\nul <>) (list-head data (1- (length data)))))
+                    ;; FIXME: " in M1 strings
+                    (not (find (cut member <> '(#\" #\' #\backspace)) data))
+                    (eq? (last data)= #\nul))
+               (format #t "\"~a\"" (list->string (list-head data (1- (length data))))))
+              (else (format #t "~a" (string-join (map text->M1 data) " "))))
+        (newline)))
+    (display "\n:HEX2_text")
+    (for-each write-function (filter cdr functions))
+    (display "\n\n:ELF_data\n") ;; FIXME
+    (display "\n\n:HEX2_data\n")
+    (for-each write-global globals)))
diff --git a/module/mes/M1.scm b/module/mes/M1.scm
new file mode 100644 (file)
index 0000000..edc0b7e
--- /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 M1)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (system base pmatch)
+  #:use-module (mes as)
+  #:use-module (mes elf)
+  #:export (object->M1
+            objects->M1
+            object->elf
+            objects->elf))
+
+(cond-expand
+ (guile-2)
+ (guile
+  (use-modules (ice-9 syncase)))
+ (mes))
+
+(include-from-path "mes/M1.mes")
index c62aa17c31e2a842fb891a75be0f56688e36bd13..eaaaf4833785fe0b0d42a8716392decb5b1c5677 100644 (file)
   (mes-use-module (mes as))))
 
 (define (i386:function-preamble)
-  '(#x55                                ; push   %ebp
-    #x89 #xe5))                         ; mov    %esp,%ebp
-
-;; (define (i386:function-locals)
-;;   '(#x83 #xec #x20))               ; sub    $0x10,%esp -- 8 local vars
+  '(("push___%ebp")                       ; push %ebp
+    ("mov____%esp,%ebp")))                ; mov  %esp,%ebp;
 
 (define (i386:function-locals)
-  '(#x83 #xec #x40))              ; sub    $0x10,%esp -- 16 local vars
+  '(("sub____%esp,$i8" (#:immediate1 #x40)))) ; sub %esp,$0x40  # 16 local vars
 
 (define (i386:push-label label)
-  `(#x68 (#:address ,label)))        ; push  $0x<o>
+  `(("push___$i32" (#:address ,label)))) ; push  $0x<label>
 
 (define (i386:push-label-mem label)
-  `(#xa1 (#:address ,label)                ; mov    0x804a000,%eax
-         #x50))                         ; push  %eax
+  `(("mov____0x32,%eax" (#:address ,label)) ; mov    0x804a000,%eax
+    ("push___%eax")))                       ; push  %eax
 
 (define (i386:push-local n)
   (or n (error "invalid value: push-local: " n))
-  `(#xff #x75 ,(- 0 (* 4 n))))          ; pushl  0x<n>(%ebp)
+  `(("push___0x8(%ebp)" (#:immediate1 ,(- 0 (* 4 n)))))) ; pushl  0x<n>(%ebp)
 
 (define (i386:push-local-address n)
   (or n (error "invalid value: push-local-address: " n))
-  `(#x8d #x45 ,(- 0 (* 4 n))            ; lea 0x<n>(%ebp),%eax
-         #x50))                         ; push %eax
+  `(("lea____0x8(%ebp),%eax" (#:immediate1 ,(- 0 (* 4 n)))) ; lea 0x<n>(%ebp),%eax
+    ("push___%eax")))                   ; push %eax
 
 (define (i386:push-byte-local-de-ref n)
   (or n (error "invalid value: push-byte-local-de-ref: " n))
-  `(#x8b #x45 ,(- 0 (* 4 n))            ; mov    -0x<n>(%ebp),%eax
-         #x0f #xb6 #x00                ; movzbl (%eax),%eax
-         #x50))                         ; push   %eax
+  `(("mov____0x8(%ebp),%eax" (#:immediate1 ,(- 0 (* 4 n)))) ; mov    -0x<n>(%ebp),%eax
+    ("movzbl_(%eax),%eax")                   ; movzbl (%eax),%eax
+    ("push___%eax")))                        ; push   %eax
 
 (define (i386:push-byte-local-de-de-ref n)
   (or n (error "invalid value: push-byte-local-de-de-ref: " n))
-  `(#x8b #x45 ,(- 0 (* 4 n))            ; mov    -0x<n>(%ebp),%eax
-         #x8b #x00                      ; mov    (%eax),%eax
-         #x0f #xb6 #x00                ; movzbl (%eax),%eax
-         #x50))
+  `(("mov____0x8(%ebp),%eax" (#:immediate1 ,(- 0 (* 4 n)))) ; mov    -0x<n>(%ebp),%eax
+     ("mov____(%eax),%eax")                  ; mov    (%eax),%eax
+     ("movzbl_(%eax),%eax")                  ; movzbl (%eax),%eax
+     ("push___%eax")))
 
 (define (i386:push-local-de-ref n)
   (or n (error "invalid value: push-byte-local-de-ref: " n))
-  `(#x8b #x45 ,(- 0 (* 4 n))            ; mov    -0x<n>(%ebp),%eax
-         #x8b #x00                      ; mov (%eax),%eax
-         #x50))                         ; push   %eax
+  `(("mov____0x8(%ebp),%eax" (#:immediate1 ,(- 0 (* 4 n)))) ; mov    -0x<n>(%ebp),%eax
+    ("mov____(%eax),%eax")              ; mov (%eax),%eax
+    ("push___%eax")))                   ; push   %eax
 
 (define (i386:pop-accu)
-  '(#x58))                              ; pop %eax
+  '(("pop____%eax")))                   ; pop %eax
 
 (define (i386:push-accu)
-  '(#x50))                              ; push %eax
+  '(("push___%eax")))                   ; push %eax
 
 (define (i386:pop-base)
-  '(#x5a))                              ; pop %edx
+  '(("pop____%edx")))                   ; pop %edx
 
 (define (i386:push-base)
-  '(#x52))                              ; push %edx
+  '(("push___%edx")))                   ; push %edx
 
 (define (i386:ret)
-  '(#xc9                                ; leave
-    #xc3))                              ; ret
+  '(("leave")                           ; leave
+    ("ret")))                           ; ret
 
 (define (i386:accu->base)
-  '(#x89 #xc2))                         ; mov    %eax,%edx
+  '(("mov____%eax,%edx")))              ; mov    %eax,%edx
 
 (define (i386:accu->base-address)
-  '(#x89 #x02))                         ; mov    %eax,%(edx)
+  '(("mov____%eax,(%edx)")))            ; mov    %eax,(%edx)
 
 (define (i386:byte-accu->base-address)
-  '(#x88 #x02))                         ; mov    %al,%(edx)
+  '(("mov____%al,(%edx)")))             ; mov    %al,(%edx)
 
 (define (i386:accu->base-address+n n)
   (or n (error "invalid value: accu->base-address+n: " n))
-  `(#x89 #x42 ,n))                      ; mov    %eax,$0x<n>%(edx)
+  `(("mov____%eax,0x8(%edx)" (#:immediate1 ,n)))) ; mov    %eax,$0x<n>%(edx)
 
 (define (i386:accu->local n)
   (or n (error "invalid value: accu->local: " n))
-  `(#x89 #x45 ,(- 0 (* 4 n))))          ; mov    %eax,-<0xn>(%ebp)
+  `(("mov____%eax,0x8(%ebp)" (#:immediate1 ,(- 0 (* 4 n)))))) ; mov    %eax,-<0xn>(%ebp)
 
 ;; (define (i386:accu->local-address n)
 ;;   (or n (error "invalid value: accu->local: " n))
 
 (define (i386:base->local n)
   (or n (error "invalid value: base->local: " n))
-  `(#x89 #x55 ,(- 0 (* 4 n))))          ; mov    %edx,-<0xn>(%ebp)
+  `(("mov____%edx,0x8(%ebp)" ,(- 0 (* 4 n))))) ; mov    %edx,-<0xn>(%ebp)
 
 (define (i386:accu->label label)
-  `(#xa3 (#:address ,label)))
+  `(("mov____%eax,0x32" (#:address ,label)))) ; mov    %eax,0x<label>
 
 (define (i386:accu-zero?)
-  '(#x85 #xc0))                         ; cmpl   %eax,%eax
-
-(define (i386:accu-non-zero?)
-  (append '(#x85 #xc0)                  ; cmpl   %eax,%eax
-          (i386:xor-zf)))
+  '(("test___%eax,%eax")))
 
 (define (i386:accu-shl n)
   (or n (error "invalid value: accu:shl n: " n))
-  `(#xc1 #xe0 ,n))                      ; shl    $0x8,%eax
+  `(("shl____$i8,%eax" (#:immediate1 ,n)))) ; shl    $0x8,%eax
 
 (define (i386:accu<<base)
-  '(#x31 #xc9                           ; xor    %ecx,%ecx
-    #x89 #xd1                           ; mov    %edx,%ecx
-    #xd3 #xe0))                         ; shl    %cl,%eax
+  '(("xor____%ecx,%ecx")                ; xor    %ecx,%ecx
+    ("mov____%edx,%ecx")                ; mov    %edx,%ecx
+    ("shl____%cl,%eax")))               ; shl    %cl,%eax
 
 (define (i386:accu>>base)
-  '(#x31 #xc9                           ; xor    %ecx,%ecx
-    #x89 #xd1                           ; mov    %edx,%ecx
-    #xd3 #xe8))                         ; shr    %cl,%eax
+  '(("xor____%ecx,%ecx")                ; xor    %ecx,%ecx
+    ("mov____%edx,%ecx")                ; mov    %edx,%ecx
+    ("shr____%cl,%eax")))               ; shr    %cl,%eax
 
 (define (i386:accu-or-base)
-  '(#x09 #xd0))                         ; or    %edx,%eax
+  '(("or_____%edx,%eax")))              ; or    %edx,%eax
 
 (define (i386:accu-and-base)
-  '(#x21 #xd0))                         ; and    %edx,%eax
+  '(("and____%edx,%eax")))              ; and    %edx,%eax
 
 (define (i386:accu-xor-base)
-  '(#x31 #xd0))                         ; and    %edx,%eax
+  '(("xor____%edx,%eax")))              ; xor    %edx,%eax
 
 (define (i386:accu+accu)
-  '(#x01 #xc0))                         ; add    %eax,%eax
+  '(("add____%eax,%eax")))              ; add    %eax,%eax
 
 (define (i386:accu+base)
-  `(#x01 #xd0))                         ; add    %edx,%eax
+  `(("add____%edx,%eax")))              ; add    %edx,%eax
 
 (define (i386:accu+value v)
   (or v (error "invalid value: accu+value: " v))
-  `(#x05 ,@(int->bv32 v)))              ; add    %eax,%eax
+  `(("add____$i32,%eax" (#:immediate ,v)))) ; add    %eax,$
 
 (define (i386:accu-base)
-  `(#x29 #xd0))                         ; sub    %edx,%eax
+  `(("sub____%edx,%eax")))              ; sub    %edx,%eax
 
 (define (i386:accu*base)
-  `(#xf7 #xe2))                         ; mul    %edx
+  `(("mul____%edx")))                   ; mul    %edx
 
 (define (i386:accu/base)
-  '(#x86 #xd3                           ; mov    %edx,%ebx
-    #x31 #xd2                           ; xor    %edx,%edx
-    #xf7 #xf3))                         ; div    %ebx
+  '(("mov____%edx,%ebx")                ; mov    %edx,%ebx
+    ("xor____%edx,%edx")                ; xor    %edx,%edx
+    ("div____%ebx")))                   ; div    %ebx
 
 (define (i386:accu%base)
-  '(#x86 #xd3                           ; mov    %edx,%ebx
-    #x31 #xd2                           ; xor    %edx,%edx
-    #xf7 #xf3                           ; div    %ebx
-    #x89 #xd0))                         ; mov    %edx,%eax
+  '(("mov____%edx,%ebx")                ; mov    %edx,%ebx
+    ("xor____%edx,%edx")                ; xor    %edx,%edx
+    ("div____%ebx")                     ; div    %ebx
+    ("mov____%edx,%eax")))              ; mov    %edx,%eax
 
 (define (i386:base->accu)
-  '(#x89 #xd0))                         ; mov    %edx,%eax
+  '(("mov____%edx,%eax")))              ; mov    %edx,%eax
 
 (define (i386:local->accu n)
   (or n (error "invalid value: local->accu: " n))
-  `(#x8b #x45 ,(- 0 (* 4 n))))          ; mov    -<0xn>(%ebp),%eax
+  `(("mov____0x8(%ebp),%eax" (#:immediate1 ,(- 0 (* 4 n)))))) ; mov    -<0xn>(%ebp),%eax
 
 (define (i386:local-address->accu n)
   (or n (error "invalid value: ladd: " n))
-  `(#x8d #x45 ,(- 0 (* 4 n))))          ; lea 0x<n>(%ebp),%eax
+  `(("lea____0x8(%ebp),%eax" (#:immediate1 ,(- 0 (* 4 n)))))) ; lea 0x<n>(%ebp),%eax
 
 (define (i386:local-ptr->accu n)
   (or n (error "invalid value: local-ptr->accu: " n))
-  `(#x89 #xe8                           ; mov    %ebp,%eax
-         #x83 #xc0 ,(- 0 (* 4 n))))     ; add    $0x<n>,%eax
+  `(("mov____%ebp,%eax")                ; mov    %ebp,%eax
+    ("add____$i8,%eax" (#:immediate1 ,(- 0 (* 4 n)))))) ; add    $0x<n>,%eax
 
 (define (i386:byte-local->accu n)
   (or n (error "invalid value: byte-local->accu: " n))
-  `(#x0f #xb6 #x45 ,(- 0 (* 4 n))))     ; movzbl 0x<n>(%ebp),%eax
+  `(("movzbl_0x8(%ebp),%eax" (#:immediate1 ,(- 0 (* 4 n)))))) ; movzbl 0x<n>(%ebp),%eax
 
 (define (i386:byte-local->base n)
   (or n (error "invalid value: byte-local->base: " n))
-  `(#x0f #xb6 #x55 ,(- 0 (* 4 n))))     ; movzbl 0x<n>(%ebp),%edx
+  `(("movzbl_0x8(%ebp),%edx" (#:immediate1 ,(- 0 (* 4 n)))))) ; movzbl 0x<n>(%ebp),%edx
 
 (define (i386:local->base n)
   (or n (error "invalid value: local->base: " n))
-  `(#x8b #x55 ,(- 0 (* 4 n))))          ; mov    -<0xn>(%ebp),%edx
+  `(("mov____0x8(%ebp),%edx" (#:immediate1 ,(- 0 (* 4 n)))))) ; mov    -<0xn>(%ebp),%edx
 
 (define (i386:local-address->base n) ;; DE-REF
   (or n (error "invalid value: local-address->base: " n))
-  `(#x8d #x55 ,(- 0 (* 4 n))))          ; lea    0x<n>(%ebp),%edx
+  `(("lea____0x8(%ebp),%edx" (#:immediate1 ,(- 0 (* 4 n)))))) ; lea    0x<n>(%ebp),%edx
 
 (define (i386:local-ptr->base n)
   (or n (error "invalid value: local-ptr->base: " n))
-  `(#x89 #xea                           ; mov    %ebp,%edx
-         #x83 #xc2 ,(- 0 (* 4 n))))     ; add    $0x<n>,%edx
+  `(("mov____%ebp,%edx")                ; mov    %ebp,%edx
+    ("add____$i8,%edx" (#:immediate1 ,(- 0 (* 4 n)))))) ; add    $0x<n>,%edx
 
 (define (i386:label->accu label)
-  `(#xb8 (#:address ,label)))              ; mov    $<>,%eax
+  `(("mov____$i32,%eax" (#:address ,label)))) ; mov    $<n>,%eax
 
 (define (i386:label->base label)
-  `(#xba (#:address ,label)))              ; mov   $<n>,%edx
+  `(("mov____$i32,%edx" (#:address ,label)))) ; mov   $<n>,%edx
 
 (define (i386:label-mem->accu label)
-  `(#xa1 (#:address ,label)))              ; mov    0x<n>,%eax
+  `(("mov____0x32,%eax" (#:address ,label)))) ; mov    0x<n>,%eax
 
 (define (i386:label-mem->base label)
-  `(#x8b #x15 (#:address ,label)))         ; mov    0x<n>,%edx
+  `(("mov____0x32,%edx" (#:address ,label)))) ; mov    0x<n>,%edx
 
 (define (i386:label-mem-add label v)
-  `(#x83 #x05 (#:address ,label) ,v))      ; addl   $<v>,0x<n>
+  `(("add____$i8,0x32" (#:address ,label) (#:immediate1 ,v)))) ; addl   $<v>,0x<n>
 
 (define (i386:byte-base-mem->accu)
-  '(#x01 #xd0                           ; add    %edx,%eax
-         #x0f #xb6 #x00))               ; movzbl (%eax),%eax
+  '(("add____%edx,%eax")                ; add    %edx,%eax
+    ("movzbl_(%eax),%eax")))            ; movzbl (%eax),%eax
 
 (define (i386:byte-mem->accu)
-  '(#x0f #xb6 #x00))                    ; movzbl (%eax),%eax
+  '(("movzbl_(%eax),%eax")))            ; movzbl (%eax),%eax
 
 (define (i386:byte-mem->base)
-  '(#x0f #xb6 #x10))                    ; movzbl (%eax),%edx
+  '(("movzbl_(%eax),%edx")))            ; movzbl (%eax),%edx
 
 (define (i386:base-mem->accu)
-  '(#x01 #xd0                           ; add    %edx,%eax
-         #x8b #x00))                    ; mov    (%eax),%eax
+  '(("add___%edx,%eax")                 ; add    %edx,%eax
+    ("mov____(%eax),%eax")))            ; mov    (%eax),%eax
 
 (define (i386:mem->accu)
-  '(#x8b #x00))                         ; mov    (%eax),%eax
+  '(("mov____(%eax),%eax")))            ; mov    (%eax),%eax
 
 (define (i386:mem+n->accu n)
-  `(#x8b #x40 ,n))                      ; mov    0x<n>(%eax),%eax
+  `(("mov____0x8(%eax),%eax" (#:immediate1 ,n)))) ; mov    0x<n>(%eax),%eax
 
 (define (i386:base-mem+n->accu n)
   (or n (error "invalid value: base-mem+n->accu: " n))
-  `(#x01 #xd0                           ; add    %edx,%eax
-         #x8b #x40 ,n))                 ; mov    <n>(%eax),%eax
+  `(("add___%edx,%eax")                 ; add    %edx,%eax
+    ("mov____0x8(%eax),%eax" (#:immediate1 ,n)))) ; mov    <n>(%eax),%eax
 
 (define (i386:value->accu v)
   (or v (error "invalid value: i386:value->accu: " v))
-  `(#xb8 ,@(int->bv32 v)))              ; mov    $<v>,%eax
+  `(("mov____$i32,%eax" (#:immediate ,v)))) ; mov    $<v>,%eax
 
 (define (i386:value->accu-address v)
-  `(#xc7 #x00 ,@(int->bv32 v)))         ; movl   $0x<v>,(%eax)
+  `(("mov____$i32,(%eax)" (#:immediate ,v)))) ; movl   $0x<v>,(%eax)
 
 (define (i386:value->accu-address+n n v)
   (or v (error "invalid value: i386:value->accu-address+n: " v))
-  `(#xc7 #x40 ,n ,@(int->bv32 v)))      ; movl   $<v>,0x<n>(%eax)
+  `(("mov____$i32,0x8(%eax)" (#:immediate1 ,n) (#:immediate ,v)))) ; movl   $<v>,0x<n>(%eax)
 
 (define (i386:base->accu-address)
-  '(#x89 #x10))                         ; mov    %edx,(%eax)
+  '(("mov____%edx,%(eax)")))            ; mov    %edx,(%eax)
 
 (define (i386:base-address->accu-address)
-  '(#x8b #x0a                           ; mov    (%edx),%ecx
-    #x89 #x08))                         ; mov    %ecx,(%eax)
+  '(("mov____(%edx),%ecx")              ; mov    (%edx),%ecx
+    ("mov____%ecx,%(eax)")))            ; mov    %ecx,(%eax)
 
 (define (i386:accu+n n)
-  `(#x83 #xc0 ,n))                      ; add    $0x00,%eax
+  `(("add____$i8,%eax" (#:immediate1 ,n)))) ; add    $0x00,%eax
 
 (define (i386:base+n n)
-  `(#x83 #xc2 ,n))                      ; add    $0x00,%edx
+  `(("add____$i8,%edx" (#:immediate1 ,n)))) ; add    $0x00,%edx
 
 (define (i386:byte-base->accu-address)
-  '(#x88 #x10))                         ; mov    %dl,(%eax)
+  '(("mov____%dl,(%eax)")))             ; mov    %dl,(%eax)
 
 (define (i386:byte-base->accu-address+n n)
   (or n (error "invalid value: byte-base->accu-address+n: " n))
-  `(#x88 #x50 ,n))                      ; mov    %dl,0x<n>(%eax)
+  `(("mov____%dl,0x8(%eax)" (#:immediate1 ,n)))) ; mov    %dl,0x<n>(%eax)
 
 (define (i386:value->base v)
   (or v (error "invalid value: i386:value->base: " v))
-  `(#xba ,@(int->bv32 v)))              ; mov    $<v>,%edx
+  `(("mov____$i32,%edx" (#:immediate ,v)))) ; mov    $<v>,%edx
 
 (define (i386:local-add n v)
   (or n (error "invalid value: i386:local-add: " n))
-  `(#x83 #x45 ,(- 0 (* 4 n)) ,v))       ; addl   $<v>,0x<n>(%ebp)
+  `(("add____$i8,0x8(%ebp)" (#:immediate1 ,(- 0 (* 4 n))) (#:immediate1 ,v)))) ; addl   $<v>,0x<n>(%ebp)
 
 (define (i386:accu-mem-add v)
-  `(#x83 #x00 ,v))                      ; addl   $<v>,(%eax)
+  `(("add____$i8,0x8(%eax)" (#:immediate1 ,v)))) ; addl   $<v>,(%eax)
 
 (define (i386:value->label label v)
   (or v (error "invalid value: value->label: " v))
-  `(#xc7 #x05 (#:address ,label)     ; movl   $<v>,(<n>)
-         ,@(int->bv32 v)))
+  `(("mov____$i32,0x32" (#:address ,label) ; movl   $<v>,(<n>)
+     (#:immediate ,v))))
 
 (define (i386:value->local n v)
   (or n (error "invalid value: value->local: " n))
-  `(#xc7 #x45 ,(- 0 (* 4 n))            ; movl   $<v>,0x<n>(%ebp)
-         ,@(int->bv32 v)))
+  `(("mov____$i32,0x8(%ebp)" (#:immediate1 ,(- 0 (* 4 n))) ; movl   $<v>,0x<n>(%ebp)
+     (#:immediate ,v))))
 
 (define (i386:local-test n v)
   (or n (error "invalid value: local-test: " n))
-  `(#x83 #x7d ,(- 0 (* 4 n)) ,v))       ; cmpl   $<v>,0x<n>(%ebp)
+  `(("cmp____$i8,0x8(%ebp)" (#:immediate1 ,(- 0 (* 4 n))) (#:immediate1 ,v)))) ; cmpl   $<v>,0x<n>(%ebp)
 
 (define (i386:call-label label n)
-  `(#xe8 (#:offset ,label)           ; call   offset $00
-         #x83 #xc4 ,(* n 4)))           ; add    $00,%esp
+  `((call32 (#:offset ,label))
+    ("add____$i8,%esp" (#:immediate1 ,(* n 4)))))
 
 (define (i386:call-accu n)
   `(,@(i386:push-accu)
     ,@(i386:pop-accu)
-    #xff #xd0                           ; call   *%eax
-    #x83 #xc4 ,(* n 4)))                ; add    $00,%esp
+    ("call___*%eax")                    ; call   *%eax
+    ("add____$i8,%esp" (#:immediate1  ,(* n 4))))) ; add    $00,%esp
 
 (define (i386:accu-not)
-  `(#x0f #x94 #xc0                      ; sete %al
-         #x0f #xb6 #xc0))               ; movzbl %al,%eax
+  '(("sete___%al")                      ; sete %al
+    ("movzbl_%al,%eax")))               ; movzbl %al,%eax
 
 (define (i386:xor-accu v)
   (or v (error "invalid value: i386:xor-accu: n: " v))
-  `(#x35 ,@(int->bv32 v)))             ;xor    $0xff,%eax
+  `(("xor___$i32,%eax" (#:immediate ,v)))) ;xor    $0xff,%eax
 
 (define (i386:xor-zf)
-  '(#x9f                                ; lahf   
-    #x80 #xf4 #x40                      ; xor    $0x40,%ah
-    #x9e))                              ; sahf   
+  '(("lahf")                               ; lahf
+    ("xor____$i8,%ah" (#:immediate1 #x40)) ; xor    $0x40,%ah
+    ("sahf")))                             ; sahf
 
 (define (i386:accu-cmp-value v)
-  `(#x83 #xf8 ,v))                      ; cmp    $<v>,%eax
+  `(("cmp____$i8,%eax" (#:immediate1 ,v)))) ; cmp    $<v>,%eax
 
 (define (i386:accu-test)
-  '(#x85 #xc0))                         ; test   %eax,%eax
+  '(("test___%eax,%eax")))              ; test   %eax,%eax
 
 (define (i386:jump label)
-  `(#xe9 (#:offset ,label)))         ; jmp . + <n>
+  `(("jmp32 " (#:offset ,label))))
 
 (define (i386:jump-z label)
-  `(#x0f #x84 (#:offset ,label)))    ; jz . + <n>
+  `(("je32  " (#:offset ,label))))        ; jz . + <n>
 
 (define (i386:jump-byte-z label)
-  `(#x84 #xc0                           ; test   %al,%al
-    #x74 (#:offset1 ,label)))           ; jne <n>
+  `(("test___%al,%al")                  ; test   %al,%al
+    ("jne8  " (#:offset1 ,label))))       ; jne <n>
 
 ;; signed
 (define (i386:jump-g label)
-  `(#x0f #x8f (#:offset ,label)))    ; jg/jnle <n>
+  `(("jg32   " (#:offset ,label))))        ; jg/jnle <n>
 
 ;; signed
 (define (i386:jump-ge label)
-  `(#x0f #x8d (#:offset ,label)))    ; jge/jnl <n>
+  `(("jge32 " (#:offset ,label))))       ; jge/jnl <n>
 
 (define (i386:jump-nz label)
-  `(#x0f #x85 (#:offset ,label)))    ; jnz . + <n>
-
-(define (i386:jump-z label)
-  `(#x0f #x84 (#:offset ,label)))    ; jz . + <n>
+  `(("jne32 " (#:offset ,label))))       ; jnz . + <n>
 
 (define (i386:byte-test-base)
-  `(#x38 #xc2))                         ; cmp    %al,%dl
+  '(("cmp____%al,%dl")))                ; cmp    %al,%dl
 
 (define (i386:test-base)
-  `(#x39 #xd0))                         ; cmp    %edx,%eax
+  (("cmp____%edx,%eax")))               ; cmp    %edx,%eax
 
 (define (i386:byte-sub-base)
-  `(#x28 #xd0))                         ; sub    %dl,%al
+  '(("sub____%dl,%al")))                ; sub    %dl,%al
 
 (define (i386:byte-base-sub)
-  `(#x28 #xd0))                         ; sub    %al,%dl
+  `(("sub____%al,%dl")))                ; sub    %al,%dl
 
 (define (i386:sub-base)
-  `(#x29 #xd0))                         ; sub    %edx,%eax
+  `(("sub____%edx,%eax")))              ; sub    %edx,%eax
 
 (define (i386:base-sub)
-  `(#x29 #xc2))                         ; sub    %eax,%edx
+  `(("sub____%eax,%edx")))              ; sub    %eax,%edx
 
 (define (i386:nz->accu)
-  '(#x0f #x95 #xc0                      ; setne   %al
-         #x0f #xb6 #xc0))               ; movzbl %al,%eax
+  '(("setne__%al")                      ; setne   %al
+    ("movzbl_%al,%eax")))               ; movzbl %al,%eax
 
 (define (i386:z->accu)
-  '(#x0f #x94 #xc0                      ; sete   %al
-         #x0f #xb6 #xc0))               ; movzbl %al,%eax
+  '(("sete___%al")                      ; sete   %al
+    ("movzbl_%al,%eax")))               ; movzbl %al,%eax
 
 (define (i386:accu<->stack)
-  '(#x87 #x04 #x24))                    ; xchg   %eax,(%esp)
-
+  '(("xchg___%eax,(%esp)")))            ; xchg   %eax,(%esp)
index 6201a4c048f1e77a619379f6e3151ee7bcf49ebd..375c6ebefc21229aac436491feb0289a7e6280a4 100644 (file)
@@ -34,7 +34,6 @@
             i386:accu->base-address+n
             i386:accu->label
             i386:accu->local
-            i386:accu-non-zero?
             i386:accu-test
             i386:accu-zero?
             i386:accu+accu
index ab4787be07ec936d8bb3f5ddceb3edfcf50dda47..747aa80797b1f81cdfe284788dd0dce62fa6aa21 100644 (file)
@@ -28,5 +28,5 @@
  (guile)
  (mes))
 
-(define (hex2->elf objects)
-  (error "->ELF support dropped, use hex2"))
+(define (M1->elf objects)
+  (error "->ELF support dropped, use M1"))
index 58a60473f90a4060b42027dc22d2dc356189c683..c715dc5fd31e90d33b53663df85eae96c7e71703 100644 (file)
@@ -23,7 +23,7 @@
 ;;; Code:
 
 (define-module (mes elf)
-  #:export (hex2->elf))
+  #:export (M1->elf))
 
 (cond-expand
  (guile-2)
diff --git a/module/mes/hex2.mes b/module/mes/hex2.mes
deleted file mode 100644 (file)
index 0eecd0f..0000000
+++ /dev/null
@@ -1,150 +0,0 @@
-;;; -*-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 (mes as))
-  (mes-use-module (mes elf))
-  (mes-use-module (mes optargs))
-  (mes-use-module (mes pmatch))))
-
-(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 (objects->hex2 objects)
-  ((compose object->hex2 merge-objects) objects))
-
-(define (object->elf o)
-  ((compose hex2->elf object->hex2) o))
-
-(define (objects->elf objects)
-  ((compose hex2->elf object->hex2 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 (hex2:address o)
-  (string-append "&" o))
-
-(define (hex2:offset o)
-  (string-append "%" o))
-
-(define (hex2:offset1 o)
-  (string-append "!" o))
-
-(define (object->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 (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
-    (define (string->label o)
-      (let ((index (list-index (lambda (s) (equal? s o)) strings)))
-        ;;;(if (not index) (error "no such string:" o))
-       (format #f "string_~a" index)))
-    (define (text->hex2 o)
-      (pmatch o
-        ;; FIXME
-        ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
-        ((#:string (#:address ,address)) (hex2:address address))
-        ((#:address (#:address ,address)) (hex2:address address))
-
-        ((#:string ,string) (hex2:address (string->label o)))
-        ((#:address ,address) (hex2:address address))
-        ((#:offset ,offset) (hex2:offset offset))
-        ((#:offset1 ,offset1) (hex2:offset1 offset1))
-        (_ (cond ((char? o) (text->hex2 (char->integer o)))
-                 ((string? o) (format #f "~a" o))
-                 ((number? o) (string-append (if (and (>= o 0) (< o 16)) "0" "")
-                                             (number->string
-                                              (if (>= o 0) o (+ o #x100))
-                                              16)))
-                 (else (format #f "~a" o))))))
-    (define (write-function o)
-      (let ((name (car o))
-            (text (cdr o)))
-        (define (line->hex2 o)
-          (cond ((null? o))
-                ((not (pair? o))
-                 (display (text->hex2 o)))
-                ((string? (car o))
-                 (format #t ";; ~a" (car o))
-                 (display (string-join (map text->hex2 (cdr o)) " ")))
-                ((number? (car o))
-                 (display (string-join (map text->hex2 o) " ")))
-                ((eq? (car o) #:label)
-                 ;;FIXME: more support for local labels?
-                 ;;(format #t ":local_~a_~a" name (cadr o))
-                 ;;(format #t ":~a_~a" name (cadr o))
-                 (format #t ":~a" (cadr o)))
-                ((eq? (car o) #:comment)
-                 (format #t "  # ~a" (cadr o)))
-                ;; ((and (pair? (car o)) (eq? (caar o) #:label))
-                ;;  (write (car o)))
-                (else (error "line->hex2 invalid line:" o)))
-          (newline))
-        (format #t "\n\n:~a\n" name)
-        (for-each line->hex2 text)))
-    (define (write-global o)
-      (define (labelize o)
-        (if (not (string? o)) o
-            (let* ((label o)
-                   (function? (member label function-names))
-                   (string-label (string->label label))
-                   (string? (not (equal? string-label "string_#f")))
-                   (global? (member label global-names)))
-              (if (or global? string?) (format #f "&~a" label)
-                  (begin (if (not function?) (stderr "warning: unresolved label: ~s\n" label))
-                         (format #f "&~a" label))))))
-      (let* ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
-                       (string->label (car o))))
-             (data (cdr o))
-             (data (filter-map labelize data)))
-        (format #t "\n:~a\n" label)
-        (display (string-join (map text->hex2 data) " "))
-        (newline)))
-    (display "\n:HEX2_text")
-    (for-each write-function (filter cdr functions))
-    (display "\n\n:ELF_data\n") ;; FIXME
-    (display "\n\n:HEX2_data\n")
-    (for-each write-global globals)))
diff --git a/module/mes/hex2.scm b/module/mes/hex2.scm
deleted file mode 100644 (file)
index 437b1fd..0000000
+++ /dev/null
@@ -1,41 +0,0 @@
-;;; -*-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 (system base pmatch)
-  #:use-module (mes as)
-  #:use-module (mes elf)
-  #:export (object->hex2
-            objects->hex2
-            object->elf
-            objects->elf))
-
-(cond-expand
- (guile-2)
- (guile
-  (use-modules (ice-9 syncase)))
- (mes))
-
-(include-from-path "mes/hex2.mes")
index 54bbaaf330a2ee86bb9bf03bcf2cf74831001dd4..e3b86620d8697a36bbad1696231cb568edaf2946 100644 (file)
@@ -64,7 +64,7 @@ SCM tmp;
 SCM tmp_num;
 
 int ARENA_SIZE = 200;
-#define TYPE(x) (g_cells[x].type)
+#define TYPE(x) g_cells[x].type
 #define CAR(x) g_cells[x].car
 #define CDR(x) g_cells[x].cdr
 #define VALUE(x) g_cells[x].cdr
@@ -972,8 +972,8 @@ main (int argc, char *argv[])
   char *p = "t.c\n";
   puts ("t.c\n");
 
-  puts ("t: argv[0] == \"out/t....\"\n");
-  if (strncmp (argv[0], "out/t", 5)) return 1;
+  puts ("t: argv[0] == \"scaffold/t....\"\n");
+  if (strncmp (argv[0], "scaffold/t", 5)) return 1;
 
   puts ("t: *argv\"\n");
   puts (*argv);
index b6569b48cf8fedb41ffde012283633aaef5b4146..cd5403d9e8bea9e647ed9f680da6e7e60c2a09d4 100755 (executable)
@@ -42,7 +42,7 @@ exit $r
 (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 (mes M1))
 (mes-use-module (srfi srfi-1))
 (mes-use-module (srfi srfi-26))
 
@@ -144,16 +144,16 @@ Usage: mescc.mes [OPTION]... FILE...
                                                         (not preprocess?)) S_IRWXU))
       (lambda ()
         (cond ((pair? objects) (let ((objects (map read-object objects)))
-                                 (if compile? (objects->hex2 objects)
+                                 (if compile? (objects->M1 objects)
                                      (objects->elf objects))))
               ((pair? asts) (let* ((infos (map main:ast->info asts))
                                    (objects (map info->object infos)))
-                              (if compile? (objects->hex2 objects)
+                              (if compile? (objects->M1 objects)
                                   (objects->elf objects))))
               ((pair? sources) (if preprocess? (map (source->ast defines includes) sources)
                                    (let* ((infos (map (source->info defines includes) sources))
                                           (objects (map info->object infos)))
-                                     (if compile? (objects->hex2 objects)
+                                     (if compile? (objects->M1 objects)
                                          (objects->elf objects))))))))))
 
 (main (command-line))
diff --git a/stage0/x86.M1 b/stage0/x86.M1
new file mode 100644 (file)
index 0000000..32bf4ee
--- /dev/null
@@ -0,0 +1,131 @@
+### 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/>.
+
+
+DEFINE add____$i32,%eax 05
+DEFINE add____$i8,%eax 83c0
+DEFINE add____$i8,%edx 83c2
+DEFINE add____$i8,%esp 83c4
+DEFINE add____$i8,0x32 8305
+DEFINE add____$i8,0x8(%eax) 8300
+DEFINE add____$i8,0x8(%ebp) 8345
+DEFINE add____%eax,%eax 01c0
+DEFINE add____%ebp,%eax 01e8
+DEFINE add____%edx,%eax 01d0
+DEFINE add____%edx,%eax 01d0
+DEFINE and____%edx,%eax 21d0
+DEFINE call32 e8
+DEFINE call___*%eax ffd0
+DEFINE cmp____$i8,%eax 83f8
+DEFINE cmp____$i8,0x8(%ebp) 83x7d
+DEFINE cmp____%al,%dl 38c2
+DEFINE cmp____%edx,%eax 39d0
+DEFINE div____%ebx f7f3
+DEFINE int____$0x80 cd80
+DEFINE je32 0f84
+DEFINE jg32 0f8f
+DEFINE jge32 0f8d
+DEFINE jmp32 e9
+DEFINE jne32 0f85
+DEFINE jne8 74
+DEFINE lahf 9f
+DEFINE lea____0x8(%ebp),%eax 8d45
+DEFINE lea____0x8(%ebp),%edx 8d55
+DEFINE leave c9
+DEFINE mov____$i32,%eax b8
+DEFINE mov____$i32,%ebx bb
+DEFINE mov____$i32,%ecx b9
+DEFINE mov____$i32,%edx ba
+DEFINE mov____$i32,(%eax) c700
+DEFINE mov____$i32,0x32 c705
+DEFINE mov____$i32,0x8(%eax) c740
+DEFINE mov____$i32,0x8(%ebp) c745
+DEFINE mov____%al,(%edx) 8802 
+DEFINE mov____%dl,(%eax) 8810
+DEFINE mov____%dl,0x8(%eax) 8850
+DEFINE mov____%eax,%ebx 89c3
+DEFINE mov____%eax,%edx 89c2
+DEFINE mov____%eax,(%edx) 8902 
+DEFINE mov____%eax,0x32 a3
+DEFINE mov____%eax,0x8(%ebp) 8945
+DEFINE mov____%eax,0x8(%edx) 8942 
+DEFINE mov____%ebp,%eax 89e8
+DEFINE mov____%ebp,%edx 89ea
+DEFINE mov____%ecx,%(eax) 8908
+DEFINE mov____%edx,%(eax) 8910
+DEFINE mov____%edx,%eax 89d0
+DEFINE mov____%edx,%ebx 86d3
+DEFINE mov____%edx,%ecx 89d1
+DEFINE mov____%edx,0x8(%ebp) 8955
+DEFINE mov____%esp,%ebp 89e5
+DEFINE mov____(%eax),%eax 8b00
+DEFINE mov____(%edx),%ecx 8b0a
+DEFINE mov____0x32,%eax a1
+DEFINE mov____0x32,%edx 8b15
+DEFINE mov____0x8(%eax),%eax 8b40
+DEFINE mov____0x8(%ebp),%eax 8b45
+DEFINE mov____0x8(%ebp),%ebx 8b5d
+DEFINE mov____0x8(%ebp),%ecx 8b4d
+DEFINE mov____0x8(%ebp),%edx 8b55
+DEFINE movzbl_%al,%eax 0fb6c0
+DEFINE movzbl_(%eax),%eax 0fb600
+DEFINE movzbl_(%eax),%edx 0fb610
+DEFINE movzbl_0x8(%ebp),%eax 0fb645
+DEFINE movzbl_0x8(%ebp),%edx 0fb655
+DEFINE mul____%edx f7e2
+DEFINE or_____%edx,%eax 09d0
+DEFINE pop____%eax 58
+DEFINE pop____%edx 5a
+DEFINE push___$i32 68
+DEFINE push___%eax 50
+DEFINE push___%ebp 55
+DEFINE push___%edox 52
+DEFINE push___0x8(%ebp) ff75
+DEFINE ret c3
+DEFINE sahf 9e
+DEFINE sete___%al 0f94c0
+DEFINE setne__%al 0f95c0
+DEFINE shl____$i8,%eax c1e0
+DEFINE shl____%cl,%eax d3e0
+DEFINE shr____%cl,%eax d3e8
+DEFINE sub____%al,%dl 28d0
+DEFINE sub____%dl,%al 28c2
+DEFINE sub____%eax,%edx 29c2
+DEFINE sub____%edx,%eax 29d0
+DEFINE sub____%edx,%eax 29d0
+DEFINE sub____%esp,$i8 83ec
+DEFINE test___%al,%al 84c0
+DEFINE test___%eax,%eax 85c0
+DEFINE xchg___%dl,%bl 86d3
+DEFINE xchg___%eax,(%esp) 870424
+DEFINE xor____$i32,%eax 35
+DEFINE xor____$i8,%ah 80f4
+DEFINE xor____%eax,%eax 31c0
+DEFINE xor____%ebx,%ebx 31db
+DEFINE xor____%ecx,%ecx 31c9
+DEFINE xor____%edx,%eax 31d0
+DEFINE xor____%edx,%edx 31d2
+
+
+DEFINE SYS_exit   01000000
+DEFINE SYS_read   03000000
+DEFINE SYS_write  04000000
+DEFINE SYS_open   05000000
+DEFINE SYS_access 21000000
+DEFINE SYS_brk    2d000000
+DEFINE SYS_fsync  76000000