From 83a43b81b3f629e200f63663ed03a1d80d277d9a Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 2 Jul 2017 16:25:14 +0200 Subject: [PATCH] mescc: Produce M1 output instead of hex2. 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. --- .gitignore | 15 + build-aux/compile-all.scm | 5 +- build-aux/mes-snarf.scm | 2 +- configure | 14 +- guile/guix/make.scm | 482 +++++++++++++++++++++++++++++++ guile/guix/records.scm | 378 ++++++++++++++++++++++++ guile/guix/shell-utils.scm | 93 ++++++ guile/mescc.scm | 8 +- make.scm | 224 ++++++++++++++ mlibc/libc-gcc.c | 72 ++--- mlibc/libc-mes.c | 111 +++---- mlibc/mini-libc-mes.c | 50 +--- module/language/c99/compiler.mes | 77 +++-- module/language/c99/compiler.scm | 2 +- module/mes/{hex2.mes => M1.mes} | 68 +++-- module/mes/{hex2.scm => M1.scm} | 9 +- module/mes/as-i386.mes | 269 +++++++++-------- module/mes/as-i386.scm | 1 - module/mes/elf.mes | 4 +- module/mes/elf.scm | 2 +- scaffold/t.c | 6 +- scripts/mescc.mes | 8 +- stage0/x86.M1 | 131 +++++++++ 23 files changed, 1662 insertions(+), 369 deletions(-) create mode 100644 guile/guix/make.scm create mode 100644 guile/guix/records.scm create mode 100644 guile/guix/shell-utils.scm create mode 100755 make.scm rename module/mes/{hex2.mes => M1.mes} (70%) rename module/mes/{hex2.scm => M1.scm} (88%) create mode 100644 stage0/x86.M1 diff --git a/.gitignore b/.gitignore index 3aaec58a..a06659f0 100644 --- a/.gitignore +++ b/.gitignore @@ -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 diff --git a/build-aux/compile-all.scm b/build-aux/compile-all.scm index e123bbb9..013904b0 100644 --- a/build-aux/compile-all.scm +++ b/build-aux/compile-all.scm @@ -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))) diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index be09704f..024de299 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -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"))) diff --git a/configure b/configure index 2709aa27..aa5ca891 100755 --- 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 index 00000000..dc5362f9 --- /dev/null +++ b/guile/guix/make.scm @@ -0,0 +1,482 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2017 Jan Nieuwenhuizen +;;; +;;; 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 . + +;;; 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 make-method + method? + (name method-name) + (build method-build (default (lambda _ #t))) + (inputs method-inputs (default (list)))) + +(define-record-type* + 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)) ; + (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 index 00000000..7de5fcce --- /dev/null +++ b/guile/guix/records.scm @@ -0,0 +1,378 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; +;;; 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 . + +(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 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 index 00000000..4e1dc5da --- /dev/null +++ b/guile/guix/shell-utils.scm @@ -0,0 +1,93 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2015 Mark H Weaver +;;; +;;; 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 . + +(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))))) diff --git a/guile/mescc.scm b/guile/mescc.scm index 7e53951e..357ec3f4 100755 --- a/guile/mescc.scm +++ b/guile/mescc.scm @@ -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 index 00000000..52e57cdb --- /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))) diff --git a/mlibc/libc-gcc.c b/mlibc/libc-gcc.c index 83a58f93..8c31ed94 100644 --- a/mlibc/libc-gcc.c +++ b/mlibc/libc-gcc.c @@ -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" diff --git a/mlibc/libc-mes.c b/mlibc/libc-mes.c index cfc930c8..dfddccb8 100644 --- a/mlibc/libc-mes.c +++ b/mlibc/libc-mes.c @@ -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 ("mov____%ebp,%eax"); // mov %ebp,%eax + asm ("add____$i8,%eax !8"); // add $0x8,%eax + asm ("push___%eax"); // 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 ("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 (".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 !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; } + diff --git a/mlibc/mini-libc-mes.c b/mlibc/mini-libc-mes.c index 3b88e4dd..2478f50a 100644 --- a/mlibc/mini-libc-mes.c +++ b/mlibc/mini-libc-mes.c @@ -18,66 +18,34 @@ * along with Mes. If not, see . */ -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 diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index 42cf683e..0b2c9c6c 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -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) @@ -648,7 +648,7 @@ ((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 @@ -753,7 +753,7 @@ (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) @@ -765,7 +765,7 @@ (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) @@ -861,7 +861,7 @@ `(,@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))))) @@ -1003,7 +1003,7 @@ (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) @@ -1012,14 +1012,14 @@ ((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 @@ -1043,13 +1043,13 @@ (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) @@ -1112,9 +1112,9 @@ (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 @@ -1307,7 +1307,7 @@ ((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?)))))) @@ -1321,7 +1321,7 @@ (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))) @@ -1334,9 +1334,9 @@ (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))) @@ -1350,9 +1350,9 @@ (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))) @@ -1366,7 +1366,7 @@ (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))))) @@ -1383,14 +1383,14 @@ (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)) @@ -1406,12 +1406,12 @@ (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)) @@ -1426,19 +1426,19 @@ (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)) @@ -1825,7 +1825,7 @@ (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))))) @@ -1840,7 +1840,7 @@ (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 @@ -1862,7 +1862,7 @@ (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)))) @@ -2129,9 +2129,6 @@ (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 #:types i386:type-alist)) @@ -2153,4 +2150,4 @@ ((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)))) diff --git a/module/language/c99/compiler.scm b/module/language/c99/compiler.scm index 95be83fd..0735eda4 100644 --- a/module/language/c99/compiler.scm +++ b/module/language/c99/compiler.scm @@ -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/hex2.mes b/module/mes/M1.mes similarity index 70% rename from module/mes/hex2.mes rename to module/mes/M1.mes index 0eecd0f5..931eb513 100644 --- a/module/mes/hex2.mes +++ b/module/mes/M1.mes @@ -20,7 +20,7 @@ ;;; Commentary: -;;; hex2.mes produces stage0' hex2 object format +;;; M1.mes produces stage0' M1 object format ;;; Code: @@ -28,6 +28,7 @@ (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)) @@ -41,14 +42,14 @@ (define (stderr string . rest) (apply logf (cons* (current-error-port) string rest))) -(define (objects->hex2 objects) - ((compose object->hex2 merge-objects) objects)) +(define (objects->M1 objects) + ((compose object->M1 merge-objects) objects)) (define (object->elf o) - ((compose hex2->elf object->hex2) o)) + ((compose M1->elf object->M1) o)) (define (objects->elf objects) - ((compose hex2->elf object->hex2 merge-objects) objects)) + ((compose M1->elf object->M1 merge-objects) objects)) (define (merge-objects objects) (let loop ((objects (cdr objects)) (object (car objects))) @@ -72,7 +73,13 @@ (define (hex2:offset1 o) (string-append "!" o)) -(define (object->hex2 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)) @@ -80,9 +87,8 @@ (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) + (define (text->M1 o) (pmatch o ;; FIXME ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string)))) @@ -93,38 +99,29 @@ ((#:address ,address) (hex2:address address)) ((#:offset ,offset) (hex2:offset offset)) ((#:offset1 ,offset1) (hex2:offset1 offset1)) - (_ (cond ((char? o) (text->hex2 (char->integer o))) + ((#: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) (string-append (if (and (>= o 0) (< o 16)) "0" "") - (number->string - (if (>= o 0) o (+ o #x100)) - 16))) + ((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->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)) + (define (line->M1 o) + (cond ((eq? (car o) #:label) (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))) + (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->hex2 text))) + (for-each line->M1 (apply append text)))) (define (write-global o) (define (labelize o) (if (not (string? o)) o @@ -141,7 +138,14 @@ (data (cdr o)) (data (filter-map labelize data))) (format #t "\n:~a\n" label) - (display (string-join (map text->hex2 data) " ")) + (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)) diff --git a/module/mes/hex2.scm b/module/mes/M1.scm similarity index 88% rename from module/mes/hex2.scm rename to module/mes/M1.scm index 437b1fd0..edc0b7ea 100644 --- a/module/mes/hex2.scm +++ b/module/mes/M1.scm @@ -22,13 +22,14 @@ ;;; Code: -(define-module (mes hex2) +(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->hex2 - objects->hex2 + #:export (object->M1 + objects->M1 object->elf objects->elf)) @@ -38,4 +39,4 @@ (use-modules (ice-9 syncase))) (mes)) -(include-from-path "mes/hex2.mes") +(include-from-path "mes/M1.mes") diff --git a/module/mes/as-i386.mes b/module/mes/as-i386.mes index c62aa17c..eaaaf483 100644 --- a/module/mes/as-i386.mes +++ b/module/mes/as-i386.mes @@ -31,82 +31,79 @@ (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 + `(("push___$i32" (#:address ,label)))) ; push $0x