1 ;;; ***********************************************************
  2 ;;; *                                                         *
  3 ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4 ;;; *                                                         *
  5 ;;; * Copyright (c) 1978 by Massachusetts Institute of        *
  6 ;;; * Technology and Honeywell Information Systems, Inc.      *
  7 ;;; *                                                         *
  8 ;;; ***********************************************************
  9 
 10 ;;;
 11 ;;;
 12 ;;;       Lisp Mode.  Extracted and modified from e_macops_,
 13 
 14 ;;; HISTORY COMMENTS:
 15 ;;;  1) change(80-05-06,Greenberg), approve(), audit(),
 16 ;;;     install(86-08-20,MR12.0-1136):
 17 ;;;     pre-hcom history:
 18 ;;;               BSG & WMY 9/11/78
 19 ;;;               GMP, 09/16/78 to add evaluation functions.
 20 ;;;               Indented by indent-to-lisp 9/18!!
 21 ;;;               Hook to LDEBUG BSG 2/25/79
 22 ;;;               Clean up compiler segs, elcp feature, backquote, comma BSG 5/6/80
 23 ;;;  2) change(85-01-03,Margolin), approve(86-02-24,MCR7186),
 24 ;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
 25 ;;;     Changed eval-lisp-region to load e_macros_ and e_define_command_,
 26 ;;;     defvar'ed loaded-e-macros.
 27 ;;;  3) change(85-01-27,Margolin), approve(86-02-24,MCR7186),
 28 ;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
 29 ;;;     Declared lots of functions *expr.
 30 ;;;                                                      END HISTORY COMMENTS
 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) ;t 9/12/80
 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 ;;; Extended command to enter LISP mode
 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 ;;;            (^Z^C   compile-buffer)            ;file-output kind
 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                       ;if not on a display
 97            (set-key 'ESC-^V 'view-defun))         ;add this useful function
 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))    ;heh heh
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)     ;get closeparen out
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                             ;go thru balancing act
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)))  ; WAS quoted
240                              (DOUBLEQUOTE (setq qct (not qct))
241                                           (forward-char))
242                              (SLASH  (forward-char)
243                                      (if (mark-reached m)(return t))
244                                      ;; The above should never happen.
245                                      (if (not qct)
246                                          (forward-char)
247                                          (if (mark-reached m)(return nil))))
248                              ;; The above finds slashed quotes.
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                       ;;fall through to test for same below
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 ;;;^L
338 ;;;
339 ;;;       Your're not going to believe this, but...
340 ;;;       Function compiling functions.
341 ;;;       BSG and archy 7/28/78
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 ;;; ^L
398 
399 ;;;
400 ;;;       Functions for evaluating LISP
401 ;;;        GMP, 09/16/78
402 ;;;
403 
404 
405 (defvar loaded-e-macros nil)                      ; non-nil => don't loadlib e-macros
406 
407 (defun eval-lisp-region ()                        ; evaluate the current 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))                   ; close any loaded files
425          (sstatus uuolinks nil)))
426 
427 (defun eval-top-level-form ()                     ; command (ESC-^Z) to evaluate form
428        (save-excursion
429          (mark-defun)                             ; marks any form starting in column one
430          (eval-lisp-region)))
431 
432 
433 (defun eval-buffer ()                             ; extended command to eval buffer
434        (save-excursion
435          (mark-whole-buffer)
436          (eval-lisp-region)))
437 
438 ;;; ^L
439 
440 ;;;
441 ;;;       Lisp indenter
442 ;;;       Made winning 9/18 by archy & BSG
443 ;;;
444 
445 (register-option 'lisp-indent-fuzz 1)
446 
447 (defun indent-to-lisp ()                          ;this one's a goody, kids!
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                        ;get to right line
459                  (backward-sexp)
460                  (if (not (and (bolp)(not (charset-member (curchar) lisptable))))
461                      (stop-doing)))               ;find non-label last sexp
462 
463                (cond ((not (skip-back-whitespace-in-line))) ;'twas all white
464                      ((back-at "(") (skip-over-whitespace)) ; (cond ((FOO.. etc
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 " ")                          ;not a label
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)          ;Rule out comment lines
506                (if-at OPEN-PAREN                  ;Don't indent these lines.
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 ;;;       BSG 5/6/80 put his favorite two fcns here..
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 ;;;   In-house LCPery, integrated 5/6/80
553 ;;;
554 
555 ;;;
556 ;;; 5/1/80 BSG
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       ;;This slight inelegance has to duplicate the global list of the compiler
565       ;;because by time the compiler can even be looked at, it has already
566       ;;interned its own things on the wrong obarray.  This is unclean, but..
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         ;request of H. Lieberman
570           expr-hash system-file compile-top-level-forms     ;for GSB & BSG 5/4/80
571           sobarray cobarray eoc-eval compiler-state compile maklap top-level coutput gofoo ;jonl's crocks for owl
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))                   ;clever bastard
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                            ;; lisp_cg_utility_ snaps link to x$symbol_table
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)))             ; get the first char of the argument.
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) ; copy it
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                   ;idea is no obj seg.
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