ralph/src/ralph/compiler/anf.ralph at d164cc51aa4ef0200951813a5accf3e16baa5e77 · turbolent/ralph · GitHub

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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
(define-module ralph/compiler/anf
  import: (ralph/compiler/utilities)
  export: (normalize-term))

;;;; based on the linear-time A-normalization algorithm
;;;; as found in "The Essence of Compiling with Continuations".

;;;; generates-statements? is introduced to fold bindings which
;;;; will not generate statements in the resulting JavaScript code

(define-function atomic? (expression)
  (any? (curry instance? expression)
        [<number> <boolean> <string> <symbol> <keyword>]))

(define-function generates-statements? (exp)
  (if (and (instance? exp <array>)
           (not (empty? exp)))
      (select (symbol-name (first exp)) ==
        (("%begin" "%if" "%while" "%bind" "%try") #t)
        (("%set")
         (generates-statements? (last exp)))
        (("%method") #f)
        (else:
         (any? generates-statements? exp)))
      #f))


(define-function normalize-term (expression env)
  (normalize expression env identity))

(define-function normalize (exp env k)
  (if (and (instance? exp <array>)
           (not (empty? exp)))
      (select (symbol-name (first exp)) ==
        (("%quote")
         (k exp))
        (("%bind")
         (destructuring-bind (_ (identifier value) form) exp
           (normalize
            value env
            (method (value*)
              `(%bind (,identifier ,value*)
                 ,(normalize form env k))))))
        (("%method")
         (destructuring-bind (_ name parameters form) exp
           (k `(%method ,name ,parameters
                 ,(normalize-term form env)))))
        (("%set")
         (destructuring-bind (_ place value) exp
           (if (op? "%get-property" place)
               (normalize**
                (rest place) env
                (method (arguments*)
                  (normalize-value
                   value env
                   (method (value*)
                     (k `(%set (%get-property ,@arguments*)
                               ,value*))))))
               (normalize-value
                value env
                (method (value*)
                  (k `(%set ,place ,value*)))))))
        (("%define" "%var")
         (destructuring-bind (op identifier value) exp
           (normalize-value
            value env
            (method (value*)
              (k `(,op ,identifier ,value*))))))
        (("%if")
         (destructuring-bind (_ test consequent alternate) exp
           (normalize-value
            test env
            (method (test*)
              (k `(%if ,test*
                       ,(normalize-term consequent env)
                       ,(normalize-term alternate env)))))))
        (("%begin")
         (destructuring-bind (_ form #rest forms) exp
           (if (empty? forms)
               (normalize form env k)
               (normalize form env
                          (method (form*)
                            `(%begin
                              ,form*
                              ,(normalize `(%begin  ,@forms)
                                          env k)))))))
        (("%while")
         (destructuring-bind (_ test form) exp
           (k (if (generates-statements? test)
                  `(%while #t
                     ,(normalize-term `(%if ,test
                                            ,(normalize-term form)
                                            (%native "break")
                                            ;; TODO [#A]: #f ?
                                            )
                                      env))
                  `(%while
                    ,(normalize-term test env)
                    ,(normalize-term form env))))))
        (("%try")
         (destructuring-bind
             (_ protected-form identifier handling-form) exp
           (k `(%try ,(normalize-term protected-form env)
                     ,identifier
                     ,(normalize-term handling-form env)))))
        (else:
         (cond
          ((generates-statements? exp)
           (normalize-all exp env k))
          (else:
           (k (map (rcurry normalize-term env)
                   exp))))))
      (k exp)))


(define-function normalize-value (exp env k)
  (if (generates-statements? exp)
      (normalize* exp env k)
      (k (if (instance? exp <array>)
             (map (rcurry normalize-term env)
                  exp)
             exp))))

(define-function normalize* (exp env k)
  (normalize exp env
             (method (exp*)
               (if (atomic? exp*)
                   (k exp*)
                   (bind ((t (generate-symbol)))
                     `(%bind (,t ,exp*)
                        ,(k t)))))))

(define-function normalize** (exp* env k)
  (if (empty? exp*)
      (k [])
      (normalize-all exp* env k)))

(define-function normalize-all (exp env k)
  (normalize* (first exp) env
              (method (t)
                (normalize** (rest exp) env
                             (method (t*)
                               (k (cons t t*)))))))