1
2
3
4
5
6
7
8
9
10
11
12
13
14
15 (%include e-macros)
16 (declare (special comment-column))
17
18
19
20
21
22
23 (defun macomp-output-to-buffer (x)
24 (macomp-bufout-r x nil)
25 (new-line))
26
27 (defun macomp-bufout-r (x indent)
28 (if (null indent)(setq indent (cur-hpos))
29 else
30 (whitespace-to-hpos indent))
31 (cond ((fixp x)(insert-string (decimal-rep x))(insert-string "."))
32 ((atom x)(insert-string (maknam (explode x))))
33 ((memq (car x) '(if if-at if-back-at lambda cond let))
34 (insert-string "(")
35 (insert-string (car x))
36 (insert-string " ")
37 (macomp-bufout-finish-form (cdr x)(cur-hpos)))
38 ((eq (car x) 'defun)
39 (insert-string "(defun ")
40 (let ((hp (cur-hpos)))
41 (macomp-bufout-r (cadr x) hp)
42 (insert-string " ")
43 (if (null (caddr x))
44 (insert-string "()")
45 else
46 (macomp-bufout-r (caddr x) nil))
47 (new-line)
48 (macomp-bufout-finish-form (cdddr x) hp)))
49 ((and (eq (car x) 'quote)(null (cddr x)))
50 (insert-string "'")
51 (macomp-bufout-r (cadr x)(1+ indent)))
52 ((eq (car x) 'do-forever)
53 (insert-string "(do-forever ")
54 (new-line)
55 (macomp-bufout-finish-form (cdr x)(+ 2 indent)))
56 ((memq (car x) '(prog2 progn))
57 (insert-string "(")
58 (insert-string (car x))
59 (insert-string " ")
60 (macomp-bufout-finish-form (cdr x)(cur-hpos)))
61 ((eq (car x) 'prog)
62 (insert-string "(prog ")
63 (let ((hp (cur-hpos)))
64 (macomp-bufout-r (cadr x) hp)
65 (new-line)
66 (do l (cddr x)(cdr l)(null l)
67 (if (atom (car l))
68 (macomp-bufout-r (car l) 0)
69 (if (> (cur-hpos)(1+ hp))(insert-string " "))
70 (setq l (cdr l)))
71 (macomp-bufout-r (car l) hp)
72 (if (not (null (cdr l)))(new-line)))
73 (insert-string ")")))
74 (t (macomp-bufout-random-list (car x)(cdr x) indent))))
75
76 (defun macomp-bufout-random-list (the-car the-cdr indent)
77 (insert-string "(")
78 (macomp-bufout-r the-car (1+ indent))
79 (if (> (+ (cur-hpos) 4) comment-column)
80 (setq indent (if (atom the-car)(+ 2 indent)
81 else (+ 1 indent)))
82 else
83 (if (atom the-car))(setq indent (1+ (cur-hpos)))
84 else (setq indent (1+ indent)))
85 (do l the-cdr (cdr l) nil
86 (if (null l)(insert-string ")")(stop-doing))
87 (if (atom l)
88 (insert-string " . ")
89 (macomp-bufout-r l nil)
90 (insert-string ")")
91 (stop-doing))
92 (if (and (> (+ (cur-hpos) 4) comment-column)
93 (or (not (atom (cdr l)))
94 (not (atom (car l)))))
95 (new-line)
96 (whitespace-to-hpos indent)
97 else (if (not (and (back-at '/) )(not (atom (car l)))))
98 (insert-string " ")))
99 (macomp-bufout-r (car l) nil)))
100
101
102
103 (defun macomp-bufout-finish-form (x hp)
104 (do l x (cdr l)(null l)
105 (macomp-bufout-r (car l) hp)
106 (if (not (null (cdr l)))(new-line)))
107 (insert-string ")"))
108
109 ^L
110
111
112
113
114 (declare (special macomp-last-cmd macomp-prog-needed-p macomp-default-search-string))
115
116 (defun macomp-compile-to-expr (name interp)
117 (setq macomp-last-cmd 'noop macomp-prog-needed-p nil
118 macomp-default-search-string nil)
119 (do ((outl nil)(inl (map 'macomp-preoptimize interp)(cdr inl))
120 (thisform)(thisfun)(lastfun '@)
121 (thisct)(lastct -1))
122 ((null inl)
123 (setq outl (nreverse outl))
124 (if macomp-prog-needed-p
125 (setq outl (list (cons 'prog (cons '() outl)))))
126 (append (list 'defun name '()) outl))
127 (setq thisform (macomp-term-compile inl))
128 (if (not (null thisform))
129 (setq thisfun (cond ((eq (car thisform) 'do-times)
130 (setq thisct (cadr thisform))
131 (caddr thisform))
132 (t (setq thisct 1) thisform)))
133 (if (equal thisfun lastfun)
134 (setq outl
135 (cons (list 'do-times
136 (setq thisct (+ thisct lastct))
137 thisfun)
138 (cdr outl)))
139 else
140 (if (and (eq (car thisfun) 'insert-string)
141 (eq (car lastfun) 'insert-string))
142 (setq outl (cons (list 'insert-string
143 (catenate (cadr lastfun)
144 (cadr thisfun)))
145 (cdr outl)))
146 else
147 (setq outl (cons thisform outl))))
148 (setq lastct thisct lastfun thisfun))))
149
150 (defun macomp-preoptimize (term)
151 (let ((fun (cdar term)))
152 (cond ((eq fun 'quote-char)
153 (cond ((eq (cdadr term) 'String)
154 (rplacd (cadr term) 'Input/ Characters)))
155 (cond ((eq (cdadr term) 'Input/ Characters)
156
157 (cond ((samepnamep (caadr term) (ascii 15))
158 (rplaca (cadr term)(get_pname NL))))
159 (rplaca term (cons (get_pname
160 (maknam (explode (caadr term))))
161 'String))
162 (rplacd term (cddr term)))
163 (t (rplaca term
164 '("Quote-char saw no input" . %macomp-ierr)))))
165 ((eq fun 're-execute-command)
166 (rplacd (car term) macomp-last-cmd))
167 ((not (memq fun '(noop Numeric/ argument multiplier noop)))
168 (setq macomp-last-cmd fun)))))
169
170 (defun macomp-term-compile (term)
171 (let ((sym (caar term))(fun (cdar term)))
172 (cond ((eq fun 'noop) nil)
173 ((eq fun '%macomp-ierr)
174 (list 'error sym))
175 ((eq fun 'String)
176 (setq sym (read-from-string sym))
177 (do-forever
178 (or (memq (cdadr term) '(rubout-char String))(stop-doing))
179 (if (eq (cdadr term) 'rubout-char)
180 (if (not (> (stringlength sym) 0))(stop-doing))
181 (rplacd term (cddr term))
182 (setq sym (substr sym 1 (1- (stringlength sym)))))
183 (if (eq (cdadr term) 'String)
184 (setq sym (catenate sym (read-from-string (caadr term))))
185 (rplacd term (cddr term))))
186 (if (> (stringlength sym) 0)
187 (list 'insert-string sym)))
188 ((eq (cdadr term) 'Numeric/ argument)
189 (macomp-comp-multipliers term))
190 ((eq fun 'multiplier)
191 (macomp-comp-multipliers term))
192 ((let ((prop (get fun 'search-command)))
193 (and prop (macomp-comp-searches prop term))))
194 ((memq fun '(next-line-command prev-line-command))
195 (let ((template
196 (cond ((eq fun 'prev-line-command)
197 '(if (firstlinep)(command-quit) else (prev-line)))
198 (t '(if (lastlinep)(command-quit) else (next-line))))))
199 (if (get (cdadr term) 'linepos-insensitive)
200 template
201 else
202 (list fun))))
203 ((eq fun 'macro-query)
204 (setq macomp-prog-needed-p t)
205 '(if (not (macro-query-get-answer))(return nil)))
206 (t (list fun)))))
207
208 (mapc '(lambda (x)(putprop x t 'linepos-insensitive))
209 '(go-to-beginning-of-line go-to-end-of-line skip-over-indentation
210 indent-to-lisp indent-relative
211 prev-line-command next-line-command))
212
213 (defun macomp-comp-searches (prop term)
214 (prog (string cmd strterm escterm)
215 (setq cmd (car prop) strterm (cdr term) escterm (cdr strterm))
216 (if (memq (cdar strterm) '(escape new-line))
217 (setq escterm strterm strterm '(("""""" . String))))
218 (if (and (eq (cdar strterm) 'String)
219 (memq (cdar escterm) '(new-line escape)))
220 (setq string (read-from-string (caar strterm)))
221 (or (stringp (setq string (macomp-search-defaultify string)))
222 (go sdf-err))
223 (setq cmd (list cmd string))
224 (if (eq (car cmd) 'regexp-search)
225 (setq cmd (list 'let (list (list 'm cmd))
226 '(and m (progn (release-mark m) t)))))
227 (return (prog2 0
228 (list 'if (list 'not cmd)
229 '(search-failure-annunciator))
230 (rplacd term (cdr escterm))))
231 else
232 (setq string (caar strterm))
233 (if (and (eq (cdar strterm) 'Input/ characters)
234 (= (getcharn string (stringlength string)) 33))
235 (setq string (substr string 1 (1- (stringlength string))))
236 (or (stringp (setq string (macomp-search-defaultify string)))
237 (progn (setq escterm strterm)
238 (go sdf-err)))
239 (return (prog2 0
240 (list 'if (list 'not (list cmd string))
241 '(search-failure-annunciator))
242 (rplacd term (cdr strterm))))))
243 (return '(error "Search string too complex. Edit the macro first."))
244 sdf-err
245 (rplacd term (cdr escterm))
246 (return '(error "Default search string may not be assumed in extension."))))
247
248
249 (defun macomp-search-defaultify (s)
250 (cond ((nullstringp s) macomp-default-search-string)
251 (t (setq macomp-default-search-string s))))
252
253 (mapc '(lambda (x)(putprop (car x)(cdr x) 'search-command))
254 '((string-search forward-search)
255 (reverse-string-search reverse-search)
256 (regexp-search-command regexp-search)
257 (incremental-search forward-search)
258 (reverse-incremental-search reverse-search)
259 (multi-word-search WORD-SEARCH-FRAMMIS)))
260
261 (defun macomp-stfix-to-fixnum (x)
262 (let ((ibase 10.))(read-from-string x)))
263
264 (defun macomp-comp-multipliers (term)
265 (let ((rest term)(num 1))
266 (do-forever
267 (cond ((eq (cdadr rest) 'Numeric/ argument)
268 (setq num (macomp-stfix-to-fixnum (caadr rest)))
269 (setq rest (cddr rest)))
270 ((eq (cdar rest) 'multiplier)
271 (setq num (* 4 num))
272 (setq rest (cdr rest)))
273 (t (stop-doing))))
274 (prog2 0
275 (let ((fun (cdar rest))
276 (data (caar rest)))
277 (cond ((eq fun 'String)
278 (setq data (read-from-string data))
279 (rplaca (car rest)
280 (maknam (explode
281 (catenate
282 (do ((l nil (cons c l))
283 (x 0 (1+ x))
284 (c (getchar data 1)))
285 ((= x num)
286 (get_pname (maknam l))))
287 (substr data 2)))))
288 nil)
289 ((get fun 'argwants)
290 (setq rest (cdr rest))
291 (list 'do-times num (list fun)))
292 (t (setq rest (cdr rest))
293 (list 'let (list (list 'numarg num))(list fun)))))
294 (rplacd term rest))))