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

Last change on this file since 36692 was 36692, checked in by felix winkelmann, 2 years ago

first attempt at porting spock, mostly untested

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