smalltalk-tng: 454c18798969 experiments/partial-eval/pe.scm

smalltalk-tng

view experiments/partial-eval/pe.scm @ 323:454c18798969

merger

author	Tony Garnock-Jones <tonygarnockjones@gmail.com>
date	Tue Feb 07 11:34:20 2012 -0500 (18 hours ago)
parents	2ab69289317c
children

line source

1 ;; Similar to the partial-evaluator in "Partial Evaluator as a

2 ;; Compiler for Reflective Languages", Asai, Masuhara, Matsuoka and

3 ;; Yonezawa (1995), but without preactions (yet).

4 ;;

7 (require (lib "1.ss" "srfi") (lib "9.ss" "srfi") (lib "pretty.ss"))

8 ;;(require 'srfi-1)

10 (define (make-node kind . vals0)

11 (let walk ((vals vals0)

12 (acc '()))

13 (cond

14 ((null? vals) (cons kind (reverse acc)))

15 ((null? (cdr vals)) (error "Bad arg list to make-node" (cons kind vals0)))

16 (else (walk (cddr vals)

17 (cons (list (car vals) (cadr vals)) acc))))))

19 (define (node-kind node) (car node))

21 (define (node-ref node field)

22 (cond

23 ((assq field (cdr node)) => cadr)

24 (else (error "No such field in node" (list field node)))))

26 (define (node-kind? node kind)

27 (eq? (node-kind node) kind))

29 (define (make-lit val)

30 (make-node 'lit 'val val))

32 (define (lit-value node)

33 (node-ref node 'val))

35 (define (lit? node)

36 (node-kind? node 'lit))

38 (define (make-undefined)

39 (make-lit 'UNDEF))

41 (define (parse-let is-rec exp env)

42 (let ((names (map car (cadr exp)))

43 (inits (map cadr (cadr exp)))

44 (bodyexp `(begin ,@(cddr exp))))

45 (cond

46 ((null? names) (parse bodyexp env))

47 (is-rec (let* ((new-env (append names env))

48 (p (lambda (x) (parse x new-env))))

49 (make-node 'letrec

50 'names names

51 'inits (map p inits)

52 'body (p bodyexp))))

53 (else (parse `((lambda ,names (filter 'unfold) ,bodyexp) ,@inits) env)))))

55 (define (parse exp env)

56 (let walk ((exp exp))

57 (cond

58 ((symbol? exp) (make-node 'ref 'name exp))

59 ((not (pair? exp)) (make-lit exp))

60 (else

61 (case (car exp)

62 ((quote) (make-lit (cadr exp)))

63 ((lambda) (let* ((has-filter (and (pair? (caddr exp))

64 (eq? (car (caddr exp)) 'filter)))

65 (formals (cadr exp))

66 (filter (and has-filter (cadr (caddr exp))))

67 (body (if has-filter (cdddr exp) (cddr exp)))

68 (newenv (append formals env)))

69 (make-node 'lambda

70 'formals formals

71 'filter (and filter (parse filter newenv))

72 'body (parse `(begin ,@body) newenv))))

73 ((lambda*) (parse `(lambda ,(cadr exp)

74 (filter 'unfold)

75 ,@(cddr exp)) env))

76 ((begin) (cond

77 ((null? (cdr exp)) (make-undefined))

78 ((null? (cddr exp)) (walk (cadr exp)))

79 (else (make-node 'begin 'exprs (map walk (cdr exp))))))

80 ((if) (make-node 'if

81 'test (walk (cadr exp))

82 'true (walk (caddr exp))

83 'false (if (null? (cdddr exp))

84 (make-undefined)

85 (walk (car (cdddr exp))))))

86 ((cond) (if (eq? (car (cadr exp)) 'else)

87 (parse `(begin ,@(cdr (cadr exp))) env)

88 (parse `(if ,(car (cadr exp))

89 (begin ,@(cdr (cadr exp)))

90 (cond ,@(cddr exp))) env)))

91 ((let) (if (symbol? (cadr exp))

92 (walk `(letrec ((,(cadr exp) (lambda ,(map car (caddr exp))

93 ,@(cdddr exp))))

94 (,(cadr exp) ,@(map cadr (caddr exp)))))

95 (parse-let #f exp env)))

96 ((letrec) (parse-let #t exp env))

97 ((let*) (if (null? (cadr exp))

98 (walk `(begin ,@(cddr exp)))

99 (walk `(let (,(caadr exp)) (let* ,(cdadr exp) ,@(cddr exp))))))

100 (else (make-node 'apply

101 'rator (walk (car exp))

102 'rands (map walk (cdr exp)))))))))

103

104 (define (extend-env env names inits)

105 (append (if inits

106 (map (lambda (name init)

107 (cons name (box (list init))))

108 names inits)

109 (map (lambda (name)

110 (cons name (box #f)))

111 names))

112 env))

113

114 (define (sval-known? node)

115 (memq (node-kind node) '(lit cons prim closure)))

116

117 (define (WARN message . args)

118 (display ";; ")

119 (display message)

120 (for-each (lambda (x)

121 (display " ")

122 (display x))

123 args)

124 (newline))

125

126 (define (pe pexp env cache)

127 ;;(pretty-print `(pe (pexp ,pexp) ));; (env ,env) (cache ,cache)))

128 (case (node-kind pexp)

129 ((lit) pexp)

130 ((letrec) (let ((newenv (extend-env env (node-ref pexp 'names) #f)))

131 (for-each (lambda (name init)

132 (let ((binding (assq name newenv)))

133 (set-box! (cdr binding) (list (pe init newenv cache)))))

134 (node-ref pexp 'names)

135 (node-ref pexp 'inits))

136 ;; BUG: need to collect free variables of the pe'd body,

137 ;; and if there are references to any of this pexp's names,

138 ;; we need to wrap the pe'd body in a letrec of the relevant

139 ;; names. (Actually, iterate until we've pulled in everything

140 ;; we need.)

141 (pe (node-ref pexp 'body) newenv cache)))

142 ((ref) (let* ((name (node-ref pexp 'name))

143 (binding (assq name env)))

144 (cond

145 ((not binding) pexp)

146 ((not (unbox (cdr binding))) pexp)

147 (else (car (unbox (cdr binding)))))))

148 ((lambda) (make-node 'closure

149 'formals (node-ref pexp 'formals)

150 'filter (node-ref pexp 'filter)

151 'body (node-ref pexp 'body)

152 'env env))

153 ((begin) (begin

154 (for-each (lambda (exp) (WARN ";; Ignoring" exp))

155 (drop-right (node-ref pexp 'exprs) 1))

156 (pe (car (take-right (node-ref pexp 'exprs) 1)) env cache)))

157 ((if) (let ((val (pe (node-ref pexp 'test) env cache)))

158 (if (sval-known? val)

159 (if (and (lit? val)

160 (lit-value val))

161 (pe (node-ref pexp 'true) env cache)

162 (pe (node-ref pexp 'false) env cache))

163 (make-node 'if

164 'test val

165 'true (pe (node-ref pexp 'true) env cache)

166 'false (pe (node-ref pexp 'false) env cache)))))

167 ((apply) (let* ((rator (pe (node-ref pexp 'rator) env cache))

168 (rands (map (lambda (x) (pe x env cache)) (node-ref pexp 'rands))))

169 (if (sval-known? rator)

170 (case (node-kind rator)

171 ((closure)

172 (let* ((filter (node-ref rator 'filter))

173 (formals (node-ref rator 'formals))

174 (rator-env (node-ref rator 'env))

175 (newenv (extend-env rator-env formals rands))

176 (directive (if (not filter)

177 (if (every sval-known? rands)

178 'unfold

179 (map (lambda (formal) #f) formals))

180 (let ((v (pe filter newenv cache)))

181 (if (not (lit? v))

182 (error "Bad filter" (codegen filter))

183 (lit-value v))))))

184 (cond

185 ((eq? directive 'unfold)

186 (pe (node-ref rator 'body)

187 newenv

188 cache))

189 ((and (list? directive)

190 (every boolean? directive))

191 (let* ((prop-rands (map (lambda (prop formal rand)

192 (if prop

193 rand

194 (make-node 'ref 'name formal)))

195 directive

196 formals

197 rands))

198 (cache-key (cons rator prop-rands))

199 (cache-entry (assoc cache-key cache)))

200 (if cache-entry

201 (make-node 'apply-cached

202 'rator (cadr cache-entry)

203 'rands rands)

204 (let* ((tmp-sym (gensym))

205 (tmp (make-node 'ref 'name tmp-sym))

206 (lambda-node

207 (make-node 'closure

208 'formals formals

209 'filter (node-ref rator 'filter)

210 'body (pe (node-ref rator 'body)

211 (extend-env rator-env

212 formals prop-rands)

213 (cons (list cache-key tmp)

214 cache))

215 'env rator-env)))

216 (make-node 'letrec

217 'names (list tmp-sym)

218 'inits (list lambda-node)

219 'body (make-node 'apply

220 'rator tmp

221 'rands rands))))))

222 (else (error "Bad filter result" directive)))))

223 ((prim)

224 ;;(pretty-print `(prim ,(node-ref rator 'prim-name) ));; ,@rands))

225 (apply (node-ref rator 'handler) rands))

226 (else (error "Bad node kind in rator in apply" (list pexp rator))))

227 (make-node 'apply

228 'rator rator

229 'rands rands))))

230 (else (error "Bad node kind in pe" pexp))))

231

232 (define (codegen0 pexp)

233 (case (node-kind pexp)

234 ((lit) `(quote ,(node-ref pexp 'val)))

235 ((cons) (let ((acode (codegen (node-ref pexp 'a)))

236 (d (node-ref pexp 'd)))

237 (if (and (lit? d)

238 (eq? (lit-value d) '()))

239 `(LIST ,acode)

240 (let ((dcode (codegen d)))

241 (if (and (pair? dcode)

242 (eq? (car dcode) 'LIST))

243 `(LIST ,acode ,@(cdr dcode))

244 `(cons ,acode ,dcode))))))

245 ((prim) (node-ref pexp 'prim-name))

246 ((closure) `(lambda ,(node-ref pexp 'formals)

247 ,@(if (node-ref pexp 'filter)

248 `((filter ,(codegen (node-ref pexp 'filter))))

249 '())

250 ,(codegen (node-ref pexp 'body))))

251

252 ((letrec) `(letrec ,(map list

253 (node-ref pexp 'names)

254 (map codegen (node-ref pexp 'inits)))

255 ,(codegen (node-ref pexp 'body))))

256 ((ref) (node-ref pexp 'name))

257 ((lambda) `(lambda ,(node-ref pexp 'formals)

258 ,@(if (node-ref pexp 'filter)

259 `((filter ,(codegen (node-ref pexp 'filter))))

260 '())

261 ,(codegen (node-ref pexp 'body))))

262 ((begin) `(begin ,@(map codegen (node-ref pexp 'exprs))))

263 ((if) `(if ,(codegen (node-ref pexp 'test))

264 ,(codegen (node-ref pexp 'true))

265 ,(codegen (node-ref pexp 'false))))

266 ((apply) `(,(codegen (node-ref pexp 'rator)) ,@(map codegen (node-ref pexp 'rands))))

267 ((apply-cached) `(GOTO ,(codegen (node-ref pexp 'rator))

268 ,@(map codegen (node-ref pexp 'rands))))

269 (else (error "Bad node-kind in codegen" pexp))))

270

271 (define (free-names pexp)

272 (case (node-kind pexp)

273 ((lit) '())

274 ((cons) (lset-union eq?

275 (free-names (node-ref pexp 'a))

276 (free-names (node-ref pexp 'd))))

277 ((prim) '())

278 ((closure lambda) (lset-difference eq?

279 (free-names (node-ref pexp 'body))

280 (node-ref pexp 'formals)))

281 ((letrec) (lset-difference eq?

282 (apply lset-union eq?

283 (free-names (node-ref pexp 'body))

284 (map free-names (node-ref pexp 'inits)))

285 (node-ref pexp 'names)))

286 ((ref) (list (node-ref pexp 'name)))

287 ((begin) (apply lset-union eq? (map free-names (node-ref pexp 'exprs))))

288 ((if) (lset-union eq?

289 (free-names (node-ref pexp 'test))

290 (free-names (node-ref pexp 'true))

291 (free-names (node-ref pexp 'false))))

292 ((apply apply-cached) (apply lset-union eq?

293 (free-names (node-ref pexp 'rator))

294 (map free-names (node-ref pexp 'rands))))

295 (else (error "Bad node-kind in free-names" pexp))))

296

297 (define (codegen pexp)

298 (let ((cache (box '()))) ;; alist of (pexp use-count-box temp-var-sym reduced-expr-box)

299 (define (walk pexp)

300 (cond

301 ((assq pexp (unbox cache)) =>

302 (lambda (entry)

303 (set-box! (cadr entry) (+ (unbox (cadr entry)) 1))

304 (caddr entry)))

305 (else

306 (let ((entry (list pexp (box 1) (gensym 't) (box #f))))

307 (set-box! cache (cons entry (unbox cache)))

308 (let ((exp (walk1 pexp)))

309 (set-box! (car (cdddr entry)) exp)

310 (caddr entry))))))

311 (define (env-entry-walker names)

312 (lambda (entry)

313 (if (memq (car entry) names)

314 (list (list (car entry) (walk (car (unbox (cdr entry))))))

315 '())))

316 (define (walk1 pexp)

317 (case (node-kind pexp)

318 ((lit) `(quote ,(node-ref pexp 'val)))

319 ((cons) (let ((acode (walk (node-ref pexp 'a)))

320 (d (node-ref pexp 'd)))

321 (if (and (lit? d)

322 (eq? (lit-value d) '()))

323 `(LIST ,acode)

324 (let ((dcode (walk d)))

325 (if (and (pair? dcode)

326 (eq? (car dcode) 'LIST))

327 `(LIST ,acode ,@(cdr dcode))

328 `(cons ,acode ,dcode))))))

329 ((prim) (node-ref pexp 'prim-name))

330 ((closure) `(let (,@(append-map (env-entry-walker (free-names (node-ref pexp 'body)))

331 (node-ref pexp 'env)))

332 (lambda ,(node-ref pexp 'formals)

333 ,@(if (node-ref pexp 'filter)

334 `((filter ,(walk (node-ref pexp 'filter))))

335 '())

336 ,(walk (node-ref pexp 'body)))))

337 ((letrec) `(letrec ,(map list

338 (node-ref pexp 'names)

339 (map walk (node-ref pexp 'inits)))

340 ,(walk (node-ref pexp 'body))))

341 ((ref) (node-ref pexp 'name))

342 ((lambda) `(lambda ,(node-ref pexp 'formals)

343 ,@(if (node-ref pexp 'filter)

344 `((filter ,(walk (node-ref pexp 'filter))))

345 '())

346 ,(walk (node-ref pexp 'body))))

347 ((begin) `(begin ,@(map walk (node-ref pexp 'exprs))))

348 ((if) `(if ,(walk (node-ref pexp 'test))

349 ,(walk (node-ref pexp 'true))

350 ,(walk (node-ref pexp 'false))))

351 ((apply) `(,(walk (node-ref pexp 'rator)) ,@(map walk (node-ref pexp 'rands))))

352 ((apply-cached) `(GOTO ,(walk (node-ref pexp 'rator))

353 ,@(map walk (node-ref pexp 'rands))))

354 (else (error "Bad node-kind in codegen" pexp))))

355 (let* ((exp (walk pexp))

356 (remapped-cache (map (lambda (entry)

357 (list (caddr entry) ;; temp-var-sym

358 (unbox (cadr entry)) ;; use-count

359 (unbox (cadddr entry)))) ;; reduced-expr

360 (unbox cache))))

361 (define (inlinable? entry)

362 (or (= (cadr entry) 1)

363 (let ((v (caddr entry)))

364 (or (symbol? v)

365 (and (pair? v)

366 (pair? (cdr v))

367 (null? (cddr v))

368 (eq? (car v) 'quote)

369 (symbol? (cadr v)))))))

370 (define (inline exp)

371 (cond

372 ((pair? exp) (cons (inline (car exp)) (inline (cdr exp))))

373 ((assq exp remapped-cache) =>

374 (lambda (entry)

375 (if (inlinable? entry)

376 (inline (caddr entry))

377 exp)))

378 (else exp)))

379 (let ((filtered-mapped-cache (map (lambda (entry)

380 (list (car entry) (cadr entry) (inline (caddr entry))))

381 (filter (lambda (entry) (not (inlinable? entry)))

382 remapped-cache))))

383 `(codegen-result ,(inline exp) ,filtered-mapped-cache)))))

384

385 (define (residualize-apply name . args)

386 (make-node 'apply 'rator (make-node 'ref 'name name) 'rands args))

387

388 (define (prim-env)

389 (map (lambda (entry)

390 (cons (car entry)

391 (box (list (make-node 'prim

392 'prim-name (car entry)

393 'handler (cadr entry))))))

394 (list

395 (list 'sval-known? (lambda (x)

396 (make-lit (sval-known? x))))

397 (list '+ (lambda vals

398 (call-with-values (lambda () (partition sval-known? vals))

399 (lambda (known unknown)

400 (let* ((part-val (apply + (map lit-value known)))

401 (part (make-lit part-val)))

402 (cond

403 ((null? unknown) part)

404 ((zero? part-val) (apply residualize-apply '+ unknown))

405 (else (apply residualize-apply '+ part unknown))))))))

406 (list '- (lambda (a b)

407 (if (and (sval-known? a) (sval-known? b))

408 (make-lit (- (lit-value a) (lit-value b)))

409 (residualize-apply '- a b))))

410 (list '< (lambda (a b)

411 (if (and (sval-known? a) (sval-known? b))

412 (make-lit (< (lit-value a) (lit-value b)))

413 (residualize-apply '< a b))))

414 (list 'cons (lambda (a d) (make-node 'cons 'a a 'd d)))

415 (list 'null? (lambda (x)

416 (if (sval-known? x)

417 (make-lit (and (lit? x)

418 (null? (lit-value x))))

419 (residualize-apply 'null? x))))

420 (list 'pair? (lambda (x)

421 (if (sval-known? x)

422 (make-lit (or (node-kind? x 'cons)

423 (and (lit? x)

424 (pair? (lit-value x)))))

425 (residualize-apply 'pair? x))))

426 (list 'zero? (lambda (x)

427 (if (sval-known? x)

428 (make-lit (zero? (lit-value x)))

429 (residualize-apply 'zero? x))))

430 (list 'eq? (lambda (x y)

431 (if (and (lit? x)

432 (lit? y))

433 (make-lit (eq? (lit-value x) (lit-value y)))

434 (residualize-apply 'eq? x y))))

435 (list 'PRIMcar (lambda (x)

436 (if (sval-known? x)

437 (cond

438 ((node-kind? x 'cons) (node-ref x 'a))

439 ((and (lit? x) (pair? (lit-value x))) (make-lit (car (lit-value x))))

440 (else (residualize-apply 'PRIMcar x)))

441 (residualize-apply 'PRIMcar x))))

442 (list 'PRIMcdr (lambda (x)

443 (if (sval-known? x)

444 (cond

445 ((node-kind? x 'cons) (node-ref x 'd))

446 ((and (lit? x) (pair? (lit-value x))) (make-lit (cdr (lit-value x))))

447 (else (residualize-apply 'PRIMcdr x)))

448 (residualize-apply 'PRIMcdr x)))))))

449

450 (define (basic-env)

451 (fold (lambda (entry env)

452 (cons (cons (car entry)

453 (box (list (pe (parse (cadr entry) '()) env '()))))

454 env))

455 (prim-env)

456 (list

457 (list 'car '(lambda (x)

458 (filter 'unfold)

459 (if (pair? x)

460 (PRIMcar x)

461 (error "Not a pair in car" x))))

462 (list 'cdr '(lambda (x)

463 (filter 'unfold)

464 (if (pair? x)

465 (PRIMcdr x)

466 (error "Not a pair in cdr" x))))

467 ; (list 'car 'PRIMcar)

468 ; (list 'cdr 'PRIMcdr)

469 (list 'reverse '(lambda (x)

470 (filter 'unfold)

471 (let loop ((x x) (acc '()))

472 (if (null? x)

473 acc

474 (loop (cdr x) (cons (car x) acc))))))

475 (list 'fold '(lambda (f acc x)

476 (filter (if (sval-known? f) 'unfold '(#f #f #f)))

477 (let loop ((x x) (acc acc))

478 (if (null? x)

479 acc

480 (loop (cdr x) (f (car x) acc))))))

481 (list 'fold-right '(lambda (f acc x)

482 (filter (if (sval-known? f) 'unfold '(#f #f #f)))

483 (let loop ((x x))

484 (if (null? x)

485 acc

486 (let ((head (car x)))

487 (f head (loop (cdr x))))))))

488 (list 'list? '(lambda (xs)

489 (let loop ((xs xs))

490 (if (null? xs)

491 #t

492 (if (pair? xs)

493 (loop (cdr xs))

494 #f)))))

495 (list 'list-of '(lambda (c)

496 (lambda (xs)

497 (let loop ((xs xs))

498 (if (null? xs)

499 #t

500 (if (pair? xs)

501 (if (c (car xs))

502 (loop (cdr xs))

503 #f)

504 #f))))))

505 (list 'any/c '(lambda (x)

506 (filter 'unfold)

507 #t))

508 (list 'map '(lambda (f x)

509 (filter 'unfold)

510 (fold-right (lambda (v c)

511 (filter 'unfold)

512 (cons (f v) c)) '() x)))

513 (list 'append '(lambda (a b)

514 (filter 'unfold)

515 (fold-right cons b a)))

516 )))

517

518 (define (basic-env/streams)

519 (fold (lambda (entry env)

520 (cons (cons (car entry)

521 (box (list (pe (parse (cadr entry) '()) env '()))))

522 env))

523 (basic-env)

524 (list

525 (list 'make-stream '(lambda* (stepper state)

526 (cons 'stream (cons stepper (cons state '())))))

527 (list 'stream-stepper '(lambda* (stream)

528 (PRIMcar (PRIMcdr stream))))

529 (list 'stream-state '(lambda* (stream)

530 (PRIMcar (PRIMcdr (PRIMcdr stream)))))

531 (list 'stream-maker '(lambda* (stepper)

532 (lambda* (state)

533 (make-stream stepper state))))

534 (list 'list-stream-stepper '(lambda (l done skip yield)

535 (if (null? l)

536 (done)

537 (yield (car l) (cdr l)))))

538 (list 'list->stream '(stream-maker list-stream-stepper))

539 (list 'string->stream '(lambda* (s)

540 (make-stream (lambda (index done skip yield)

541 (filter '(#f #t #t #t))

542 (if (= index (string-length s))

543 (done)

544 (yield (string-ref s index)

545 (+ index 1))))

546 0)))

547 (list 'smap

548 '(lambda* (f stream)

549 (let ((stepper (stream-stepper stream)))

550 (make-stream (lambda* (state done skip yield)

551 (stepper state

552 done

553 skip

554 (lambda* (elt new-state) (yield (f elt) new-state))))

555 (stream-state stream)))))

556 (list 'sfilter '(lambda* (pred stream)

557 (let ((stepper (stream-stepper stream)))

558 (make-stream (lambda* (state done skip yield)

559 (stepper state

560 done

561 skip

562 (lambda* (elt new-state)

563 (if (pred elt)

564 (yield elt new-state)

565 (skip new-state)))))

566 (stream-state stream)))))

567 (list 'sfoldr

568 '(lambda* (kons knil stream)

569 (let ((stepper (stream-stepper stream)))

570 (let loop ((state (stream-state stream)))

571 (stepper state

572 (lambda* () knil)

573 (lambda* (new-state) (loop new-state))

574 (lambda* (elt new-state) (kons elt (loop new-state))))))))

575 (list 'sfoldl

576 '(lambda* (kons knil stream)

577 (let ((stepper (stream-stepper stream)))

578 (let loop ((knil knil)

579 (state (stream-state stream)))

580 (stepper state

581 (lambda* () knil)

582 (lambda* (new-state) (loop new-state))

583 (lambda* (elt new-state) (loop (kons elt knil) new-state)))))))

584 (list 'stream->list '(lambda* (stream)

585 (sfoldr cons '() stream)))

586 (list 'make-szip-state '(lambda* (cell left right)

587 (cons cell (cons left (cons right '())))))

588 (list 'szip-state-cell '(lambda* (s) (PRIMcar s)))

589 (list 'szip-state-left '(lambda* (s) (PRIMcar (PRIMcdr s))))

590 (list 'szip-state-right '(lambda* (s) (PRIMcar (PRIMcdr (PRIMcdr s)))))

591 (list 'szip

592 '(lambda* (left right)

593 (let ((left-stepper (stream-stepper left))

594 (right-stepper (stream-stepper right)))

595 (make-stream

596 (lambda (state done skip yield)

597 ;;(filter (if (sval-known? (szip-state-cell state)) 'unfold '(#f #f #f #f)))

598 (let ((cell (szip-state-cell state)))

599 (cond

600 ((null? cell)

601 (right-stepper

602 (szip-state-right state)

603 done

604 (lambda* (new-right)

605 (skip (make-szip-state '() (szip-state-left state) new-right)))

606 (lambda* (elt new-right)

607 (skip (make-szip-state (cons elt '()) (szip-state-left state) new-right)))))

608 (else

609 (left-stepper

610 (szip-state-left state)

611 done

612 (lambda* (new-left)

613 (skip (make-szip-state cell new-left (szip-state-right state))))

614 (lambda* (elt new-left)

615 (yield (cons elt cell)

616 (make-szip-state '() new-left (szip-state-right state)))))))))

617 (make-szip-state '() (stream-state left) (stream-state right))))))

618 (list 'make-sconcatmap-state '(lambda* (fstep fstate rs)

619 (cons fstep (cons fstate (cons rs '())))))

620 (list 'sconcatmap-state-first-stepper '(lambda* (s) (PRIMcar s)))

621 (list 'sconcatmap-state-first-state '(lambda* (s) (PRIMcar (PRIMcdr s))))

622 (list 'sconcatmap-state-remaining-streams '(lambda* (s) (PRIMcar (PRIMcdr (PRIMcdr s)))))

623 (list 'sconcatmap

624 '(lambda* (f streams)

625 (let ((remaining-streams-stepper (stream-stepper streams)))

626 (make-stream (lambda (state done skip yield)

627 (let ((first-stepper (sconcatmap-state-first-stepper state)))

628 (if first-stepper

629 (first-stepper

630 (sconcatmap-state-first-state state)

631 (lambda* ()

632 (skip (make-sconcatmap-state

633 #f #f

634 (sconcatmap-state-remaining-streams state))))

635 (lambda* (new-first-state)

636 (skip (make-sconcatmap-state

637 first-stepper new-first-state

638 (sconcatmap-state-remaining-streams state))))

639 (lambda* (elt new-first-state)

640 (yield elt

641 (make-sconcatmap-state

642 first-stepper new-first-state

643 (sconcatmap-state-remaining-streams state)))))

644 (remaining-streams-stepper

645 (sconcatmap-state-remaining-streams state)

646 done

647 (lambda* (new-remaining-streams)

648 (skip (make-sconcatmap-state

649 #f #f

650 new-remaining-streams)))

651 (lambda* (first new-remaining-streams)

652 (let ((first-stream (f first)))

653 (skip (make-sconcatmap-state

654 (stream-stepper first-stream)

655 (stream-state first-stream)

656 new-remaining-streams))))))))

657 (make-sconcatmap-state #f #f (stream-state streams))))))

658 (list 'sconcatenate

659 '(lambda* (streams)

660 (sconcatmap (lambda* (stream) stream) streams)))

661 )))

662

663 (define (test-exp exp)

664 (pe (parse exp '()) (basic-env/streams) '()))

665

666 (define (test)

667 (let ((result (test-exp '(map (lambda (x)

668 (filter 'unfold)

669 (+ x 1))

670 (append '(1 2) rest)))))

671 (pretty-print 'test-done)

672 (pretty-print (codegen result))))

673

674 (define (popt exp)

675 (pretty-print (codegen (test-exp exp))))

676

677 (define even-exp

678 '(lambda (x)

679 ;; eta-conversion here to stop the letrec from being elided

680 ;; because of bug described above.

681 (letrec ((odd? (lambda (x1)

682 (if (zero? x1)

683 #f

684 (even? (- x1 1)))))

685 (even? (lambda (x2)

686 (filter 'unfold)

687 (if (zero? x2)

688 #t

689 (odd? (- x2 1))))))

690 (even? x))))

691

692 (define fib-exp

693 '(letrec ((fib (lambda (n)

694 (if (< n 2)

695 n

696 (+ (fib (- n 1))

697 (fib (- n 2)))))))

698 (fib arg)))

699

700 (define curried-exp

701 '((((lambda (a)

702 (lambda (b)

703 (lambda (c)

704 (do-something-with a b c))))

705 'aa)

706 (bb))

707 'cc))

708

709 (define curried-exp2

710 '(let ((bv (bb)))

711 ((((lambda (a)

712 (lambda (b)

713 (lambda (c)

714 (do-something-with a b c))))

715 'aa)

716 bv)

717 'cc)))

718

719 (define curried-cps-exp

720 '((lambda (k a) (k (lambda (k b) (k (lambda (k c) (do-something-with k a b c))))))

721 (lambda (bf) (bf (lambda (cf) (cf (lambda (x) (begin x))

722 'cc))

723 (bb)))

724 'aa))

725

726 (define code-duplication-exp

727 '(let ((x (f a b c)))

728 (let ((y (g x x)))

729 (h y y))))

730

731 (define filtering-mapping-exp

732 '(fold (lambda* (elt acc)

733 (if (even? elt)

734 (cons elt acc)

735 acc))

736 '()

737 (map (lambda* (x) (* x 2)) mylist)))

738

739 (define filtering-mapping-exp2

740 '(fold (lambda* (elt acc)

741 (if (even? elt)

742 (cons elt acc)

743 acc))

744 '()

745 (map (lambda* (x) (* x 2)) '(1 2 3 4 5))))

746

747 (define sfiltering-smapping-exp

748 '(stream->list

749 (sfilter (lambda* (elt)

750 (even? elt))

751 (smap (lambda* (x)

752 (* x 2))

753 (list->stream mylist)))))

754

755 (define sfiltering-smapping-exp1

756 '(sfilter (lambda* (elt)

757 (even? elt))

758 (smap (lambda* (x)

759 (* x 2))

760 mystream)))

761

762 (define sfiltering-smapping-exp2

763 '(stream->list

764 (sfilter (lambda* (elt)

765 (even? elt))

766 (smap (lambda* (x)

767 (* x 2))

768 (list->stream '(1 2 3 4 5))))))

769

770 (define list-serializer

771 '(letrec ((ser (lambda* (x emit k)

772 (if (pair? x)

773 (emit 'open

774 (lambda* (emit)

775 (letrec ((serlist (lambda* (xs emit k)

776 (if (pair? xs)

777 (ser (car x) emit

778 (lambda* (emit)

779 (serlist (cdr xs) emit k)))

780 (k emit)))))

781 (serlist x emit (lambda* (emit)

782 (emit 'close k))))))

783 (if (number? x)

784 (emit x k)

785 (error 'not-supported-in-ser))))))

786 (letrec ((collect (lambda* (v k)

787 (cons v (k collect)))))

788 (ser '(12 22 32)

789 collect

790 (lambda* (emit) '())))))

791

792 ;;; Local Variables:

793 ;;; eval: (put 'lambda* 'scheme-indent-function 1)

794 ;;; End: