M4 -> Scheme
Patrick Premont
premont@cs.toronto.edu
Wed, 24 Jan 1996 17:30:45 -0500
Hello,
Fare has answered favorably to my suggestion of using Scheme instead
of M4. I've sent him 2 messages after his response, I havn't received
a response to these. [Did you get them ?, I've sent them at rideau@ens.fr].
I was itching to do something so I did. I've started the translation.
Actually the part I've done ignores most of the M4 macros. It is
mainly the internal representation, the display function that writes
it as an assembler file and a few conditional and loop constructs.
I hope Fare hasn't started to do the same thing. But it's possible
since I haven't heard from him[you] in a few days.
So here is what I've written. This should work on any R4RS Scheme.
I was testing it on MIT-Scheme. (change the paths if you want to test it)
There are assembler programs exemples, (search for "exemples") this is
the most interresting if you don't care about understanding everything.
; Translation to Scheme of Tunes V0.0.0.25
; Version of this translation : V0.1
(define (l) (load "f:\\desktop1\\projects\\lll.scm")) ; this file for reloads
(define (r) (restart 1)) ; an abbreviation for the mit-scheme debugger
(define (******)
(error "Execution has reached the unimplemented expression ******"))
; ---------------------------------------------------------------------------
; Generic object manipulation facilities
; ---------------------------------------------------------------------------
; Creates an object constructor from a type.
; An object is just a pair where the car is the type
; and the cdr is a list of the object members.
(define (constructor t)
(lambda args
(cons t args)))
; From a type, creates a fonction that determines if an
; object is of that type.
(define (detector t)
(lambda (object)
(and (pair? object)
(eq? (car object) t))))
; General constructor.
; (define (make t . args) ((constructor t) args))
; Or more efficiently, without the test for the presence of the type
(define make list)
; General detector.
(define (is-a? t object) ((detector t) object))
; Extracts the type.
(define (type object)
(if (pair? object)
(car object)
(if (number? object)
'number
(error "Tried to get type of unsupported object :" object))))
; Takes n and makes a getter which retreives the n-th element.
; 0 is the first object member, not the type.
(define (getter n)
(lambda (object)
(list-ref (cdr object) n)))
; Returns the object members.
(define object-members cdr)
; Returns the object size.
(define (object-size object)
(length (object-members object)))
; ---------------------------------------------------------------------------
; The object types that make up the internal assembly language representation.
; ---------------------------------------------------------------------------
; Object type command sequence (seq). This represents a program.
(define seq (constructor 'seq))
(define seq? (detector 'seq))
(define seq-nargs object-size)
(define seq-args cdr)
; ........................................
; The types for the different commands.
; ........................................
; Object type instruction (inst).
; Its first member is the operation, a string.
; All remaining members are arguments to the operation.
(define inst (constructor 'inst))
(define inst? (detector 'inst))
(define inst-op (getter 0))
(define inst-nargs (lambda (i) (- (object-size i) 1)))
(define inst-arg (lambda (n i) ((getter (+ n 1)) i)))
(define (inst-args o) (cdr (object-members o)))
; Object type label.
; It has one member, a string, the name of the label.
(define label (constructor 'label))
(define label? (detector 'label))
(define label-string (getter 0))
; Object type comment.
; It has one member, the comment string, which must be a single-line string.
(define comment (constructor 'comment))
(define comment? (detector 'comment))
(define comment-string (getter 0))
; ........................................
; The types for arguments to instructions. (operands)
; ........................................
; Object type register.
; It has one member, a symbol, the name of the register.
(define reg (constructor 'reg))
(define reg? (detector 'reg))
(define reg-symbol (getter 0))
(define (reg-string r)
(list->string (map char-upcase
(string->list (symbol->string (reg-symbol r))))))
; Object type index.
; It has any positive number of members. Which are non-label operands.
; Its semantics is that all arguments are summed and the result is
; dereferenced. This allows many types of indexing.
(define index (constructor 'index))
(define index? (detector 'index))
(define index-nargs object-size)
(define index-args object-members)
; A simple dereference is when there is nothing to sum (just one arg).
(define (deref? arg) (and (index? arg)
(= (object-size arg) 1)))
; Object type label has alread been defined.
; It is mentionned here because a label may be an operand.
; Numbers are also a valid type of operand.
; ........................................
; Another type that can appear as an index arg.
; ........................................
; Object type scale.
; It has two members. The first is a register and the other is a number.
(define scale (constructor 'scale))
(define scale? (detector 'scale))
(define scale-reg (getter 0))
(define scale-scale (getter 1))
; ---------------------------------------------------------------------------
; Display routines
; ---------------------------------------------------------------------------
; Newline string.
(define nl "\n")
; Tab string.
(define tab "\t")
; Take a program, a language identifier and optionally a port and
; writes the program in the given language on the specified port.
; The port returned by (current-output-port) is the default port.
(define (display-asm program language . rest)
(let* ((port (if (pair? rest) (car rest) (current-output-port)))
(p (lambda args (for-each (lambda (x) (display x port)) args)))
(line-comment-prefix
(case language
((as86) ";")
(else (Error "Unsupported language :" language))))
(display-comment (lambda (string)
(p line-comment-prefix " " string nl))))
(display-comment
"Assembler file generated by the Scheme Tunes LLL generator")
(p nl)
(letrec ((display-index-arg
(lambda (arg)
(case (type arg)
((number) (p arg))
((reg) (p (reg-string arg)))
((scale) (p (reg-string (scale-reg arg))
"*" (scale-scale arg)))
(else
(error "Tried to write an unsupported indexing argument"
arg)))))
(display-arg
(lambda (arg)
(case (type arg)
((number) (p arg))
((index) (p "[")
(display-index-arg (car (index-args arg)))
(for-each (lambda (x)
(if (not (and (number? x)
(negative? x)))
(p "+"))
(display-index-arg x))
(cdr (index-args arg)))
(p "]"))
((reg) (p (reg-string arg)))
((name) (p (name-string arg)))
((label) (p (label-string arg))))))
(display-args
(lambda (args)
(if (pair? args)
(begin (display-arg (car args))
(if (pair? (cdr args))
(begin (p ", ")
(display-args (cdr args))))))))
(display-command
(lambda (c)
(case (type c)
((inst) (p tab (inst-op c) tab)
(display-args (inst-args c))
(p nl))
((decl) (******))
((label) (p (label-string c) ":" nl))
((comment) (display-comment (comment-string c)))
(else (error "Unrecognised command :" command))))))
(letrec ((display-seq
(lambda (program)
(for-each (lambda (prog-part)
(if (seq? prog-part)
(display-seq prog-part)
(display-command prog-part)))
(seq-args program)))))
(display-seq program)))))
; ---------------------------------------------------------------------------
; Definition of registers to make the assembler writen in Scheme look better.
; ---------------------------------------------------------------------------
(define ah '(reg ah))
(define bh '(reg bh))
(define ch '(reg ch))
(define dh '(reg dh))
(define al '(reg al))
(define bl '(reg bl))
(define cl '(reg cl))
(define dl '(reg dl))
(define ax '(reg ax))
(define bx '(reg bx))
(define cx '(reg cx))
(define dx '(reg dx))
(define eax '(reg eax))
(define ebx '(reg ebx))
(define ecx '(reg ecx))
(define edx '(reg edx))
(define bp '(reg bp))
(define sp '(reg sp))
(define si '(reg si))
(define bi '(reg bi))
(define ebp '(reg ebp))
(define esp '(reg esp))
(define esi '(reg esi))
(define ebi '(reg ebi))
(define cs '(reg cs))
(define ds '(reg ds))
(define es '(reg es))
(define fs '(reg fs))
(define gs '(reg gs))
(define ss '(reg ss))
(define eip '(reg eip))
(define eflags '(reg eflags))
(define cr0 '(reg cr0))
(define cr1 '(reg cr1))
(define cr2 '(reg cr2))
(define cr3 '(reg cr3))
(define dr0 '(reg dr0))
(define dr1 '(reg dr1))
(define dr2 '(reg dr2))
(define dr3 '(reg dr3))
(define dr4 '(reg dr4))
(define dr5 '(reg dr5))
(define dr6 '(reg dr6))
(define dr7 '(reg dr7))
(define tr3 '(reg tr3))
(define tr4 '(reg tr4))
(define tr5 '(reg tr5))
(define tr6 '(reg tr6))
(define tr7 '(reg tr7))
; ---------------------------------------------------------------------------
; Functions to link 32 bits registers to their 8 and 16 bits versions
; ---------------------------------------------------------------------------
(define (rconverter n)
(lambda (r)
(let ((table '(("EAX" "AX" "AH" "AL")
("EBX" "BX" "BH" "BL")
("ECX" "CX" "CH" "CL")
("EDX" "DX" "DH" "DL")
("EBP" "BP" "" "")
("ESP" "SP" "" "")
("ESI" "SI" "" "")
("EBI" "BI" "" ""))))
(letrec ((conv2 (lambda (t)
(if (null? t)
(error "Can't convert register" r)
(if (member (reg-string r) (car t))
(let ((res (list-ref (car t) n)))
(if (equal? res "")
(error "Can't convert register" r)
res))
(conv2 (cdr t)))))))
(reg (string->symbol (conv2 table)))))))
(define r32 (rconverter 0))
(define r16 (rconverter 1))
(define r8h (rconverter 2))
(define r8l (rconverter 3))
; ---------------------------------------------------------------------------
; Label generator
; ---------------------------------------------------------------------------
(define (make-counter)
(let ((n -1))
(lambda ()
(set! n (+ n 1))
n)))
(define gen-label
(let ((counter (make-counter)))
(lambda ()
(label (string-append "l"
(number->string (counter)))))))
; ---------------------------------------------------------------------------
; Tests / exemples
; ---------------------------------------------------------------------------
(define target 'as86)
(define (unsupported-target)
(error "This construct doesn't support the specified target language."))
(define (increment reg)
(case target
('as86 (inst 'add reg 1))
(else (unsupported-target))))
(define (decrement reg)
(case target
('as86 (inst 'sub reg 1))
(else (unsupported-target))))
; Here is an exemple. It shows what can be done. Don't try to analyse
; what the program does. Also the indexing shown may not be possible.
(define program
(seq
(inst 'mov ax bx)
(inst 'add ax 4)
(inst 'jmp (label "hello"))
(comment "Now something a bit more complex.")
(inst 'mov ax (index bp bx 10))
(label "j23")
(inst 'mov (r16 al) (index bp bx -6))
(inst 'mov ecx (index (scale ebp 4) ebx 10))
(increment ax)
(seq (inst 'mov ax bx)
(increment cx))
(inst 'jmp (label "j23"))
))
(newline)
(display-asm program 'as86)
(call-with-output-file "f:\\desktop1\\projects\\output.s"
(lambda (port)
(display-asm program 'as86 port)))
; Here's the output (inside the stars)
;****************************************************************************
;*; Assembler file generated by the Scheme Tunes LLL generator
;*
;* mov AX, BX
;* add AX, 4
;* jmp hello
;*; Now something a bit more complex.
;* mov AX, [BP+BX+10]
;*j23:
;* mov AX, [BP+BX-6]
;* mov ECX, [EBP*4+EBX+10]
;* add AX, 1
;* mov AX, BX
;* add CX, 1
;* jmp j23
;***************************************************************************
; ---------------------------------------------------------------------------
; Conditionals and Loops
; ---------------------------------------------------------------------------
; Translate from a "user-friendly comparison" to the string that goes
; in the mnemonic instruction.
(define (test-string test)
(let ((table '((> . "a") (a . "a") (nbe . "a")
(< . "b") (b . "b") (nae . "b")
(>= . "ae") (=> . "ae") (ae . "ae") (nb . "ae")
(<= . "be") (=< . "be") (be . "be") (na . "be")
(= . "e") (== . "e") (s= . "e")
(s== . "e") (e . "e") (z . "e")
(<> . "ne") (!= . "ne") (~= . "ne") (ne . "ne") (nz . "ne")
(s<> . "ne") (s!= . "ne") (s~= . "ne")
(s> . "g") (g . "g") (nle . "g")
(s< . "l") (l . "l") (nge . "l")
(s>= . "ge") (s=> . "ge") (ge . "ge") (nl . "ge")
(s<= . "le") (s=< . "le") (le . "le") (ng . "le"))))
(cdr (assoc test table))))
; Remove the n at the beginning of the test string
; if there is one and add it if there is none.
(define (negate-test-string string)
(let ((chars (string->list string)))
(if (eqv? (car chars) #\n)
(list->string (cdr chars))
(list->string (cons #\n chars)))))
; This function should not be used directly, use if-jump or if-set.
(define (if-jump-or-set op1 test op2 dest action)
(seq (inst 'cmp op1 op2)
(inst (string->symbol
(string-append action (test-string test))) dest)))
; Jumps to the specified destination if the condition is true.
(define (if-jump op1 test op2 dest)
(if-jump-or-set op1 test op2 dest "j"))
; Set to 1 the specified location if the condition is true (0 otherwise).
(define (if-set op1 test op2 loc)
(if-jump-or-set op1 test op2 loc "set"))
; Execute prog-part while the condition is true.
; l1 and l2 are the labels before and after the while.
; They can be used to implement C's continue and break respectively.
(define (while-labels op1 test op2 prog-part l1 l2)
(seq l1
prog-part
(if-jump op1 test op2 l1)
l2))
; The while to use if you don't want continue or break.
(define (while op1 test op2 prog-part)
(while-labels op1 test op2 prog-part (gen-label) (gen-label)))
; Executes prog-part iff the condition is false.
(define (unless op1 test op2 prog-part)
(let ((l (gen-label)))
(seq (if-jump op1 test op2 l)
prog-part
l)))
; Executes then-part iff the condition is true.
(define (if-then op1 test op2 then-part)
(let ((l (gen-label)))
(seq (if-jump op1 (string->symbol
(negate-test-string (test-string test))) op2 l)
then-part
l)))
; Executes then-part iff the condition is true and else-part otherwise.
(define (if-then-else op1 test op2 then-part else-part)
(let ((begin-else (gen-label))
(end-else (gen-label)))
(seq (if-jump op1 (string->symbol
(negate-test-string (test-string test))) op2 begin-else)
then-part
(inst 'jmp end-else)
begin-else
else-part
end-else)))
; ---------------------------------------------------------------------------
; Other tests / exemples
; ---------------------------------------------------------------------------
; Another exemple program.
(define prog2
(seq
(if-jump ax '> bx (label "j23"))
(if-jump ecx 's<= edx (label "j24")) ; The s before the <= is for "signed"
(if-jump cx '= 0 (gen-label))
(if-jump ecx '= 0 (gen-label))
(while cx '> 0 (seq (decrement cx) (increment dx)))
(comment "The same while but this time with a break when dx = 45")
(comment "The other label in while-labels is the continue point")
(let ((end-of-while (gen-label)))
(while-labels cx '> 0 (seq (decrement cx)
(increment dx)
(if-jump dx '= 45 end-of-while))
(gen-label) end-of-while))
(comment "Here's an if-then-else")
(if-then-else cx '= 0
(comment "The then part would be here.")
(comment "The else part would be here."))))
(display-asm prog2 'as86)
(call-with-output-file "f:\\desktop1\\projects\\output2.s"
(lambda (port)
(display-asm prog2 'as86 port)))
; Here's the output (inside the stars)
;****************************************************************************
;*; Assembler file generated by the Scheme Tunes LLL generator
;*
;* cmp AX, BX
;* ja j23
;* cmp ECX, EDX
;* jle j24
;* cmp CX, 0
;* je l7
;* cmp ECX, 0
;* je l6
;*l5:
;* sub CX, 1
;* add DX, 1
;* cmp CX, 0
;* ja l5
;*l4:
;*; The same while but this time with a break when dx = 45
;*; The other label in while-labels is the continue point
;*l3:
;* sub CX, 1
;* add DX, 1
;* cmp DX, 45
;* je l2
;* cmp CX, 0
;* ja l3
;*l2:
;*; Here's an if-then-else
;* cmp CX, 0
;* jne l1
;*; The then part would be here.
;* jmp l0
;*l1:
;*; The else part would be here.
;*l0:
;****************************************************************************