blob: 373fbd406099e4912fe82f5488bbb7f9b0aceee9 (
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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
;;; copy-flic.scm -- general copy functions for flic structures
;;;
;;; author : Sandra Loosemore
;;; date : 23 Feb 1993
;;;
;;;
;;; The var-renamings argument is an a-list. It's used to map local vars
;;; in the input expression to new, gensymed vars.
(define-flic-walker copy-flic (object var-renamings))
(define (copy-flic-list objects var-renamings)
(let ((result '()))
(dolist (o objects)
(push (copy-flic o var-renamings) result))
(nreverse result)))
(define (copy-flic-top object)
(copy-flic object '()))
(define-copy-flic flic-lambda (object var-renamings)
(let ((new-vars (map (lambda (v)
(let ((new (copy-temp-var (def-name v))))
(push (cons v new) var-renamings)
(when (var-force-strict? v)
(setf (var-force-strict? new) '#t))
(init-flic-var new '#f '#f)))
(flic-lambda-vars object))))
(make-flic-lambda
new-vars
(copy-flic (flic-lambda-body object) var-renamings))))
;;; Hack to avoid concatenating multiple gensym suffixes.
(define (copy-temp-var sym)
(if (gensym? sym)
(let* ((string (symbol->string sym))
(n (string-length string))
(root (find-string-prefix string 0 n)))
(create-temp-var root))
(create-temp-var sym)))
(define (find-string-prefix string i n)
(declare (type string string) (type fixnum i n))
(cond ((eqv? i n)
string)
((char-numeric? (string-ref string i))
(substring string 0 i))
(else
(find-string-prefix string (+ i 1) n))))
(define-copy-flic flic-let (object var-renamings)
(let ((new-vars (map (lambda (v)
(let ((new (copy-temp-var (def-name v))))
(when (var-force-inline? v)
(setf (var-force-inline? new) '#t))
(push (cons v new) var-renamings)
new))
(flic-let-bindings object))))
(for-each
(lambda (new old)
(init-flic-var new (copy-flic (var-value old) var-renamings) '#f))
new-vars
(flic-let-bindings object))
(make-flic-let
new-vars
(copy-flic (flic-let-body object) var-renamings)
(flic-let-recursive? object))))
(define-copy-flic flic-app (object var-renamings)
(make-flic-app
(copy-flic (flic-app-fn object) var-renamings)
(copy-flic-list (flic-app-args object) var-renamings)
(flic-app-saturated? object)))
(define-copy-flic flic-ref (object var-renamings)
(let* ((var (flic-ref-var object))
(entry (assq var var-renamings)))
(if entry
(make-flic-ref (cdr entry))
(make-flic-ref var)))) ; don't share structure
(define-copy-flic flic-const (object var-renamings)
(declare (ignore var-renamings))
(make-flic-const (flic-const-value object))) ; don't share structure
(define-copy-flic flic-pack (object var-renamings)
(declare (ignore var-renamings))
(make-flic-pack (flic-pack-con object))) ; don't share structure
;;; Don't have to gensym new block names; these constructs always
;;; happen in pairs.
(define-copy-flic flic-case-block (object var-renamings)
(make-flic-case-block
(flic-case-block-block-name object)
(copy-flic-list (flic-case-block-exps object) var-renamings)))
(define-copy-flic flic-return-from (object var-renamings)
(make-flic-return-from
(flic-return-from-block-name object)
(copy-flic (flic-return-from-exp object) var-renamings)))
(define-copy-flic flic-and (object var-renamings)
(make-flic-and
(copy-flic-list (flic-and-exps object) var-renamings)))
(define-copy-flic flic-if (object var-renamings)
(make-flic-if
(copy-flic (flic-if-test-exp object) var-renamings)
(copy-flic (flic-if-then-exp object) var-renamings)
(copy-flic (flic-if-else-exp object) var-renamings)))
(define-copy-flic flic-sel (object var-renamings)
(make-flic-sel
(flic-sel-con object)
(flic-sel-i object)
(copy-flic (flic-sel-exp object) var-renamings)))
(define-copy-flic flic-is-constructor (object var-renamings)
(make-flic-is-constructor
(flic-is-constructor-con object)
(copy-flic (flic-is-constructor-exp object) var-renamings)))
(define-copy-flic flic-con-number (object var-renamings)
(make-flic-con-number
(flic-con-number-type object)
(copy-flic (flic-con-number-exp object) var-renamings)))
(define-copy-flic flic-void (object var-renamings)
(declare (ignore object var-renamings))
(make-flic-void)) ; don't share structure
|
