LISTING FOR  >spec>on>11/30/82>e-macros.incl
COMPILED BY Multics LISP Compiler, Version hc9.2, June 5, 1981
ON 11/30/82  1528.5 mst Tue
IN BEHALF OF Holmstedt.SysMaint.a



;;; ***********************************************************
;;; *                                                         *
;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
;;; *                                                         *
;;; * Copyright (c) 1978 by Massachusetts Institute of        *
;;; * Technology and Honeywell Information Systems, Inc.      *
;;; *                                                         *
;;; ***********************************************************
;;;
;;;
;;;	Macros for Programming in EMACS Environment
;;;
;;; Written by BSG.
;;; Added without-line-control, cleaned up a bit. 25 June 1981 RMSoley
;;; Added protect, save-excursion-on-error 10 November 1981 RMSoley
;;;


;;; Added by BSG 5/8/80.
;;; This attempts to punt loading the interpreted version of e-macros
;;; (what you are reading) and load in the pre-compiled, if such
;;; exists.

(eval-when (compile eval)
	 (let ((objnamelist
	         (reverse (cdr (reverse (namelist (truename infile)))))))
	      (cond ((and (equal (cdr objnamelist) '(e-macros incl))
		        (or instack (status feature Emacs))
		        (allfiles objnamelist))
		   ;; Load in pre-compiled e-macros.lisp
		   (load objnamelist)
		   ;; Force lisp to stop reading this file (simulate EOF).
		   (filepos infile 'eof)))))

;;; Added by BSG 4/28/80: Include backquote in compilation.
(%include backquote)

;;; The hair of a thousand self-shaving barbers 5/10/80
;;; If conditions are ripe,  compile this file into an object segment.

(defun e-macros-self-compile-qwerty macro (x)
	 (cond ((and (equal (cdr (namelist infile)) '(e-macros incl lisp))
		   (null instack))		;yes
	        (do x (read)(read)(equal x ''end-self-compile)(eval x))
	        (do x (read) (read) nil (e-macros-self-compile-1 x)
		  (tyipeek t)
		  (and (= (tyipeek) 3)(return nil)))
	        `(progn `compile . ,(nreverse e-macros-self-compile-list)))
	       (t (do x (read)(read)(equal x ''end-self-compile)) nil)))

(e-macros-self-compile-qwerty)

(setq e-macros-self-compile-list
      '((load (catenate (car (namelist (truename infile)))
		    ">lisp_backquote_"))))

(defun e-macros-self-compile-output (x)
       (setq e-macros-self-compile-list (cons x e-macros-self-compile-list)))

(defun e-macros-self-compile-1 (x)
       (cond ((atom x) nil)
	   ((eq (car x) 'declare)
	    (e-macros-self-compile-output
	      `(and (status feature compiler)
		  (progn . ,(cdr x)))))
	   ((eq (car x) 'eval-when)
	    (cond ((memq 'compile (cadr x))
		 (e-macros-self-compile-1
		   (cons
		     (cond ((memq 'eval (cadr x)) 'progn)    ;10/22/80
			 (t 'declare))
		     (cddr x))))))
	   ((eq (car x) 'defun)
	    (cond ((eq (caddr x) 'macro)
		 (let ((mname (cadr x))
		       (var (car (cadddr x)))
		       (body (cddddr x)))
		      (let ((xmname (make_atom (catenate mname " MACRO"))))
			 (e-macros-self-compile-output
			   `(defun ,xmname (,var)
				 (setq ,var ,var) .,body))
			 (e-macros-self-compile-output
			   `(putprop ',mname ',xmname 'macro)))))
		((eq (caddr x) 'macro-helper)  ; 10 November 1981
		 (let ((mname (cadr x))
		       (var (cadddr x))
		       (body (cddddr x)))
		      (e-macros-self-compile-output
		        `(defun ,mname ,var .,body))))
		(t (error "Don't know how to compile fcn def: "
			x 'fail-act))))
	   (t (e-macros-self-compile-output x))))

'end-self-compile

(declare					;basic editor stuff
  (*expr apply-catenate charlisten
         assert-minor-mode backward-char charset-member command-abort
         command-quit
         copy-region cur-hpos curline-as-string curbuf-as-string curchar
         curline-as-string delete-char e_lap_$trim establish-local-var
         dont-notice-modified-buffer destroy-buffer-contents empty-buffer-p 
         e_cline_ exchange-point-and-mark firstlinep forward-char
         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-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 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 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 set-emacs-epilogue-handler
         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-mark-here set-buffer-self-destruct set-key
         set-perm-key set-mark set-the-mark
         skip-to-whitespace skip-to-whitespace-in-line
         wipe-point-mark wipe-region
         trim-minibuf-response yesp write-out-file 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-print-noclear report-error report-error-noabort))

(declare (or (and (get 'unwind-protect 'fsubr)(get 'eval-when 'fsubr))
	   (error "This version of the Lisp Compiler does not support this version of e-macros.incl.lisp")))

(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))

(eval-when (eval compile)
(load (catenate (car (namelist (truename infile))) ">e_define_command_")))

(defun bolp macro (x)
       '(= curpointpos 0))

(defun eolp macro (x)
       '(= curpointpos (1- curlinel)))

(defun at-white-char macro (x)
       '(get (curchar) 'whiteness))


(defun with-mark macro (x)
       (let ((forms (cddr x))
	   (mark (cadr x)))
	  `((lambda (,mark)
		  (unwind-protect
		    (progn (setq ,mark (set-mark)) . ,forms)
			   (release-mark ,mark)))
		   nil))))

(defun save-excursion macro (x)
       (let ((forms (cdr x))
	   (mark (gensym)))
	  `((lambda (,mark)
		  (unwind-protect
		    (progn (setq ,mark (set-mark)) . ,forms)
		    (go-to-mark ,mark)
		    (release-mark ,mark)))
	    nil)))

(defun save-excursion-on-error macro (form)
       (let ((forms (cdr form))
	   (mark (gensym)))
	  `(let ((,mark (set-mark)))
	        (protect ,.forms
		       &failure (go-to-mark   ,mark)
		       &always  (release-mark ,mark)))))

(defun save-excursion-buffer macro (x)
       (let ((forms (cdr x))
	   (buffer (gensym))
	   (prevbuf (gensym)))
	  `((lambda (,buffer ,prevbuf)
		  (unwind-protect
		    (progn . ,forms)
		    (go-to-or-create-buffer ,buffer)
		    (setq previous-buffer ,prevbuf)))
	    current-buffer previous-buffer)))

(defun protect-excursion macro (x)
       (let ((forms (cdr x))
	   (buffer (gensym))
	   (done (gensym))
	   (mark (gensym)))
	  `(let ((,buffer current-buffer)
	         (,mark)
	         (,done))
	        (unwind-protect
		(prog2
		  (setq ,mark (set-mark))
		  (progn . ,forms)
		  (setq ,done t))
		(or ,done (progn (go-to-or-create-buffer ,buffer)
			       (and ,mark (go-to-mark ,mark))))
		(release-mark ,mark)))))

(defun  do-forever macro (x)
        `(do nil (nil) . ,(cdr x)))

(defun with-the-mark-last macro (x)
       (let ((forms (cddr x))
	   (mark (cadr x)))
	   `(and (or der-wahrer-mark
		   (display-error "There is no true mark."))
	         (save-excursion
		 (with-mark ,mark
			  (cond ((point>markp der-wahrer-mark)
			         (go-to-mark der-wahrer-mark))
			        (t (move-mark ,mark der-wahrer-mark)))
			  (progn . ,forms))))))))))

(defun if-at macro (x)
       (let ((forms (cddr x))
	   (char  (cond ((stringp (cadr x))
		       (list 'quote (getchar (cadr x) 1)))
		      (t (cadr x)))))
	  `(Multics-Emacs-if (eq (curchar) ,char) . ,forms)))

(defun at-white macro (x)
       '(get (curchar) 'whiteness))

(defun stop-doing macro (x)
       '(return nil))

(defun dispatch-on-current-char macro (x)
       (do ((gs (gensym))
	  (clauses (cdr x) (cdr clauses))
	  (outs nil (cons s outs))
	  (s))
	 ((null clauses)
	  `((lambda (,gs)(cond . ,(nreverse outs)))
	    (curchar)))
	 (setq s (cons (cond ((eq (caar clauses) 'else) 't)
			 ((stringp (caar clauses))
			  `(eq ,gs ',(getchar (caar clauses) 1)))
			 (t (list 'eq gs (caar clauses))))
		     (cdar clauses)))))

(defun Multics-Emacs-if macro (x)
       (do ((ifs)
	  (elses)
	  (l (cddr x) (cdr l)))
	 ((null l)
	  (cond (elses (list 'cond (cons (cadr x) (nreverse ifs))
			 (cons 't (cdr (nreverse elses)))))
	        (t (list 'cond (cons (cadr x) (nreverse ifs))))))
	 (cond ((eq (car l) 'else)(setq elses (list nil)))
	       (elses (setq elses (cons (car l) elses)))
	       (t (setq ifs (cons (car l) ifs))))))

;;; See Bawden "if" treaty of 5/9/80 -BSG
(or (getl 'if '(macro expr subr))
    (putprop 'if (or (get 'Multics-Emacs-if 'macro)
		 (get 'Multics-Emacs-if/ MACRO 'expr)
		 'Multics-Emacs-if/ MACRO)
	   'macro))

(defun at-end-of-buffer macro (x)
       '(and (eolp)(lastlinep)))

(defun at-beginning-of-buffer macro (x)
       '(and (bolp)(firstlinep)))

(defun walk-through-region macro (x)
       (let ((forms (cdr x))
	   (mark (gensym)))
	  `(with-the-mark-last
	     ,mark
	     (do-forever
	       (and (mark-reached ,mark)(return nil))
	       . ,forms))))

(defun without-saving macro (x)
       `(let ((dont-stash t)) .,(cdr x)))

(defun do-times macro (x)
       (let ((forms (cddr x))
	   (howmany (cadr x))
	   (dovar (gensym)))
	  `(do ,dovar ,howmany (1- ,dovar)(= 0 ,dovar) . ,forms)))

(defun if-back-at macro (x)
       (let ((forms (cddr x))
	   (thing  (cond ((stringp (cadr x))
		        (list 'quote (getchar (cadr x) 1)))
		       (t (cadr x)))))
	  `(Multics-Emacs-if (eq (lefthand-char) ,thing) . ,forms)))

(defun at macro (x)
       (let ((thing  (cond ((stringp (cadr x))
		        (list 'quote (getchar (cadr x) 1)))
		       (t (cadr x)))))
	  `(eq (curchar) ,thing)))

(defun back-at macro (x)
       (let ((thing  (cond ((stringp (cadr x))
		        (list 'quote (getchar (cadr x) 1)))
		       (t (cadr x)))))
	  `(eq (lefthand-char) ,thing)))

(defun dispatch-on-lefthand-char macro (x)
       (do ((gs (gensym))
	  (clauses (cdr x) (cdr clauses))
	  (outs nil (cons s outs))
	  (s))
	 ((null clauses)
	  `(let ((,gs (lefthand-char)))
	        (cond . ,(nreverse outs))))
	 (setq s (cons (cond ((eq (caar clauses) 'else) 't)
			 ((stringp (caar clauses))
			  `(eq ,gs ',(getchar (caar clauses) 1)))
			 (t (list 'eq gs (caar clauses))))
		     (cdar clauses)))))

(defun without-modifying macro (x)
       `((lambda (read-only-flag buffer-modified-flag) . ,(cdr x)) nil t)))

(defun display-as-printout macro (x)
       `(progn
	(save-excursion-buffer
	  (go-to-or-create-buffer (gensym))
	  (putprop current-buffer t 'temporary-buffer)
	  (init-local-displays)
	  (progn . ,(cdr x))
	  (display-buffer-as-printout))
	(end-local-displays)))


(defun defvar macro (f)
       (let ((specials nil)
	   (inits nil)
	   (nothing (ncons nil)))
	  (cond ((atom (cadr f))
	         (setq f
		     `(defvar ((,(cadr f) ,(cond ((null (cddr f)) nothing)
					   (t (caddr f)))))))))
	  (mapc '(lambda (x)
		       (let ((v)(init nothing))
			  (cond ((atom x)(setq v x))
			        ((null (cdr x))
			         (setq v (car x) init nil))
			        (t (setq v (car x) init (cadr x))))
			  (setq specials (cons v specials))
			  (or (eq init nothing)
			      (setq inits
				  (cons
				    `(or (boundp ',v)(setq ,v ,init))
				    inits)))))
	        (cadr f))
	  (setq specials (reverse specials))
	  (cond ((null inits) `(declare (special . ,specials)))
	        (t 
		`(progn 'compile
		        (declare (special .,specials))
		        . ,(reverse inits))))))

;;; Macro to invisibly (and temporarily) turn off line control
;;; 25 June 1981 Richard Mark Soley
(defun without-line-control macro (x)
       `(let ((read-only-flag nil) (line-control:buffer 0))
	   . ,(cdr x)))


;;; Macro to be more useful than unwind-protect.
;;; (protect stuff to do &success stuff &failure stuff &always stuff)
;;; 10 November 1981 Richard Mark Soley
(defun protect macro (form)
       (do ((form (cdr form) (cdr form))
	  (body ())
	  (success ())
	  (failure ())
	  (always ())
	  (current 'body))
	 ((null form)
	  (protect/ MACRO/ build
	    (nreverse body) (nreverse success) (nreverse failure)
	    (nreverse always)))
	 (let ((this (car form)))
	      (cond
	        ((eq this '&success) (setq current 'success))
	        ((eq this '&failure) (setq current 'failure))
	        ((eq this '&always ) (setq current 'always))
	        ((eq current 'body) (setq body (cons this body)))
	        ((eq current 'success) (setq success (cons this success)))
	        ((eq current 'failure) (setq failure (cons this failure)))
	        ('else (setq always (cons this always)))))))

(defun protect/ MACRO/ build macro-helper (body success failure always)
       `(let ((&protect-done-variable nil))
	   (unwind-protect
	     (progn ,.body (setq &protect-done-variable t))
	     (cond (&protect-done-variable . ,success)
		 (t . ,failure))
	     . ,always)))

INCLUDE FILE >ldd>include>backquote.incl.lisp

;;;
;;; backquote.incl.lisp - BSG 10/9/79
;;; Loads lisp_backquote_ into either the compiler or interpreter
;;; environment.
;;;
(declare (eval (read)))
(load (catenate (car (namelist (truename infile))) ">lisp_backquote_"))

			Functions Defined

Name			Offset		Offset		Name


Multics-Emacs-if MACRO           1176		   0		bolp MACRO
at MACRO                         1602		   5		eolp MACRO
at-beginning-of-buffer MACRO     1337		   12		at-white-char MACRO
at-end-of-buffer MACRO           1332		   17		with-mark MACRO
at-white MACRO                   1016		   113		save-excursion MACRO
at-white-char MACRO              12		   217		save-excursion-on-error MACRO
back-at MACRO                    1650		   315		save-excursion-buffer MACRO
bolp MACRO                       0		   413		protect-excursion MACRO
defvar MACRO                     2155		   611		do-forever MACRO
dispatch-on-current-char MACRO    1030		   633		with-the-mark-last MACRO
dispatch-on-lefthand-char MACRO    1716		   733		if-at MACRO
display-as-printout MACRO        2111		   1016		at-white MACRO
do-forever MACRO                 611		   1023		stop-doing MACRO
do-times MACRO                   1440		   1030		dispatch-on-current-char MACRO
eolp MACRO                       5		   1176		Multics-Emacs-if MACRO
if-at MACRO                      733		   1332		at-end-of-buffer MACRO
if-back-at MACRO                 1520		   1337		at-beginning-of-buffer MACRO
protect MACRO                    2445		   1344		walk-through-region MACRO
protect MACRO build              2577		   1420		without-saving MACRO
protect-excursion MACRO          413		   1440		do-times MACRO
save-excursion MACRO             113		   1520		if-back-at MACRO
save-excursion-buffer MACRO      315		   1602		at MACRO
save-excursion-on-error MACRO    217		   1650		back-at MACRO
stop-doing MACRO                 1023		   1716		dispatch-on-lefthand-char MACRO
walk-through-region MACRO        1344		   2064		without-modifying MACRO
with-mark MACRO                  17		   2111		display-as-printout MACRO
with-the-mark-last MACRO         633		   2155		defvar MACRO
without-line-control MACRO       2425		   2425		without-line-control MACRO
without-modifying MACRO          2064		   2445		protect MACRO
without-saving MACRO             1420		   2577		protect MACRO build





			Functions Referenced

gensym                                  nconc                                   protect MACRO build
getchar                                 nreverse                                reverse


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


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