source: project/release/5/spock/trunk/core.scm @ 39038

Last change on this file since 39038 was 39038, checked in by felix winkelmann, 6 weeks ago

spock 0.3: added convenience %inline for calls to dotted names, by wasamasa

File size: 10.9 KB
Line 
1;;;; core.scm
2
3
4(define (add-undefined var)
5  (unless (memq var undefined)
6    (set! undefined (cons var undefined))))
7
8(define (add-access var assign)
9  (let ((d (get var 'defined)))
10    (if d
11        (when (and (symbol? d) (not (memq d used-sections)))
12          (set! used-sections (cons d used-sections)))
13        (add-undefined var))
14    (cond (assign 
15           (unless (get var 'assigned)
16             (put! var 'assigned #t)
17             (set! assigned (cons var assigned))))
18          ((not (get var 'referenced))
19           (put! var 'referenced #t)
20           (set! referenced (cons var referenced))))))
21
22(define (canonicalize form state)
23  (let ((looping #f)
24        (debug-mode (test-option 'debug state))
25        (xref-mode (test-option 'xref state))
26        (strict-mode (test-option 'strict state)))
27    (define (match-llist? llist args)
28      (let loop ((ll llist) (args args))
29        (cond ((null? ll) (null? args))
30              ((symbol? ll))
31              ((null? args) #f)
32              (else (loop (cdr ll) (cdr args))))))
33    (define (dotted? name)
34      (string-find-char #\. (stringify name)))
35    (define (normalize-ref ref)
36      (let* ((str (stringify ref))
37             (len (string-length str)))
38        (cond ((char=? #\. (string-ref str 0))
39               (normalize-ref (substring str 1 len)))
40              ((char=? #\. (string-ref str (- len 1)))
41               (normalize-ref (substring str 0 (- len 1))))
42              (else str))))
43    (define (walk x e tail ldest)
44      ;;(pp x)
45      (match x
46        ((or (? char?) (? number?) (? string?) (? boolean?))
47         `(quote ,x))
48        ((? symbol?)
49         (if (and (not strict-mode) (dotted? x))
50             (let ((str (symbol->string x)))
51               (cond ((char=? #\. (string-ref str 0))
52                      `(%property-ref ,(normalize-ref str)))
53                     (else
54                      `(%host-ref ,(normalize-ref str)))))
55             (cond ((assq x e) => cdr)
56                   (else
57                    (when xref-mode (add-access x #f))
58                    `(%global-ref ,x)))))
59        ;; interop function call
60        (((and (? symbol?) (? dotted?) arg) . args)
61         (walk `(%inline ,arg ,@args) e tail ldest))
62        (('set! x y)
63         (let ((y (walk y e #f #f)))
64           (if (and (not strict-mode) (dotted? x))
65               `(%host-set! ,(normalize-ref x) ,y)
66               (cond ((assq x e) => (lambda (a) `(set! ,(cdr a) ,y)))
67                     (else
68                      (when xref-mode
69                        (put! x 'assigned #t)
70                        (add-access x #t))
71                      `(%global-set! ,x ,y))))))
72        (('quote _) x)
73        (('if x y) 
74         `(if ,(walk x e #f #f)
75              ,(walk y e tail ldest) 
76              (%void)))
77        (('if x y z)
78         `(if ,(walk x e #f #f)
79              ,(walk y e tail ldest)
80              ,(walk z e tail ldest)))
81        ((('lambda _ ('%dispatch lambdas ...)) args ...)
82         (let loop ((ls lambdas))
83           (if (or (null? (cdr ls))
84                   (match-llist? (cadar ls) args))
85               (walk `(,(car ls) ,@args) e tail ldest)
86               (loop (cdr ls)))))
87        ((('lambda () body ...))
88         (walk `(begin ,@body) e #t ldest))
89        ((('lambda llist body ...) args ...)
90         (match-let (((vars rest) (parse-llist llist)))
91           (let ((aliases (map (lambda (v) (cons v (temp))) vars)))
92             (let loop ((as aliases) (vars vars) (args args))
93               (cond ((null? as)
94                      ;; handle surplus arguments
95                      (let loop2 ((args args))
96                        (if (null? args)
97                            (walk 
98                             `(begin ,@body) 
99                             (append aliases e)
100                             tail ldest)
101                            `(let ((%unused ,(walk (car args) e #f #f)))
102                               ,(loop2 (cdr args))))))
103                     ((eq? rest (caar as))
104                      `(let ((,(cdar as) ,(walk `(%list ,@args) e #f (car vars))))
105                         ,(loop '() '() '())))
106                     ((null? args)
107                      `(let ((,(cdar as) (%void)))
108                         ,(loop (cdr as) (cdr vars) '())))
109                     (else
110                      `(let ((,(cdar as) ,(walk (car args) e #f (car vars))))
111                         ,(loop (cdr as) (cdr vars) (cdr args)))))))))
112        (('lambda _ ('%dispatch lambdas ...))
113         (walk (last lambdas) e tail ldest))
114        (('letrec () body ...)
115         (walk `(begin ,@body) e tail ldest))
116        (('letrec ((vars vals) ...) body ...)
117         (let* ((aliases (map (lambda (v) (cons v (temp))) vars))
118                (e2 (append aliases e)))
119           (let loop1 ((as aliases))
120             (if (null? as)
121                 (if strict-mode
122                     (let ((temps (map (lambda _ (temp)) aliases)))
123                       (let loop2 ((tmps temps) (vals vals))
124                         (if (null? tmps)
125                             (let loop3 ((as aliases) (temps temps))
126                               (if (null? as) 
127                                   (walk `(begin ,@body) e2 tail #f)
128                                   `(let ((%unused (set! ,(cdar as) ,(car temps))))
129                                      ,(loop3 (cdr as) (cdr temps)))))
130                             `(let ((,(car tmps) ,(walk (car vals) e2 #f #f)))
131                                ,(loop2 (cdr tmps) (cdr vals))))))
132                     (let loop2 ((as aliases) (vars vars) (vals vals))
133                       (if (null? as) 
134                           (walk `(begin ,@body) e2 tail #f)
135                           `(let ((%unused
136                                   (set! ,(cdar as) ,(walk (car vals) e2 #f (car vars)))))
137                              ,(loop2 (cdr as) (cdr vars) (cdr vals))))))
138                 `(let ((,(cdar as) (%void)))
139                    ,(loop1 (cdr as)))))))
140        (('%check type x)
141         (if (not debug-mode)
142             (walk x e tail ldest)
143             `(%check ,type ,(walk x e tail ldest))))
144        (('%check x)
145         (if (not debug-mode)
146             ''#t
147             (walk x e tail ldest)))
148        (((or '%void '%void?) args ...)
149         `(,(car x) ,@(map (cut walk <> e #f #f) args)))
150        (('%host-ref (or ('quote name) name))
151         `(%host-ref ,(normalize-ref name)))
152        (('%host-set! (or ('quote name) name) x)
153         `(%host-set! ,(normalize-ref name) ,(walk x e #f #f)))
154        (('%syntax-error msg . arg)
155         (apply fail msg arg))
156        (('%new args ...) 
157         `(%new ,@(map (cut walk <> e #f #f) args)))
158        (('%property-ref (or ('quote name) name) x)
159         `(%property-ref ,(normalize-ref name) ,(walk x e #f #f)))
160        (('%property-ref (or ('quote name) name))
161         `(%property-ref ,(normalize-ref name)))
162        (('%property-set! (or ('quote name) name) x y)
163         `(%property-set!
164           ,(normalize-ref name)
165           ,(walk x e #f #f)
166           ,(walk y e #f #f)))
167        (('%inline (or name ('quote name)) xs ...) 
168         `(%inline ,name ,@(map (cut walk <> e #f #f) xs)))
169        (((or '%native-lambda '%code) code ...) x)
170        (('begin x) (walk x e tail ldest))
171        (('begin) '(%void))
172        (('begin x1 . more)
173         `(let ((%unused ,(walk x1 e #f #f)))
174            ,(walk `(begin ,@more) e tail ldest)))
175        (('lambda llist body ...)
176         (set! looping #f)
177         (match-let (((vars rest) (parse-llist llist)))
178           (let* ((aliases (map (lambda (v) (cons v (temp))) vars))
179                  (newllist
180                   (append
181                    (map cdr (if rest (butlast aliases) aliases))
182                    (if rest
183                        (cdr (assq rest aliases))
184                        '()))))
185             `(lambda ,newllist
186                ,(fluid-let ((looping #t))
187                   ;; walking body checks for self-call in tail-pos. and sets `looping'
188                   (let ((body (walk `(begin ,@body) (append aliases e) #t ldest)))
189                     (if looping
190                         `(%loop ,newllist ,body)
191                         body)))))))
192        (('define v x)
193         (when (and xref-mode
194                    (not (get v 'defined)))
195           (put! v 'defined #t)
196           (set! defined (cons v defined)))
197         `(%global-set! ,v ,(walk x e #f #f)))
198        ;;XXX we actually have to check `op' for not being a special form name
199        ((op args ...)
200         (cond ((and tail (symbol? op) (eq? op ldest)) ; tail + self call?
201                `(%continue ,@(map (cut walk <> e #f #f) x)))
202               (else
203                (set! looping #f)
204                (map (cut walk <> e #f #f) x))))
205        (_ (fail "bad expression" x))))
206    (walk form '() #t #f)))
207
208;; CPS-conversion algorithm from "Essentials of Programming Languages"
209(define (cps form)
210  (let ((toplambdas '()))
211    (define (zero x)
212      (let ((k (temp "k")))
213        `(lambda (,k) ,(one x k))))     ; Cpgm
214    (define (one x k)
215      (match x
216        (('let ((v x)) y)               ; canonicalizer only generates single-var `let'
217         (if (simple? x)
218             `(let ((,v ,(two x)))      ; Clet
219                ,(one y k))
220             (let ((t (temp)))          ; Chead
221               (one x `(lambda (,t)
222                         (let ((,v ,t))
223                           ,(one y k)))))))
224        ((? simple?)
225         (callk k (lambda () x)))
226        ;; from here on `x' is non-simple
227        (((or 'set! '%global-set! '%host-set!) v y)
228         (let ((t (temp)))
229           (one y `(lambda (,t)         ; Chead
230                     (let ((%unused (,(car x) ,v ,t)))
231                       ,(callk k (lambda () '(%void))))))))
232        (('if x y z)
233         (bindk
234          k
235          (lambda (k)           ; Cif
236            (if (simple? x)
237                `(if ,(two x)
238                     ,(one y k)
239                     ,(one z k))
240                (let ((t (temp)))               ; Chead
241                  (one x `(lambda (,t)
242                            (if ,t 
243                                ,(one y k)
244                                ,(one z k)))))))))
245        (('%loop llist x) `(%loop ,llist ,(one x k)))
246        (('%continue args ...)
247         (head
248          args
249          (lambda (args2)
250            `(%continue ,(car args2) ,k ,@(cdr args2)))))
251        (((or '%property-set! '%inline) info xs ...)
252          ;; simple %inline/%property-set! form is already handled above
253         (head 
254          xs
255          (lambda (xs2)
256            (callk k (lambda () `(,(car x) ,info ,@xs2))))))
257        (('%check type x)               ; s.a.
258         (head 
259          (list x)
260          (lambda (xs2)
261            (callk k (lambda () `(%check ,type ,@xs2))))))
262        (('%new args ...)
263         (head
264          args
265          (lambda (args2)
266            (callk k (lambda () `(%new ,@args2))))))
267        (((? simple?) ...)              ; Capp
268         (cons (two (car x)) (cons k (map two (cdr x)))))
269        ((xs ...)
270         (head
271          xs
272          (lambda (xs2) (cons (car xs2) (cons k (cdr xs2))))))
273        (else (error "one" x k))))
274    (define (two x)
275      (match x
276        ((? symbol?) x)
277        (('lambda llist body)           ; Cproc
278         (let ((k (temp "k")))
279           `(lambda (,k . ,llist) ,(one body k))))
280        (('if xs ...) `(if ,@(map two xs)))
281        (((or '%inline '%property-set!) info xs ...) 
282         `(,(car x) ,info ,@(map two xs)))
283        (((or 'set! '%global-set! '%check) v y) `(,(car x) ,v ,(two y)))
284        (((or 'quote '%host-ref '%code '%native-lambda '%void) . _) x)
285        (('%property-ref parts) x)
286        (((or '%host-set! '%property-ref) parts y) 
287         `(,(car x) ,parts ,(two y)))
288        (('let ((var x)) y)
289         `(let ((,var ,(two x))) ,(two y)))
290        (((or '%new '%continue '%void?) xs ...) `(,(car x) ,@(map two xs)))
291        ((xs ...) (map two xs))
292        (_ (error "two" x))))
293    (define (bindk k proc)
294      (if (symbol? k)
295          (proc k)
296          (let ((t (temp)))
297            `(let ((,t ,k))
298               ,(proc t)))))
299    (define (callk k thunk)
300      (if (symbol? k)
301          `(,k ,(two (thunk)))        ; Csimplevar
302          (let ((v (caadr k)))        ; Csimpleproc
303            `(let ((,v ,(two (thunk))))     ;XXX must we `two' here as well?
304               ,(caddr k)))))
305    (define (head xs wrap)
306      (let loop ((xs xs) (xs2 '()))     ; Chead
307        (if (null? xs)
308            (wrap (reverse xs2))
309            (let ((x (car xs)))
310              (if (simple? x)
311                  (loop (cdr xs) (cons (two x) xs2))
312                  (let ((t (temp)))
313                    (one x `(lambda (,t) 
314                              ,(loop (cdr xs) (cons t xs2))))))))))
315    (define (simple? x)
316      (match x
317        (((or '%host-ref '%code 'lambda 'quote '%global-ref '%void
318              '%native-lambda) . _)
319         #t)
320        (('%property-ref _) #t)
321        (((or '%host-set! '%property-ref) _ x) (simple? x))
322        ((? symbol?) #t)
323        (('if (? simple?) ...) #t)
324        (('%void? (? simple?)) #t)
325        (('let ((_ (? simple?))) (? simple?)) #t)
326        (((or 'set! '%inline '%global-set! '%check '%new '%property-set!) _ (? simple?) ...)
327         #t)
328        (((or '%loop '%continue) . _) #f)
329        (_ #f)))
330    (define (sequence parts)
331      (let loop ((parts parts))
332        (if (null? (cdr parts))
333            (car parts)
334            `(let (,(car parts))
335               ,(loop (cdr parts))))))
336    (define (toplambda parts)
337      (set! toplambdas (cons (zero (sequence parts)) toplambdas)))
338    (define (top x parts)
339      ;; perform "clustering": build groups of toplevel forms
340      ;; transformed together to reduce function nesting
341      ;; XXX is this still needed, or does this pay off?
342      (match x
343        (('let ((_ (? simple?))) y)
344         (top y (cons (caadr x) parts)))
345        (('let (('%unused z)) y)
346         (toplambda (reverse (cons z parts)))
347         (top y '()))
348        (_ (toplambda
349            (if (null? parts)
350                (list x)
351                (reverse (cons x parts)))))))
352    (top form '())
353    (reverse toplambdas)))
Note: See TracBrowser for help on using the repository browser.