e_macros_.lisp                  08/20/86  2309.2rew 08/20/86  2244.6       84483



;;; ***********************************************************
;;; *                                                         *
;;; * 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

;;; 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):
;;;     Extracted from e-macros.incl.lisp, removed all the qwerty and macro-helper
;;;     stuff, and changed it to use defmacro; I actually ended up rewriting
;;;     many macros, either for efficiency or readability.
;;;     Previous journalization from e-macros.incl.lisp:
;;;               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
;;;  2) change(85-01-27,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     removed (%include other_other),
;;;     added local push defmacro, and removed extraneous "macro" in
;;;     at-white defmacro.
;;;  3) change(86-02-24,Margolin), approve(86-02-24,MCR7325),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Fixed "protect" macro expansion to return the value of the body.
;;;                                                      END HISTORY COMMENTS

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

(%include defmacro)

(declare (macros nil))
(defmacro push (val var)			;Can't %include other_other,
	`(setq ,var (cons ,val ,var)))	;as it defines the wrong IF.
(declare (macros t))

(defmacro bolp ()
	'(= curpointpos 0))

(defmacro eolp ()
	'(= curpointpos (1- curlinel)))

(defmacro at-white-char ()
	'(get (curchar) 'whiteness))

(defmacro with-mark (mark &body forms)
	`(let ((,mark nil))
	      (unwind-protect
	        (progn (setq ,mark (set-mark))
		     . ,forms)
	        (and ,mark (release-mark ,mark)))))

(defmacro save-excursion (&body forms)
       (let ((mark (gensym)))
	  `(with-mark ,mark
		    (unwind-protect
		      (progn .,forms)
		      (go-to-mark ,mark)))))

(defmacro save-excursion-on-error (&body forms)
	(let ((mark (gensym)))
	     `(with-mark ,mark
		       (protect (progn ,.forms)
			      &failure (go-to-mark   ,mark)))))

(defmacro save-excursion-buffer (&body forms)
	(let ((buffer (gensym)))
	     `(let ((,buffer current-buffer)
		  (previous-buffer previous-buffer))
		 (unwind-protect
		   (progn . ,forms)
		   (go-to-or-create-buffer ,buffer)))))

(defmacro protect-excursion (&body forms)
	(let ((buffer (gensym))
	      (prevbuf (gensym))
	      (mark (gensym)))
	     `(with-mark ,mark
		       (let ((,buffer current-buffer)
			   (,prevbuf previous-buffer)
			   (value))
			  (protect
			    (setq value (progn . ,forms))
			    &failure
			    (go-to-or-create-buffer ,buffer)
			    (setq previous-buffer ,prevbuf)
			    (go-to-mark ,mark))
			  value))))

(defmacro do-forever (&body forms)
	`(do nil (nil) . ,forms))

(defmacro with-the-mark-last (mark &body forms)
	`(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)))))

(defmacro if-at (char &body forms)
	`(Multics-Emacs-if (at ,char) . ,forms)))

(defmacro at-white ()
	'(get (curchar) 'whiteness))

(defmacro stop-doing ()
	'(return nil))

(defmacro dispatch-on-current-char (&body forms)
	(do ((gs (gensym))
	     (clauses forms (cdr clauses))
	     (outs nil (cons s outs))
	     (s))
	    ((null clauses)
	     `(let ((,gs (curchar)))
		 (cond . ,(nreverse outs))))
	    (let ((thing (caar clauses))
		(result (cdar clauses))
		(condition))
	         (cond ((eq thing 'else)
		      (setq condition 't))
		     (t (cond ((stringp thing)
			     (setq thing `',(getchar thing 1))))
		        (setq condition `(eq ,gs ,thing))))
	         (setq s `(,condition .,result)))))

(defmacro Multics-Emacs-if (condition &rest forms)
	(do ((ifs)
	     (elses)
	     (l forms (cdr l)))
	    ((null l)
	     (cond (elses
		   `(cond (,condition .,(nreverse ifs))
			(t .,(cdr (nreverse elses)))))
		 (t `(cond (,condition .,(nreverse ifs))))))
	    (let ((form (car l)))
	         (cond ((eq form 'else)
		      (setq elses (list nil)))
		     (elses (push form elses))
		     (t (push form ifs))))))

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

(defmacro at-end-of-buffer ()
	'(and (eolp) (lastlinep)))

(defmacro at-beginning-of-buffer ()
       '(and (bolp) (firstlinep)))

(defmacro walk-through-region (&body forms)
	(let ((mark (gensym)))
	     `(with-the-mark-last
	        ,mark
	        (do ()
		  ((mark-reached ,mark))
		  . ,forms))))

(defmacro without-saving (&body forms)
	`(let ((dont-stash t))
	      dont-stash			;keep lcp from complaining
	      .,forms))

(defmacro do-times (howmany &body forms)
	(let ((dovar (gensym)))
	     `(do ,dovar ,howmany (1- ,dovar) (< ,dovar 1)
		. ,forms)))

(defmacro if-back-at (thing &body forms)
	`(Multics-Emacs-if (back-at ,thing) . ,forms))

(defmacro at (thing)
	(cond ((stringp thing)
	       (setq thing `',(getchar thing 1))))
	`(eq (curchar) ,thing))

(defmacro back-at (thing)
	(cond ((stringp thing)
	       (setq thing `',(getchar thing 1))))
	`(eq (lefthand-char) ,thing)))

(defmacro dispatch-on-lefthand-char (&body forms)
	(do ((gs (gensym))
	     (clauses forms (cdr clauses))
	     (outs nil (cons s outs))
	     (s))
	    ((null clauses)
	     `(let ((,gs (lefthand-char)))
		 (cond . ,(nreverse outs))))
	    (let ((thing (caar clauses))
		(result (cdar clauses))
		(condition))
	         (cond ((eq thing 'else)
		      (setq condition 't))
		     (t (cond ((stringp thing)
			     (setq thing `',(getchar thing 1))))
		        (setq condition `(eq ,gs ,thing))))
	         (setq s `(,condition .,result)))))

(defmacro without-modifying (&body forms)
	`(let ((read-only-flag nil)
	       (buffer-modified-flag t))
	      read-only-flag buffer-modified-flag    ;so lcp doesn't complain
	      .,forms))

(defmacro display-as-printout (&body forms)
	`(progn
	   (save-excursion-buffer
	     (go-to-or-create-buffer (gensym))
	     (putprop current-buffer t 'temporary-buffer)
	     (init-local-displays)
	     (progn . ,forms)
	     (display-buffer-as-printout))
	   (end-local-displays)))

(defmacro defvar (var-specs &optional (single-value nil value-given))
       (let ((specials nil)
	   (inits nil)
	   (nothing (ncons nil)))
	  (cond ((atom var-specs)		;(defvar <var> {<val>})
	         (setq var-specs
		     `((,var-specs ,(cond (value-given single-value)
				      (t nothing)))))))
	  (mapc '(lambda (spec)
		       (let ((v) (init))
			  (cond ((atom spec)
			         (setq v spec
				     init nothing))
			        ((null (cdr spec))
			         (setq v (car spec) init nil))
			        (t (setq v (car spec)
				       init (cadr spec))))
			  (push v specials)
			  (or (eq init nothing)
			      (push `(or (boundp ',v) (setq ,v ,init))
				  inits))))
	        var-specs)
	  (setq specials (nreverse 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
(defmacro without-line-control (&body forms)
       `(let ((read-only-flag nil) (line-control:buffer 0))
	   read-only-flag line-control:buffer	;so lcp won't complain
	   . ,forms))


;;; Macro to be more useful than unwind-protect.
;;; (protect stuff to do &success stuff &failure stuff &always stuff)
;;; 10 November 1981 Richard Mark Soley
(defmacro protect (&body forms)
	(do ((form forms (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) (push this body))
		 ((eq current 'success) (push this success))
		 ((eq current 'failure) (push this failure))
		 ('else (push this always))))))

(defun protect/ MACRO/ build (body success failure always)
       (cond ((and (null success) (null failure))
	    `(unwind-protect
	       (progn ,.body)
	       ,.always))
	   (t (let ((protect-done-variable (gensym)))
		 `(let ((,protect-done-variable nil))
		       (unwind-protect
		         (prog1 (progn .,body)
			      (setq ,protect-done-variable t))
		         (cond (,protect-done-variable . ,success)
			     (t . ,failure))
		         . ,always))))))

(sstatus feature e-macros)




		    e_internal_macros_.lisp         08/20/86  2309.2rew 08/20/86  2244.6       38223



;;; ***********************************************************
;;; *                                                         *
;;; * Copyright, (C) Honeywell Information Systems Inc., 1985 *
;;; *                                                         *
;;; ***********************************************************

;;; Macros used internally in Emacs.

;;; HISTORY COMMENTS:
;;;  1) change(85-01-05,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Created.  Mark and eline definitions taken from e_basic_.lisp, and
;;;     turned into defstructs.
;;;  2) change(86-02-24,Margolin), approve(86-02-24,MCR7325),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Added file-object, pathname, and packed-pointer structures, and
;;;     associated macros.
;;;                                                      END HISTORY COMMENTS

(%include sharpsign)
(%include defstruct)
(%include defmacro)
(declare (macros t))

;;;	The "eline" (editor-line) datatype is constructed as such:
;;;
;;;	(line-contents . (previous-line . next-line))
;;;
;;;	previous-line and next-line are other editor lines; line-contents
;;;	is either a Lisp string or a "filecons", which is constructed
;;;	as follows:
;;;
;;;	(char-ptr . linel)
;;;
;;;	char-ptr is a fixnum-encoded pointer to the starting character
;;;	of a line in a temp-seg into which e_pl1_ copied a file at read-in
;;;	time.  linel is the length of that line, including the mandatory
;;;	newline at the end.
(defstruct (eline
	   (:type tree)
	   (:conc-name))
	 (contents nil)
	 (previous nil)
	 (next nil))

;;; Some special cases
(defmacro prevline ()
	'(eline-previous curline))
(defmacro nextline ()
	'(eline-next curline))
;;; No need for the old curelevator, it was only directly referenced in
;;; one place, and that was fixed.

;;; If this format ever changes, e_lap_.lap will have to be changed.
;;; It expects a cons.
(defstruct (filecons
	   (:type tree)
	   (:conc-name))
	 pointer
	 length)

;;; The format of a mark is (eline . position)
(defstruct (mark
	   (:type tree)
	   (:conc-name))
	 eline
	 position)

;;;
;;; The Multics file interface in EMACS operates on a "file-object".  A 
;;; file-object is the following list:
;;;
;;;	(CONTENTS ABSPATH UID FCB_PTR)
;;;
;;; where:
;;;
;;;   CONTENTS
;;;	a list of fileconses (ptr .length) to the segments that
;;;	make up the file (one if it is an archive component or SSF,
;;;	multiple if it is an MSF),
;;;   ABSPATH
;;;	is the absolute pathname of the Multics file (segment),
;;;   UID
;;;	is the Multics unique-id of the file and is used by find-file,
;;;   FCB_PTR
;;;	is a pointer to the msf_manager_ file control block for the file.
;;;   DTCM
;;;	is a fixnum representing the time the file was last modified.
;;;   ORIGINAL-ACCESS
;;;	if non-nil is a pointer to a data structure used to restore
;;;	access after it was forced.

(defstruct (file-object
	   (:type list)
	   (:conc-name fobj-))
	 contents
	 path
	 uid
	 (fcb-ptr nil)
	 dtcm
	 (original-access nil))

;;; A couple of special cases for segment 0
(defmacro fobj-seg0 (file-object)
	`(first (fobj-contents ,file-object)))
(defmacro fobj-pointer (file-object)
	`(filecons-pointer (fobj-seg0 ,file-object)))
(defmacro fobj-length (file-object)
	`(filecons-length (fobj-seg0 ,file-object)))
;;; And a common combination
(defmacro fobj-abs-path (file-object)
	`(absolute-pathname (fobj-path ,file-object)))

;;; A PATHNAME consists of a directory, an entryname, and an archive component
;;; name.  If it isn't an archive component, pn-component is the null string.
;;; The expand-pathname and absolute-pathname functions in e_multics_files_
;;; translate from and to a single character string.  Absolute-pathname
;;; encaches the absolute pathname in the abs-path component, to speed up
;;; repetitive calls.

(defstruct (pathname
	   (:type list)
	   (:conc-name pn-))
	 (directory "")
	 (entry "")
	 (component "")
	 (abs-path nil))

;;; 

;;; The packed-pointer defstruct is usable for manipulating
;;; pointers expressed as a Lisp fixnum.

(defstruct (packed-pointer
	   (:type fixnum)
	   (:conc-name pptr-))
	 ((bit-offset #o3606)
	  (seg-number #o2214)
	  (word-offset #o0022)))




		    e_define_command_.lisp          08/20/86  2309.2rew 08/20/86  2249.1      248544



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

;;;
;;;
;;;       Emacs Command Definition Macro
;;;
;;;
;;; Initial coding:  August-September 1979 by GMP.
;;; Modified:	 7 May 1981 Soley to fix minor bugs.
;;; Modified:	 Fall 1981 Soley for &nobreak and &completions.
;;; Modified:	 31 March 1982 Soley for &undo-function, clean up.
;;; Modified:	 15 May 1982 by J. Spencer Love for &epilogue, &cleanup.
;;;
;;;
;;; Syntax:
;;;	  (define-command function-name
;;;		        forms)
;;;
;;;	  (defcom function-name forms)
;;;
;;; Keywords in forms:
;;;
;;; &arguments ARGS,  &args ARGS,  &a ARGS
;;;
;;; &cleanup FUNCTION
;;;
;;; &documentation STRING,  &doc STRING
;;;
;;; &epilogue SYMBOL
;;;
;;; &negative-function FUNCTION,  &nf FUNCTION
;;;
;;; &numeric-argument SPEC,  &numarg SPEC,  &na SPEC
;;;
;;; &numeric-function SYMBOL
;;;
;;; &no-break
;;;
;;; &prologue SYMBOL
;;;
;;; &undo-function SPEC,  &undo SPEC,  &inverse SPEC
;;;
;;; Terms:
;;;	ARGS is a list of argument specifications.
;;;	STRING is a character string in doublequotes.
;;;	SYMBOL is the name of a function.
;;;	FUNCTION is either a SYMBOL, or &code FORMS &end_code.
;;;	VALUE is either a CONSTANT or &eval FORM.
;;;	CONSTANT is either a STRING, a number, or a quoted FORM.
;;;	FORM is something for lisp to evaluate.
;;;
;;; Format of an argument specification:
;;;
;;; Format of &numeric-argument FORM:
;;;	&numeric-argument is followed by a keyword or by a list which
;;;	contains one or more keywords.  The keywords which may appear
;;;	after &numeric-argument are &pass, &ignore, &reject and &repeat.
;;;	The additional keywords which may appear in the list are
;;;	&lower-bound (&lb) and &upper-bound (&ub).  These two keywords
;;;	are followed by a VALUE.  &reject is the default unless bounds
;;;	are specified, in which case &pass is the default.
;;;

(declare (macros t)
         (*lexpr dc-error dc-error-argument dcev-error)
         (special encoded-values))

(%include backquote)

;;; Macro to define an Emacs command

(defprop define-command define-command/ MACRO macro)
(defprop defcom define-command/ MACRO macro)

;;; Macro to define a synonym of an Emacs command
;;; Syntax: (defcom-synonym synonym command)

(defun define-command-synonym macro (form)
       (let ((synonym (cadr form))
	   (command (caddr form)))
	  `(progn 'compile
		(defprop ,synonym ,command editor-command)
		(defprop ,synonym ,command expr))))

(defprop defcom-synonym define-command-synonym macro)

;;;
;;; Function that parses a command definition
;;;

(defun define-command/ MACRO (the-form)
       (let ((function-name (cadr the-form))       ;first arg must be name
             (the-function)
	   (prologue-function)
	   (epilogue-function)
	   (numeric-function)
             (negative-function)
	   (cleanup-function)
	   (undo-function)
	   (undo-info)
             (argument-info)
	   (numeric-arg-info)
             (documentation))

            (or (symbolp function-name)
	      (dc-error "" "Function name must be a symbol."))
	  (setq encoded-values nil)

	  (do ((form (cddr the-form) rest-of-form)
                 (current)
	       (no-break nil)
                 (rest-of-form))
                ((null form)                      ;until nothing left
                 (dc-build-result-list function-name (nreverse the-function)
			         prologue-function epilogue-function
			         numeric-function negative-function
                                       argument-info numeric-arg-info
			         documentation no-break undo-function
			         undo-info cleanup-function))

	      (setq current (car form) rest-of-form (cdr form))

                (cond

	        ;; Prologue function.
	        ((eq current '&prologue)
	         (and prologue-function
		    (dc-error-duplicate-key function-name current))
	         (let ((x (dc-parse-encoded-value function-name 0
					  rest-of-form current
					  'symbolp
					  "a function name")))
		    (setq prologue-function (cadar x)    ;want the symbol
			rest-of-form (cdr x))))

	        ;; Epilogue function.
	        ((eq current '&epilogue)
	         (and epilogue-function
		    (dc-error-duplicate-key function-name current))
	         (let ((x (dc-parse-encoded-value function-name 0
					  rest-of-form current
					  'symbolp
					  "a function name")))
		    (setq epilogue-function (cadar x)    ;want the symbol
			rest-of-form (cdr x))))

	        ;; Cleanup function.
	        ((eq current '&cleanup)
	         (and cleanup-function
		    (dc-error-duplicate-key function-name current))
	         (let ((x (dc-parse-encoded-value function-name 0
					  rest-of-form current
					  'symbolp
					  "a function name")))
		    (setq cleanup-function (cadar x)    ;want the symbol
			rest-of-form (cdr x))))

	        ;; Numeric function.
	        ((eq current '&numeric-function)
	         (and numeric-function
		    (dc-error-duplicate-key function-name current))
	         (let ((x (dc-parse-encoded-value function-name 0
					  rest-of-form current
					  'symbolp
					  "a function name")))
		    (setq numeric-function (cadar x)    ;want the symbol
			rest-of-form (cdr x))))

	        ;; Negative function.
	        ((memq current '(&negative-function &nf))
	         (and negative-function
		    (dc-error-duplicate-key function-name
				        '&negative-function))
	         (cond ((symbolp (car rest-of-form))
		      (cond ((eq (car rest-of-form) '&code)
			   (setq rest-of-form (cdr rest-of-form))
			   (do	;get the function body
			     ((nf (car rest-of-form)
				(car rest-of-form)))
			     ((or (null nf)
				(and (symbolp nf)
				     (samepnamep (substr nf 1 1)
					       "&")))
			      (and (eq nf '&end-code)
				 (setq rest-of-form
				       (cdr rest-of-form))))
			     (setq negative-function
				 (nconc negative-function 
				        (list nf))
				 rest-of-form (cdr rest-of-form))))
			  ((samepnamep (substr (car rest-of-form)
					   1 1)
				     "&")
			   (dc-error function-name
				   "Unknown keyword after "
				   "&negative-function: "
				   (car rest-of-form)))
			  (t		;function name
			    (setq negative-function
				(car rest-of-form)
				rest-of-form (cdr rest-of-form)))))
		     (t		;bad syntax
		       (dc-error function-name
			       "&negative-function must be followed "
			       "by a function name or &code."))))

	        ;; Undo function.
	        ((memq current '(&undo-function &undo &inverse))
	         (and (or undo-function undo-info)
		    (dc-error-duplicate-key function-name current))
	         (cond ((member (car rest-of-form) '(&pass (&pass)))
		      (setq undo-info '&pass
			  rest-of-form (cdr rest-of-form)))
		     ((member (car rest-of-form) '(&ignore (&ignore)))
		      (setq undo-info '&ignore
			  rest-of-form (cdr rest-of-form)))
		     ((or (eq (car rest-of-form) '&reject)
			(equal (car rest-of-form) '(&reject)))
		      (setq undo-info '&reject
			  rest-of-form (cdr rest-of-form)))
		     ((not (symbolp (car rest-of-form)))
		      (dc-error
		        function-name
		        "&undo-function must be followed "
		        "by a function name, &pass, &reject, "
		        "&ignore, or &code."))
		     ((eq (car rest-of-form) '&code)
		      (setq rest-of-form (cdr rest-of-form))
		      (do	;get the function body
		        ((nf (car rest-of-form)
			   (car rest-of-form)))
		        ((or (null nf)
			   (and (symbolp nf)
			        (samepnamep (substr nf 1 1) "&")))
		         (and (eq nf '&end-code)
			    (setq rest-of-form
				(cdr rest-of-form))))
		        (setq undo-function
			    (nconc undo-function (list nf))
			    rest-of-form (cdr rest-of-form))))
		     ((samepnamep (substr (car rest-of-form) 1 1) "&")
		      (dc-error function-name
			      "Unknown keyword after "
			      "&undo-function: "
			      (car rest-of-form)))
		     (t		;function name
		       (setq undo-function (car rest-of-form)
			   rest-of-form (cdr rest-of-form)))))

	        ;; Numeric argument.
	        ((memq current '(&numeric-argument &numarg &na))
	         (and numeric-arg-info
		    (dc-error-duplicate-key function-name
				        '&numeric-argument))
	         (setq numeric-arg-info
		     (dc-parse-numeric-arg-info function-name
					  (car rest-of-form))
		     rest-of-form (cdr rest-of-form)))

	        ;; Signal echnego that this doesn't cause a break.
	        ((eq current '&no-break) (setq no-break t))

	        ;; Arguments.
	        ((memq current '(&arguments &args &a))
	         (and argument-info
		    (dc-error-duplicate-key function-name '&arguments))
	         (setq argument-info
		     (dc-parse-arguments function-name (car rest-of-form))
		     rest-of-form (cdr rest-of-form)))

	        ;; Documentation.
	        ((memq current '(&documentation &doc))
	         (and documentation
		    (dc-error-duplicate-key function-name '&documentation))
	         (setq documentation (car rest-of-form)
		     rest-of-form (cdr rest-of-form))
	         (or (stringp documentation)
		   (dc-error function-name
			   "&documentation must be followed "
			   "by a string.")))

	        ;; Unknown.  Might be the actual function.....
	        ((and (symbolp current)
		    (samepnamep (substr current 1 1) "&"))
	         (dc-error function-name "Unrecoginzed keyword: " current))

	        ;; Yup, it's the function.
	        (t (setq the-function (cons current the-function)))))))

;;;
;;; Parse an encoded value: an encoded value is either a constant or
;;;  &eval followed by a form to evaluate at runtime
;;;

(defun dc-parse-encoded-value (function-name arg-no rest-of-form
			 qualifier-name value-typep value-name)
       (let ((type 'quote)                        ;just a value
	   (value (car rest-of-form)))
	  (cond ((eq value '&eval)
	         (let ((eval-name
		       (make_atom (catenate function-name "-$-"
				        (dc-decimal arg-no)
				        "-$-" qualifier-name)))
		     (function))
		    (or (cdr rest-of-form)	;if nothing follows it
		        (dcev-error function-name arg-no qualifier-name
				" &eval must be followed by a form "
				"or &code."))
		    (cond ((eq (cadr rest-of-form) '&code)
			 (setq rest-of-form (cddr rest-of-form))
			 (do		;construct the function
			   ((nf (car rest-of-form) (car rest-of-form)))
			   ((or (null nf)	;either nothing left
			        (and (symbolp nf)
				   (samepnamep (substr nf 1 1) "&")))
			    (and (eq nf '&end-code)
			         (setq rest-of-form (cdr rest-of-form))))
			   (setq function (nconc function (list nf))
			         rest-of-form (cdr rest-of-form))))
			((and (symbolp (cadr rest-of-form))
			      (samepnamep (substr (cadr rest-of-form)
					      1 1)
				        "&"))
			 (dcev-error function-name arg-no qualifier-name
				   " Unknown keyword following &eval: "
				   (cadr rest-of-form)))
			(t (setq function (list (cadr rest-of-form))
			         rest-of-form (cddr rest-of-form))))
		    (setq encoded-values
			`(,.encoded-values
			  (defun ,eval-name ()
			         . ,function))
			type 'eval
			value eval-name)))	;get name in right place
	        (t                              ;simple value, check type
		(or (funcall value-typep value)
		    (dcev-error function-name arg-no qualifier-name
			      " must be followed by " value-name
			      " or &eval."))
		(setq rest-of-form (cdr rest-of-form))))
	  (cons (list type value) rest-of-form)))

;;;
;;; Parse specifications for handling of numeric argument by this command.
;;;

(defun dc-parse-numeric-arg-info (function-name the-form)
       (do ((form the-form rest-of-form)
            (processing-type)
            (lower) (upper)
            (phrase) (rest-of-form))
           ((null form)			;until all parsed
            (and (eq processing-type '&ignore)	;ignore the argument
                 (or lower upper)
	       (dc-error function-name
		       "&ignore may not be used with other "
		       "&numeric-argument qualifiers."))
	  (and (eq processing-type '&reject)	;reject numeric arguments
                 (or lower upper)
	       (dc-error function-name
                           "&reject may not be used with other "
		       "&numeric-argument qualifiers."))
	  (and lower (eq (car lower) 'quote)
	       upper (eq (car upper) 'quote)
	       (< (cadr upper) (cadr lower))    ;invalid range
	       (dc-error function-name
		       "Invalid numeric argument range "
		       (dc-decimal (cadr lower))
		       ":" (dc-decimal (cadr upper))))
	  (and (null processing-type)
	       (or lower upper)
	       (setq processing-type '&pass))
	  (cons (or processing-type '&reject)	;supply default if needed
	        (and (or lower upper) (cons lower upper))))
	 ;;
	 ;; Find next token to be digested.
	 ;;
	 (cond ((not (atom form))
	        (setq phrase (car form)
		      rest-of-form (cdr form)))
	       ((not (eq form the-form))
	        (dc-error function-name
		        "Malformed list following &numeric-argument."))
	       (t (setq phrase form
		    rest-of-form nil)))
	 ;;
	 ;; Analyze token.
	 ;;
	 (cond ((memq phrase '(&pass &repeat &ignore &reject))
                  (and processing-type
                       (dc-error function-name
			   "Only one of &pass, &repeat, &ignore, or "
			   "&reject may appear after "
			   "&numeric-argument."))
	        (setq processing-type phrase))
	       ((memq phrase '(&lower-bound &lb))
	        (and lower
		   (dc-error function-name
			   "The key &lower-bound may only appear once "
			   "after &numeric-argument."))
	        (let ((x (dc-parse-encoded-value function-name 0 rest-of-form
					 '&lower-bound 'fixp 
					 "an integer")))
		   (setq lower (car x) rest-of-form (cdr x))))
	       ((memq phrase '(&upper-bound &ub))
	        (and upper
		   (dc-error function-name
			   "The key &upper-bound may only appear once "
			   "after &numeric-argument."))
	        (let ((x (dc-parse-encoded-value function-name 0 rest-of-form
					 '&upper-bound 'fixp
					 "an integer")))
		   (setq upper (car x) rest-of-form (cdr x))))
	       (t (dc-error function-name
			"Unrecognized keyword following "
			"&numeric-argument: " phrase)))))

;;;
;;; Parse the list of argument specifications.
;;;

(defun dc-parse-arguments (function-name the-form)
       (do ((form the-form (cdr form))
            (argument-list)
            (arg-no 1 (1+ arg-no)))               ;for error messages
           ((null form)			;done when out of forms
	  (nreverse argument-list))
           (let ((phrase (car form)))
                (let ((x (dcpa-single-argument function-name
				       (null (cdr form))
				       arg-no phrase)))
		 (setq argument-list (cons x argument-list))))))

;;;
;;; Parse a single argument specification.
;;;

(defun dcpa-single-argument (function-name last-argp arg-no specification)
       (let ((name)                               ;argument symbol
             (data-type)                          ;datatype of argument
             (default-value)                      ;default value
             (prompt-info)                        ;prompt string and terminator
             (range-info)                         ;range for integers
	   (completion-info)		;for completer command
             (validation-info))                   ;acceptable values of symbols
            (cond ((symbolp specification)        ;simple case
	         (setq name specification))
                  (t                              ;more complex
                    (setq name (car specification))
                    (or (symbolp name)
		    (dc-error-argument function-name arg-no
				   "No name specified."))
		(do ((qualifiers (cdr specification) rest-of-qualifiers)
		     (current) (rest-of-qualifiers))
		    ((null qualifiers))       ;until nothing left
		    (setq current (car qualifiers)
			rest-of-qualifiers (cdr qualifiers))
		    (cond
		      ((or (not (symbolp current))
			 (not (samepnamep (substr current 1 1) "&")))
		       (dc-error-argument function-name arg-no
				      "An & construct was expected, "
				      "but not found.")))
		    (cond
		      ((memq current '(&rest-as-string &rest-as-list))
		       (and (or data-type prompt-info default-value
			      range-info completion-info validation-info
			      rest-of-qualifiers)
			  (dc-error-argument
			    function-name arg-no current
			    " may not appear with any other argument "
			    "qualifiers."))
		       (or last-argp
			 (dc-error-argument function-name arg-no
					"The argument with "
					current " must be last."))
		       (setq data-type current))
		      ((memq current '(&completions &completion &comp))
		       (and completion-info
			  (dc-error-argument-duplicate-key
			    function-name arg-no '&completions))
		       (setq completion-info (car rest-of-qualifiers)
			   rest-of-qualifiers (cdr rest-of-qualifiers)))
		      ((memq current '(&string &symbol &integer))
		       (and data-type
			  (dc-error-argument
			    function-name arg-no
			    "Only one of &string, &symbol, and "
			    "&integer may be used."))
		       (setq data-type current))
		      ((eq current '&prompt)   ;prompt string
		       (and prompt-info
			  (dc-error-argument-duplicate-key
			    function-name arg-no '&prompt))
		       (let ((x (dcpa-parse-prompt function-name arg-no
					     rest-of-qualifiers)))
			  (setq prompt-info (car x)
			        rest-of-qualifiers (cdr x))))
		      ((eq current '&default)  ;default value
		       (and default-value
			  (dc-error-argument-duplicate-key
			    function-name arg-no '&default))
		       (let ((x (dc-parse-encoded-value
			        function-name arg-no rest-of-qualifiers
			        '&default 'atom "a value")))
			  (setq default-value (car x)
			        rest-of-qualifiers (cdr x))))
		      (t
		        (dc-error-argument function-name arg-no
				       "Unrecognized keyword: "
				       current))))))

	  ;; Perform consistency checks and construct value
	  (or data-type (setq data-type '&string))
	  (and validation-info (not (eq data-type '&symbol))
	       (dc-error-argument function-name arg-no
                                    "&valid may only be specified for "
			      "&symbol arguments."))
	  (and range-info (not (eq data-type '&integer))
	       (dc-error-argument function-name arg-no
			      "Numeric ranges may only be specified "
			      "for &integer arguments."))
	  (or prompt-info default-value
	      (setq prompt-info (cons (list 'quote (catenate name ": "))
				(ascii 012)))) ;end with newline
	  (cons name
	        (list
		(boole 7                  ;fixnum describing argument
		       (cond
		         ((eq data-type '&string) 0)
		         ((eq data-type '&symbol) (lsh 100000 18.))
		         ((eq data-type '&integer) (lsh 200000 18.))
		         ((eq data-type '&rest-as-string) (lsh 300000 18.))
		         ((eq data-type '&rest-as-list) (lsh 400000 18.))
		         (t (lsh 700000 18.)))
		       (cond (prompt-info (lsh 040000 18.))   ;have prompt
			   (t 0))
		       (cond (default-value (lsh 020000 18.)) (t 0))
		       (cond ((or range-info validation-info)
			    (lsh 010000 18.))
			   (t 0)))
		prompt-info
		default-value
		(cond ((eq data-type '&integer) range-info)
		      (t validation-info))
		completion-info))))

;;;
;;; Parse prompt specification
;;;

(defun dcpa-parse-prompt (function-name arg-no rest-of-qualifiers)
       (let ((x (dc-parse-encoded-value function-name arg-no rest-of-qualifiers
                                        '&prompt 'stringp "a string")))
            (let ((string (car x))
                  (rest (cdr x))
                  (term))
                 (setq term (car rest))           ;get possible terminator
                 (cond ((and term                 ;there's something
                             (symbolp term)
                             (not (samepnamep (substr term 1 1) "&")))
                        (cond ((memq term '(NL ESC))
                               (setq term (cond ((eq term 'NL) (ascii 012))
                                                (t (ascii 033)))
                                     rest (cdr rest)))
                              (t
                                (dc-error-argument function-name arg-no
					 "Prompt terminator must "
					 "be NL or ESC."))))
		   (t (setq term (ascii 012))))
                 (cons (cons string term)
                       rest))))

;;; Create result of define-command macro
(defun dc-build-result-list (function-name the-function prologue-function
		         epilogue-function numeric-function
		         negative-function argument-info numeric-arg-info
		         documentation no-break undo-function undo-info
		         cleanup-function)
       ;;
       ;; Check numeric function conflicts.
       ;;
       (and numeric-function negative-function
	  (dc-error-conflict function-name "&numeric-function"
			 "&negative-function"))
       (and numeric-function numeric-arg-info
	  (dc-error-conflict function-name "&numeric-function"
			 "&numeric-argument"))
       (and numeric-function
	  (setq numeric-arg-info '(&pass)))
       ;;
       ;; Check for negative function conflicts.
       ;;
       (and negative-function
	  (null numeric-arg-info)
	  (dc-error-required function-name "&negative-function"
			 "&numeric-argument"))
       (and negative-function
            (eq (car numeric-arg-info) '&ignore)	;But ignore argument!
	  (dc-error-conflict function-name "&negative-function"
			 "&numeric-argument (&ignore)"))
       (and negative-function
	  (eq (car numeric-arg-info) '&reject)	;But reject argument!
            (dc-error-conflict function-name "&negative-function"
			 "&numeric-argument (&reject)"))
       ;;
       ;; Default numeric argument handling.
       ;;
       (or numeric-arg-info (setq numeric-arg-info '(&reject)))
       ;;
       ;; Construct flag word for execute-new-command.
       ;;
       (let ((result ())
	   (editor-command-value
               (boole 7			;Logical OR.
		  (cond (argument-info
			(boole 7		;Logical OR.
			       (lsh 400000 18.)
			       (boole 1 (length argument-info) 777777)))
		        (t 0))                ;No arguments.
		  (cond (negative-function (lsh 200000 18.)) (t 0))
		  (cond ((cdr numeric-arg-info) (lsh 100000 18.)) (t 0))
		  (let ((type (car numeric-arg-info)))
		       (cond ((eq type '&pass) 0)
			   ((eq type '&repeat) (lsh 010000 18.))
			   ((eq type '&ignore) (lsh 020000 18.))
			   ((eq type '&reject) (lsh 030000 18.))
			   (t               ;Unknown type.
			     (lsh 070000 18.))))
		  (cond (prologue-function (lsh 004000 18.)) (t 0))
		  (cond (epilogue-function (lsh 002000 18.)) (t 0))
		  (cond (numeric-function (lsh 001000 18.)) (t 0))
		  (cond (undo-function (lsh 000400 18.)) (t 0))
		  (cond ((eq undo-info '&pass) (lsh 000200 18.)) (t 0))
		  (cond ((eq undo-info '&ignore) (lsh 000100 18.))
		        (t 0))
		  (cond (cleanup-function (lsh 000040 18.)) (t 0)))))
	  ;;
	  ;; Build output structure.
	  ;;
	  (setq result
	        `((putprop ',function-name ,editor-command-value
		         'editor-command)
		. ,result))

	  (and no-break
	       (setq result
		   `((setq nobreak-functions
			 (cons ',function-name nobreak-functions))
		     . ,result)))

	  (setq result
	        `((defun ,function-name
		       ,(mapcar '(lambda (x) (car x)) argument-info)
		       . ,the-function)
		. ,result))

	  (and prologue-function
	       (setq result
		   `((putprop ',function-name ',prologue-function
			    'ed-prologue-function)
		     . ,result)))

	  (and epilogue-function
	       (setq result
		   `((putprop ',function-name ',epilogue-function
			    'ed-epilogue-function)
		     . ,result)))

	  (and cleanup-function
	       (setq result
		   `((putprop ',function-name ',cleanup-function
			    'ed-cleanup-function)
		     . ,result)))

	  (and numeric-function
	       (setq result
		   `((putprop ',function-name ',numeric-function
			    'ed-numeric-function)
		     . ,result)))

	  (and negative-function
	       (cond ((symbolp negative-function)
		    (setq result
			`((putprop ',function-name ',negative-function
				 'ed-negative-function)
			  . ,result)))
		   (t (let ((nf-name
			    (make_atom
			      (catenate function-name
				      "-$-negative-function"))))
			 (setq result
			       `((defun ,nf-name
				      ,(mapcar '(lambda (x) (car x))
					    argument-info)
				      . ,negative-function)
			         (putprop ',function-name
				        ',nf-name
				        'ed-negative-function)
			         . ,result))))))

	  (and undo-function
	       (cond ((symbolp undo-function)
		    (setq result
			`((putprop ',function-name ',undo-function
				 'ed-undo-function)
			  . ,result)))
		   (t (let ((un-name
			    (make_atom
			      (catenate function-name
				      "-$-undo-function"))))
			 (setq result
			       `((defun ,un-name
				      ,(mapcar '(lambda (x) (car x))
					    argument-info)
				      . ,undo-function)
			         (putprop ',function-name
				        ',un-name
				        'ed-undo-function)
			         . ,result))))))

	  (let ((range (cdr numeric-arg-info)))
	       (and range
		  (setq result
		        `((putprop ',function-name ',range
			         'ed-numeric-range)
			. ,result))))

	  (and argument-info
                 (setq result
		   `((putprop ',function-name
			    ',(mapcar '(lambda (x) (cdr x))
				    argument-info)
			    'ed-argument-list)
		     . ,result)))

	  (and encoded-values
	       (setq result (nconc result encoded-values)))

            (and documentation
	       (setq result
		   `((putprop ',function-name ,documentation
			    'documentation)
		     . ,result)))

	  `(progn 'compile . ,result)))

;;; Error reporting functions

(defun dc-error n
       (cond ((= (stringlength (arg 1)) 0)
              (error
	      (apply
	        'catenate
	        (cons "define-command: " (listify (- 1 n))))))
	   (t (error
	        (apply
		'catenate
		(cons (catenate
		        "define-command: In definition of " (arg 1) ". ")
		      (mapcar 'dc-decimal (listify (- 1 n)))))))))

(defun dc-error-duplicate-key (function-name key-name)
       (dc-error function-name
                 "The key " key-name " may only appear once."))


(defun dc-error-conflict (function-name key-1 key-2)
       (dc-error function-name
	       "The keys " key-1 " and " key-2 " are mutually exclusive."))


(defun dc-error-required (function-name given-key missing-key)
       (dc-error function-name
	       "Use of the key " given-key " requires that the key "
	       missing-key " also be specified."))


(defun dc-error-argument n
       (error (apply 'catenate
                     (cons (catenate
		         "define-command: In definition of argument #"
		         (dc-decimal (arg 2)) " of " (arg 1) ". ")
		       (listify (- 2 n))))))


(defun dc-error-argument-duplicate-key (function-name arg-no key-name)
       (dc-error-argument function-name arg-no
                          "The key " key-name " may only appear once."))


(defun dcev-error n
       (cond ((= (arg 2) 0) (apply 'dc-error (listify n)))
             (t (apply 'dc-error-argument (listify n)))))


(defun dc-decimal (x)
       (let ((base 10.) (ibase 10.) (*nopoint t))
	  (maknam (exploden x))))




		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

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


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