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 ;;

5 ;; Copyright (C) 2005 Tony Garnock-Jones <tonyg@kcbbs.gen.nz>

6

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

8 ;;(require 'srfi-1)

9

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))))))

18

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

20

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)))))

25

26 (define (node-kind? node kind)

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

28

29 (define (make-lit val)

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

31

32 (define (lit-value node)

33 (node-ref node 'val))

34

35 (define (lit? node)

36 (node-kind? node 'lit))

37

38 (define (make-undefined)

39 (make-lit 'UNDEF))

40

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)))))

54

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 (list name init))

108 names inits)

109 (map (lambda (name)

110 (cons name #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-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 (cdr binding)) pexp)

147 (else (cadr 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 '()))

299 (define (walk pexp)

300 (cond

301 ((assq pexp cache) =>

302 (lambda (entry)

303 (set-car! (cdr entry) (+ (cadr entry) 1))

304 (caddr entry)))

305 (else

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

307 (set! cache (cons entry cache))

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

309 (set-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 (cadr 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) (cadr entry) (cadddr entry)))

358 cache)))

359 (define (inlinable? entry)

360 (or (= (cadr entry) 1)

361 (let ((v (caddr entry)))

362 (or (symbol? v)

363 (and (pair? v)

364 (pair? (cdr v))

365 (null? (cddr v))

366 (eq? (car v) 'quote)

367 (symbol? (cadr v)))))))

368 (define (inline exp)

369 (cond

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

371 ((assq exp remapped-cache) =>

372 (lambda (entry)

373 (if (inlinable? entry)

374 (inline (caddr entry))

375 exp)))

376 (else exp)))

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

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

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

380 remapped-cache))))

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

382

383 (define (residualize-apply name . args)

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

385

386 (define (prim-env)

387 (map (lambda (entry)

388 (list (car entry)

389 (make-node 'prim

390 'prim-name (car entry)

391 'handler (cadr entry))))

392 (list

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

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

395 (list '+ (lambda vals

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

397 (lambda (known unknown)

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

399 (part (make-lit part-val)))

400 (cond

401 ((null? unknown) part)

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

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

404 (list '- (lambda (a b)

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

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

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

408 (list '< (lambda (a b)

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

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

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

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

413 (list 'null? (lambda (x)

414 (if (sval-known? x)

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

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

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

418 (list 'pair? (lambda (x)

419 (if (sval-known? x)

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

421 (and (lit? x)

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

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

424 (list 'zero? (lambda (x)

425 (if (sval-known? x)

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

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

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

429 (if (and (lit? x)

430 (lit? y))

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

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

433 (list 'PRIMcar (lambda (x)

434 (if (sval-known? x)

435 (cond

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

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

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

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

440 (list 'PRIMcdr (lambda (x)

441 (if (sval-known? x)

442 (cond

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

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

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

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

447

448 (define (basic-env)

449 (fold (lambda (entry env)

450 (cons (list (car entry)

451 (pe (parse (cadr entry) '()) env '()))

452 env))

453 (prim-env)

454 (list

455 (list 'car '(lambda (x)

456 (filter 'unfold)

457 (if (pair? x)

458 (PRIMcar x)

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

460 (list 'cdr '(lambda (x)

461 (filter 'unfold)

462 (if (pair? x)

463 (PRIMcdr x)

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

465 ; (list 'car 'PRIMcar)

466 ; (list 'cdr 'PRIMcdr)

467 (list 'reverse '(lambda (x)

468 (filter 'unfold)

469 (let loop ((x x) (acc '()))

470 (if (null? x)

471 acc

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

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

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

475 (let loop ((x x) (acc acc))

476 (if (null? x)

477 acc

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

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

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

481 (let loop ((x x))

482 (if (null? x)

483 acc

484 (let ((head (car x)))

485 (f head (loop (cdr x))))))))

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

487 (filter 'unfold)

488 (fold-right (lambda (v c)

489 (filter 'unfold)

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

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

492 (filter 'unfold)

493 (fold-right cons b a)))

494 )))

495

496 (define (basic-env/streams)

497 (fold (lambda (entry env)

498 (cons (list (car entry)

499 (pe (parse (cadr entry) '()) env '()))

500 env))

501 (basic-env)

502 (list

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

504 (cons 'stream (cons stepper (cons state '())))))

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

506 (PRIMcar (PRIMcdr stream))))

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

508 (PRIMcar (PRIMcdr (PRIMcdr stream)))))

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

510 (lambda* (state)

511 (make-stream stepper state))))

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

513 (if (null? l)

514 (done)

515 (yield (car l) (cdr l)))))

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

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

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

519 (filter '(#f #t #t #t))

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

521 (done)

522 (yield (string-ref s index)

523 (+ index 1))))

524 0)))

525 (list 'smap

526 '(lambda* (f stream)

527 (let ((stepper (stream-stepper stream)))

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

529 (stepper state

530 done

531 skip

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

533 (stream-state stream)))))

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

535 (let ((stepper (stream-stepper stream)))

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

537 (stepper state

538 done

539 skip

540 (lambda* (elt new-state)

541 (if (pred elt)

542 (yield elt new-state)

543 (skip new-state)))))

544 (stream-state stream)))))

545 (list 'sfoldr

546 '(lambda* (kons knil stream)

547 (let ((stepper (stream-stepper stream)))

548 (let loop ((state (stream-state stream)))

549 (stepper state

550 (lambda* () knil)

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

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

553 (list 'sfoldl

554 '(lambda* (kons knil stream)

555 (let ((stepper (stream-stepper stream)))

556 (let loop ((knil knil)

557 (state (stream-state stream)))

558 (stepper state

559 (lambda* () knil)

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

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

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

563 (sfoldr cons '() stream)))

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

565 (cons cell (cons left (cons right '())))))

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

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

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

569 (list 'szip

570 '(lambda* (left right)

571 (let ((left-stepper (stream-stepper left))

572 (right-stepper (stream-stepper right)))

573 (make-stream

574 (lambda (state done skip yield)

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

576 (let ((cell (szip-state-cell state)))

577 (cond

578 ((null? cell)

579 (right-stepper

580 (szip-state-right state)

581 done

582 (lambda* (new-right)

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

584 (lambda* (elt new-right)

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

586 (else

587 (left-stepper

588 (szip-state-left state)

589 done

590 (lambda* (new-left)

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

592 (lambda* (elt new-left)

593 (yield (cons elt cell)

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

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

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

597 (cons fstep (cons fstate (cons rs '())))))

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

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

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

601 (list 'sconcatmap

602 '(lambda* (f streams)

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

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

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

606 (if first-stepper

607 (first-stepper

608 (sconcatmap-state-first-state state)

609 (lambda* ()

610 (skip (make-sconcatmap-state

611 #f #f

612 (sconcatmap-state-remaining-streams state))))

613 (lambda* (new-first-state)

614 (skip (make-sconcatmap-state

615 first-stepper new-first-state

616 (sconcatmap-state-remaining-streams state))))

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

618 (yield elt

619 (make-sconcatmap-state

620 first-stepper new-first-state

621 (sconcatmap-state-remaining-streams state)))))

622 (remaining-streams-stepper

623 (sconcatmap-state-remaining-streams state)

624 done

625 (lambda* (new-remaining-streams)

626 (skip (make-sconcatmap-state

627 #f #f

628 new-remaining-streams)))

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

630 (let ((first-stream (f first)))

631 (skip (make-sconcatmap-state

632 (stream-stepper first-stream)

633 (stream-state first-stream)

634 new-remaining-streams))))))))

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

636 (list 'sconcatenate

637 '(lambda* (streams)

638 (sconcatmap (lambda* (stream) stream) streams)))

639 )))

640

641 (define (test-exp exp)

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

643

644 (define (test)

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

646 (filter 'unfold)

647 (+ x 1))

648 (append '(1 2) rest)))))

649 (pretty-print 'test-done)

650 (pretty-print (codegen result))))

651

652 (define (popt exp)

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

654

655 (define even-exp

656 '(lambda (x)

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

658 ;; because of bug described above.

659 (letrec ((odd? (lambda (x1)

660 (if (zero? x1)

661 #f

662 (even? (- x1 1)))))

663 (even? (lambda (x2)

664 (filter 'unfold)

665 (if (zero? x2)

666 #t

667 (odd? (- x2 1))))))

668 (even? x))))

669

670 (define fib-exp

671 '(letrec ((fib (lambda (n)

672 (if (< n 2)

673 n

674 (+ (fib (- n 1))

675 (fib (- n 2)))))))

676 (fib arg)))

677

678 (define curried-exp

679 '((((lambda (a)

680 (lambda (b)

681 (lambda (c)

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

683 'aa)

684 (bb))

685 'cc))

686

687 (define curried-exp2

688 '(let ((bv (bb)))

689 ((((lambda (a)

690 (lambda (b)

691 (lambda (c)

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

693 'aa)

694 bv)

695 'cc)))

696

697 (define curried-cps-exp

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

699 (lambda (bf) (bf (lambda (cf) (cf (lambda (x) (begin x))

700 'cc))

701 (bb)))

702 'aa))

703

704 (define code-duplication-exp

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

706 (let ((y (g x x)))

707 (h y y))))

708

709 ;;; Local Variables:

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

711 ;;; End: