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 (%include e-macros)
34
35 (declare (special
36 OPEN-PAREN CLOSE-PAREN SEMI SINGLEQUOTE DOUBLEQUOTE SLASH
37 BACKQUOTE COMMA elcp
38 lisptable sexp-searcher-mark-list instack infile
39 env-dir lisp-indent-fuzz
40 fill-column comment-column comment-prefix
41 current-buffer-mode whitespace-charactertbl
42 include-dir tty-no-upmotionp)
43 (*lexpr comout-get-output))
44 (declare (*expr delete_$path hcs_$initiate_count indent-for-comment
45 kill-contents-of-line mark-whole-buffer one-back-is-a
46 redisplay-current-window-relative search-charset-backwards
47 search-charset-forward unwind-sexp-searchers-marks-and-nlgoto
48 view-region-as-lines))
49
50 (setq OPEN-PAREN '/( CLOSE-PAREN '/) SEMI '/;
51 DOUBLEQUOTE '/" SLASH '// SINGLEQUOTE '/' BACKQUOTE '/` COMMA '/,)
52
53
54 (defvar ((sexp-searcher-mark-list nil)
55 (elcp t)
56 (lisp-mode-clean-up-lcp-temps-list nil)
57 (lisptable (charscan-table (catenate TAB SPACE SEMI OPEN-PAREN CLOSE-PAREN NL
58 COMMA DOUBLEQUOTE SINGLEQUOTE SLASH BACKQUOTE)))
59 (lisp-mode-hook nil)))
60
61 (register-option 'elcp t)
62
63 (define-autoload-lib emacs-lisp-debug-mode ldebug-set-break)
64
65
66 (defun lisp-mode ()
67 (establish-local-var 'compiler 'lisp_compiler)
68 (establish-local-var 'compile-options "")
69 (setq current-buffer-mode 'Lisp
70 comment-column 50.
71 comment-prefix ";")
72 (mapc '(lambda (x)
73 (set-key (car x) (cadr x)))
74 '((TAB indent-to-lisp)
75 ("ESC-(" lisp-one-less-paren)
76 ("ESC-)" lisp-one-more-paren)
77 (ESC-/& ldebug-set-break)
78 (ESC-Q lisp-indent-function)
79 (ESC-^A begin-defun)
80 (ESC-^B backward-sexp)
81 (ESC-^C compile-function)
82
83 (ESC-^D down-list-level)
84 (ESC-^E end-defun)
85 (ESC-^F forward-sexp)
86 (ESC-^H mark-defun)
87 (ESC-^I indent-to-lisp)
88 (ESC-^K kill-sexp)
89 (ESC-^M lisp-cret-and-indent)
90 (ESC-^N forward-list)
91 (ESC-^P backward-list)
92 (ESC-^Q lisp-indent-region)
93 (ESC-^R move-defun-to-screen-top)
94 (ESC-^T mark-sexp)
95 (ESC-^Z eval-top-level-form)))
96 (if tty-no-upmotionp
97 (set-key 'ESC-^V 'view-defun))
98 (and lisp-mode-hook (errset (funcall lisp-mode-hook))))
99
100 (defun begin-defun ()
101 (do-forever
102 (go-to-beginning-of-line)
103 (if (firstlinep) (stop-doing))
104 (if-at OPEN-PAREN (stop-doing))
105 (prev-line)))
106
107
108 (defun end-defun ()
109 (begin-defun)
110 (forward-sexp))
111
112
113 (defun mark-defun ()
114 (begin-defun)
115 (set-the-mark)
116 (forward-sexp))
117
118
119 (defun view-defun ()
120 (mark-defun)
121 (view-region-as-lines))
122
123
124 (defun skip-lisp-whitespace-and-comments ()
125 (do-forever
126 (skip-over-whitespace)
127 (dispatch-on-current-char
128 (SEMI
129 (if (lastlinep)(stop-doing))
130 (next-line)
131 (go-to-beginning-of-line))
132 (else (stop-doing)))))
133
134 (defun forward-sexp ()
135 (prog ()
136 (skip-close-parens-and-comments-and-whitespace)
137 retry
138 (dispatch-on-current-char
139 (CLOSE-PAREN (return t))
140 (OPEN-PAREN (forward-char)
141 (forward-list))
142 (SINGLEQUOTE (forward-char)(forward-sexp))
143 (BACKQUOTE (forward-char)(forward-sexp))
144 (COMMA (forward-char)(forward-sexp))
145 (SLASH (forward-char)
146 (forward-char)
147 (go retry))
148 (DOUBLEQUOTE (forward-char)
149 (if (forward-search DOUBLEQUOTE)
150 else
151 (display-error-noabort "Unbalanced doublequote.")
152 (unwind-sexp-searchers-marks-and-nlgoto))
153 (if-at DOUBLEQUOTE (go retry))
154 (return nil))
155 (else (if (search-charset-forward lisptable)
156 (if-at SLASH (forward-char)
157 (forward-char)
158 (go retry))
159 (return t)
160 else (error "forward-sexp: whaah? delim?"))))))
161
162 (defun skip-close-parens-and-comments-and-whitespace ()
163 (do-forever
164 (skip-lisp-whitespace-and-comments)
165 (dispatch-on-current-char
166 (CLOSE-PAREN (forward-char))
167 (else (stop-doing)))))
168
169 (defun forward-list ()
170 (skip-lisp-whitespace-and-comments)
171 (with-mark mm
172 (setq sexp-searcher-mark-list (cons mm sexp-searcher-mark-list))
173 (if (at-end-of-buffer) (display-error "Unbalanced Parentheses")
174 else
175 (do-forever
176 (if-at CLOSE-PAREN (forward-char)(stop-doing))
177 (if (at-end-of-buffer)
178 (display-error-noabort "Unbalanced Parentheses.")
179 (go-to-mark mm)
180 (unwind-sexp-searchers-marks-and-nlgoto))
181 (if (or (at-white-char)(looking-at ";"))
182 (skip-lisp-whitespace-and-comments)
183 (if-at CLOSE-PAREN (forward-char)(stop-doing)))
184 (forward-sexp)))))
185
186 (defun down-list-level ()
187 (do-forever
188 (skip-close-parens-and-comments-and-whitespace)
189 (if (at-end-of-buffer)(stop-doing))
190 (if-at "(" (forward-char)(stop-doing))
191 (forward-sexp)))
192
193 (defprop nextlist-sexp forward-list expr)
194
195 (defun backward-sexp ()
196 (prog ()
197 (skip-backwards-open-parens-comments-and-other-cruft)
198 retry
199 (if (one-back-is-a SLASH)
200 (if (and (back-at """")
201 (lisp-mode-slash-quote-sneak))
202 else
203 (do-times 2 (backward-char))
204 (go retry)))
205
206 (dispatch-on-lefthand-char
207 (OPEN-PAREN (return t))
208 (CLOSE-PAREN (backward-char)
209 (backward-list)
210 (do-forever (if (memq (lefthand-char)
211 '(/' /` /,))
212 (backward-char)
213 else (stop-doing))))
214 (SINGLEQUOTE (backward-char)(go retry))
215 (BACKQUOTE (backward-char)(go retry))
216 (COMMA (backward-char)(go retry))
217 (DOUBLEQUOTE (backward-char)
218 (if (reverse-search DOUBLEQUOTE)
219 else (display-error-noabort "Unbalanced Doublequote.")
220 (unwind-sexp-searchers-marks-and-nlgoto))
221 (if-back-at DOUBLEQUOTE (go retry))
222 (return nil))
223 (else (if (search-charset-backwards lisptable)
224 (if (one-back-is-a SLASH)(go retry))
225 (do-forever (if-back-at SINGLEQUOTE (backward-char)
226 else (stop-doing)))
227 (return t)
228 else (return nil))))))
229
230 (defun lisp-mode-slash-quote-sneak ()
231 (save-excursion
232 (with-mark m
233 (let ((qct))
234 (go-to-beginning-of-line)
235 (do-forever
236 (if (mark-reached m)(return t))
237 (dispatch-on-current-char
238 (SEMI (if qct (forward-char)
239 else (return t)))
240 (DOUBLEQUOTE (setq qct (not qct))
241 (forward-char))
242 (SLASH (forward-char)
243 (if (mark-reached m)(return t))
244
245 (if (not qct)
246 (forward-char)
247 (if (mark-reached m)(return nil))))
248
249 (else (forward-char))))))))
250
251 (defun backward-list ()
252 (with-mark mm
253 (setq sexp-searcher-mark-list (cons mm sexp-searcher-mark-list))
254 (if (at-beginning-of-buffer)
255
256 else
257 (do-forever
258 (if-back-at OPEN-PAREN (backward-char)(stop-doing))
259 (if (at-beginning-of-buffer)
260 (display-error-noabort "Unbalanced Parentheses.")
261 (go-to-mark mm)
262 (unwind-sexp-searchers-marks-and-nlgoto))
263 (if (or (bolp)(get (lefthand-char) 'whiteness))
264 (skip-backwards-lisp-whitespace-comment-cruft)
265 (if (and (back-at OPEN-PAREN)
266 (not (one-back-is-a SLASH)))
267 (backward-char)
268 (stop-doing)))
269 (backward-sexp)))))
270
271 (defun skip-backwards-open-parens-comments-and-other-cruft ()
272 (do-forever
273 (skip-backwards-lisp-whitespace-comment-cruft)
274 (dispatch-on-lefthand-char
275 (OPEN-PAREN (backward-char)
276 (if-back-at SLASH (forward-char)(stop-doing)))
277 (else (stop-doing)))))
278
279 (defun skip-backwards-lisp-whitespace-comment-cruft ()
280 (do-forever
281 tbolp (if (at-beginning-of-buffer)(stop-doing))
282 (if (bolp)(backward-char)
283 (if (bolp)(go tbolp))
284 (skip-backwards-possible-lisp-comment)
285 (go tbolp))
286 (dispatch-on-lefthand-char
287 (TAB (backward-char))
288 (SPACE (backward-char))
289 (NL (backward-char))
290 (SLASH (forward-char)(stop-doing))
291 (else (stop-doing)))))
292
293 (defun skip-backwards-possible-lisp-comment ()
294 (go-to-end-of-line)
295 (find-lisp-comment-start))
296
297 (defun find-lisp-comment-start ()
298 (prog (qct foundit)
299 (go-to-beginning-of-line)
300 (if (not (forward-search-in-line ";"))
301 (go-to-end-of-line)
302 (return nil)
303 else (go-to-beginning-of-line))
304 (setq qct nil)
305 (do-forever
306 (if (eolp)(stop-doing))
307 (dispatch-on-current-char
308 (DOUBLEQUOTE (setq qct (not qct))(forward-char))
309 (SEMI (if qct (forward-char)
310 else (setq foundit t)
311 (stop-doing)))
312 (SLASH (forward-char)
313 (if (eolp)(stop-doing))
314 (if (not qct) (forward-char)))
315 (else (forward-char))))
316 (return foundit)))
317
318 (defprop prevlist-sexp backward-list expr)
319
320 (defun mark-sexp ()
321 (skip-lisp-whitespace-and-comments)
322 (if-at CLOSE-PAREN (forward-char)
323 else (forward-sexp))
324 (set-the-mark)
325 (backward-sexp)
326 (exchange-point-and-mark))
327
328 (defprop kill-sexp forward kills)
329 (defun kill-sexp ()(with-mark m
330 (forward-sexp)
331 (kill-backwards-to-mark m)
332 (merge-kills-forward)))
333
334 (defun move-defun-to-screen-top ()
335 (begin-defun)
336 (redisplay-current-window-relative 0))
337
338
339
340
341
342
343
344 (defun compile-function ()
345 (prog (fnname)
346 (if elcp (return (elcp-compile-top-level-form-from-buffer)))
347 (compile-string
348 (save-excursion
349 (begin-defun)
350 (down-list-level)
351 (forward-sexp)
352 (skip-lisp-whitespace-and-comments)
353 (with-mark n
354 (forward-sexp)
355 (killsave-string (setq fnname (point-mark-to-string n))))
356 (begin-defun)
357 (with-mark m
358 (forward-sexp)
359 (point-mark-to-string m)))
360 fnname)))
361
362 (defun compile-string (stuff function-name)
363 (set-emacs-epilogue-handler '(lisp-mode-clean-up-lcp-temps) t)
364 (let ((source-name (catenate process-dir ">!!e!lcptemp!.lisp"))
365 (object-name (catenate "!ect" (maknam (explodec (runtime))))))
366 (save-excursion-buffer
367 (go-to-or-create-buffer 'compiler-temp)
368 (putprop current-buffer t 'temporary-buffer)
369 (setq buffer-modified-flag t)
370 (destroy-buffer-contents)
371 (insert-string "(declare (use c))")
372 (new-line)
373 (insert-string "(declare (setq seg-name ""[pd]>")
374 (insert-string object-name)
375 (insert-string """)(use w))")
376 (new-line)
377 (insert-string "(declare (inpush (openi """)
378 (insert-string include-dir)
379 (insert-string ">e-macros.incl.lisp"")))")
380 (new-line)
381 (insert-string stuff)
382 (write-out-file source-name)
383 (setq lisp-mode-clean-up-lcp-temps-list
384 (cons object-name lisp-mode-clean-up-lcp-temps-list))
385 (display-error-noabort "Compiling " function-name " ..."))
386 (display-as-printout
387 (comout-get-output "lisp_compiler" source-name))
388 (loadfile (catenate process-dir ">" object-name))
389 (sstatus uuolinks nil)))
390
391 (defun lisp-mode-clean-up-lcp-temps ()
392 (delete_$path process-dir "!!e!lcptemp!.lisp" (lsh 44 30.) "emacs")
393 (mapc '(lambda (x)
394 (delete_$path process-dir x (lsh 44 30.) "emacs"))
395 lisp-mode-clean-up-lcp-temps-list))
396
397
398
399
400
401
402
403
404
405 (defvar loaded-e-macros nil)
406
407 (defun eval-lisp-region ()
408 (with-the-mark-last
409 m
410 (if (not loaded-e-macros)
411 (load (catenate env-dir ">e_macros_"))
412 (load (catenate env-dir ">e_define_command_"))
413 (setq loaded-e-macros t))
414 (let ((answer (car (errset
415 (eval (read-from-string
416 (catenate "(progn "
417 (point-mark-to-string m)
418 " )")))))))
419 (let ((prinlevel 3)
420 (prinlength 6))
421 (minibuffer-print "Value: " (maknam (explode answer)))))
422 (do ((next-file infile (car instack)))
423 ((eq infile t))
424 (close next-file))
425 (sstatus uuolinks nil)))
426
427 (defun eval-top-level-form ()
428 (save-excursion
429 (mark-defun)
430 (eval-lisp-region)))
431
432
433 (defun eval-buffer ()
434 (save-excursion
435 (mark-whole-buffer)
436 (eval-lisp-region)))
437
438
439
440
441
442
443
444
445 (register-option 'lisp-indent-fuzz 1)
446
447 (defun indent-to-lisp ()
448 (go-to-beginning-of-line)
449 (indent-to-lisp-1))
450
451 (defun indent-to-lisp-1 ()
452 (if (charset-member (curchar) lisptable)
453 (delete-white-sides)
454 (if (not (bolp))(insert-char " "))
455 (whitespace-to-hpos
456 (save-excursion
457
458 (do-forever
459 (backward-sexp)
460 (if (not (and (bolp)(not (charset-member (curchar) lisptable))))
461 (stop-doing)))
462
463 (cond ((not (skip-back-whitespace-in-line)))
464 ((back-at "(") (skip-over-whitespace))
465 (t (with-mark
466 start-of-predecessor
467 (backward-list)
468 (if (mark-on-current-line-p start-of-predecessor)
469 (down-list-level)
470 (forward-sexp)
471 (skip-lisp-whitespace-and-comments)
472 else
473 (down-list-level)
474 (do-forever
475 (skip-lisp-whitespace-and-comments)
476 (if (and (mark-on-current-line-p start-of-predecessor)
477 (or (mark-reached start-of-predecessor)
478 (and (bolp)(at "("))
479 (not (bolp))))
480 (stop-doing))
481 (forward-sexp))))))
482 (if (and (back-at OPEN-PAREN)
483 (not (at OPEN-PAREN)))
484 (+ (cur-hpos) lisp-indent-fuzz)
485 else (cur-hpos))))
486 else
487 (forward-sexp)
488 (search-for-first-not-charset-line whitespace-charactertbl)
489 (if (not (or (eolp)(at ";")))
490 (indent-to-lisp-1))))
491
492 (defun lisp-cret-and-indent ()
493 (delete-white-sides)
494 (new-line)
495 (insert-char " ")
496 (indent-to-lisp))
497
498 (defun lisp-indent-region ()
499 (copy-region)
500 (with-the-mark-last
501 m
502 (do-forever
503 (if (line-is-blank)(without-saving (kill-contents-of-line))
504 else
505 (go-to-beginning-of-line)
506 (if-at OPEN-PAREN
507 else (search-for-first-not-charset-line whitespace-charactertbl)
508 (if (not (at ";"))(indent-to-lisp)))
509 (if (find-lisp-comment-start)
510 (place-lisp-comments)))
511 (if (mark-on-current-line-p m)(stop-doing))
512 (next-line)))))
513
514
515 (defun place-lisp-comments ()
516 (cond ((looking-at ";;;")(delete-white-sides))
517 ((looking-at ";;")(indent-to-lisp))
518 (t (indent-for-comment))))
519
520 (defun lisp-indent-function ()
521 (mark-defun)
522 (lisp-indent-region))
523
524
525
526 ^L
527
528
529
530
531 (defcom lisp-one-more-paren
532 &na (&repeat)
533 (save-excursion
534 (go-to-beginning-of-line)
535 (skip-backwards-lisp-whitespace-comment-cruft)
536 (insert-char ")"))
537 (indent-to-lisp))
538
539 (defcom lisp-one-less-paren
540 &na (&repeat)
541 (save-excursion
542 (go-to-beginning-of-line)
543 (skip-backwards-lisp-whitespace-comment-cruft)
544 (if-back-at ")"
545 (rubout-char)
546 else
547 (display-error "Previous s-exp doesn't end in close paren.")))
548 (indent-to-lisp))
549
550 ^L
551
552
553
554
555
556
557
558
559 (declare (*expr runoff-fill-region compile-top-level-forms))
560 (declare (special elcp-@seg-name lisp-system-dir elcp-internmes elcp-spake))
561 (declare (special elcp-@undfuns elcp-@being-compiled))
562
563 (setq elcp-internmes
564
565
566
567 '(cf cl pause genprefix nfunvars special fixnum flonum fixsw flosw notype arith array* closed muzzled
568 unspecial reducible irreducible noargs mapex symbols lisp
569 put-in-tree
570 expr-hash system-file compile-top-level-forms
571 sobarray cobarray eoc-eval compiler-state compile maklap top-level coutput gofoo
572 nocompile
573 -db -debug -eval -tm -time -times -ps -pause -pause_at -mc -macros -gp -gnp
574 -genprefix -nw -nowarn -tt -total -total_time -list -ls -long -lg
575 -all_special -pathname -pn -p -no_compile -ncp
576 -ck -check -ioc -messioc -mioc -hd -hold -pedigree -pdg -brief -bf arith
577 *expr *fexpr *lexpr **array messioc check debug macros dataerrp barfp
578 defpl1 update return ignore fixed bin binary float packed-pointer packed-ptr
579 pointer ptr bit aligned unaligned character varying char lisp array
580 l le g ge n e))
581
582 (defun elcp-load-lcp ()
583 (let ((obarray (get '*VIRGIN-OBARRAY* 'array))
584 (errlist errlist))
585 (makoblist 'compiler-obarray)
586 (setq obarray (get 'compiler-obarray 'array))
587 (mapc 'intern elcp-internmes)
588 (putprop (intern (copysymbol 'use nil)) 'elcp-use 'expr)
589 (putprop (intern (copysymbol 'global nil)) 'elcp-global 'expr)
590 (setq elcp-@seg-name (intern (copysymbol 'seg-name nil)))
591 (setq elcp-@undfuns (intern (copysymbol 'undfuns nil)))
592 (setq elcp-@being-compiled (intern (copysymbol 'being-compiled nil)))
593 (set (intern (copysymbol 'compiler-revision nil)) "Emacs")
594 (mapc '(lambda (x)
595 (hcs_$initiate_count lisp-system-dir x x 0)
596
597 (load (catenate lisp-system-dir ">" x)))
598 '(lcp_semant_ lcp_cg_))
599 (putprop (intern (copysymbol 'printmes nil)) 'elcp-lcp-error-printer 'expr)))
600
601
602 (defun elcp-use fexpr (x)
603 (let ((x (getchar (car x) 1)))
604 (cond ((eq x 'c) (setq obarray (get 'compiler-obarray 'array))
605 'compiler-obarray)
606 ((eq x 'w) (setq obarray (get 'obarray 'array))
607 'working-obarray)
608 ((eq x 'n) (setq obarray (get '*VIRGIN-OBARRAY* 'array))
609 (makoblist 'obarray)
610 (setq obarray (get 'obarray 'array))
611 'new-working-obarray)
612 (t (display-error-noabort "use: argument must be c, w, or n.")))
613 nil))
614
615 (defun elcp-global fexpr (x)
616 (let ((obarray (get 'obarray 'array)))
617 (mapc '(lambda (y)
618 (setq x (intern y))
619 (or (eq x y)
620 (display-error-noabort "elcp-global: obarray ""already interned"" conflict: " y)))
621 x)))
622
623 (defun cfun (fname)
624 (let ((prop (getl fname '(expr fexpr macro))))
625 (or prop
626 (display-error "cfun: " fname " not a function"))
627 (elcp-compile-and-load
628 `((defprop ,fname ,(cadr prop) ,(car prop))))))
629
630 (defun elcp-compile-and-load (forms)
631 (set-emacs-epilogue-handler '(lisp-mode-clean-up-lcp-temps) t)
632 (setq elcp-spake nil)
633 (if (null (get 'compiler-obarray 'array))
634 (display-error-remark "Loading LCP into Emacs environment...")
635 (elcp-load-lcp)
636 (display-error-remark "Precompiling e-macros.incl.lisp...")
637 (setq loaded-e-macros t)
638 (compile-top-level-forms
639 `((declare
640 (setq eoc-eval
641 '((cf ,(catenate include-dir ">e-macros.incl.lisp"))))))
642 nil))
643 (let ((segname
644 (catenate "!ect" (maknam (explodec (runtime)))))
645 (fname (cond ((or (atom forms)(atom (car forms))))
646 ((cdr forms) "...")
647 ((memq (caar forms) '(defun defcom define-command defmacro defstruct))
648 (cadar forms))
649 (t "...."))))
650 (setq lisp-mode-clean-up-lcp-temps-list
651 (cons segname lisp-mode-clean-up-lcp-temps-list))
652 (display-error-remark "Compiling " fname "...")
653
654 (compile-top-level-forms forms (catenate "[pd]>" segname))
655
656 (let ((undfuns (symeval elcp-@undfuns)))
657 (setq undfuns
658 (mapcan '(lambda (x)(cond ((getl x '(subr lsubr fsubr expr fexpr))
659 nil)
660 (t (list x))))
661 undfuns))
662 (if undfuns
663 (elcp-lcp-error-printer undfuns " - functions referenced but not defined. " nil)
664 (set elcp-@undfuns nil)))
665 (minibuffer-print-noclear " Loading ..")
666 (loadfile (catenate process-dir ">" segname))
667 (sstatus uuolinks nil)
668 (and (symbolp fname)(killsave-string fname))
669 (minibuffer-print "Compiled."))
670 (and elcp-spake (end-local-displays)))
671
672 (defun elcp-compile-top-level-form-from-buffer ()
673 (let ((stuff
674 (save-excursion (mark-defun)
675 (with-the-mark-last
676 m
677 (car (errset (read-from-string
678 (point-mark-to-string m))))))))
679 (elcp-compile-and-load (list stuff))
680 (and stuff
681 (not (atom stuff))
682 (not (cdr stuff))
683 (not (atom (car stuff)))
684 (cdar stuff)
685 (memq (caar stuff)'(defun defmacro defcom define-command defstruct))
686 (putprop (caar stuff) current-buffer 'tagbuf))))
687
688 (defun elcp-lcp-error-printer (data msg error-type)
689 (if (not elcp-spake)
690 (init-local-displays)
691 (setq elcp-spake t))
692 (save-excursion-buffer
693 (go-to-or-create-buffer 'Compiler/ Diagnostics)
694 (go-to-end-of-buffer)
695 (without-modifying
696 (if (not (at-beginning-of-buffer))
697 (new-line))
698 (set-the-mark)
699 (if (and (boundp elcp-@being-compiled)
700 (symeval elcp-@being-compiled))
701 (if (not (at-beginning-of-buffer))
702 (new-line)
703 (set-the-mark))
704 (insert-string "*** DIAGNOSTICS FOR ")
705 (insert-string (maknam (explodec (symeval elcp-@being-compiled))))
706 (insert-string " ***")
707 (new-line)
708 (set elcp-@being-compiled nil)
709 (elcp-filled-print-region)
710 (new-line)
711 (set-the-mark))
712 (setq error-type
713 (let ((obarray (get 'obarray 'array)))
714 (intern error-type)))
715 (insert-string (cdr (assq error-type
716 '((warn . "Warning: ")
717 (nonfatal . "Error: ")
718 (data . "Severe error: ")
719 (barf . "Compiler error: ")
720 (nil . "lisp_compiler: ")))))
721 (if data
722 (insert-string " ")
723 (insert-string
724 (let ((prinlevel 3)(prinlength 6))
725 (maknam (explode data))))
726 (new-line))
727 (insert-string " ")
728 (insert-string msg)
729 (new-line)
730 (elcp-filled-print-region))))
731
732
733 (defun elcp-filled-print-region ()
734 (without-saving (runoff-fill-region))
735 (with-mark x
736 (go-to-mark der-wahrer-mark)
737 (do-forever
738 (local-display-current-line)
739 (if (mark-on-current-line-p x)(stop-doing))
740 (next-line)))
741 (go-to-end-of-buffer))
742