Import to github.
[software/yale-haskell.git] / cfn / misc.scm
1 ;;; misc.scm -- random other transformations done during CFN processing
2 ;;;
3 ;;; author : Sandra Loosemore
4 ;;; date : 27 Feb 1992
5 ;;;
6 ;;; This file contains specialized CFN walkers that implement rewrite rules
7 ;;; for list-exp, sequence-xxx, list-comp, section-l, and section-r.
8
9
10 ;;; Turn list-exps into cons chains.
11
12 (define-walker-method cfn list-exp (object)
13 (do-cfn-list-exp (list-exp-exps object)))
14
15 (define (do-cfn-list-exp exps)
16 (if (null? exps)
17 ;; Make a con-ref for []
18 (**con/def (core-symbol "Nil"))
19 ;; Otherwise make an app of :
20 (let ((first (cfn-ast-1 (car exps)))
21 (rest (do-cfn-list-exp (cdr exps))))
22 (**app (**con/def (core-symbol ":")) first rest))))
23
24
25 ;;; Sections get turned into lambda expressions.
26
27 (define-walker-method cfn section-l (object)
28 (let ((def (create-temp-var 'section-arg)))
29 (**lambda/pat
30 (list (**var-pat/def def))
31 (**app (cfn-ast-1 (section-l-op object))
32 (**var/def def)
33 (cfn-ast-1 (section-l-exp object))))))
34
35 (define-walker-method cfn section-r (object)
36 (let ((def (create-temp-var 'section-arg)))
37 (**lambda/pat
38 (list (**var-pat/def def))
39 (**app (cfn-ast-1 (section-r-op object))
40 (cfn-ast-1 (section-r-exp object))
41 (**var/def def)))))
42
43
44
45 ;;; Do list comprehensions.
46 ;;; rewrite in terms of build and foldr so that we can apply
47 ;;; deforestation techniques later.
48
49 (define-walker-method cfn list-comp (object)
50 (let ((c (create-temp-var 'c))
51 (n (create-temp-var 'n)))
52 (cfn-ast-1
53 (**app (**var/def (core-symbol "build"))
54 (**lambda/pat
55 (list (**var-pat/def c) (**var-pat/def n))
56 (do-cfn-list-comp
57 (list-comp-exp object) (list-comp-quals object) c n))))))
58
59 (define (do-cfn-list-comp exp quals c n)
60 (if (null? quals)
61 (**app (**var/def c) exp (**var/def n))
62 (let ((qual (car quals)))
63 (if (is-type? 'qual-generator qual)
64 (do-cfn-list-comp-generator exp qual (cdr quals) c n)
65 (do-cfn-list-comp-filter exp qual (cdr quals) c n)))))
66
67 (define (do-cfn-list-comp-filter exp qual quals c n)
68 (**if (qual-filter-exp qual)
69 (do-cfn-list-comp exp quals c n)
70 (**var/def n)))
71
72 (define (do-cfn-list-comp-generator exp qual quals c n)
73 (let ((gen-pat (qual-generator-pat qual))
74 (gen-exp (qual-generator-exp qual))
75 (l (create-temp-var 'list))
76 (b (create-temp-var 'rest)))
77 (**app (**var/def (core-symbol "foldr"))
78 (**lambda/pat
79 (list (**var-pat/def l) (**var-pat/def b))
80 (**case (**var/def l)
81 (list (**alt/simple
82 gen-pat
83 (do-cfn-list-comp exp quals c b))
84 (**alt/simple
85 (**wildcard-pat)
86 (**var/def b)))))
87 (**var/def n)
88 gen-exp)))
89
90 ;;; Placeholders just get eliminated
91
92 (define-walker-method cfn dict-placeholder (object)
93 (if (eq? (dict-placeholder-exp object) '#f)
94 (error "Type checker screwed a dict placeholder object ~s." object)
95 (cfn-ast-1 (dict-placeholder-exp object))))
96
97 (define-walker-method cfn method-placeholder (object)
98 (if (eq? (method-placeholder-exp object) '#f)
99 (error "Type checker screwed a method placeholder object ~s." object)
100 (cfn-ast-1 (method-placeholder-exp object))))
101
102 (define-walker-method cfn recursive-placeholder (object)
103 (if (eq? (recursive-placeholder-exp object) '#f)
104 (error "Type checker screwed a recursive placeholder object ~s." object)
105 (cfn-ast-1 (recursive-placeholder-exp object))))
106
107 (define-walker-method cfn cast (object)
108 (cfn-ast-1 (cast-exp object)))
109
110 ;;; Eliminate saved old expressions
111
112 (define-walker-method cfn save-old-exp (object)
113 (cfn-ast-1 (save-old-exp-new-exp object)))