blob: 4bcba64404329001d16ef89db385a9e1e06168e9 (
about) (
plain)
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
|
;;; misc.scm -- random other transformations done during CFN processing
;;;
;;; author : Sandra Loosemore
;;; date : 27 Feb 1992
;;;
;;; This file contains specialized CFN walkers that implement rewrite rules
;;; for list-exp, sequence-xxx, list-comp, section-l, and section-r.
;;; Turn list-exps into cons chains.
(define-walker-method cfn list-exp (object)
(do-cfn-list-exp (list-exp-exps object)))
(define (do-cfn-list-exp exps)
(if (null? exps)
;; Make a con-ref for []
(**con/def (core-symbol "Nil"))
;; Otherwise make an app of :
(let ((first (cfn-ast-1 (car exps)))
(rest (do-cfn-list-exp (cdr exps))))
(**app (**con/def (core-symbol ":")) first rest))))
;;; Sections get turned into lambda expressions.
(define-walker-method cfn section-l (object)
(let ((def (create-temp-var 'section-arg)))
(**lambda/pat
(list (**var-pat/def def))
(**app (cfn-ast-1 (section-l-op object))
(**var/def def)
(cfn-ast-1 (section-l-exp object))))))
(define-walker-method cfn section-r (object)
(let ((def (create-temp-var 'section-arg)))
(**lambda/pat
(list (**var-pat/def def))
(**app (cfn-ast-1 (section-r-op object))
(cfn-ast-1 (section-r-exp object))
(**var/def def)))))
;;; Do list comprehensions.
;;; rewrite in terms of build and foldr so that we can apply
;;; deforestation techniques later.
(define-walker-method cfn list-comp (object)
(let ((c (create-temp-var 'c))
(n (create-temp-var 'n)))
(cfn-ast-1
(**app (**var/def (core-symbol "build"))
(**lambda/pat
(list (**var-pat/def c) (**var-pat/def n))
(do-cfn-list-comp
(list-comp-exp object) (list-comp-quals object) c n))))))
(define (do-cfn-list-comp exp quals c n)
(if (null? quals)
(**app (**var/def c) exp (**var/def n))
(let ((qual (car quals)))
(if (is-type? 'qual-generator qual)
(do-cfn-list-comp-generator exp qual (cdr quals) c n)
(do-cfn-list-comp-filter exp qual (cdr quals) c n)))))
(define (do-cfn-list-comp-filter exp qual quals c n)
(**if (qual-filter-exp qual)
(do-cfn-list-comp exp quals c n)
(**var/def n)))
(define (do-cfn-list-comp-generator exp qual quals c n)
(let ((gen-pat (qual-generator-pat qual))
(gen-exp (qual-generator-exp qual))
(l (create-temp-var 'list))
(b (create-temp-var 'rest)))
(**app (**var/def (core-symbol "foldr"))
(**lambda/pat
(list (**var-pat/def l) (**var-pat/def b))
(**case (**var/def l)
(list (**alt/simple
gen-pat
(do-cfn-list-comp exp quals c b))
(**alt/simple
(**wildcard-pat)
(**var/def b)))))
(**var/def n)
gen-exp)))
;;; Placeholders just get eliminated
(define-walker-method cfn dict-placeholder (object)
(if (eq? (dict-placeholder-exp object) '#f)
(error "Type checker screwed a dict placeholder object ~s." object)
(cfn-ast-1 (dict-placeholder-exp object))))
(define-walker-method cfn method-placeholder (object)
(if (eq? (method-placeholder-exp object) '#f)
(error "Type checker screwed a method placeholder object ~s." object)
(cfn-ast-1 (method-placeholder-exp object))))
(define-walker-method cfn recursive-placeholder (object)
(if (eq? (recursive-placeholder-exp object) '#f)
(error "Type checker screwed a recursive placeholder object ~s." object)
(cfn-ast-1 (recursive-placeholder-exp object))))
(define-walker-method cfn cast (object)
(cfn-ast-1 (cast-exp object)))
;;; Eliminate saved old expressions
(define-walker-method cfn save-old-exp (object)
(cfn-ast-1 (save-old-exp-new-exp object)))
|
