202 lines
7.9 KiB
Scheme
202 lines
7.9 KiB
Scheme
;;; -*-scheme-*-
|
|
|
|
;;; Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; This file is part of Mes.
|
|
;;;
|
|
;;; Mes is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
;;; your option) any later version.
|
|
;;;
|
|
;;; Mes is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; M1.mes produces stage0' M1 object format
|
|
|
|
;;; Code:
|
|
|
|
(cond-expand
|
|
(guile)
|
|
(mes
|
|
(mes-use-module (srfi srfi-1))
|
|
(mes-use-module (srfi srfi-26))
|
|
(mes-use-module (mes as))
|
|
(mes-use-module (mes elf))
|
|
(mes-use-module (mes optargs))
|
|
(mes-use-module (mes pmatch))
|
|
(mes-use-module (language c99 info))))
|
|
|
|
(define (logf port string . rest)
|
|
(apply format (cons* port string rest))
|
|
(force-output port)
|
|
#t)
|
|
|
|
(define (stderr string . rest)
|
|
(apply logf (cons* (current-error-port) string rest)))
|
|
|
|
(define (pke . stuff)
|
|
(newline (current-error-port))
|
|
(display ";;; " (current-error-port))
|
|
(write stuff (current-error-port))
|
|
(newline (current-error-port))
|
|
(car (last-pair stuff)))
|
|
|
|
(define (objects->M1 file-name objects)
|
|
((compose (cut object->M1 file-name <>) merge-objects) objects))
|
|
|
|
(define (object->elf file-name o)
|
|
((compose M1->elf (cut object->M1 file-name <>)) o))
|
|
|
|
(define (objects->elf file-name objects)
|
|
((compose M1->elf (cut object->M1 file-name <>) merge-objects) objects))
|
|
|
|
(define (merge-objects objects)
|
|
(let loop ((objects (cdr objects)) (object (car objects)))
|
|
(if (null? objects) object
|
|
(loop (cdr objects)
|
|
`((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions)))
|
|
(globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals))))))))
|
|
|
|
(define (alist-add a b)
|
|
(let* ((b-keys (map car b))
|
|
(a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
|
|
(a-keys (map car a)))
|
|
(append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
|
|
|
|
(define (hex2:address o)
|
|
(string-append "&" o))
|
|
|
|
(define (hex2:offset o)
|
|
(string-append "%" o))
|
|
|
|
(define (hex2:offset1 o)
|
|
(string-append "!" o))
|
|
|
|
(define hex? #t)
|
|
|
|
(define (hex2:immediate o)
|
|
(if hex? (string-append "%0x" (dec->hex o))
|
|
(string-append "%" (number->string o))))
|
|
|
|
(define (hex2:immediate1 o)
|
|
(if hex? (string-append "!0x" (dec->hex o))
|
|
(string-append "!" (number->string o))))
|
|
|
|
(define* (display-join o #:optional (sep ""))
|
|
(let loop ((o o))
|
|
(when (pair? o)
|
|
(display (car o))
|
|
(if (pair? (cdr o))
|
|
(display sep))
|
|
(loop (cdr o)))))
|
|
|
|
(define (object->M1 file-name o)
|
|
(stderr "dumping M1: object\n")
|
|
(let* ((functions (assoc-ref o 'functions))
|
|
(function-names (map car functions))
|
|
(globals (assoc-ref o 'globals))
|
|
(global-names (map car globals))
|
|
(strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
|
|
(define (string->label o)
|
|
(let ((index (list-index (lambda (s) (equal? s o)) strings)))
|
|
(if index
|
|
(string-append "_string_" file-name "_" (number->string index))
|
|
"")))
|
|
(define (text->M1 o)
|
|
(cond
|
|
((char? o) (text->M1 (char->integer o)))
|
|
((string? o) o)
|
|
((symbol? o) (symbol->string o))
|
|
((number? o) (let ((o (if (< o #x80) o (- o #x100))))
|
|
(if hex? (string-append "!0x"
|
|
(if (and (>= o 0) (< o 16)) "0" "")
|
|
(number->string o 16))
|
|
(string-append "!" (number->string o)))))
|
|
((and (pair? o) (keyword? (car o)))
|
|
(pmatch o
|
|
;; FIXME
|
|
((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
|
|
((#:address (#:address ,address)) (guard (string? address))
|
|
(hex2:address address))
|
|
((#:address (#:address ,global)) (guard (global? global))
|
|
(hex2:address (global->string global)))
|
|
((#:string ,string)
|
|
(hex2:address (string->label o)))
|
|
((#:address ,address) (guard (string? address)) (hex2:address address))
|
|
((#:address ,global) (guard (global? global))
|
|
(hex2:address (global->string global)))
|
|
((#:offset ,offset) (hex2:offset offset))
|
|
((#:offset1 ,offset1) (hex2:offset1 offset1))
|
|
((#:immediate ,immediate) (hex2:immediate immediate))
|
|
((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))))
|
|
((pair? o) (string-join (map text->M1 o)))))
|
|
(define (write-function o)
|
|
(let ((name (car o))
|
|
(text (function:text (cdr o))))
|
|
(define (line->M1 o)
|
|
(cond ((eq? (car o) #:label)
|
|
(display (string-append ":" (cadr o))))
|
|
((eq? (car o) #:comment)
|
|
(display "\t\t\t\t\t# ")
|
|
(display (text->M1 (cadr o))))
|
|
((or (string? (car o)) (symbol? (car o)))
|
|
(display "\t" )
|
|
(display-join (map text->M1 o) " "))
|
|
(else (error "line->M1 invalid line:" o)))
|
|
(newline))
|
|
(display (string-append " :" name "\n") (current-error-port))
|
|
(display (string-append "\n\n:" name "\n"))
|
|
(for-each line->M1 (apply append text))))
|
|
(define (write-global o)
|
|
(define (labelize o)
|
|
(if (not (string? o)) o
|
|
(let* ((label o)
|
|
(function? (member label function-names))
|
|
(string-label (string->label label))
|
|
(string? (not (equal? string-label "_string_#f"))))
|
|
(cond ((and (pair? o) (global? (cdr o))) (string-append "&" (global->string o)))
|
|
((and (not string?) (not function?)) (stderr "warning: unresolved label: ~s\n" label))
|
|
(else (string-append "&" label))))))
|
|
(let* ((label (cond
|
|
((and (pair? (car o)) (eq? (caar o) #:string))
|
|
(string->label (car o)))
|
|
((global? (cdr o)) (global->string (cdr o)))
|
|
(else (car o))))
|
|
(string? (string-prefix? "_string" label))
|
|
(foo (if (not (eq? (car (string->list label)) #\_))
|
|
(display (string-append " :" label "\n") (current-error-port))))
|
|
(data ((compose global:value cdr) o))
|
|
(data (filter-map labelize data))
|
|
(len (length data))
|
|
(string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 256))
|
|
(string-data (and string? (list-head data (1- (length data))))))
|
|
(display (string-append "\n:" label "\n"))
|
|
(if (and string-data
|
|
(< len string-max)
|
|
(char? (car data))
|
|
(eq? (last data) #\nul)
|
|
(not (find (cut memq <> '(#\")) string-data))
|
|
(not (any (lambda (ch)
|
|
(or (and (not (memq ch '(#\tab #\newline)))
|
|
(< (char->integer ch) #x20))
|
|
(>= (char->integer ch) #x80))) string-data)))
|
|
(display (string-append "\"" (list->string string-data) "\""))
|
|
(display-join (map text->M1 data) " "))
|
|
(newline)))
|
|
(display "M1: functions\n" (current-error-port))
|
|
(for-each write-function (filter cdr functions))
|
|
(when (assoc-ref functions "main")
|
|
(display "\n\n:ELF_data\n") ;; FIXME
|
|
(display "\n\n:HEX2_data\n"))
|
|
(display "M1: globals\n" (current-error-port))
|
|
(for-each write-global globals)))
|