root/lang/scheme/backend-to-frontend/1.4.scm @ 31388

Revision 31388, 8.0 kB (checked in by mokehehe, 5 years ago)

1.4 exercise 3の条件式による分岐に対応

Line 
1(load "./tests-driver.scm")
2(load "./tests-1.4-req.scm")
3
4(define fxshift 2)
5(define fxmask #x03)
6(define fxtag #x00)
7(define bool_f #x2f)
8(define bool_t #x6f)
9(define bool_bit 6)
10(define bool_mask #xbf)
11(define bool_tag  #x2f)
12(define wordsize 4) ; bytes
13
14(define nullval #b00111111)
15(define charshift 8)
16(define chartag #b00001111)
17(define charmask #xff)
18
19(define fixnum-bits (- (* wordsize 8) fxshift))
20
21(define fxlower (- (expt 2 (- fixnum-bits 1))))
22
23(define fxupper (sub1 (expt 2 (- fixnum-bits 1))))
24
25
26(define (emit-program expr)
27  (emit-function-header "_scheme_entry")
28  (emit-expr expr)
29  (emit "    ret"))
30
31(define (emit-function-header funcname)
32  (emit "    .text")
33  (emit (string-append "    .global " funcname))
34  (emit "    .def       _scheme_entry;  .scl    2;      .type   32;     .endef")
35  (emit (string-append funcname ":")))
36
37(define (emit-expr expr)
38  (cond
39   ((immediate? expr) (emit-immediate expr))
40   ((if? expr)        (emit-if expr))
41   ((and? expr)       (emit-and expr))
42   ((or? expr)        (emit-or expr))
43   ((primcall? expr)  (emit-primcall expr))
44   ((predicate-call? expr) (emit-predicate-val expr))
45   (else (error "not implemented"))))
46
47(define (emit-immediate x)
48  (emit "    movl $~s, %eax" (immediate-rep x)))
49
50(define (emit-primcall expr)
51  (let ((prim (car expr)) (args (cdr expr)))
52    (check-primcall-args prim args)
53    (apply (primitive-emitter prim) args)))
54
55(define (emit-predicate-val expr)
56  (emit-predicate-test expr)
57  (let ((prim (car expr)) (args (cdr expr)))
58    (emit-to-boolean)))
59
60(define (emit-predicate-test expr)
61  (let ((prim (car expr)) (args (cdr expr)))
62    (check-primcall-args prim args)
63    (apply (predicate-emitter prim) args)))
64
65(define (emit-label label)
66  (emit "~a:" label))
67
68(define (emit-test expr)
69  (if (predicate-call? expr)
70      (begin
71        (emit-predicate-test expr)
72        #t)
73    (begin
74      (emit-expr expr)
75      (emit "    cmp $~s, %al" bool_f)
76      #f)))
77
78(define (emit-if expr)
79  (let ((alt-label (unique-label))
80        (end-label (unique-label)))
81    (if (emit-test (if-test expr))
82        (emit "    jne ~a" alt-label)
83      (emit "    je ~a" alt-label))
84    (emit-expr (if-conseq expr))
85    (emit "    jmp ~a" end-label)
86    (emit-label alt-label)
87    (emit-expr (if-altern expr))
88    (emit-label end-label)))
89
90(define (emit-and expr)
91  (define (test-false expr false-label end-label)
92    (if (predicate-call? expr)
93        (begin
94          (emit-predicate-test expr)
95          (emit "    jne ~a" false-label))  ; ���肪���s������f �̑��ɔ�      (begin
96        (emit-test expr)
97        (emit "    je ~a" end-label))))  ; �l�̏ꍇ�͂��ł�#f �ɂȂ�Ă����Œ��ڏI���֔�  (let ((p (cdr expr)))
98    (cond ((null? p)
99           (emit "    mov $~s, %eax" bool_t))
100          (else
101           (let ((false-label (unique-label))
102                 (end-label (unique-label)))
103             (let loop ((p p))
104               (if (null? (cdr p)) ; �Ō�                  (emit-expr (car p))
105                 (begin
106                   (test-false (car p) false-label end-label)
107                   (loop (cdr p)))))
108             (emit "    jmp ~a" end-label)
109             (emit-label false-label)
110             (emit "    mov $~s, %eax" bool_f)
111             (emit-label end-label))))))
112
113(define (emit-or expr)
114  (define (test-true expr true-label end-label)
115    (if (predicate-call? expr)
116        (begin
117          (emit-predicate-test expr)
118          (emit "    je ~a" true-label))  ; ���肪�������t �̑��ɔ�      (begin
119        (emit-test expr)
120        (emit "    jne ~a" end-label))))  ; �l�̏ꍇ�͐^����������ɔ�  (let ((p (cdr expr)))
121    (cond ((null? p)
122           (emit "    mov $~s, %eax" bool_f))
123          (else
124           (let ((true-label (unique-label))
125                 (end-label (unique-label)))
126             (let loop ((p p))
127               (if (null? (cdr p))
128                   (emit-expr (car p))
129                 (begin
130                   (test-true (car p) true-label end-label)
131                   (loop (cdr p)))))
132             (emit "    jmp ~a" end-label)
133             (emit-label true-label)
134             (emit "    mov $~s, %eax" bool_t)
135             (emit-label end-label))))))
136
137
138
139
140
141(define (fixnum? x)
142  (and (integer? x) (exact? x) (<= fxlower x fxupper)))
143
144(define (immediate? x)
145  (or (fixnum? x) (boolean? x) (char? x) (null? x)))
146
147(define (immediate-rep x)
148  (cond
149   ((fixnum? x) (ash x fxshift))
150   ((eq? x #t) bool_t)
151   ((eq? x #f) bool_f)
152   ((char? x) (+ (ash (char->integer x) charshift) chartag))
153   ((null? x) nullval)
154   (else (error "must not happen"))))
155
156
157(define-syntax define-primitive
158  (syntax-rules ()
159    ((_ (prim-name arg* ...) b b* ...)
160     (begin
161       (putprop 'prim-name '*is-prim* #t)
162       (putprop 'prim-name '*arg-count*
163                (length '(arg* ...)))
164       (putprop 'prim-name '*emitter*
165                (lambda (arg* ...) b b* ...))))))
166
167(define (primitive? x)
168  (and (symbol? x) (getprop x '*is-prim*)))
169
170(define (primitive-emitter x)
171  (or (getprop x '*emitter*) (error "must not happen")))
172
173(define (primcall? expr)
174  (and (pair? expr) (primitive? (car expr))))
175
176(define (check-primcall-args prim args)
177  (let ((n (getprop prim '*arg-count*))
178        (m (length args)))
179    (if (= m n)
180        #t
181      (error "illegal argnum:" m 'for n))))
182
183
184(define-syntax define-predicate
185  (syntax-rules ()
186    ((_ (prim-name arg* ...) b b* ...)
187     (begin
188       (putprop 'prim-name '*is-predicate* #t)
189       (putprop 'prim-name '*arg-count*
190                (length '(arg* ...)))
191       (putprop 'prim-name '*emitter*
192                (lambda (arg* ...) b b* ...))))))
193
194(define (predicate? x)
195  (and (symbol? x) (getprop x '*is-predicate*)))
196
197(define (predicate-call? expr)
198  (and (pair? expr) (predicate? (car expr))))
199
200(define (predicate-emitter x)
201  (or (getprop x '*emitter*) (error "must not happen")))
202
203
204
205(define unique-label
206  (let ((count 0))
207    (lambda ()
208      (let ((L (format "L_~s" count)))
209        (set! count (add1 count))
210        L))))
211
212(define (if? expr)
213  (and (pair? expr) (eq? (car expr) 'if)))
214
215(define (if-test expr) (cadr expr))
216(define (if-conseq expr) (caddr expr))
217(define (if-altern expr) (cadddr expr))
218
219(define (and? expr)
220  (and (pair? expr) (eq? (car expr) 'and)))
221
222(define (or? expr)
223  (and (pair? expr) (eq? (car expr) 'or)))
224
225
226
227(define-primitive ($fxadd1 arg)
228                  (emit-expr arg)
229                  (emit "    addl $~s, %eax" (immediate-rep 1)))
230
231(define-primitive ($fxsub1 arg)
232                  (emit-expr arg)
233                  (emit "    subl $~s, %eax" (immediate-rep 1)))
234
235(define-primitive ($fixnum->char arg)
236                  (emit-expr arg)
237                  (emit "    shll $~s, %eax" (- charshift fxshift))
238                  (emit "    orl $~s, %eax" chartag))
239
240(define-primitive ($char->fixnum arg)
241                  (emit-expr arg)
242                  (emit "    shrl $~s, %eax" (- charshift fxshift)))
243
244(define (emit-to-boolean)
245  (emit "    sete %al")
246  (emit "    movzbl %al, %eax")
247  (emit "    sal $~s, %al" bool_bit)
248  (emit "    or $~s, %al" bool_f))
249
250(define-predicate (fixnum? arg)
251                  (emit-expr arg)
252                  (emit "    and $~s, %al" fxmask)
253                  (emit "    cmp $~s, %al" fxtag))
254
255(define-predicate ($fxzero? arg)
256                  (emit-expr arg)
257                  (emit "    cmp $0, %al"))
258
259(define-predicate (null? arg)
260                  (emit-expr arg)
261                  (emit "    cmp $~s, %al" nullval))
262
263(define-predicate (boolean? arg)
264                  (emit-expr arg)
265                  (emit "    and $~s, %al" bool_mask)
266                  (emit "    cmp $~s, %al" bool_tag))
267
268(define-predicate (char? arg)
269                  (emit-expr arg)
270                  (emit "    and $~s, %al" charmask)
271                  (emit "    cmp $~s, %al" chartag))
272
273(define-predicate (not arg)
274                  (emit-expr arg)
275                  (emit "    cmp $~s, %al" bool_f))
276
277(define-primitive ($fxlognot arg)
278                  ; assert(fixnum?)
279                  (emit-expr arg)
280                  (emit "    notl %eax")
281                  (emit "    and $~s, %eax" (lognot fxmask)))
282
283;;;;
284
285(define (main args)
286  (test-all "1.2.runtime.c")
287  0)
Note: See TracBrowser for help on using the browser.