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

mescc: Unify labels.

Browse source 
* module/language/c99/compiler.mes: Use (#:address label) (#local
  label) (#:relative label) thoughout.
* module/mes/elf-util.mes (add-s:-prefix, drop-s:-prefix): Remove.
  (function->text): Update.
* module/mes/hex2.mes (write-hex2): Update.
This commit is contained in:
Jan Nieuwenhuizen 2017-06-11 18:05:56 +02:00
parent 1263d6e278
commit d46994f2fe
5 changed files with 52 additions and 57 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

64
module/language/c99/compiler.mes
View file

@ -217,7 +217,7 @@
(define (push-global globals) (define (push-global globals)
(lambda (o) (lambda (o)
(list (i386:push-label-mem o)))) (list (i386:push-label-mem `(#:address ,o)))))
(define (push-local locals) (define (push-local locals)
(lambda (o) (lambda (o)
@ -255,10 +255,10 @@
(error "TODO int-de-de-ref"))))) (error "TODO int-de-de-ref")))))
(define (string->global string) (define (string->global string)
(make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul)))) (make-global `(#:string ,string) "string" 0 (append (string->list string) (list #\nul))))
(define (int->global value) (define (int->global value)
(make-global (add-s:-prefix (number->string value)) "int" 0 (int->bv32 value))) (make-global `(#:string ,(number->string value)) "int" 0 (int->bv32 value)))
(define (ident->global name type pointer value) (define (ident->global name type pointer value)
(make-global name type pointer (if (pair? value) value (int->bv32 value)))) (make-global name type pointer (if (pair? value) value (int->bv32 value))))
@ -286,7 +286,7 @@
(if constant (if constant
(wrap-as (append (i386:value->accu constant) (wrap-as (append (i386:value->accu constant)
(i386:push-accu))) (i386:push-accu)))
((push-global-address #f) `(address ,o)))))))))) ((push-global-address #f) `(#:address ,o))))))))))
(define (push-ident-address info) (define (push-ident-address info)
(lambda (o) (lambda (o)
@ -295,7 +295,7 @@
(let ((global (assoc-ref (.globals info) o))) (let ((global (assoc-ref (.globals info) o)))
(if global (if global
((push-global-address (.globals info)) o) ((push-global-address (.globals info)) o)
((push-global-address #f) `(address ,o)))))))) ((push-global-address #f) `(#:address ,o))))))))
(define (push-ident-de-ref info) (define (push-ident-de-ref info)
(lambda (o) (lambda (o)
@ -316,7 +316,7 @@
(define (globals:add-string globals) (define (globals:add-string globals)
(lambda (o) (lambda (o)
(let ((string (add-s:-prefix o))) (let ((string `(#:string ,o)))
(if (assoc-ref globals string) globals (if (assoc-ref globals string) globals
(append globals (list (string->global o))))))) (append globals (list (string->global o)))))))
@ -328,7 +328,7 @@
((p-expr (string ,string)) ((p-expr (string ,string))
(let* ((globals ((globals:add-string (.globals info)) string)) (let* ((globals ((globals:add-string (.globals info)) string))
(info (clone info #:globals globals))) (info (clone info #:globals globals)))
(append-text info ((push-global-address info) (add-s:-prefix string))))) (append-text info ((push-global-address info) `(#:string ,string)))))
((p-expr (ident ,name)) ((p-expr (ident ,name))
(append-text info ((push-ident info) name))) (append-text info ((push-ident info) name)))
@ -376,12 +376,12 @@
(size (if (= ptr 1) (type->size info type) (size (if (= ptr 1) (type->size info type)
4))) 4)))
(case ptr (case ptr
((-1) (list (i386:label->accu o))) ((-1) (list (i386:label->accu `(#:address ,o))))
((1) (list (i386:label-mem->accu o))) ((1) (list (i386:label-mem->accu `(#:address ,o))))
((2) (list (i386:label->accu o))) ((2) (list (i386:label->accu `(#:address ,o))))
(else (list (i386:label-mem->accu o))))) (else (list (i386:label-mem->accu `(#:address ,o))))))
(if constant (wrap-as (i386:value->accu constant)) (if constant (wrap-as (i386:value->accu constant))
(list (i386:label->accu `(address ,o))))))))) (list (i386:label->accu `(#:address ,o)))))))))
(define (ident-address->accu info) (define (ident-address->accu info)
(lambda (o) (lambda (o)
@ -393,8 +393,8 @@
(size (if (= ptr 1) (type->size info type) (size (if (= ptr 1) (type->size info type)
4))) 4)))
(wrap-as (i386:local-ptr->accu (local:id local)))) (wrap-as (i386:local-ptr->accu (local:id local))))
(if global (list (i386:label->accu o)) (if global (list (i386:label->accu `(#:address ,o)))
(list (i386:label->accu `(address ,o)))))))) (list (i386:label->accu `(#:address ,o))))))))
(define (ident-address->base info) (define (ident-address->base info)
(lambda (o) (lambda (o)
@ -407,8 +407,8 @@
(size (if (= ptr 1) (type->size info type) (size (if (= ptr 1) (type->size info type)
4))) 4)))
(wrap-as (i386:local-ptr->base (local:id local)))) (wrap-as (i386:local-ptr->base (local:id local))))
(if global (list (i386:label->base o)) (if global (list (i386:label->base `(#:address ,o)))
(list (i386:label->accu `(address ,o)))))))) (list (i386:label->accu `(#:address ,o))))))))
(define (value->accu v) (define (value->accu v)
(wrap-as (i386:value->accu v))) (wrap-as (i386:value->accu v)))
@ -418,13 +418,13 @@
(let ((local (assoc-ref (.locals info) o))) (let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:accu->local (local:id local))) (if local (wrap-as (i386:accu->local (local:id local)))
(let ((ptr (ident->pointer info o))) (let ((ptr (ident->pointer info o)))
(list (i386:accu->label o))))))) (list (i386:accu->label `(#:address ,o))))))))
(define (base->ident info) (define (base->ident info)
(lambda (o) (lambda (o)
(let ((local (assoc-ref (.locals info) o))) (let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:base->local (local:id local))) (if local (wrap-as (i386:base->local (local:id local)))
(list (i386:base->label o)))))) (list (i386:base->label `(#:address ,o)))))))
(define (base->ident-address info) (define (base->ident-address info)
(lambda (o) (lambda (o)
@ -443,13 +443,13 @@
(lambda (o value) (lambda (o value)
(let ((local (assoc-ref (.locals info) o))) (let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:value->local (local:id local) value)) (if local (wrap-as (i386:value->local (local:id local) value))
(list (i386:value->label o value)))))) (list (i386:value->label `(#:address ,o) value))))))
(define (ident-add info) (define (ident-add info)
(lambda (o n) (lambda (o n)
(let ((local (assoc-ref (.locals info) o))) (let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:local-add (local:id local) n)) (if local (wrap-as (i386:local-add (local:id local) n))
(list (i386:label-mem-add o n)))))) (list (i386:label-mem-add `(#:address ,o) n))))))
(define (ident-address-add info) (define (ident-address-add info)
(lambda (o n) (lambda (o n)
@ -459,7 +459,7 @@
(i386:accu-mem-add n) (i386:accu-mem-add n)
(i386:pop-accu))) (i386:pop-accu)))
(list (wrap-as (append (i386:push-accu) (list (wrap-as (append (i386:push-accu)
(i386:label->accu o) (i386:label->accu `(#:address ,o))
(i386:accu-mem-add n) (i386:accu-mem-add n)
(i386:pop-accu)))))))) (i386:pop-accu))))))))
@ -482,12 +482,12 @@
(if global (if global
(let ((ptr (ident->pointer info o))) (let ((ptr (ident->pointer info o)))
(case ptr (case ptr
((-1) (list (i386:label->base o))) ((-1) (list (i386:label->base `(#:address ,o))))
((2) (list (i386:label->base o))) ((2) (list (i386:label->base `(#:address ,o))))
(else (list (i386:label-mem->base o))))) (else (list (i386:label-mem->base `(#:address ,o))))))
(let ((constant (assoc-ref (.constants info) o))) (let ((constant (assoc-ref (.constants info) o)))
(if constant (wrap-as (i386:value->base constant)) (if constant (wrap-as (i386:value->base constant))
(list (i386:label->base `(address ,o))))))))))) (list (i386:label->base `(#:address ,o)))))))))))
(define (expr->accu info) (define (expr->accu info)
(lambda (o) (lambda (o)
@ -505,10 +505,10 @@
((p-expr (string ,string)) ((p-expr (string ,string))
(let* ((globals (append globals (list (string->global string)))) (let* ((globals (append globals (list (string->global string))))
(info (clone info #:globals globals))) (info (clone info #:globals globals)))
(append-text info (list (i386:label->accu (add-s:-prefix string)))))) (append-text info (list (i386:label->accu `(#:string ,string))))))
((p-expr (string . ,strings)) ((p-expr (string . ,strings))
(append-text info (list (i386:label->accu (add-s:-prefix (apply string-append strings)))))) (append-text info (list (i386:label->accu `(#:string ,(apply string-append strings))))))
((p-expr (fixed ,value)) ((p-expr (fixed ,value))
(append-text info (value->accu (cstring->number value)))) (append-text info (value->accu (cstring->number value))))
@ -644,7 +644,7 @@
(if (and (not (assoc name (.functions info))) (if (and (not (assoc name (.functions info)))
(not (assoc name globals))) (not (assoc name globals)))
(stderr "warning: undeclared function: ~a\n" name)) (stderr "warning: undeclared function: ~a\n" name))
(append-text args-info (list (i386:call-label name n)))) (append-text args-info (list (i386:call-label `(#:relative ,name) n))))
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) `(p-expr (ident ,name))))) (accu ((expr->accu empty) `(p-expr (ident ,name)))))
(append-text args-info (append (.text accu) (append-text args-info (append (.text accu)
@ -1535,7 +1535,7 @@
((goto (ident ,label)) ((goto (ident ,label))
(let* ((jump (lambda (n) (i386:XXjump n))) (let* ((jump (lambda (n) (i386:XXjump n)))
(offset (+ (length (jump 0)) (length (object->list text))))) (offset (+ (length (jump 0)) (length (object->list text)))))
(append-text info (list (i386:jump-label `(label ,label)))))) (append-text info (list (i386:jump-label `(#:local ,label))))))
((return ,expr) ((return ,expr)
(let ((info ((expr->accu info) expr))) (let ((info ((expr->accu info) expr)))
@ -1597,7 +1597,7 @@
(globals (append globals (list (string->global string)))) (globals (append globals (list (string->global string))))
(info (clone info #:locals locals #:globals globals))) (info (clone info #:locals locals #:globals globals)))
(append-text info (append (append-text info (append
(list (i386:label->accu (add-s:-prefix string))) (list (i386:label->accu `(#:string ,string)))
((accu->ident info) name)))) ((accu->ident info) name))))
(let* ((global (string->global string)) (let* ((global (string->global string))
(globals (append globals (list global))) (globals (append globals (list global)))
@ -1776,7 +1776,7 @@
(append text (append text
(.text accu) (.text accu)
((accu->ident info) name) ((accu->ident info) name)
(wrap-as (append (i386:label->base '(address "_start")) (wrap-as (append (i386:label->base `(#:address "_start"))
(i386:accu+base)))) (i386:accu+base))))
#:locals locals))) #:locals locals)))
@ -2141,7 +2141,7 @@
((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value))) ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value)))) ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
((initzer (ref-to (p-expr (ident ,name)))) `(,name #f #f #f)) ((initzer (ref-to (p-expr (ident ,name)))) `(,name #f #f #f))
((initzer (p-expr (string ,string))) `(,(add-s:-prefix string) #f #f #f)) ((initzer (p-expr (string ,string))) `((#:string ,string) #f #f #f))
(_ (error "initzer->data: unsupported: " o)))) (_ (error "initzer->data: unsupported: " o))))
(define (.formals o) (define (.formals o)

20
module/mes/elf-util.mes
View file

@ -50,9 +50,6 @@
(define global:pointer cadr) (define global:pointer cadr)
(define global:value caddr) (define global:value caddr)
(define (drop-s:-prefix o) (substring o 2))
(define (add-s:-prefix o) (string-append "s:" o))
(define (dec->hex o) (define (dec->hex o)
(cond ((number? o) (number->string o 16)) (cond ((number? o) (number->string o 16))
((char? o) (number->string (char->integer o) 16)) ((char? o) (number->string (char->integer o) 16))
@ -87,29 +84,30 @@
(if (null? text) '() (if (null? text) '()
(let ((label (car text))) (let ((label (car text)))
(if (number? label) (cons label (loop (cdr text) (1+ off))) (if (number? label) (cons label (loop (cdr text) (1+ off)))
(if (and (pair? label) (member (car label) '(#:comment #:label))) ;;(cons #x90 (loop (cdr text) (1+ off))) (if (and (pair? label) (member (car label) '(#:comment #:label)))
(loop (cdr text) off) (loop (cdr text) off)
(let* ((prefix (if (and (pair? (cdr text)) (let* ((prefix (if (and (pair? (cdr text))
(pair? (cddr text)) (pair? (cddr text))
(boolean? (caddr text))) 4 (boolean? (caddr text))) 4
2)) 2))
;;(foo (format (current-error-port) "LABEL=~s\n" label)) ;;(foo (format (current-error-port) "LABEL=~s\n" label))
;; FiXME: address vs relative address (address? (and (pair? label) (eq? (car label) #:address)))
(address? (and (pair? label) (member (car label) '(address)))) (local? (and (pair? label) (eq? (car label) #:local)))
(label (if address? (cadr label) label)) (relative? (and (pair? label) (eq? (car label) #:relative)))
(label (if (or address? local? relative?) (cadr label) label))
(function-address (function-offset label functions)) (function-address (function-offset label functions))
(data-address (data-offset label globals)) (data-address (data-offset label globals))
(label-address (label-offset (car o) (and (pair? label) (label-address (label-offset (car o) `((#:label ,label)) functions))
`((#:label ,(cadr label)))) functions))
;; (foo (format (current-error-port) " address?=~s\n" address?)) ;; (foo (format (current-error-port) " address?=~s\n" address?))
;; (foo (format (current-error-port) " d=~s\n" data-address)) ;; (foo (format (current-error-port) " d=~s\n" data-address))
;; (foo (format (current-error-port) " f=~s\n" function-address)) ;; (foo (format (current-error-port) " f=~s\n" function-address))
;; (foo (format (current-error-port) " l=~s\n" label-address)) ;; (foo (format (current-error-port) " l=~s\n" label-address))
(address (or (and=> data-address (lambda (a) (+ a d))) (address (or (and local?
(and=> label-address (lambda (a) (- a (- off offset) prefix))))
(and=> data-address (lambda (a) (+ a d)))
(if address? (if address?
(and=> function-address (lambda (a) (+ a ta))) (and=> function-address (lambda (a) (+ a ta)))
(and=> function-address (lambda (a) (- a off prefix)))) (and=> function-address (lambda (a) (- a off prefix))))
(and=> label-address (lambda (a) (- a (- off offset) prefix)))
(error "unresolved label: " label)))) (error "unresolved label: " label))))
(append ((if (= prefix 2) int->bv16 int->bv32) address) (append ((if (= prefix 2) int->bv16 int->bv32) address)
(loop (list-tail text prefix) (+ off prefix)))))))))))) (loop (list-tail text prefix) (+ off prefix))))))))))))

2
module/mes/elf-util.scm
View file

@ -27,8 +27,6 @@
#:use-module (mes bytevectors) #:use-module (mes bytevectors)
#:export (data-offset #:export (data-offset
dec->hex dec->hex
add-s:-prefix
drop-s:-prefix
function-offset function-offset
int->bv16 int->bv16
int->bv32 int->bv32

22
module/mes/hex2.mes
View file

@ -28,7 +28,6 @@
(guile) (guile)
(mes (mes
(mes-use-module (srfi srfi-1)) (mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-26))
(mes-use-module (mes elf-util)) (mes-use-module (mes elf-util))
(mes-use-module (mes elf)) (mes-use-module (mes elf))
(mes-use-module (mes optargs)))) (mes-use-module (mes optargs))))
@ -114,7 +113,7 @@
(function-names (map car functions)) (function-names (map car functions))
(globals (assoc-ref o 'globals)) (globals (assoc-ref o 'globals))
(global-names (map car globals)) (global-names (map car globals))
(strings (filter (cut string-prefix? "s:" <>) global-names))) (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
(define (string->label o) (define (string->label o)
(format #f "string_~a" (list-index (lambda (s) (equal? s o)) strings))) (format #f "string_~a" (list-index (lambda (s) (equal? s o)) strings)))
(define (dec->hex o) (define (dec->hex o)
@ -123,8 +122,8 @@
(if (>= o 0) o (+ o #x100)) (if (>= o 0) o (+ o #x100))
16))) 16)))
((char? o) (dec->hex (char->integer o))) ((char? o) (dec->hex (char->integer o)))
((and (string? o) (string-prefix? "s:" o)) ((and (pair? o) (eq? (car o) #:string))
(format #f "&~a" (string->label o))) (format #f "&~a" (string->label (cadr o))))
((string? o) (format #f "~a" o)) ((string? o) (format #f "~a" o))
(else (format #f "~a" o)))) (else (format #f "~a" o))))
(define (write-line o) (define (write-line o)
@ -142,17 +141,18 @@
(pair? (cddr text)) (pair? (cddr text))
(boolean? (caddr text))) 4 (boolean? (caddr text))) 4
2)) 2))
(address? (and (pair? label) (member (car label) '(address)))) (address? (and (pair? label) (eq? (car label) #:address)))
(label (if address? (cadr label) label)) (local? (and (pair? label) (eq? (car label) #:local)))
(relative? (and (pair? label) (eq? (car label) #:relative)))
(label (if (or address? local? relative?) (cadr label) label))
(function? (member label function-names)) (function? (member label function-names))
(string-label (string->label label)) (string-label (string->label label))
(string? (not (equal? string-label "string_#f"))) (string? (not (equal? string-label "string_#f")))
(global? (member label global-names)) (global? (member label global-names)))
(label? (and (pair? label) (eq? (car label) #:label))))
(cons (cond (cons (cond
((eq? prefix 1) (format #f "!~a" label)) ((eq? prefix 1) (format #f "!~a" label))
((eq? prefix 2) (format #f "@~a" label)) ((eq? prefix 2) (format #f "@~a" label))
(label? (format #f "%label_~a" label)) (local? (format #f "%local_~a" label))
(function? (format #f "%~a" label)) (function? (format #f "%~a" label))
(string? (format #f "&~a" string-label)) (string? (format #f "&~a" string-label))
(global? (format #f "&~a" label)) (global? (format #f "&~a" label))
@ -175,7 +175,7 @@
(if (pair? (cadr o)) (for-each write-line (cdr o)) (if (pair? (cadr o)) (for-each write-line (cdr o))
(write-line (cdr o)))) (write-line (cdr o))))
(define (write-global o) (define (write-global o)
(let ((label (if (not (string-prefix? "s:" (car o))) (car o) (let ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
(string->label (car o))))) (string->label (car o)))))
(format #t "\n:~a\n" label) (format #t "\n:~a\n" label)
(display (string-join (map dec->hex (cdr o)) " ")) (display (string-join (map dec->hex (cdr o)) " "))
@ -186,7 +186,7 @@
(display "### @<label> 2 byte relative\n") (display "### @<label> 2 byte relative\n")
(display "### &<label> 4 byte address\n") (display "### &<label> 4 byte address\n")
(display "### %<label> 4 byte relative\n") (display "### %<label> 4 byte relative\n")
(display "### label_<label> function-local\n") (display "### local_<label> function-local\n")
(display "### string_<index> string #<index>\n") (display "### string_<index> string #<index>\n")
(display "\n##.text") (display "\n##.text")
(for-each write-function (filter cdr functions)) (for-each write-function (filter cdr functions))

1
module/mes/hex2.scm
View file

@ -24,7 +24,6 @@
(define-module (mes hex2) (define-module (mes hex2)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (mes elf-util) #:use-module (mes elf-util)
#:use-module (mes elf) #:use-module (mes elf)
#:export (objects->hex2 #:export (objects->hex2