LISTING FOR  >spec>install>1136>emacs-lisp-mode
COMPILED BY Multics LISP Compiler, Version 2.13c, July 11, 1983
ON 08/20/86  2252.3 mst Wed
IN BEHALF OF Martinson.SysMaint.a



;;; ***********************************************************
;;; *                                                         *
;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
;;; *                                                         *
;;; * Copyright (c) 1978 by Massachusetts Institute of        *
;;; * Technology and Honeywell Information Systems, Inc.      *
;;; *                                                         *
;;; ***********************************************************

;;;
;;;
;;;	Lisp Mode.  Extracted and modified from e_macops_,

;;; HISTORY COMMENTS:
;;;  1) change(80-05-06,Greenberg), approve(), audit(),
;;;     install(86-08-20,MR12.0-1136):
;;;     pre-hcom history:
;;;               BSG & WMY 9/11/78
;;;               GMP, 09/16/78 to add evaluation functions.
;;;               Indented by indent-to-lisp 9/18!!
;;;               Hook to LDEBUG BSG 2/25/79
;;;               Clean up compiler segs, elcp feature, backquote, comma BSG 5/6/80
;;;  2) change(85-01-03,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Changed eval-lisp-region to load e_macros_ and e_define_command_,
;;;     defvar'ed loaded-e-macros.
;;;  3) change(85-01-27,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Declared lots of functions *expr.
;;;                                                      END HISTORY COMMENTS


(%include e-macros)

(declare (special
	 OPEN-PAREN CLOSE-PAREN SEMI SINGLEQUOTE DOUBLEQUOTE SLASH
	 BACKQUOTE COMMA elcp
	 lisptable sexp-searcher-mark-list instack infile
	 env-dir lisp-indent-fuzz
	 fill-column comment-column comment-prefix
	 current-buffer-mode whitespace-charactertbl
	 include-dir tty-no-upmotionp)
         (*lexpr comout-get-output))
(declare (*expr delete_$path hcs_$initiate_count indent-for-comment
	      kill-contents-of-line mark-whole-buffer one-back-is-a
	      redisplay-current-window-relative search-charset-backwards
	      search-charset-forward unwind-sexp-searchers-marks-and-nlgoto
	      view-region-as-lines))

(setq OPEN-PAREN '/( CLOSE-PAREN '/) SEMI '/;
      DOUBLEQUOTE '/" SLASH '// SINGLEQUOTE '/' BACKQUOTE '/` COMMA '/,)


(defvar ((sexp-searcher-mark-list nil)
         (elcp t) ;t 9/12/80
         (lisp-mode-clean-up-lcp-temps-list nil)
         (lisptable (charscan-table (catenate TAB SPACE SEMI OPEN-PAREN CLOSE-PAREN NL 
				      COMMA DOUBLEQUOTE SINGLEQUOTE SLASH BACKQUOTE)))
         (lisp-mode-hook nil)))

(register-option 'elcp t)

(define-autoload-lib emacs-lisp-debug-mode ldebug-set-break)

;;; Extended command to enter LISP mode
(defun lisp-mode ()
       (establish-local-var 'compiler 'lisp_compiler)
       (establish-local-var 'compile-options "")
       (setq current-buffer-mode 'Lisp
	   comment-column 50.
	   comment-prefix ";")
       (mapc '(lambda (x)
		  (set-key (car x) (cadr x)))
	   '((TAB indent-to-lisp)
	     ("ESC-(" lisp-one-less-paren)
	     ("ESC-)" lisp-one-more-paren)
	     (ESC-/& ldebug-set-break)
	     (ESC-Q  lisp-indent-function)
	     (ESC-^A begin-defun)
	     (ESC-^B backward-sexp)
	     (ESC-^C compile-function)
;;;	     (^Z^C   compile-buffer)		;file-output kind
	     (ESC-^D down-list-level)
	     (ESC-^E end-defun)
	     (ESC-^F forward-sexp)
	     (ESC-^H mark-defun)
	     (ESC-^I indent-to-lisp)
	     (ESC-^K kill-sexp)
	     (ESC-^M lisp-cret-and-indent)
	     (ESC-^N forward-list)
	     (ESC-^P backward-list)
	     (ESC-^Q lisp-indent-region)
	     (ESC-^R move-defun-to-screen-top)
	     (ESC-^T mark-sexp)
	     (ESC-^Z eval-top-level-form)))
       (if tty-no-upmotionp			;if not on a display
	 (set-key 'ESC-^V 'view-defun))	;add this useful function
       (and lisp-mode-hook (errset (funcall lisp-mode-hook))))

(defun begin-defun ()
       (do-forever
         (go-to-beginning-of-line)
         (if (firstlinep) (stop-doing))
         (if-at OPEN-PAREN (stop-doing))
         (prev-line)))


(defun end-defun ()
       (begin-defun)
       (forward-sexp))


(defun mark-defun ()
       (begin-defun)
       (set-the-mark)
       (forward-sexp))


(defun view-defun ()
       (mark-defun)
       (view-region-as-lines))


(defun skip-lisp-whitespace-and-comments ()
       (do-forever
         (skip-over-whitespace)
         (dispatch-on-current-char
	 (SEMI
	   (if (lastlinep)(stop-doing))
	   (next-line)
	   (go-to-beginning-of-line))
	 (else (stop-doing)))))

(defun forward-sexp ()
       (prog ()
	   (skip-close-parens-and-comments-and-whitespace)
retry
	   (dispatch-on-current-char
	     (CLOSE-PAREN   (return t))
	     (OPEN-PAREN    (forward-char)
			(forward-list))
	     (SINGLEQUOTE   (forward-char)(forward-sexp))
	     (BACKQUOTE     (forward-char)(forward-sexp))
	     (COMMA         (forward-char)(forward-sexp))
	     (SLASH         (forward-char)
			(forward-char)
			(go retry))
	     (DOUBLEQUOTE   (forward-char)
			(if (forward-search DOUBLEQUOTE)
			    else
			    (display-error-noabort "Unbalanced doublequote.")
			    (unwind-sexp-searchers-marks-and-nlgoto))
			(if-at DOUBLEQUOTE (go retry))
			(return nil))
	     (else (if (search-charset-forward lisptable)
		     (if-at SLASH (forward-char)
			  (forward-char)
			  (go retry))
		     (return t)
		     else (error "forward-sexp: whaah? delim?"))))))

(defun skip-close-parens-and-comments-and-whitespace ()
       (do-forever
         (skip-lisp-whitespace-and-comments)
         (dispatch-on-current-char
	 (CLOSE-PAREN (forward-char))
	 (else (stop-doing)))))

(defun forward-list ()
       (skip-lisp-whitespace-and-comments)
       (with-mark mm
	        (setq sexp-searcher-mark-list (cons mm sexp-searcher-mark-list))
	        (if (at-end-of-buffer) (display-error "Unbalanced Parentheses")
		  else
		  (do-forever
		    (if-at CLOSE-PAREN (forward-char)(stop-doing))
		    (if (at-end-of-buffer)
		        (display-error-noabort "Unbalanced Parentheses.")
		        (go-to-mark mm)
		        (unwind-sexp-searchers-marks-and-nlgoto))
		    (if (or (at-white-char)(looking-at ";"))
		        (skip-lisp-whitespace-and-comments)
		        (if-at CLOSE-PAREN (forward-char)(stop-doing)))
		    (forward-sexp)))))

(defun down-list-level ()
       (do-forever
         (skip-close-parens-and-comments-and-whitespace)
         (if (at-end-of-buffer)(stop-doing))
         (if-at "(" (forward-char)(stop-doing))
         (forward-sexp)))

(defprop nextlist-sexp forward-list expr)

(defun backward-sexp ()
       (prog ()
	   (skip-backwards-open-parens-comments-and-other-cruft)
retry
	   (if (one-back-is-a SLASH)
	       (if (and (back-at """")
		      (lisp-mode-slash-quote-sneak))	;heh heh
		 else
		 (do-times 2 (backward-char))
		 (go retry)))

	   (dispatch-on-lefthand-char
	     (OPEN-PAREN	(return t))
	     (CLOSE-PAREN	(backward-char)	;get closeparen out
			(backward-list)
			(do-forever (if (memq (lefthand-char)
					  '(/' /` /,))
				      (backward-char)
				      else (stop-doing))))
	     (SINGLEQUOTE	(backward-char)(go retry))
	     (BACKQUOTE	(backward-char)(go retry))
	     (COMMA	(backward-char)(go retry))
	     (DOUBLEQUOTE	(backward-char)
			(if (reverse-search DOUBLEQUOTE)
			    else (display-error-noabort "Unbalanced Doublequote.")
			    (unwind-sexp-searchers-marks-and-nlgoto))
			(if-back-at DOUBLEQUOTE (go retry))
			(return nil))
	     (else (if (search-charset-backwards lisptable)
		     (if (one-back-is-a SLASH)(go retry))
		     (do-forever (if-back-at SINGLEQUOTE (backward-char)
				         else (stop-doing)))
		     (return t)
		     else (return nil))))))

(defun lisp-mode-slash-quote-sneak ()
       (save-excursion
         (with-mark m			;go thru balancing act
		(let ((qct))
		     (go-to-beginning-of-line)
		     (do-forever
		       (if (mark-reached m)(return t))
		       (dispatch-on-current-char
		         (SEMI   (if qct (forward-char)
				 else (return t)))	; WAS quoted
		         (DOUBLEQUOTE (setq qct (not qct))
				  (forward-char))
		         (SLASH  (forward-char)
			       (if (mark-reached m)(return t))
			       ;; The above should never happen.
			       (if (not qct)
				 (forward-char)
				 (if (mark-reached m)(return nil))))
		         ;; The above finds slashed quotes.
		         (else  (forward-char))))))))

(defun backward-list ()
       (with-mark mm
	        (setq sexp-searcher-mark-list (cons mm sexp-searcher-mark-list))
	        (if (at-beginning-of-buffer)
		  ;;fall through to test for same below
		  else
		  (do-forever
		    (if-back-at OPEN-PAREN (backward-char)(stop-doing))
		    (if (at-beginning-of-buffer)
		        (display-error-noabort "Unbalanced Parentheses.")
		        (go-to-mark mm)
		        (unwind-sexp-searchers-marks-and-nlgoto))
		    (if (or (bolp)(get (lefthand-char) 'whiteness))
		        (skip-backwards-lisp-whitespace-comment-cruft)
		        (if (and (back-at OPEN-PAREN)
			       (not (one-back-is-a SLASH)))
			  (backward-char)
			  (stop-doing)))
		    (backward-sexp)))))

(defun skip-backwards-open-parens-comments-and-other-cruft ()
       (do-forever
         (skip-backwards-lisp-whitespace-comment-cruft)
         (dispatch-on-lefthand-char
	 (OPEN-PAREN (backward-char)
		   (if-back-at SLASH (forward-char)(stop-doing)))
	 (else (stop-doing)))))

(defun skip-backwards-lisp-whitespace-comment-cruft ()
       (do-forever
tbolp    (if (at-beginning-of-buffer)(stop-doing))
         (if (bolp)(backward-char)
	   (if (bolp)(go tbolp))
	   (skip-backwards-possible-lisp-comment)
	   (go tbolp))
         (dispatch-on-lefthand-char
	 (TAB		(backward-char))
	 (SPACE		(backward-char))
	 (NL		(backward-char))
	 (SLASH		(forward-char)(stop-doing))
	 (else		(stop-doing)))))

(defun skip-backwards-possible-lisp-comment ()
       (go-to-end-of-line)
       (find-lisp-comment-start))

(defun find-lisp-comment-start ()
       (prog (qct foundit)
	   (go-to-beginning-of-line)
	   (if (not (forward-search-in-line ";"))
	       (go-to-end-of-line)
	       (return nil)
	       else (go-to-beginning-of-line))
	   (setq qct nil)
	   (do-forever
	     (if (eolp)(stop-doing))
	     (dispatch-on-current-char
	       (DOUBLEQUOTE (setq qct (not qct))(forward-char))
	       (SEMI	(if qct (forward-char)
			    else (setq foundit t)
			    (stop-doing)))
	       (SLASH	(forward-char)
			(if (eolp)(stop-doing))
			(if (not qct) (forward-char)))
	       (else	(forward-char))))
	   (return foundit)))

(defprop prevlist-sexp backward-list expr)

(defun mark-sexp ()
       (skip-lisp-whitespace-and-comments)
       (if-at CLOSE-PAREN (forward-char)
	    else (forward-sexp))
       (set-the-mark)
       (backward-sexp)
       (exchange-point-and-mark))

(defprop kill-sexp forward kills)
(defun kill-sexp ()(with-mark m
			(forward-sexp)
			(kill-backwards-to-mark m)
			(merge-kills-forward)))

(defun move-defun-to-screen-top ()
       (begin-defun)
       (redisplay-current-window-relative 0))
;;;
;;;
;;;	Your're not going to believe this, but...
;;;	Function compiling functions.
;;;	BSG and archy 7/28/78
;;;

(defun compile-function ()
       (prog (fnname)
	   (if elcp (return (elcp-compile-top-level-form-from-buffer)))
	   (compile-string
	     (save-excursion
	       (begin-defun)
	       (down-list-level)
	       (forward-sexp)
	       (skip-lisp-whitespace-and-comments)
	       (with-mark n
		        (forward-sexp)
		        (killsave-string (setq fnname (point-mark-to-string n))))
	       (begin-defun)
	       (with-mark m
		        (forward-sexp)
		        (point-mark-to-string m)))
	     fnname)))

(defun compile-string (stuff function-name)
       (set-emacs-epilogue-handler  '(lisp-mode-clean-up-lcp-temps) t)
       (let ((source-name (catenate process-dir ">!!e!lcptemp!.lisp"))
	   (object-name (catenate "!ect" (maknam (explodec (runtime))))))
	  (save-excursion-buffer
	    (go-to-or-create-buffer 'compiler-temp)
	    (putprop current-buffer t 'temporary-buffer)
	    (setq buffer-modified-flag t)
	    (destroy-buffer-contents)
	    (insert-string "(declare (use c))")
	    (new-line)
	    (insert-string "(declare (setq seg-name ""[pd]>")
	    (insert-string object-name)
	    (insert-string """)(use w))")
	    (new-line)
	    (insert-string "(declare (inpush (openi """)
	    (insert-string include-dir)
	    (insert-string ">e-macros.incl.lisp"")))")
	    (new-line)
	    (insert-string stuff)
	    (write-out-file source-name)
	    (setq lisp-mode-clean-up-lcp-temps-list
		(cons object-name lisp-mode-clean-up-lcp-temps-list))
	    (display-error-noabort "Compiling " function-name " ..."))
	  (display-as-printout
	    (comout-get-output "lisp_compiler" source-name))
	  (loadfile (catenate process-dir ">" object-name))
	  (sstatus uuolinks nil)))

(defun lisp-mode-clean-up-lcp-temps ()
       (delete_$path process-dir "!!e!lcptemp!.lisp" (lsh 44 30.) "emacs")
       (mapc '(lambda (x)
		  (delete_$path process-dir x (lsh 44 30.) "emacs"))
	   lisp-mode-clean-up-lcp-temps-list))

;;; 

;;;
;;;	Functions for evaluating LISP
;;;	 GMP, 09/16/78
;;;


(defvar loaded-e-macros nil)			; non-nil => don't loadlib e-macros

(defun eval-lisp-region ()			; evaluate the current region
       (with-the-mark-last
         m
         (if (not loaded-e-macros)
	   (load (catenate env-dir ">e_macros_"))
	   (load (catenate env-dir ">e_define_command_"))
	   (setq loaded-e-macros t))
         (let ((answer (car (errset
			(eval (read-from-string
			        (catenate "(progn "
				        (point-mark-to-string m)
				        " )")))))))
	    (let ((prinlevel 3)
		(prinlength 6))
	         (minibuffer-print "Value: " (maknam (explode answer)))))
         (do ((next-file infile (car instack)))
	   ((eq infile t))
	   (close next-file))		; close any loaded files
         (sstatus uuolinks nil)))

(defun eval-top-level-form ()			; command (ESC-^Z) to evaluate form
       (save-excursion
         (mark-defun)			; marks any form starting in column one
         (eval-lisp-region)))


(defun eval-buffer ()			; extended command to eval buffer
       (save-excursion
         (mark-whole-buffer)
         (eval-lisp-region)))

;;; 

;;;
;;;	Lisp indenter
;;;	Made winning 9/18 by archy & BSG
;;;

(register-option 'lisp-indent-fuzz 1)

(defun indent-to-lisp ()			;this one's a goody, kids!
       (go-to-beginning-of-line)
       (indent-to-lisp-1))

(defun indent-to-lisp-1 ()
       (if (charset-member (curchar) lisptable)
	 (delete-white-sides)
	 (if (not (bolp))(insert-char " "))
	 (whitespace-to-hpos
	   (save-excursion

	     (do-forever			;get to right line
	       (backward-sexp)
	       (if (not (and (bolp)(not (charset-member (curchar) lisptable))))
		 (stop-doing)))		;find non-label last sexp

	     (cond ((not (skip-back-whitespace-in-line))) ;'twas all white
		 ((back-at "(") (skip-over-whitespace)) ; (cond ((FOO.. etc
		 (t (with-mark
		      start-of-predecessor
		      (backward-list)
		      (if (mark-on-current-line-p start-of-predecessor)
			(down-list-level)
			(forward-sexp)
			(skip-lisp-whitespace-and-comments)
			else
			(down-list-level)
			(do-forever
			  (skip-lisp-whitespace-and-comments)
			  (if (and (mark-on-current-line-p start-of-predecessor)
				 (or (mark-reached start-of-predecessor)
				     (and (bolp)(at "("))
				     (not (bolp))))
			      (stop-doing))
			  (forward-sexp))))))
	     (if (and (back-at OPEN-PAREN)
		    (not (at OPEN-PAREN)))
	         (+ (cur-hpos) lisp-indent-fuzz)
	         else (cur-hpos))))
	 else
	 (forward-sexp)
	 (search-for-first-not-charset-line whitespace-charactertbl)
	 (if (not (or (eolp)(at ";")))
	     (indent-to-lisp-1))))

(defun lisp-cret-and-indent ()
       (delete-white-sides)
       (new-line)
       (insert-char " ")			;not a label
       (indent-to-lisp))

(defun lisp-indent-region ()
       (copy-region)
       (with-the-mark-last
         m
         (do-forever
	 (if (line-is-blank)(without-saving (kill-contents-of-line))
	     else
	     (go-to-beginning-of-line)	;Rule out comment lines
	     (if-at OPEN-PAREN		;Don't indent these lines.
		  else (search-for-first-not-charset-line whitespace-charactertbl)
		  (if (not (at ";"))(indent-to-lisp)))
	     (if (find-lisp-comment-start)
	         (place-lisp-comments)))
	 (if (mark-on-current-line-p m)(stop-doing))
	 (next-line)))))


(defun place-lisp-comments ()
       (cond ((looking-at ";;;")(delete-white-sides))
	   ((looking-at ";;")(indent-to-lisp))
	   (t (indent-for-comment))))

(defun lisp-indent-function ()
       (mark-defun)
       (lisp-indent-region))




;;;
;;;	BSG 5/6/80 put his favorite two fcns here..
;;;

(defcom lisp-one-more-paren
        &na (&repeat)
        (save-excursion
	(go-to-beginning-of-line)
	(skip-backwards-lisp-whitespace-comment-cruft)
	(insert-char ")"))
        (indent-to-lisp))

(defcom lisp-one-less-paren
        &na (&repeat)
        (save-excursion
	(go-to-beginning-of-line)
	(skip-backwards-lisp-whitespace-comment-cruft)
	(if-back-at ")"
		  (rubout-char)
		  else
		  (display-error "Previous s-exp doesn't end in close paren.")))
        (indent-to-lisp))


;;;
;;;   In-house LCPery, integrated 5/6/80
;;;

;;;
;;; 5/1/80 BSG
;;;

(declare (*expr runoff-fill-region compile-top-level-forms))
(declare (special elcp-@seg-name lisp-system-dir elcp-internmes elcp-spake))
(declare (special elcp-@undfuns elcp-@being-compiled))

(setq elcp-internmes
      ;;This slight inelegance has to duplicate the global list of the compiler
      ;;because by time the compiler can even be looked at, it has already
      ;;interned its own things on the wrong obarray.  This is unclean, but..
      '(cf cl pause genprefix nfunvars special fixnum flonum fixsw flosw notype arith array* closed muzzled
	unspecial reducible irreducible noargs mapex symbols lisp
	put-in-tree	;request of H. Lieberman
	expr-hash system-file compile-top-level-forms	;for GSB & BSG 5/4/80
	sobarray cobarray eoc-eval compiler-state compile maklap top-level coutput gofoo ;jonl's crocks for owl
	nocompile
	-db -debug -eval -tm -time -times -ps -pause -pause_at -mc -macros -gp -gnp
	-genprefix -nw -nowarn -tt -total -total_time -list -ls -long -lg
	-all_special -pathname -pn -p -no_compile -ncp
	-ck -check -ioc -messioc -mioc -hd -hold -pedigree -pdg -brief -bf arith
	*expr *fexpr *lexpr **array messioc check debug macros dataerrp barfp
	defpl1 update return ignore fixed bin binary float packed-pointer packed-ptr
	pointer ptr bit aligned unaligned character varying char lisp array
	l le g ge n e))

(defun elcp-load-lcp ()
       (let ((obarray (get '*VIRGIN-OBARRAY* 'array))
	   (errlist errlist))		;clever bastard
	  (makoblist 'compiler-obarray)
	  (setq obarray (get 'compiler-obarray 'array))
	  (mapc 'intern elcp-internmes)
	  (putprop (intern (copysymbol 'use nil)) 'elcp-use 'expr)
	  (putprop (intern (copysymbol 'global nil)) 'elcp-global 'expr)
	  (setq elcp-@seg-name (intern (copysymbol 'seg-name nil)))
	  (setq elcp-@undfuns (intern (copysymbol 'undfuns nil)))
	  (setq elcp-@being-compiled (intern (copysymbol 'being-compiled nil)))
	  (set (intern (copysymbol 'compiler-revision nil)) "Emacs")
	  (mapc '(lambda (x)
		       (hcs_$initiate_count lisp-system-dir x  x 0)
		       ;; lisp_cg_utility_ snaps link to x$symbol_table
		       (load (catenate lisp-system-dir ">" x)))
	        '(lcp_semant_ lcp_cg_))
	  (putprop (intern (copysymbol 'printmes nil)) 'elcp-lcp-error-printer 'expr)))


(defun elcp-use fexpr (x)
       (let ((x (getchar (car x) 1)))		; get the first char of the argument.
	  (cond ((eq x 'c) (setq obarray (get 'compiler-obarray 'array))
		         'compiler-obarray)
	        ((eq x 'w) (setq obarray (get 'obarray 'array))
		         'working-obarray)
	        ((eq x 'n) (setq obarray (get '*VIRGIN-OBARRAY* 'array))
		         (makoblist 'obarray) ; copy it
		         (setq obarray (get 'obarray 'array))
		         'new-working-obarray)
	        (t (display-error-noabort "use: argument must be c, w, or n.")))
	  nil))

(defun elcp-global fexpr (x)
       (let ((obarray (get 'obarray 'array)))
	  (mapc '(lambda (y)
		       (setq x (intern y))
		       (or (eq x y)
			 (display-error-noabort "elcp-global: obarray ""already interned"" conflict: " y)))
	        x)))

(defun cfun (fname)
       (let ((prop (getl fname '(expr fexpr macro))))
	  (or prop
	      (display-error "cfun: " fname " not a function"))
	  (elcp-compile-and-load
	    `((defprop ,fname ,(cadr prop) ,(car prop))))))

(defun elcp-compile-and-load (forms)
       (set-emacs-epilogue-handler  '(lisp-mode-clean-up-lcp-temps) t)
       (setq elcp-spake nil)
       (if (null (get 'compiler-obarray 'array))
	 (display-error-remark "Loading LCP into Emacs environment...")
	 (elcp-load-lcp)
	 (display-error-remark "Precompiling e-macros.incl.lisp...")
	 (setq loaded-e-macros t)
	 (compile-top-level-forms
	   `((declare
	       (setq eoc-eval		;idea is no obj seg.
		   '((cf ,(catenate include-dir ">e-macros.incl.lisp"))))))
	   nil))
       (let ((segname
	     (catenate "!ect" (maknam (explodec (runtime)))))
	   (fname (cond ((or (atom forms)(atom (car forms))))
		      ((cdr forms) "...")
		      ((memq (caar forms) '(defun defcom define-command defmacro defstruct))
		       (cadar forms))
		      (t "...."))))
	  (setq lisp-mode-clean-up-lcp-temps-list
	        (cons segname lisp-mode-clean-up-lcp-temps-list))
	  (display-error-remark "Compiling " fname "...")

	  (compile-top-level-forms forms (catenate "[pd]>" segname))

	  (let ((undfuns (symeval elcp-@undfuns)))
	       (setq undfuns
		   (mapcan '(lambda (x)(cond ((getl x '(subr lsubr fsubr expr fexpr))
					nil)
				         (t (list x))))
			undfuns))
	       (if undfuns
		 (elcp-lcp-error-printer undfuns " - functions referenced but not defined. " nil)
		 (set elcp-@undfuns nil)))
	  (minibuffer-print-noclear " Loading ..")
	  (loadfile (catenate process-dir ">" segname))
	  (sstatus uuolinks nil)
	  (and (symbolp fname)(killsave-string fname))
	  (minibuffer-print "Compiled."))
       (and elcp-spake (end-local-displays)))

(defun elcp-compile-top-level-form-from-buffer ()
       (let ((stuff
	     (save-excursion (mark-defun)
			 (with-the-mark-last
			   m
			   (car (errset (read-from-string
				        (point-mark-to-string m))))))))
	  (elcp-compile-and-load (list stuff))
	  (and stuff
	       (not (atom stuff))
	       (not (cdr stuff))
	       (not (atom (car stuff)))
	       (cdar stuff)
	       (memq (caar stuff)'(defun defmacro defcom define-command defstruct))
	       (putprop (caar stuff) current-buffer 'tagbuf))))

(defun elcp-lcp-error-printer (data msg error-type)
       (if (not elcp-spake)
	 (init-local-displays)
	 (setq elcp-spake t))
       (save-excursion-buffer
         (go-to-or-create-buffer 'Compiler/ Diagnostics)
         (go-to-end-of-buffer)
         (without-modifying
	 (if (not (at-beginning-of-buffer))
	     (new-line))
	 (set-the-mark)
	 (if (and (boundp elcp-@being-compiled)
		(symeval elcp-@being-compiled))
	     (if (not (at-beginning-of-buffer))
	         (new-line)
	         (set-the-mark))
	     (insert-string "*** DIAGNOSTICS FOR   ")
	     (insert-string (maknam (explodec (symeval elcp-@being-compiled))))
	     (insert-string " ***")
	     (new-line)
	     (set elcp-@being-compiled nil)
	     (elcp-filled-print-region)
	     (new-line)
	     (set-the-mark))
	 (setq error-type
	       (let ((obarray (get 'obarray 'array)))
		  (intern error-type)))
	 (insert-string (cdr (assq error-type
			       '((warn . "Warning: ")
			         (nonfatal . "Error: ")
			         (data . "Severe error: ")
			         (barf . "Compiler error: ")
			         (nil . "lisp_compiler: ")))))
	 (if data
	     (insert-string " ")
	     (insert-string
	       (let ((prinlevel 3)(prinlength 6))
		  (maknam (explode data))))
	     (new-line))
	 (insert-string " ")
	 (insert-string msg)
	 (new-line)
	 (elcp-filled-print-region))))


(defun elcp-filled-print-region ()
       (without-saving (runoff-fill-region))
       (with-mark x
	        (go-to-mark der-wahrer-mark)
	        (do-forever
		(local-display-current-line)
		(if (mark-on-current-line-p x)(stop-doing))
		(next-line)))
       (go-to-end-of-buffer))


INCLUDE FILE >spec>install>1136>executable>e-macros.incl.lisp

;;; BEGIN INCLUDE FILE e-macros.incl.lisp

;;; Declares for use by Emacs programs and extenstions.  Also loads
;;; in e_macros_, which contains macro definitions.

;;; HISTORY COMMENTS:
;;;  1) change(85-01-01,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Written: New Year's Day 1985, by excerpting the old e-macros.incl.lisp
;;;     and leaving out all the definitions and qwerty junk (don't ask).
;;;  2) change(86-02-24,Margolin), approve(86-02-24,MCR7325),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Alphabetized declarations, and added more declarations for documented
;;;     functions, and also for some undocumented functions.
;;;                                                      END HISTORY COMMENTS

(%include backquote)

(declare					;basic editor stuff
  (*expr apply-catenate
         assert-minor-mode backward-char backward-n-chars charlisten
         charset-member command-abort command-quit
         copy-region cur-hpos curline-as-string curbuf-as-string curchar
         curline-as-string delete-char delete-word destroy-buffer-contents
         dont-notice-modified-buffer e_cline_ e_lap_$reverse-search-string
         e_lap_$trim empty-buffer-p error_table_ establish-local-var
         exchange-point-and-mark firstlinep forward-char forward-n-chars
         forward-regexp-search-in-line forward-search forward-search-in-line
         get-char get-search-string go-to-beginning-of-buffer
         go-to-beginning-of-line go-to-buffer go-to-end-of-buffer
         go-to-end-of-line go-to-hpos go-to-mark go-to-or-create-buffer
         insert-char insert-string kill-backwards-to-mark kill-forward-to-mark
         kill-pop kill-to-end-of-line killsave-string lastlinep loadfile
         looking-at lowercase map-over-emacs-commands mark-on-current-line-p
         mark-reached merge-kills-forward merge-kills-reverse move-mark
         minibuf-response minibuffer-clear
         negate-minor-mode new-line next-line nullstringp pathname_
         pathname_$component point-mark-to-string
         point>markp prev-line printable process-char produce-named-mark-list
         read-in-file release-mark reverse-search
         register-local-var reverse-search-in-line
         search-back-first-charset-line
         search-back-first-not-charset-line search-failure-annunciator
         search-for-first-charset-line search-for-first-not-charset-line
         set-emacs-epilogue-handler set-buffer-self-destruct set-key
         set-mark-here set-mark set-perm-key set-the-mark set-the-mark-here
         skip-to-whitespace skip-to-whitespace-in-line
         wipe-point-mark wipe-region write-out-file
         trim-minibuf-response yesp yank)
  (*fexpr define-autoload-lib))

(declare					;redisplay stuff
  (*expr end-local-displays init-local-displays ring-tty-bell
         local-display-generator local-display-generator-nnl
         next-screen prev-screen local-display-current-line
         find-buffer-in-window select-buffer-window window-info
         select-buffer-find-window select-other-window select-window
         buffer-on-display-in-window redisplay full-redisplay))

(declare					;extended stuff
  (*expr forward-word backward-word skip-over-whitespace skip-back-whitespace
         skip-over-whitespace-in-line skip-back-whitespace-in-line
         skip-back-to-whitespace skip-to-whitespace rubout-char date
         display-buffer-as-printout delete-white-sides lefthand-char
         format-to-col whitespace-to-hpos line-is-blank decimal-rep
         register-option minibuffer-clear))

(declare (*lexpr display-error display-com-error display-error-noabort
	       display-error-remark comout-get-output
	       display-com-error-noabort minibuffer-print
	       minibuffer-response trim-minibuffer-response
	       intern-minibuffer-response minibuffer-remark
	       minibuffer-print-noclear report-error report-error-noabort))

(declare (special TAB NL SPACE ESC curpointpos current-buffer dont-stash
	        numarg der-wahrer-mark fpathname fill-column completion-list
	        curlinel BACKSPACE read-only-flag buffer-modified-flag
	        previous-buffer current-buffer-mode env-dir process-dir
	        minibuffer-end-string NLCHARSTRING undo null-pointer))

;;; Load in macro packages
(eval-when (eval compile)
  (or (status feature e-defcom)
      (progn (load (catenate (car (namelist (truename infile))) ">e_define_command_"))
	   (sstatus feature e-defcom)))
  (or (status feature e-macros)
      (load (catenate (car (namelist (truename infile))) ">e_macros_"))))

;;; END INCLUDE FILE e-macros.incl.lisp

INCLUDE FILE >ldd>include>backquote.incl.lisp

;;;
;;; backquote.incl.lisp - BSG 10/9/79
;;; Loads lisp_backquote_ into either the compiler or interpreter
;;; environment.
;;;
;;; Modified 10/30/82 by Richard Lamson to use eval-when and
;;;				   (status feature backquote)
;;;
(eval-when (eval compile)
  (or (status feature backquote)
      (load (catenate (car (namelist (truename infile))) ">lisp_backquote_"))))

			Functions Defined

Name			Offset		Offset		Name


backward-list                    764		   0		lisp-mode
backward-sexp                    447		   100		begin-defun
begin-defun                      100		   115		end-defun
cfun                             3540		   120		mark-defun
compile-function                 1354		   124		view-defun
compile-string                   1505		   127		skip-lisp-whitespace-and-comments
down-list-level                  424		   150		forward-sexp
elcp-compile-and-load            3604		   263		skip-close-parens-and-comments-and-whitespace
elcp-compile-top-level-form-from-buffer    4204		   276		forward-list
elcp-filled-print-region         4672		   424		down-list-level
elcp-global                      3470		   447		backward-sexp
elcp-lcp-error-printer           4445		   616		lisp-mode-slash-quote-sneak
elcp-load-lcp                    3142		   764		backward-list
elcp-use                         3374		   1104		skip-backwards-open-parens-comments-and-other-cruft
end-defun                        115		   1124		skip-backwards-lisp-whitespace-comment-cruft
eval-buffer                      2333		   1174		skip-backwards-possible-lisp-comment
eval-lisp-region                 2032		   1177		find-lisp-comment-start
eval-top-level-form              2274		   1276		mark-sexp
find-lisp-comment-start          1177		   1311		kill-sexp
forward-list                     276		   1343		move-defun-to-screen-top
forward-sexp                     150		   1354		compile-function
indent-to-lisp                   2372		   1505		compile-string
indent-to-lisp-1                 2375		   1764		lisp-mode-clean-up-lcp-temps
kill-sexp                        1311		   2032		eval-lisp-region
lisp-cret-and-indent             2620		   2274		eval-top-level-form
lisp-indent-function             3025		   2333		eval-buffer
lisp-indent-region               2630		   2372		indent-to-lisp
lisp-mode                        0		   2375		indent-to-lisp-1
lisp-mode-clean-up-lcp-temps     1764		   2620		lisp-cret-and-indent
lisp-mode-slash-quote-sneak      616		   2630		lisp-indent-region
lisp-one-less-paren              3072		   3003		place-lisp-comments
lisp-one-more-paren              3030		   3025		lisp-indent-function
mark-defun                       120		   3030		lisp-one-more-paren
mark-sexp                        1276		   3072		lisp-one-less-paren
move-defun-to-screen-top         1343		   3142		elcp-load-lcp
place-lisp-comments              3003		   3374		elcp-use
skip-backwards-lisp-whitespace-comment-cruft    1124		   3470		elcp-global
skip-backwards-open-parens-comments-and-other-cruft    1104		   3540		cfun
skip-backwards-possible-lisp-comment    1174		   3604		elcp-compile-and-load
skip-close-parens-and-comments-and-whitespace    263		   4204		elcp-compile-top-level-form-from-buffer
skip-lisp-whitespace-and-comments    127		   4445		elcp-lcp-error-printer
view-defun                       124		   4672		elcp-filled-print-region





			Functions Referenced

*sstatus                                find-lisp-comment-start                 mark-on-current-line-p
assq                                    firstlinep                              mark-reached
backward-char                           forward-char                            mark-whole-buffer
backward-list                           forward-list                            merge-kills-forward
backward-sexp                           forward-search                          minibuffer-print
begin-defun                             forward-search-in-line                  minibuffer-print
catenate                                forward-sexp                            minibuffer-print-noclear
catenate                                funcall                                 move-mark
charset-member                          gensym                                  new-line
close                                   get                                     next-line
comout-get-output                       getchar                                 one-back-is-a
compile-string                          getl                                    place-lisp-comments
compile-top-level-forms                 go-to-beginning-of-line                 point-mark-to-string
copy-region                             go-to-end-of-buffer                     point>markp
copysymbol                              go-to-end-of-line                       prev-line
cur-hpos                                go-to-mark                              putprop
curchar                                 go-to-or-create-buffer                  read-from-string
delete-white-sides                      hcs_$initiate_count                     redisplay-current-window-relative
delete_$path                            indent-for-comment                      release-mark
destroy-buffer-contents                 indent-to-lisp                          reverse-search
display-buffer-as-printout              indent-to-lisp-1                        rubout-char
display-error                           init-local-displays                     runoff-fill-region
display-error                           insert-char                             runtime
display-error-noabort                   insert-string                           search-charset-backwards
display-error-noabort                   intern                                  search-charset-forward
display-error-noabort                   kill-backwards-to-mark                  search-for-first-not-charset-line
display-error-remark                    kill-contents-of-line                   set-emacs-epilogue-handler
display-error-remark                    killsave-string                         set-key
down-list-level                         last                                    set-mark
elcp-compile-and-load                   lastlinep                               set-the-mark
elcp-compile-top-level-form-from-buffer  lefthand-char                           skip-back-whitespace-in-line
elcp-filled-print-region                line-is-blank                           skip-backwards-lisp-whitespace-comment-cruft
elcp-lcp-error-printer                  lisp-indent-region                      skip-backwards-open-parens-comments-and-other-cruft
elcp-load-lcp                           lisp-mode-slash-quote-sneak             skip-backwards-possible-lisp-comment
end-local-displays                      load                                    skip-close-parens-and-comments-and-whitespace
error                                   loadfile                                skip-lisp-whitespace-and-comments
establish-local-var                     local-display-current-line              skip-over-whitespace
eval                                    looking-at                              unwind-sexp-searchers-marks-and-nlgoto
eval-lisp-region                        maknam                                  view-region-as-lines
exchange-point-and-mark                 makoblist                               whitespace-to-hpos
explode                                 mark-defun                              write-out-file
explodec                                                                        


                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL
and BULL HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture 
for managing computer hardware properly and for executing programs. Many subsequent operating systems 
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by BULL HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved