artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mescc: Produce M1 output instead of hex2.

Browse source 
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.
This commit is contained in:
Jan Nieuwenhuizen 2017-07-02 16:25:14 +02:00
parent 03ecebd594
commit 83a43b81b3
23 changed files with 1662 additions and 369 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
.gitignore vendored
View 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

5
build-aux/compile-all.scm
View 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)))

2
build-aux/mes-snarf.scm
View file

@ -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")))

14
configure vendored
View file

@ -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"))))

482
guile/guix/make.scm Normal file
View file

@ -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))

378
guile/guix/records.scm Normal file
View file

@ -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

93
guile/guix/shell-utils.scm Normal file
View file

@ -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)))))

8
guile/mescc.scm
View file

@ -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?))

224
make.scm Executable file
View file

@ -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)))

10
mlibc/libc-gcc.c
View file

@ -34,8 +34,8 @@ void
exit (int code)
{
asm (
"movl %0,%%ebx\n\t"
"movl $1,%%eax\n\t"
"mov %0,%%ebx\n\t"
"mov $1,%%eax\n\t"
"int $0x80"
: // no outputs "=" (r)
: "" (code)
@ -50,9 +50,9 @@ 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"

111
mlibc/libc-mes.c
View 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 ("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;
}

50
mlibc/mini-libc-mes.c
View file

@ -18,66 +18,34 @@
* 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

77
module/language/c99/compiler.mes
View 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)
@ -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 <info> #: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))))

2
module/language/c99/compiler.scm
View 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

68
module/mes/hex2.mes → module/mes/M1.mes
View file

@ -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))

9
module/mes/hex2.scm → module/mes/M1.scm
View file

@ -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")

269
module/mes/as-i386.mes
View file

@ -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<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))
@ -114,280 +111,272 @@
(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)

1
module/mes/as-i386.scm
View 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

4
module/mes/elf.mes
View 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"))

2
module/mes/elf.scm
View file

@ -23,7 +23,7 @@
;;; Code:
(define-module (mes elf)
#:export (hex2->elf))
#:export (M1->elf))
(cond-expand
(guile-2)

6
scaffold/t.c
View 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);

8
scripts/mescc.mes
View file

@ -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))

131
stage0/x86.M1 Normal file
View file

@ -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