blob: 45d2167f702f081f9f4a9e44f2175a5d4496159f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
;; Assume that core.scm is loaded
(define *unique-counter* 0)
(define (next-unique)
(set! *unique-counter* (+ 1 *unique-counter*))
*unique-counter*)
(define *macro-scratch-reg* R12)
(define (%packed-string s)
;; emit length
(define sl (string-length s))
(u16 sl) ; cast to u16 to get bounds check
(emit-word sl)
;; compute packed words
(for-each (@ emit-byte) (string->ascii-list s)))
(define-syntax emit-test-eq
(syntax-rules ()
((_ lhs rhs dest set)
(begin (sub lhs rhs)
(br flag-zero (label dest) set: set)))))
(define-syntax emit-test-lt
(syntax-rules ()
((_ lhs rhs dest set)
(begin (sub lhs rhs)
(br flag-sign (label dest) set: set)))))
(define-syntax emit-test-lte
(syntax-rules ()
((_ lhs rhs dest set)
(begin (sub lhs rhs)
(sub lhs (u16 1))
(br flag-sign (label dest) set: set)))))
(define-syntax %if-else
(syntax-rules ()
((_ pred tb fb)
(let* ((lhs (eval (car 'pred)))
(op (cadr 'pred))
(rhs (eval (caddr 'pred)))
(n (next-unique))
(sym-false (string->symbol (format "~A-false" n)))
(sym-end (string->symbol (format "~A-end" n))))
(ld *macro-scratch-reg* lhs)
(cond
((eq? '== op) (emit-test-eq *macro-scratch-reg* rhs sym-false #f))
((eq? '!= op) (emit-test-eq *macro-scratch-reg* rhs sym-false #t))
((eq? '< op) (emit-test-lt *macro-scratch-reg* rhs sym-false #f))
((eq? '>= op) (emit-test-lt *macro-scratch-reg* rhs sym-false #t))
((eq? '<= op) (emit-test-lte *macro-scratch-reg* rhs sym-false #f))
((eq? '> op) (emit-test-lte *macro-scratch-reg* rhs sym-false #t))
(else (error "unsupported operator" op)))
tb
(ld PC (label sym-end))
(def-label sym-false)
fb
(def-label sym-end)))))
(define-syntax %if
(syntax-rules ()
((_ pred tb)
(let* ((lhs (eval (car 'pred)))
(op (cadr 'pred))
(rhs (eval (caddr 'pred)))
(n (next-unique))
(sym-end (string->symbol (format "~A-end" n))))
(ld *macro-scratch-reg* lhs)
(cond
((eq? '== op) (emit-test-eq *macro-scratch-reg* rhs sym-end #f))
((eq? '!= op) (emit-test-eq *macro-scratch-reg* rhs sym-end #t))
((eq? '< op) (emit-test-lt *macro-scratch-reg* rhs sym-end #f))
((eq? '>= op) (emit-test-lt *macro-scratch-reg* rhs sym-end #t))
((eq? '<= op) (emit-test-lte *macro-scratch-reg* rhs sym-end #f))
((eq? '> op) (emit-test-lte *macro-scratch-reg* rhs sym-end #t))
(else (error "unsupported operator" op)))
tb
(def-label sym-end)))))
|
