



		    PNOTICE_emacs.alm               11/14/89  1109.5r w 11/14/89  1109.4        3555



	dec	1			"version 1 structure
	dec	2			"no. of pnotices
	dec	3			"no. of STIs
	dec	156			"lgth of all pnotices + no. of pnotices
          acc       "Copyright, (C) Honeywell Information Systems Inc., 1989"
          acc       "Copyright (c) 1989 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"C1EMCM0E0000"
	aci	"C2EMCM0E0000"
	aci	"C3EMCM0E0000"
	end




		    e_argument_parse_.pl1           08/01/88  1002.5r w 08/01/88  0953.2       97785



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

e_argument_parse_: procedure (P_arglist, P_name, P_code);

/* Modified: 25 November 1983 by B. Margolin to add -shared_static */
/* Modified: 2 November 1984 by B. Margolinto add -force/-no_force */

/* Parameters */
dcl  P_arglist pointer parameter;
dcl  P_code fixed bin (35);
dcl  P_name character (*) parameter;
dcl  P_type fixed bin parameter;

/* System Entries */
dcl  com_err_ entry() options(variable);
dcl  cu_$arg_count_rel entry (fixed bin, ptr, fixed bin(35));
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr);
dcl  cv_dec_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35));
dcl  get_system_free_area_ entry() returns(ptr);

/* Based */
dcl  arg character (al) based (ap);
dcl  area area based (area_ptr);

/* Automatic */
dcl  al fixed bin (21);
dcl  ap pointer;
dcl  area_ptr pointer;
dcl  code fixed bin (35);
dcl  idx fixed bin;
dcl  nargs fixed bin;
dcl  temp_path character (168);
dcl  temp_ptr pointer;
dcl  temp_type fixed bin;

/* External */
dcl  error_table_$badopt fixed bin(35) ext static;
dcl  error_table_$bad_conversion fixed bin(35) ext static;

/* Static */
dcl  path_pointer pointer static internal initial (null ());

/* Builtin */
dcl (null, substr) builtin;

/* Include Files */
%include emacs_data;

	emacs_data_ptr = e_find_invocation_ ();

	/* Defaultify arguments. */
	emacs_data.arguments.task = "0"b;
	emacs_data.arguments.no_task = "0"b;
	emacs_data.arguments.destroy_task = "0"b;
	emacs_data.arguments.shared_static = "0"b;
	emacs_data.arguments.query = "0"b;
	emacs_data.arguments.reset = "0"b;
	emacs_data.arguments.ns = "0"b;
	emacs_data.arguments.apply = -1;
	emacs_data.arguments.pl = -1;
	emacs_data.arguments.ll = -1;
	emacs_data.arguments.ls = -1;
	emacs_data.arguments.path_count = 0;
	emacs_data.arguments.ttp = "";
	emacs_data.arguments.first_path = null ();
	emacs_data.arguments.force = "0"b;

	/* Clear flags and IOCB pointers. */
	emacs_data.flags.new_arguments = "1"b;
	emacs_data.flags.using_video = "0"b;
	if ^emacs_data.flags.debugging
	     & ^emacs_data.tasking.task_flags.in_task then do;
	     emacs_data.output_iocb, emacs_data.input_iocb = null ();
	end;

	P_code = 0;
	area_ptr = get_system_free_area_ ();

	call cu_$arg_count_rel (nargs, P_arglist, code);
	if code ^= 0 then do;
	     P_code = code;
	     call com_err_ (code, P_name);
	     return;
	end;

	do idx = 1 to nargs;
	     call get_argument (idx, "");

	     if index (arg, "-") ^= 1 then do;		/* not control arg */
		allocate path in (area) set (temp_ptr);
		if emacs_data.arguments.path_count = 0
		     then emacs_data.arguments.first_path = temp_ptr;
		else path_pointer -> path.next_path = temp_ptr;
		path_pointer = temp_ptr;
		emacs_data.arguments.path_count =
		     emacs_data.arguments.path_count + 1;
		path_pointer -> path.name = arg;
		path_pointer -> path.type = FIND_PATH;
	     end;

	     else if arg = "-no_start_up" | arg = "-no_startup" | arg = "-ns"
		then emacs_data.arguments.ns = "1"b;

	     else if arg = "-reset" then do;
		emacs_data.arguments.ttp = "";
		emacs_data.arguments.query = "0"b;
		emacs_data.arguments.reset = "1"b;
	     end;

	     else if arg = "-query" then do;
		emacs_data.arguments.ttp = "";
		emacs_data.arguments.reset = "0"b;
		emacs_data.arguments.query = "1"b;
	     end;

	     else if arg = "-terminal_type" | arg = "-ttp" then do;
		idx = idx + 1;
		call get_argument (idx, "Terminal type.");
		emacs_data.arguments.ttp = arg;
		emacs_data.arguments.reset = "0"b;
		emacs_data.arguments.query = "0"b;
	     end;

	     else if arg = "-macros" | arg = "-macro" | arg = "-mc" then do;
		idx = idx + 1;
		call get_argument (idx, "Macro file pathname.");
		allocate path in (area) set (temp_ptr);
		if emacs_data.arguments.path_count = 0
		     then emacs_data.arguments.first_path = temp_ptr;
		else path_pointer -> path.next_path = temp_ptr;
		path_pointer = temp_ptr;
		emacs_data.arguments.path_count = 
		     emacs_data.arguments.path_count + 1;
		path_pointer -> path.name = arg;
		path_pointer -> path.type = MACRO_PATH;
	     end;

	     else if arg = "-line_length" | arg = "-ll" then do;
		idx = idx + 1;
		emacs_data.arguments.ll =
		     get_numeric_argument (idx, "line length.");
	     end;

	     else if arg = "-page_length" | arg = "-pl" then do;
		idx = idx + 1;
		emacs_data.arguments.pl =
		     get_numeric_argument (idx, "page length.");
	     end;

	     else if arg = "-apply" | arg = "-ap" then do;
		idx, emacs_data.arguments.apply = idx + 1;
		call get_argument (idx, "Argument after -apply.");
		idx = nargs;
	     end;

	     else if arg = "-task" then do;
		emacs_data.arguments.task = "1"b;
		emacs_data.arguments.no_task = "0"b;
	     end;

	     else if arg = "-no_task" | arg = "-ntk" then do;
		emacs_data.arguments.task = "0"b;
		emacs_data.arguments.no_task = "1"b;
	     end;

	     else if arg = "-destroy_task" | arg = "-dtk" then do;
		emacs_data.arguments.destroy_task = "1"b;
	     end;

	     else if arg = "-shared_static" | arg = "-sst" then
		emacs_data.arguments.shared_static = "1"b;

	     else if arg = "-no_shared_static" | arg = "-nsst" then
		emacs_data.arguments.shared_static = "0"b;

	     else if arg = "-line_speed" | arg = "-ls" then do;
		idx = idx + 1;
		emacs_data.arguments.ls =
		     get_numeric_argument (idx, "line speed.");
	     end;

	     else if arg = "-force" | arg = "-fc" then emacs_data.arguments.force = "1"b;

	     else if arg = "-no_force" | arg = "-nfc" then emacs_data.arguments.force = "0"b;

	     else do;
		P_code = error_table_$badopt;
		call com_err_ (error_table_$badopt, P_name, "^a", arg);
	     end;
	end;

	if emacs_data.arguments.path_count > 0
	     then path_pointer -> path.next_path = null ();
	path_pointer = emacs_data.arguments.first_path;

returner:
	return;

subroutine: entry (P_iocbp, P_pathname, P_environment, P_info_ptr);

dcl (P_iocbp, P_info_ptr) pointer;
dcl (P_pathname, P_environment) character (*) parameter;

	emacs_data_ptr = e_find_invocation_ ();

	/* Defaultify arguments. */
	emacs_data.arguments.task = "0"b;
	emacs_data.arguments.no_task = "0"b;
	emacs_data.arguments.destroy_task = "0"b;
	emacs_data.arguments.shared_static = "0"b;
	emacs_data.arguments.query = "0"b;
	emacs_data.arguments.reset = "0"b;
	emacs_data.arguments.ns = "0"b;
	emacs_data.arguments.apply = -1;
	emacs_data.arguments.pl = -1;
	emacs_data.arguments.ll = -1;
	emacs_data.arguments.ls = -1;
	emacs_data.arguments.ttp = "";
	emacs_data.arguments.first_path = null ();
	emacs_data.arguments.path_count = 0;

	emacs_data.flags.new_arguments = "1"b;
	emacs_data.status_code = 0;
	emacs_data.output_iocb, emacs_data.input_iocb = P_iocbp;
	emacs_data.info_ptr = P_info_ptr;

	area_ptr = get_system_free_area_ ();

	if P_environment ^= "" then do;
	     allocate path in (area) set (path_pointer);
	     path_pointer -> path.next_path =  null ();
	     path_pointer -> path.name = P_environment;
	     path_pointer -> path.type = MACRO_PATH;
	     emacs_data.arguments.first_path = path_pointer;
	     emacs_data.arguments.path_count = 1;
	end;

	if P_pathname ^= "" then do;
	     allocate path in (area) set (path_pointer);
	     path_pointer -> path.next_path = emacs_data.arguments.first_path;
	     path_pointer -> path.name = P_pathname;
	     path_pointer -> path.type = FIND_PATH;
	     emacs_data.arguments.first_path = path_pointer;
	     emacs_data.arguments.path_count = emacs_data.arguments.path_count + 1;
	end;

	return;

/* Entries to get specific values back to Lisp. */

/* P_what_to_do: 0=noarg, 1=reset, 2=query, 3=ttp in P_ttp, add 100 more
	       for -force. */
get_ttp_info: entry (P_what_to_do, P_ttp);

dcl  P_what_to_do fixed bin parameter;
dcl  P_ttp character (168);

	emacs_data_ptr = e_find_invocation_ ();

	P_what_to_do = 0;
	if emacs_data.arguments.reset then P_what_to_do = 1;
	else if emacs_data.arguments.query then P_what_to_do = 2;
	else if emacs_data.arguments.ttp ^= "" then P_what_to_do = 3;
	if emacs_data.arguments.force then P_what_to_do = P_what_to_do + 100;
	P_ttp = emacs_data.arguments.ttp;
	return;

get_startup_info: entry (P_run_startup, P_tasking, P_path_count, P_pl, P_ll, P_ls, P_apply_arg);

dcl (P_run_startup, P_tasking, P_path_count, P_pl, P_ll, P_ls, P_apply_arg) fixed bin parameter;

	emacs_data_ptr = e_find_invocation_ ();

	if emacs_data.arguments.ns then P_run_startup = 0;
	else P_run_startup = 1;
	if emacs_data.arguments.task then P_tasking = 1;
	else P_tasking = 0;
	P_path_count = emacs_data.arguments.path_count;
	P_pl = emacs_data.arguments.pl;
	P_ll = emacs_data.arguments.ll;
	P_ls = emacs_data.arguments.ls;
	P_apply_arg = emacs_data.arguments.apply;
	emacs_data.flags.new_arguments = "0"b;
	return;

get_one_path: entry (P_pathname, P_type);

	emacs_data_ptr = e_find_invocation_ ();

	P_pathname = "";
	if path_pointer = null () then return;
	P_pathname = path_pointer -> path.name;
	temp_ptr = path_pointer -> path.next_path;
	P_type = path_pointer -> path.type;
	free path_pointer -> path in (area);
	path_pointer = temp_ptr;
	return;

new_arguments: entry () returns (fixed bin);

	emacs_data_ptr = e_find_invocation_ ();

	if emacs_data.flags.new_arguments then return (1);
	else return (0);

/* INTERNAL PROCEDURES */

get_argument: procedure (P_which, P_complaint);

dcl  P_which fixed bin;
dcl  P_complaint character (*) parameter;

	call cu_$arg_ptr_rel (P_which, ap, al, code, P_arglist);
	if code ^= 0 then do;
	     P_code = code;
	     call com_err_ (code, P_name, "^a", P_complaint);
	     go to returner;
	end;
     end get_argument;

get_numeric_argument: procedure (P_which, P_complaint) returns (fixed bin);

dcl  P_which fixed bin;
dcl  P_complaint character (*) parameter;
dcl  answer fixed bin;

	call cu_$arg_ptr_rel (P_which, ap, al, code, P_arglist);
	if code ^= 0 then do;
	     P_code = code;
	     call com_err_ (code, P_name, "^a", P_complaint);
	     go to returner;
	end;
	answer = cv_dec_check_ (arg, code);
	if code ^= 0 then do;
	     P_code = error_table_$bad_conversion;
	     call com_err_ (P_code, P_name, "Expected integer, got ^a for ^a", arg, P_complaint);
	     go to returner;
	end;
	if answer < 1 then do;
	     P_code = 1;
	     call com_err_ (0, P_name, "Negative value not allowed for ^a (^a).", P_complaint, arg);
	     go to returner;
	end;
	return (answer);
     end get_numeric_argument;

end e_argument_parse_;




		    e_basic_.lisp                   08/01/88  1002.5rew 08/01/88  0948.3      993627



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

;;; Multics EMACS
;;;     A product of Greenberg, 3/78
;;;     Started by BSG & BEE 3/3/78
;;;
;;;               EMACS's most basic functions
;;;               The sine qua non of Emacs' functionality, split away
;;;               June 1981 RMSoley.  This is the stuff that used to be
;;;               in emacs_ and some of what was in e_macops_.
     
;;;                BSG, WMY, GMP, RSL, RMSoley, and many others.


;;; HISTORY COMMENTS:
;;;  1) change(86-02-24,Margolin), approve(), audit(), install():
;;;     Pre-hcom journalization:
;;;     Modified: June 1982 - Barmar - to add JSL's new searching primitives.
;;;                   Also added more &undo's, and gave self-insert and &undo.
;;;     Modified: 2 November 1983 - Barmar - to add (backward forward)-n-chars
;;;                   and make (backward forward)-char use them.
;;;     Modified: 25 November 1983 - Barmar - to add JSL's .unh hack for paragraphs.
;;;     Modified: 29 November 1983 - Barmar - rename (forward backward)-char to
;;;                   ===-command and put back the old ===.  This is because the new
;;;                   commands use look at the value of numarg, which primitives should
;;;                   not do, and (forward backward)-char is a primitive.
;;;     Modified: 3 December 1983 - Barmar - to change add-new-line and
;;;                   delete-line to not change number-of-lines-in-buffer when
;;;                   in the minibuffer.
;;;     Modified: 19 January 1984 - Barmar - to comment out the register-option
;;;                   forms, as they were moved into e_option_defaults_.
;;;  2) change(86-02-24,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     More pre-hcom journalization:
;;;     Modified: 25 December 1984 - Barmar - to use defmacro, delete some macros
;;;                   that are also in e-macros.incl.lisp.
;;;     Modified: 26 December 1984 - Barmar - to not (zerop old-numarg) in
;;;                   autofill-self-insert, since old-numarg can be nil, to initialize
;;;                   current-command with defvar, move %include's to before most
;;;                   declares, fix save-buffer-state to not reference unbound local
;;;                   vars.
;;;     Modified: 27 December 1984 - Barmar - fix register-local-var to initialize
;;;                   local variables that were unbound, as documented, and remove the
;;;                   change to save-buffer-state.
;;;     Modified: 30 December 1984 - Barmar - change retrieve-buffer-state to
;;;                   maintain the Macro Learn minor mode, minibuffer-response to
;;;                   not change key bindings in recursive minibuffers, changes to
;;;                   fill-mode to fill on CR and TAB.
;;;     Modified: 6 January 1985 - Barmar - changed to use defstruct for eline
;;;                   and mark, move gratuitous-mark-setter into prologue for
;;;                   go-to-(beginning end)-of-buffer, changed del-mark-from-buffer
;;;                   to bind curline (release-mark needs this).
;;;     Modified: 27 January 1985 - Barmar - added some special declarations.
;;;     Modified: 3 February 1985 Barmar: took CR out of fill-mode-delimiters,
;;;                   and special-cased it in fill-mode/fill-mode-off; changed
;;;                   fill-mode-off to interact with speedtype better, like fill-mode
;;;                   does.
;;;  3) change(86-02-24,Margolin), approve(86-02-24,MCR7325),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Added insert-new-line and insert-new-empty-line.  Added
;;;     buffer-file-dtcm to the buffer data structure in
;;;     buffer-in-nihilem-factus-est.  Fixed destroy-buffer-contents and
;;;     reinitialize-current-buffer to release buffer tempsegs.
;;;  4) change(88-01-11,Schroth), approve(88-02-29,MCR7852),
;;;     audit(88-06-06,RBarstad), install(88-08-01,MR12.2-1071):
;;;     Update minibuffer-response for split screen displays.
;;;                                                      END HISTORY COMMENTS


;;;

(declare (genprefix /!e_basic_))

(%include e-macros)
(%include defmacro)
(declare (macros nil))
(%include emacs-internal-macros)
(%include defstruct)
(%include other_other)

(declare (*expr convert_status_code_ cur-screen-hpos emacs_search_file_caller_
	      e$get_temporary_seg e_lap_$compare_strings e_lap_$delete-chars
	      e_lap_$forward-search-string e_lap_$ggcharn e_lap_$insert-chars
	      e_lap_$make-dat-ol-black-magic-string
	      e_lap_$reverse-search-string e_lap_$rplacstring
	      e_lap_$rplacstring-offset e_lap_$rtrim e_lap_$string_length
	      e_lap_$tabscan e_lap_$tct e_lap_$tctr filerep-to-string
	      get_pdir_ go-to-screen-hpos hcs_$make_ptr
	      instate-local-key-bindings
	      redisplay-buffer-reinit-purge redisplay-leave-buffer
	      redisplay-purge-buffer release-temp-segments
	      revert-local-key-bindings speedtype speedtypeoff))
(declare (*lexpr display-error-noabort display-error display-com-error
	       report-error report-error-noabort
	       display-error-remark minibuffer-remark
	       display-com-error-noabort minibuffer-print
	       minibuffer-print-noclear ncline comout))

(declare (special

	 process-dir		;user's process directory
	 env-dir			;dir where system libraries live
	 lisp-system-dir		;place where Lisp lives
	 multesque-readtable	;for reading without dots, etc.
	 next-multics-argno
	 firstline		;first line of buffer
	 lastline
	 curline			;current line doublecons
	 fill-prefix		;the fill prefix
	 default-fill-column	;used to reset fill-column
	 hard-enforce-fill-column	;used in echo negotiation
	 fill-column
	 default-comment-column	;used to reset comment-column
	 comment-column
	 comment-prefix
	 tab-equivalent
	 curlinel			;# chars in current line
	 minibufferp		;in Minny Buffer.
	 minibuffer-prompt-string	;for redisplay
	 minibuffer-end-string	;Usually "<>"
	 numarg			;numeric argument to current function, or nil if none
	 last-input-char		;current char, for self-inserts
	 nobreak-functions		;functions that don't break echnego
	 fpathname		;filepath
	 curpointpos		;# of chars to left of cursor, this line
	 work-seg			;seg stringorum
	 building-buf		;rplacablestring for kills, &c
	 work-string		;string segii
	 last-curline		;redisplay var
	 curstuff			;string, filecons, or work-string
	 buffer-tempsegs		;list of temp segments for this buffer
	 buffer-uid		;unique ID of segment this buffer holds
	 known-buflist		;syms with buffer-state property
	 list-of-known-options	;options used by  command
	 target-screen-hpos		;vertical motion target for next/prev l
	 current-buffer		;symbol name of current buffer
	 buffer-modified-flag	;as it says
	 buffer-minor-modes		;dorian, phrygian, aeolian, etc.
	 buffer-locvars		;local values of user op vars
	 current-buffer-mode	;current major mode
	 number-of-lines-in-buffer
	 display-linechange-interrupt-hook
	 macro-execution-in-progress	;pointer on current xec list
	 macro-collection-in-progress	;if non-null, the current macro collection
	 per-buffer-key-bindings	;as it says, assq list
	 previous-buffer		;buffer we came from
	 previous-command		;last cmd symbol
	 read-only-flag		;per buffer
	 spec-op-name-flag		;for redisplay, query replace etc.
	 tty-no-upmotionp		;Tty can't move cursor up.
	 buf-state-template		;specials to save for bufswitch
	 NLCHARSTRING		;a newline as string object
	 TAB			;ascii TAB
	 ESC			;ascii escape
	 CRET			;carriage return symbol
	 NL
	 search-ring		;ring of strings searched for recently
	 last-search-string		;same value as top of search-ring
	 last-minibuf-response
	 kill-ring		;ring of killed stuff
	 kill-ring-current-size	;8/4/80
	 kill-ring-max-size
	 dont-stash		;flag to not store killage
	 der-wahrer-mark		;mark that user knows of
	 marklist			;list of marks
	 mark-ring		;ring of user marks
	 named-mark-list		;list of named marks
	 curline-marklist		;list of marks for current line
	 damaged-flag		;redisplay, watchout
	 dont-damage-flag		;open-line, don't set above
	 touchy-damaged-flag	;el gran kludge- see redisplay
	 pdir-temp-ename
	 pdir-temp-pathname		;file in process dir
	 suppress-redisplay-flag
	 rdis-suppress-redisplay
	 e-lisp-error-mode		;see e_interact_
	 e-quit-transparency	;see signalquit in e_interact_
	 good-word-charactertbl	;Character table for words.
	 whitespace-charactertbl	;Same for whitespace.
	 two-window-mode 
	 varlist
	 OPEN-PAREN
	 CLOSE-PAREN
	 SEMI
	 SINGLEQUOTE
	 DOUBLEQUOTE
	 SLASH
	 CR
	 sexp-searcher-mark-list
	 MCS-editing-characters
	 MCS-escape-character
	 line-control:template
	 line-control:buffer
	 ))

(defvar current-command nil)			;current cmd symbol

(defmacro consp (x) `(not (atom ,x)))

(defmacro firstlinep () '(null (prevline)))

(defmacro lastlinep () '(null (nextline)))

(defmacro curline-openp () '(eq curstuff work-string))

(defmacro note-modified-buffer ()
       '(and (or read-only-flag (not buffer-modified-flag))
	   (buffer-has-been-modified--take-note)))

(defmacro defkill (command type) `(defprop ,command ,type kills))

(defmacro hook-function (hook-name)
	`(and ,hook-name (funcall ,hook-name ',hook-name)))

(defmacro defhook (hook-name)
	`(progn 'compile
	        (declare (special ,hook-name))
	        (setq ,hook-name nil)))

(setq OPEN-PAREN '/(	CLOSE-PAREN '/)	SEMI '/;
      DOUBLEQUOTE '/"	SLASH '//		SINGLEQUOTE '/'
      sexp-searcher-mark-list nil minibuffer-end-string "<>")

;;;	The "eline" (editor-line) datatype is constructed with defstruct.
;;;	It currently contains three slots:
;;;	eline-contents: either a string, a filecons (see below), or the
;;;	symbol "deleted"
;;;	eline-previous, eline-next: either another eline or nil
;;;
;;;	A filecons is a defstruct with two slots:
;;;	filecons-pointer: 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.  
;;;	filecons-length: the length of that line, including the mandatory
;;;	newline at the end.
;;;
;;;	The variable "curstuff" is bound to either the "eline-contents"
;;;	of the current line, in which case the current line is said to
;;;	be "closed", or to the rplacable string "work-string", in which
;;;	case the contents of work-string are the valid contents of the 
;;;	line, which is then said to be "open".

(defun firstlinep () (null (prevline)))

(defun lastlinep ()  (null (nextline)))

(defun next-line ()
       (or (lastlinep)(go-to-line-point (nextline) 0)))

(defun prev-line ()
       (or (firstlinep)(go-to-line-point (prevline) 0)))

(defun open-line ()
       (or dont-damage-flag (setq damaged-flag t))     ;redisplay, forget it
       (setq touchy-damaged-flag t)		;SOMEthing happened.
       (note-modified-buffer)			;this is a macro
       (cond ((curline-openp))	;done already
	   (t (compute-marks-for-this-line)
	      (e_lap_$rplacstring work-string curstuff curlinel 0 curlinel)
	      (setq curstuff work-string))))

(defhook close-line-hook)

(defun close-line ()
       (hook-function close-line-hook)
       (cond ((curline-openp)
	    (setq curline-marklist nil)
	    (setq curstuff (substr work-string 1))
	    (setf (eline-contents curline) curstuff))
	   (t (setq curstuff (eline-contents curline)))))

(defun go-to-line-point (line point)
       (and (eq (eline-contents line) 'deleted)
	  (error "Internal error: Transfer to deleted line." nil 'fail-act))
       (setq curstuff
	   (cond ((eq curline line) curstuff)
	         (t (close-line)
		  (setq curline line)
		  (eline-contents curline)))
	   curlinel
	   (cond ((consp curstuff) (filecons-length curstuff))
	         ((stringp curstuff)(stringlength curstuff))
	         (t (error "Internal error: go-to-line-point confused."
		         nil 'fail-act))))
       (cond ((> point (1- curlinel))(setq point (1- curlinel))))
       (setq curpointpos point))

(defun add-new-empty-line ()
       (add-new-line NLCHARSTRING))

;;; Adds a new line after the current line.  Doesn't move point.
(defun add-new-line (linerepresentation)
       (prog (l)
	   (note-modified-buffer)
	   (setq damaged-flag t)
	   (setq l (make-eline contents linerepresentation
			   previous curline
			   next (nextline)))
	   (cond ((lastlinep)(setq lastline l))
	         (t (setf (eline-previous (nextline)) l)))
	   (setf (nextline) l))
       (or minibufferp
	 (setq number-of-lines-in-buffer (1+ number-of-lines-in-buffer))))

;;; Like above, but inserts BEFORE the current line
(defun insert-new-line (linerep)
       (note-modified-buffer)
       (setq damaged-flag t)
       (let ((l (make-eline contents linerep
		        next curline
		        previous (prevline))))
	  (cond ((firstlinep) (setq firstline l))
	        (t (setf (eline-next (prevline)) l)))
	  (setf (prevline) l))
       (or minibufferp (incf number-of-lines-in-buffer)))

(defun insert-new-empty-line ()
       (insert-new-line NLCHARSTRING))

(defun delete-line ()			;kill curline
       (cond ((and (lastlinep)(firstlinep)))	;act like Millard Fillmore
					;(Do nothing)
	   (t (setq damaged-flag t buffer-modified-flag t)
	      (let ((prev (prevline))
		  (next  (nextline)))
		 (and prev (setf (eline-next prev) next))
		 (and next (setf (eline-previous next) prev))
		 (close-line)
		 (setf (eline-contents curline) 'deleted)    ;mark dead for redisplay
		 (and (lastlinep)(setq lastline prev))
		 (and (firstlinep)(setq firstline next))
		 (and next (go-to-line-point next curpointpos))
		 (or minibufferp
		     (setq number-of-lines-in-buffer
			 (1- number-of-lines-in-buffer)))))))

;;; Underpinnings of single-character movement, insertion, testing, deletion.

;;; Test lefthand-character.
(defun one-back-is-a (c)
   (if (stringp c)(setq c (getchar c 1)))
   (if (at-beginning-of-buffer) nil
       else (backward-char)
	  (if (at-beginning-of-buffer)
	      (forward-char)
	      nil
	      else (prog2 0 (eq (lefthand-char) c)(forward-char)))))

;;; Return the character to the left of the cursor.
(defun lefthand-char ()
     (if (bolp) NL
         else (prog2 (backward-char)
		 (curchar)
		 (forward-char))))

;;; Insert a character into the buffer.
(defun insert-char (char)
       (let ((dont-damage-flag (cond ((eq char NL) nil)
			       ((not (eq curline last-curline)) nil)
			       ((eolp) t)
			       (t nil))))
	  (open-line))
       (or (eolp)
	 (relocate-marks curline 1 'c+));hack to optimize only
       (e_lap_$insert-chars work-string curpointpos char 1)
       (setq curlinel (1+ curlinel) curpointpos (1+ curpointpos))
       (and (eq char NL)(break-the-line)))

(defun break-the-line ()			;called with line open
       (let ((oldstring (substr work-string 1))
	   (saved-clml curline-marklist)
	   (cpp curpointpos))
	  (close-line)
	  ;; Optimize breaking for redisplay's benefit.
	  (cond ((and (not (firstlinep))(< cpp (- curlinel cpp)))
	         (prev-line)
	         (add-new-line (substr oldstring 1 cpp))	;stick before not after
	         (next-line)		;the one we just added
	         (next-line)		;the original line
	         (setq curstuff (substr oldstring (1+ cpp)))
	         (setf (eline-contents curline) curstuff) ;this is obscure
	         (setq curlinel (- (stringlength oldstring) cpp))
	         (compute-marks-for-this-line)
	         (relocate-marks (prevline) cpp 'rev-brk)
	         (relocate-marks curline (- cpp) 'c+))
	        (t (setf (eline-contents curline) (substr oldstring 1 cpp))
		 (add-new-line (substr oldstring (1+ cpp)))
		 (setq curline-marklist saved-clml)
		 (relocate-marks (nextline) curpointpos 'break)
		 (next-line)))))

;;; Underpinnings of line movement, etc.

(defun kill-to-end-of-line ()
       (and (eq current-buffer line-control:buffer)
	  (line-control:check 'end))
       (open-line)
       (or dont-stash (killsave-string (substr work-string (1+ curpointpos)(- curlinel curpointpos 1))))
       (relocate-marks curline curpointpos 'set)
       (e_lap_$rplacstring work-string NL 1 curpointpos (1+ curpointpos))
       (setq curlinel (1+ curpointpos)))


(defun merge-line ()
       (note-modified-buffer)
       (and (eq current-buffer line-control:buffer)
	  (line-control:check 0))
       (setq damaged-flag t)
       (let ((clml curline-marklist)
	   (openp (curline-openp)))
	  (close-line)
	  (cond ((lastlinep))
	        (t (let ((origcurl curline)
		       (origcpp curpointpos)
		       (thiss curstuff)
		       (thissl (1- curlinel)))
		      (cond ((or (= 0 thissl)
			       (> (let ((nextstuff
				        (eline-contents (nextline))))
				     (cond ((consp nextstuff)
					  (filecons-length nextstuff))
					 (t (e_lap_$string_length nextstuff))))
				curlinel))
			   (cond  ((> thissl 0)
				 (next-line)
				 (compute-marks-for-this-line)
				 (relocate-marks curline thissl '+)
				 (go-to-line-point origcurl origcpp)))
			   (cond (openp (setq curline-marklist clml))
			         (t (compute-marks-for-this-line)))
			   (relocate-marks (nextline) 0 '+)
			   (delete-line)
			   (cond ((> thissl 0)
				(setf (eline-contents curline)
				      (setq curstuff
					  (progn
					    (e_lap_$rplacstring work-string thiss thissl 0 thissl)
					    (e_lap_$rplacstring work-string curstuff curlinel thissl (+ thissl curlinel))
					    (substr work-string 1))))))
			   (setq origcurl curline))
			  (t (next-line)
			     (setf (eline-contents origcurl)
				 (progn
				   (e_lap_$rplacstring work-string thiss thissl 0 thissl)
				   (e_lap_$rplacstring work-string curstuff curlinel thissl (+ thissl curlinel))
				   (substr work-string 1)))
			     (compute-marks-for-this-line)
			     (relocate-marks origcurl thissl '+)
			     (delete-line)))
		      (go-to-line-point origcurl origcpp))))))

;;;
;;;	The "mark" datum.
;;;
;;;	Redone 7/3/79 by BSG for curline-marklist.
;;;	8/19/79 by BSG for named marks and mark-ring.
;;;
;;;	The format of a mark is (defstruct (mark (:conc-name))
;;;				     eline position)
;;;	"marklist" lists all marks in the current buffer.
;;;	In addition, curline-marklist lists all marks for
;;;	current line (curline) if and only if it is open.
;;;	Only marks for the current line ever have to be relocated.

(defun compute-marks-for-this-line ()
       (setq curline-marklist
	   (mapcan '(lambda (m)
			(and (eq (mark-eline m) curline)
			     (ncons m)))
		 marklist)))

(defun set-mark ()
       (let ((mark (make-mark eline curline
			position curpointpos)))
	  (push mark marklist)
	  (and (curline-openp)
	       (push mark curline-marklist))
	  mark))

(defun move-mark (to from)
       (and (eq (mark-eline to) curline)
	  (not (eq (mark-eline from)  curline))
	  (setq curline-marklist (delq to curline-marklist)))
       (alter-mark to
	         eline (mark-eline from)
	         position (mark-position from)))

(defun set-mark-here (m)
       (and (not (eq (mark-eline m) curline))
	  (curline-openp)
	  (push m curline-marklist))
       (alter-mark m
	         eline curline
	         position curpointpos))

(defun go-to-mark (m)
       (go-to-line-point (mark-eline m) (mark-position m)))

(defun release-mark (m)
       (and (eq curline (mark-eline m))
	  (setq curline-marklist (delq m curline-marklist 1)))
       (setq marklist (delq m marklist 1)))

(defun mark-reached (m)
       (cond ((eq (mark-eline m) curline)
	    (not (< curpointpos (mark-position m))))
	   ((lastlinep))			;KLUDGE
	   (t nil)))

(defun mark-same-line-p (m1 m2)
       (eq (mark-eline m1) (mark-eline m2)))

(defun mark-equal (m1 m2)
       (and (eq (mark-eline m1) (mark-eline m2))
	  (= (mark-position m1) (mark-position m2))))

(defun mark-on-current-line-p (m)
       (eq curline (mark-eline m)))

(defun mark-at-current-point-p (m)
       (and (eq (mark-eline m) curline)
	  (= (mark-position m) curpointpos)))

(defun mark-reached-backwards (m)
       (cond ((eq (mark-eline m) curline)
	    (not (> curpointpos (mark-position m))))
	   ((firstlinep))			;KLUDGE
	   (t nil)))

(defun relocate-marks (newline offset flag)	;oldline is always curline
       (mapc '(lambda (m)
		  (cond ((eq flag '+)
		         (alter-mark m
				 eline newline
				 position (+ (mark-position m) offset)))
		        ((eq flag 'set)
		         (cond ((> (mark-position m) offset)
			      (setf (mark-position m) offset))))
		        ((eq flag 'break)
		         (cond ((< curpointpos (mark-position m))
			      (alter-mark m
				        eline newline
				        position (- (mark-position m) offset)))))
		        ((eq flag 'c+)
		         (cond ((> (mark-position m) curpointpos)
			      (setf (mark-position m)
				  (max curpointpos
				       (+ offset (mark-position m)))))))
		        ((eq flag 'rev-brk)
		         (cond ((< (mark-position m) offset)
			      (setf (mark-eline m) newline))))))
	   curline-marklist)
       (or (eq curline newline)
	 (setq curline-marklist
	       (mapcan '(lambda (m)
			    (and (eq (mark-eline m) curline)
			         (ncons m)))
		     curline-marklist))))

(defun kill-forward-to-mark (m)
       (and (eq line-control:buffer current-buffer)
	  (line-control:check m))
       (open-line)
       (or dont-stash (killsave-string (point-mark-to-string m)))
       (do ((dont-stash t))((mark-reached m))
	 (cond ((not (eq (mark-eline m) curline))
	        (kill-to-end-of-line)
	        (merge-line))
	       (t (let ((howmany (- (mark-position m) curpointpos)))
		     (open-line)
		     (relocate-marks curline (- howmany) 'c+)
		     (e_lap_$delete-chars work-string curpointpos howmany)
		     (setq curlinel (- curlinel howmany)))
		(return t)))))

(defun point-mark-to-string (m)
       (cond ((point>markp m)
	    (let ((val))
	         (unwind-protect
		 (setq val (progn (exch-point-mark m)
			        (point-mark-to-string1 m)))
		 (exch-point-mark m))
	         val))
	   (t (point-mark-to-string1 m))))

(defun point-mark-to-string1 (m)
       (e_lap_$rplacstring building-buf "" 0 0 0)	;clean slate
       (with-mark savem
	        (do nil (nil)
		  (let ((limit (cond ((eq (mark-eline m) curline)
				  (mark-position m))
				 (t curlinel))))
		       (let ((curl (stringlength building-buf))
			   (addl (- limit curpointpos)))
			  (e_lap_$rplacstring-offset
			    building-buf curstuff addl curl
			    (+ curl addl) curpointpos)))
		  (cond ((eq (mark-eline m) curline)
		         (go-to-mark savem)
		         (return (substr building-buf 1))))
		  (go-to-line-point (nextline) 0) )))

(defun in-line-compare-string (str m)
       (cond ((consp m)(setq m (mark-position m))))
       (cond ((not (= (abs (- curpointpos m))(stringlength str)))
	    nil)
	   ((> curpointpos m)
	    (e_lap_$compare_strings curstuff m str 0 (- curpointpos m)))
	   (t (e_lap_$compare_strings
	        curstuff curpointpos str 0 (- m curpointpos)))))

(defun looking-at (string)
       (let ((leftl (- curlinel curpointpos))
	   (sl (stringlength string)))
	  (cond ((> sl leftl) nil)
	        ((= 0 sl) t)
	        (t (e_lap_$compare_strings
		   curstuff curpointpos string 0 sl)))))

(defun kill-backwards-to-mark (m)
       (let ((old-line curline)
	   (old-pos curpointpos))
	  (protect
	    (exch-point-mark m)
	    (kill-forward-to-mark m)
	    &failure
	    (or (and (eq old-line curline)	;only if we've made it thru
		   (= old-pos curpointpos))	;the first exchange
	        (exch-point-mark m)))))

(defcom exchange-point-and-mark
        &undo &ignore
        (cond (der-wahrer-mark (exch-point-mark der-wahrer-mark))
	    (t (report-error 'mark-not-set))))

(defun exch-point-mark (m)
       (let ((line (mark-eline m))
	   (hpos (mark-position m)))
	  (set-mark-here m)
	  (go-to-line-point line hpos)))

(defun order-mark-last (m)			;makes mark follow point
       (and (point>markp m)(exch-point-mark m)))

(defun point>markp (m)
       (cond ((eq (eline-contents (mark-eline m)) 'deleted)
	    (error "Internal error: point>markp found mark in deleted line."
		 current-buffer 'fail-act))
	   ((eq curline (mark-eline m))
	    (> curpointpos (mark-position m)))
	   (t (do ((mp (mark-eline m)
		     (eline-next mp))
		 (pp curline (eline-next pp)))
		((and (not pp)(not mp))
		 (error "Internal error: point>markp can't find mark."
		        current-buffer 'fail-act))
		(cond ((eq pp (mark-eline m))(return nil))
		      ((eq mp curline)(return t)))))))

(defun set-the-mark ()
       (cond ((and der-wahrer-mark (mark-at-current-point-p der-wahrer-mark)))
	   (t (and der-wahrer-mark
		 (not minibufferp)
		 (push-mark-ring der-wahrer-mark))
	      (release-mark der-wahrer-mark)
	      (setq der-wahrer-mark (set-mark)))))

(defun set-the-mark-here (where)
       (cond ((and der-wahrer-mark (mark-equal der-wahrer-mark where)))
	   (t (and der-wahrer-mark
		 (not minibufferp)
		 (push-mark-ring der-wahrer-mark))
	      (release-mark der-wahrer-mark)
	      (setq der-wahrer-mark where))))

(defcom set-or-pop-the-mark
        &numeric-argument (&pass)
        (cond ((null numarg)
	     (set-the-mark)
	     (or tty-no-upmotionp (minibuffer-remark "Set.")))
	    (minibufferp (ring-tty-bell))
	    (t (do x mark-ring (cadr x) nil
		 (cond ((and (car x) (mark-at-current-point-p (car x)))
		        (return nil))
		       ((eq (cadr x) mark-ring)
		        (let ((r mark-ring) (m (set-mark)))
			   (push-mark-ring m)
			   (release-mark m)
			   (setq mark-ring r))
		        (return nil))))
	       (do x mark-ring (cddr x) nil
		 (cond ((car x)(return (setq mark-ring x)))
		       ((eq (cddr x) mark-ring) (return nil))))
	       (cond ((car mark-ring)
		    (go-to-mark (car mark-ring))
		    (setq mark-ring (cddr mark-ring)))))))

(defun push-mark-ring (markval)
       (cond ((and (car mark-ring)
	         (mark-equal (car mark-ring) markval)))
	   (t (setq mark-ring (cadr mark-ring))
	      (cond ((not (car mark-ring))
		   (rplaca mark-ring (set-mark))))
	      (move-mark (car mark-ring) markval))))
	    
(defun wipe-point-mark (m)
       (let ((old-line curline)
	   (old-pos curpointpos))
	  (protect
	    (and (point>markp m)
	         (exch-point-mark m))
	    (kill-forward-to-mark m)
	    &failure
	    (or (and (eq old-line curline)	;only if we made
		   (= old-pos curpointpos))	;the first exchange
	        (exch-point-mark m)))))

;;; EIS Search and Verify: The searching and character set primitives.
;;;   Hirsute multiline search inserted 5/8/80 by BSG
;;; June 1982 - JSL - Reimplemented and/or reformatted most of this.
;;;		  Added bounded searches.

(defun forward-search-in-line (string)
       (let ((cpp)
	   (result
	     (e_lap_$forward-search-string curstuff curpointpos string)))
	  (cond ((< result 0) nil)
	        ((> curlinel
		  (setq cpp (+ result curpointpos (stringlength string))))
	         (setq curpointpos cpp)
	         result)
	        (t nil))))


(defun forward-search (string)
       (let ((cl curline)
	   (cpp curpointpos)
	   (forever 100000000.)
	   (nl1x (e_lap_$forward-search-string string 0 NL)))
	  (let ((result (cond ((< nl1x 0)
			   (search:forward-nnl string forever))
			  (t (search:forward-nl string nl1x forever)))))
	       (or result (go-to-line-point cl cpp))
	       result)))


(defun forward-search-bounded (string bound)
       (let ((cl curline)
	   (cpp curpointpos)
	   (nl1x (e_lap_$forward-search-string string 0 NL)))
	  (let ((result (cond ((< nl1x 0)
			   (search:forward-nnl string bound))
			  (t (search:forward-nl string nl1x bound)))))
	       (or result (go-to-line-point cl cpp))
	       result)))

(defun reverse-search-in-line (string)
       (let ((result
	     (e_lap_$reverse-search-string curstuff curpointpos string)))
	  (cond ((< result 0) nil)
	        (t (setq curpointpos
		       (- curpointpos result (stringlength string)))
		 result))))


(defun reverse-search (string)
       (let ((cl curline)
	   (cpp curpointpos)
	   (forever 100000000.)
	   (nl1x (e_lap_$forward-search-string string 0 NL)))
	  (let ((result (cond ((< nl1x 0)
			   (search:reverse-nnl string forever))
			  (t (search:reverse-nl string nl1x forever)))))
	       (or result (go-to-line-point cl cpp))
	       result)))


(defun reverse-search-bounded (string bound)
       (let ((cl curline)
	   (cpp curpointpos)
	   (nl1x (e_lap_$forward-search-string string 0 NL)))
	  (let ((result
		(cond ((< nl1x 0)
		       (search:reverse-nnl string bound))
		      (t (search:reverse-nl string nl1x bound)))))
	       (or result (go-to-line-point cl cpp))
	       result)))

(defun search:forward-nnl (s bound)
       (do ((count 0)
	  (result (e_lap_$forward-search-string curstuff curpointpos s)
		(e_lap_$forward-search-string curstuff curpointpos s)))
	 ((not (< result 0))
	  (cond ((not (> (setq count (+ count result)) bound))
	         (setq curpointpos (+ curpointpos result (stringlength s)))
	         count)))
	 (and (lastlinep) (return nil))
	 (setq count (+ count curlinel))
	 (and (> count bound) (return nil))
	 (next-line)))


(defun search:forward-nl (lines nlx bound)
       (do ((cl curline curline)
	  (count 0)
	  (cpp curpointpos curpointpos)
	  (lines (cdr (search:break-and-save-string lines nlx)))
	  (result))
	 ((do ((l lines (cdr l))
	       (sl)
	       (start)
	       (string))
	      ((null l)
	       (cond ((< (setq start (+ start sl)) curlinel)
		    (setq curpointpos start))
		   ((lastlinep) nil)
		   (t (next-line) t)))
	      (setq sl (e_lap_$string_length (car l))
		  string (car l))
	      (cond ((eq l lines)
		   (setq start (- curlinel sl))
		   (and (< start 0) (return nil))
		   (setq result start))
		  ((lastlinep) (return nil))
		  (t (next-line)
		     (and (> sl curlinel) (return nil))
		     (setq start 0)))
	      (or (e_lap_$compare_strings curstuff start string 0 sl)
		(return nil)))
	  (and (not (> (setq result (+ count result)) bound))
	       result))
	 (go-to-line-point cl cpp)
	 (and (lastlinep) (return nil))
	 (setq count (+ count curlinel))
	 (and (> count bound) (return nil))
	 (next-line)))

(defun search:reverse-nnl (s bound)
       (do ((count 0)
	  (result (e_lap_$reverse-search-string curstuff curpointpos s)
		(e_lap_$reverse-search-string curstuff curpointpos s)))
	 ((not (< result 0))
	  (cond ((not (> (setq count (+ count result)) bound))
	         (setq curpointpos (- curpointpos result (stringlength s)))
	         count)))
	 (and (firstlinep) (return nil))
	 (setq count (+ count curpointpos 1))
	 (and (> count bound) (return nil))
	 (prev-line)
	 (go-to-end-of-line)))


(defun search:reverse-nl (lines nlx bound)
       (do ((cl curline curline)
	  (count 0)
	  (cpp curpointpos curpointpos)
	  (initial-cl curline)
	  (result)
	  (lines (cdr (search:reverse
		      (search:break-and-save-string lines nlx)))))
	 ((do ((l lines (cdr l))
	       (sl)
	       (start 0)
	       (string))
	      ((null l)
	       (setq curpointpos start))
	      (setq sl (e_lap_$string_length (car l))
		  string (car l))
	      (cond ((eq l lines)
		   (cond ((eq initial-cl curline)
			(or (cdr l) (return nil))
			(setq result (- curpointpos sl))
			(and (< result 0) (return nil)))
		         ((null (cdr l))
			(setq start (- curlinel sl) result 0)
			(and (< start 0) (return nil)))
		         (t (setq result (- curlinel sl))
			  (and (< result 0) (return nil)))))
		  ((firstlinep) (return nil))
		  ((null (cdr l))
		   (prev-line)
		   (setq start (- curlinel sl))
		   (and (< start 0) (return nil)))
		  (t (prev-line)
		     (or (= curlinel sl) (return nil))))
	      (or (e_lap_$compare_strings curstuff start string 0 sl)
		(return nil)))
	  (and (not (> (setq result (+ result count)) bound))
	       result))
	 (go-to-line-point cl cpp)
	 (and (firstlinep) (return nil))
	 (cond ((eq cl curline)
	        (setq count (+ count curpointpos)))
	       (t (setq count (+ count curlinel))))
	 (and (> count bound) (return nil))
	 (prev-line)))

(declare (special search:saved-broken-string))

(setq search:saved-broken-string nil)

(defun search:break-and-save-string (s nlx)
       (cond ((and search:saved-broken-string
	        (samepnamep s (caar search:saved-broken-string)))
	    search:saved-broken-string)
	   (t (setq search:saved-broken-string
		  (search:break-string s nlx)))))


(defun search:reverse (broken-string)
       (cond ((cdar broken-string) (car broken-string))
	   (t (rplacd (car broken-string) (reverse (cdr broken-string))))))


(defun search:break-string (string nlx)
       (do ((line)
	  (line-length)
	  (line-list (ncons (substr string 1 (1+ nlx))))
	  (nlx (1+ nlx))
	  (sl (stringlength string)))
	 ((not (< nlx sl))
	   (cons (ncons string) (nreverse line-list)))
	 (setq line-length (1+ (e_lap_$forward-search-string string nlx NL)))
	 (and (= line-length 0) (setq line-length (- sl nlx)))
	 (setq line (substr string (1+ nlx) line-length))
	 (setq line-list (cons line line-list))
	 (setq nlx (+ nlx line-length))))

;;; Old functions for searching for strings containing newlines.
;;; Obsoleted by JSL's new stuff (above) but left in just in case
;;; someone is using them (although they are internal interfaces).

(defun forward-search-multi (s nlx)
       (let ((ol (chunkify-string s nlx)))
	  (do ()(nil)
	      (let ((ocp curpointpos)
		  (ocl curline))
		 (and (do ((l ol (cdr l)))(nil)
			(let ((cl (e_lap_$string_length (car l)))
			      (chunk (car l))
			      (remains (- curlinel curpointpos 1)))
			     (cond ((> cl remains)(return nil)))
			     (and (eq l ol) ;first chunk
				(setq curpointpos (- curlinel cl 1) remains cl))
			     (cond ((null (cdr l))	;last chunk
				  (cond ((= cl 0)	;right after NL
				         (return (bolp)))
				        ((e_lap_$compare_strings curstuff curpointpos chunk 0 cl)
				         (return (setq curpointpos (+ curpointpos cl))))
				        (t (return nil))))
				 ((not (= cl remains))(return nil))
				 ((not (e_lap_$compare_strings curstuff curpointpos chunk 0 cl))
				  (return nil)))
			     (cond ((lastlinep)(return nil)))
			     (next-line)))
		      (return t))		;inner do won.
		 (go-to-line-point ocl ocp)
		 (cond ((lastlinep)(return nil)))
		 (next-line)))))

(defun reverse-search-multi (s nlx)
       (let ((ol (reverse (chunkify-string s nlx))))   ;cant nreverse or sharing loses
	  (do ()(nil)
	      (let ((ocp curpointpos)
		  (ocl curline))
		 (and (do ((l ol (cdr l)))(nil)
			(let ((cl (e_lap_$string_length (car l)))
			      (chunk (car l)))
			     (cond ((> cl curpointpos)(return nil)))
			     (and (eq l ol)
				(setq curpointpos cl))
			     (cond ((null (cdr l))	;last chunk
				  (cond ((= cl 0)
				         (return (eolp)))
				        ((e_lap_$compare_strings curstuff (- curlinel cl 1) chunk 0 cl)
				         (return (setq curpointpos (- curlinel cl 1))))
				        (t (return nil))))
				 ((not (= cl curpointpos))(return nil))
				 ((not (e_lap_$compare_strings curstuff 0 chunk 0 cl))
				  (return nil)))
			     (cond ((firstlinep)(return nil)))
			     (prev-line)
			     (go-to-end-of-line)))
		      (return t))
		 (go-to-line-point ocl ocp)
		 (cond ((firstlinep)(return nil)))
		 (prev-line)
		 (go-to-end-of-line)))))


(declare (special ss-chunkify-last-in ss-chunkify-last-out
	        ss-chunkify-generate-meter))

(setq ss-chunkify-last-in ""
      ss-chunkify-last-out nil
      ss-chunkify-generate-meter 0)

(defun chunkify-string (s nlx)
       (cond ((eq s ss-chunkify-last-in) ss-chunkify-last-out)
	   (t (let ((l (ncons (substr s 1 nlx)))
		  (sl (stringlength s)))
		 (setq nlx (1+ nlx)
		       ss-chunkify-generate-meter
		       (1+ ss-chunkify-generate-meter))
		 (do ((chunk)(x))
		     ((null sl)
		      (setq ss-chunkify-last-in s
			  ss-chunkify-last-out (nreverse l)))
		     (setq x (e_lap_$forward-search-string s nlx NL))
		     (cond ((< x 0)
			  (setq chunk (substr s (1+ nlx)))
			  (setq ss-chunkify-generate-meter
			        (1+ ss-chunkify-generate-meter))
			  (setq sl nil))
			 (t (setq chunk (substr s (1+ nlx) x))
			    (setq nlx (+ nlx x 1))))
		     (setq l (cons chunk l)))))))

(defun search-for-first-not-charset-line (tbl)	;move point, return t/nil
       (prog (r)
	   (setq r (e_lap_$tct curpointpos (cdr tbl) curstuff))
	   (and (< (setq r (+ curpointpos r)) curlinel)
	        (return (setq curpointpos r)))))

(defun search-for-first-charset-line (tbl)	;move point, return t/nil
       (prog (r)
	   (setq r (e_lap_$tct curpointpos (car tbl) curstuff))
	   (and (< (setq r (+ curpointpos r)) curlinel)
	        (return (setq curpointpos r)))))

(defun search-back-first-not-charset-line (tbl)	;move point, return t/nil
       (prog (r)
	   (setq r (e_lap_$tctr curpointpos (cdr tbl) curstuff))
	   (cond ((> (setq r (- curpointpos r)) 0)
		(return (setq curpointpos r)))
	         ((not (zerop (boole 1
			         000000001000
			         (arraycall fixnum (cdr tbl) 2))))
		(return (setq curpointpos 0))))))

(defun search-back-first-charset-line (tbl)	;move point, return t/nil
       (prog (r)
	   (setq r (e_lap_$tctr curpointpos (car tbl) curstuff))
	   (cond ((> (setq r (- curpointpos r)) 0)
		(return (setq curpointpos r)))
	         ((not (zerop (boole 1
			         000000001000
			         (arraycall fixnum (car tbl) 2))))
		(return (setq curpointpos 0))))))

(defun charscan-table (chars)
       (let ((haves (*array (gensym) 'fixnum 128.))
	   (havenots (*array (gensym) 'fixnum 128.)))
	  (fillarray haves '(0))
	  (fillarray havenots '(0))
	  (do  ((i 1 (1+ i))
	        (chn))
	       ((> i (stringlength chars)))
	       (setq chn (getcharn chars i))
	       (store (arraycall fixnum haves (// chn 4))
		    (boole 7.	; Use this instead of "+" to avoid
				; problems when a character appears
				; in "chars" > once.
			 (arraycall fixnum haves (// chn 4))
			 (lsh 777 (* 9. (- 3 (\ chn 4)))))))
	  (do i 0 (1+ i)(= i 128.)
	      (store (arraycall fixnum havenots i)
		   (boole 6 -1 (arraycall fixnum haves i))))
	  (cons haves havenots)))

(defun charset-member (c charset)
       (or (fixp c) (setq c (getcharn c 1)))
       (not (zerop (boole 1 777 (lsh (arraycall fixnum (car charset) (// c 4))
			       (* 9. (- (\ c 4) 3)))))))

;;;	Regular Expressions `a la "QEDX"

(defun forward-regexp-search (s)
       (prog (result ix len origpos)
	   (setq origpos (set-mark))
lhoop 	   (cond ((consp curstuff)
		(setq result
		      (emacs_search_file_caller_
		        s curpointpos (car curstuff) (cdr curstuff) "")))
	         (t (setq result
		        (emacs_search_file_caller_
			s curpointpos 7777000001 0 curstuff))))
	   (setq s "")			;makes it better, I'm told.
	   (setq ix (lsh result -22) len (boole 1 result 777777))
	   (cond ((not (= ix 777777))		;found something
		(do nil ((= ix curpointpos))(forward-char))
		(release-mark origpos)
		(setq origpos (set-mark))
		(do x 1 (1+ x)(> x len) (forward-char))
		(return origpos)))
	   (cond ((lastlinep)
		(go-to-mark origpos)
		(release-mark origpos)
		(return nil)))
	   (next-line)
	   (go lhoop)))

(defun forward-regexp-search-in-line (s)
       (prog (result ix len startpos)
	   (cond ((consp curstuff)
		(setq result
		      (emacs_search_file_caller_
		        s curpointpos (car curstuff) (cdr curstuff) "")))
	         (t (setq result
		        (emacs_search_file_caller_
			s curpointpos 7777000001 0 curstuff))))
	   (setq ix (lsh result -22) len (boole 1 result 777777))
	   (cond ((not (= ix 777777))		;found something
		(do nil ((= ix curpointpos))(forward-char))
		(setq startpos (set-mark))
		(do x 1 (1+ x)(> x len) (forward-char))
		(return startpos)))
	   (return nil)))

;;; Character set searchers.
(defprop search-charset-forwards search-charset-forward expr)
(defun search-charset-forward (charset)
       (with-mark here
	        (do-forever
		(cond ((search-for-first-charset-line charset)
		       (return (curchar)))
		      ((lastlinep)
		       (go-to-mark here)
		       (return nil))
		      (t (next-line))))))

(defprop search-not-charset-forwards search-not-charset-forward expr)
(defun search-not-charset-forward (charset)
       (with-mark here
	        (do-forever
		(cond ((search-for-first-not-charset-line charset)
		       (return (curchar)))
		      ((lastlinep)
		       (go-to-mark here)
		       (return nil))
		      (t (next-line))))))

(defprop search-charset-backward search-charset-backwards expr)
(defun search-charset-backwards (charset)
       (with-mark here
	        (do-forever
		(cond ((search-back-first-charset-line charset)
		       (return (prog2 (backward-char)
				  (curchar)
				  (forward-char))))
		      ((firstlinep)
		       (go-to-mark here)
		       (return nil))
		      (t (prev-line)
		         (go-to-end-of-line))))))

(defprop search-not-charset-backward search-not-charset-backwards expr)
(defun search-not-charset-backwards (charset)
       (with-mark here
	        (do-forever
		(cond ((search-back-first-not-charset-line charset)
		       (return (prog2 (backward-char)
				  (curchar)
				  (forward-char))))
		      ((firstlinep)
		       (go-to-mark here)
		       (return nil))
		      (t (prev-line)
		         (go-to-end-of-line))))))

;;;
;;;	Whitespace hackers.
;;;	Consolidated and upgraded 9/11/78 by archy.
;;;

(mapc '(lambda (x)(putprop x t 'whiteness))(list SPACE TAB NL FF VT CRET))
(setq SPACES "                                                                                                                        ")

(setq whitespace-charactertbl
      (charscan-table (catenate SPACE TAB NL FF VT CRET)))

(defun line-is-blank ()
       (or (and (bolp)(eolp))
	 (save-excursion
	  (go-to-beginning-of-line)
	  (not (search-for-first-not-charset-line
	         whitespace-charactertbl)))))

(defun skip-over-whitespace ()
       (do-forever
        (if (search-for-first-not-charset-line whitespace-charactertbl)
	  (stop-doing))
        (if (lastlinep)
	  (go-to-end-of-line)
	  (stop-doing))
        (next-line)))

(defun skip-over-whitespace-in-line ()
       (if (search-for-first-not-charset-line whitespace-charactertbl)
	 else (go-to-end-of-line)))

(defun skip-back-whitespace-in-line ()
       (if (search-back-first-not-charset-line whitespace-charactertbl)
	 else (go-to-beginning-of-line)))

(defun skip-to-whitespace-in-line ()
   (if (search-for-first-charset-line whitespace-charactertbl)
       else (go-to-end-of-line)))

(defun skip-to-whitespace ()
       (do-forever
        (if (search-for-first-charset-line whitespace-charactertbl)
	  (stop-doing))
        (next-line)))			; No lastlinep check needed

(defun skip-back-whitespace ()
       (do-forever
        (if (search-back-first-not-charset-line whitespace-charactertbl)
	  (stop-doing))
        (if (firstlinep)
	  (go-to-beginning-of-line)
	  (stop-doing))
        (prev-line)
        (go-to-end-of-line)))

(defun skip-back-to-whitespace ()
       (do-forever
        (if (search-back-first-charset-line whitespace-charactertbl)
	  (stop-doing))
        (if (firstlinep)
	  (stop-doing))
        (prev-line)
        (go-to-end-of-line)))

(defcom delete-white-sides
        (do-forever
	(if (eolp)(stop-doing))
	(if (at-white-char)(delete-char)
	    else (stop-doing)))
        (do-forever
	(if (bolp)(stop-doing))
	(backward-char)
	(if (at-white-char)
	    (delete-char)
	    else (forward-char)
	    (stop-doing))))

;;;
;;;	Paragraph routines.
;;;	Redone totally by BSG & WMY 7/21/78
;;;

(declare (special paragraph-definition-type))
;;;(register-option 'paragraph-definition-type 1) ;;; moved to e_option_defaults_

(defun at-beginning-of-paragraph ()
       (establish-local-var 'paragraph-definition-type 1)
       (cond ((not (bolp)) nil)
	   ;; Clearly now at beginning of line,
	   ((or (eolp) (line-is-blank)) nil)
	   ;; Optimization for null line.
	   ((looking-at ".") t)
	   ;; Formatter control lines are special paragraphs,
	   ((firstlinep) t)
	   ;; First line of file is first line of paragraph.
	   ((and (= paragraph-definition-type 2)
	         (at-white-char))
	    t)
	   ;; An indented line begins a type 2 paragraph.
	   (t (save-excursion
	        (prev-line)
	        (cond ((or (looking-at ".") (line-is-blank)) t)
		    ;; Previous line blank or control like top of file.
		    ((firstlinep) nil)
		    ;; Treat hanging undent lines like control lines.
		    (t (progn (prev-line)
			    (looking-at ".unh"))))))))


(defun at-end-of-paragraph ()
       (establish-local-var 'paragraph-definition-type 1)
       (cond ((not (eolp)) nil)
	   ;; Clearly now at end of line.
	   ((or (bolp) (line-is-blank)) nil)
	   ;; Optimization for null line.
	   ((lastlinep) t)
	   ;; Last line ends paragraph.
	   ((save-excursion (go-to-beginning-of-line)
			(looking-at "."))
	    t)
	   ;; Control line is special paragraph.
	   ((and (not (firstlinep))
	         (save-excursion (prev-line)
			     (looking-at ".unh")))
	    t)
	   ;; Treat hanging undents like control lines.
	   (t (save-excursion
	        (next-line)
	        (cond ((or (looking-at ".") (line-is-blank)) t)
		    ;; Following control or blank line like end of file.
		    ((= paragraph-definition-type 2)
		     (at-white-char))
		    ;; Indentation begins new type 2 paragraph, ends this.
		    (t nil))))))

(defcom beginning-of-paragraph
        &numeric-argument (&repeat)
        &negative-function end-of-paragraph
        (if (at-beginning-of-paragraph)
	  (skip-back-whitespace)
	  (if (at-beginning-of-buffer)(command-quit)))
        (go-to-beginning-of-line)
        (do-forever
	(if (at-beginning-of-paragraph)(stop-doing))
	(if (firstlinep)(command-quit))
	(prev-line)))

(defcom end-of-paragraph
        &numeric-argument (&repeat)
        &negative-function beginning-of-paragraph
        (if (at-end-of-paragraph)
	  (skip-over-whitespace)
	  (if (at-end-of-buffer)(command-quit)))
        (do-forever
	(go-to-end-of-line)
	(if (at-end-of-paragraph)(stop-doing))
	(if (lastlinep)(command-quit))
	(next-line)))


(defcom mark-paragraph
        (if (at-beginning-of-paragraph)
	  (set-the-mark)
	  (end-of-paragraph)
	  else
	  (if (at-end-of-paragraph)
	      (set-the-mark)
	      (beginning-of-paragraph)
	      (exchange-point-and-mark)
	      else
	      (beginning-of-paragraph)
	      (set-the-mark)
	      (end-of-paragraph))))

;;;
;;;	Buffers and the multi-plexing thereof.
;;;	 (New buffer state management, GMP, 09/26/78)
;;;

;;; This template defines the saved state of a buffer.
(setq buf-state-template
      '((marklist)(curline-marklist) (buffer-modified-flag) (curstuff)
        (curline) (curlinel) (curpointpos) (fpathname) (buffer-tempsegs)
        (buffer-uid) (buffer-file-dtcm) (firstline) (lastline) (der-wahrer-mark)
        (current-buffer-mode) (per-buffer-key-bindings) (fill-prefix)
        (fill-column) (comment-column) (comment-prefix) (tab-equivalent)
        (buffer-minor-modes) (buffer-locvars) (read-only-flag)
        (number-of-lines-in-buffer) (hard-enforce-fill-column)
        (mark-ring) (named-mark-list) (display-linechange-interrupt-hook)))

;;; Buffer hooks.  RMSoley 1 July 1981
;;; Hooks for the life of your buffer.
(defhook buffer-creation-hook)
(defhook buffer-entrance-hook)
(defhook buffer-exit-hook)
(defhook buffer-destruction-hook)

(defun destroy-buffer-contents ()
       (go-to-beginning-of-buffer)
       (with-mark here
	        (go-to-end-of-buffer)
	        (without-saving
		(wipe-point-mark here)))
       (release-temp-segments buffer-tempsegs)
       (setq buffer-tempsegs nil))

;;; Create a new buffer
(defun buffer-factus-est (bufnam)
       (and minibufferp (command-quit))
       (putprop bufnam (subst nil nil buf-state-template) 'buffer-state)
       ;; give buffer initial state
       (buffer-in-nihilem-factus-est)
       (setq per-buffer-key-bindings nil
	   buffer-minor-modes nil
	   buffer-modified-flag nil
	   buffer-locvars nil
	   read-only-flag nil
	   current-buffer bufnam)
       (or (memq bufnam known-buflist)
	 (setq known-buflist (cons bufnam known-buflist)))
       (fundamental-mode)
       (hook-function buffer-creation-hook))

;;; Destroy buffer's contents
(defun buffer-in-nihilem-factus-est ()
       (setq curstuff NLCHARSTRING		;hic incipit omnia
	   curline (cons curstuff (ncons nil))
	   curlinel 1
	   curpointpos 0
	   number-of-lines-in-buffer 1
	   fpathname nil
	   buffer-tempsegs nil
	   buffer-uid 0
	   buffer-file-dtcm 0
	   der-wahrer-mark nil
	   marklist nil			;let marks not inhib gc
	   curline-marklist nil
	   mark-ring (make-kill-ring 10.)
	   named-mark-list nil
	   firstline curline
	   lastline curline))


;;; Establish bare EMACS mode
(defcom fundamental-mode
        (revert-local-key-bindings)
        (setq buffer-minor-modes nil
	    per-buffer-key-bindings nil
	    fill-prefix ""
	    fill-column default-fill-column
	    hard-enforce-fill-column nil
	    display-linechange-interrupt-hook nil
	    tab-equivalent 10.
	    comment-prefix ""
	    comment-column default-comment-column
	    current-buffer-mode 'Fundamental))

(defun exists-buffer (buffer-name)
       (memq buffer-name known-buflist))

;;; Kill the named buffer
(defun buffer-kill (bufnam)
       (cond ((get bufnam 'buffer-delenda-est))	;avoid recursion from
	   (t (putprop bufnam t 'buffer-delenda-est) ;redisplay
	      (hook-function buffer-destruction-hook)
	      (redisplay-purge-buffer bufnam)
	      (buffer-destroy-annihilate-named-marks
	        (get-buffer-state bufnam 'named-mark-list) bufnam)
	      (release-temp-segments
	        (get-buffer-state bufnam 'buffer-tempsegs))
	      (setq known-buflist (delq bufnam known-buflist))
	      (remprop bufnam 'buffer-state)
	      (remprop bufnam 'dont-notice-modified-buffer)
	      (remprop bufnam 'temporary-buffer)
	      (remprop bufnam 'buffer-delenda-est)
	      (cond ((eq bufnam current-buffer)
		   (setq current-buffer
		         (car known-buflist)))
		  (t nil)))))

(defun dont-notice-modified-buffer (buf)
       (putprop buf t 'dont-notice-modified-buffer))

;;; Reinitialize buffer
(defun reinitialize-current-buffer ()
       (redisplay-buffer-reinit-purge current-buffer)
       (buffer-destroy-annihilate-named-marks named-mark-list current-buffer)
       (release-temp-segments buffer-tempsegs)
       (buffer-in-nihilem-factus-est))

;;; Get rid of all the named marks
(defun buffer-destroy-annihilate-named-marks (loc-marklist bufnam)
       (and loc-marklist			;cheap bum to avoid 1 cons
	  (setq bufnam (mark-tag-fun bufnam)))
       (mapc '(lambda (x)(remprop x bufnam)) loc-marklist))

(defun mark-tag-fun (name)
       (make_atom (catenate name ".mark_tag")))

;;; Save state of current buffer
(defun save-buffer-state ()
       (close-line)
       (setq previous-buffer current-buffer)
       (revert-local-key-bindings)
       ;; Store old and instate new buffer variables.
       (mapc '(lambda (x)
		  (rplacd (cdr x) (symeval (car x)))
		  (set (car x) (cadr x)))	;old value
	   buffer-locvars)
       (mapc '(lambda (x)			;save state values
		  (rplacd x (symeval (car x))))
	   (get current-buffer 'buffer-state))
       (cond ((get current-buffer 'temporary-buffer)
	    (buffer-kill current-buffer)
	    (setq previous-buffer (car known-buflist)))))

;;; Set buffer to die.
(defun set-buffer-self-destruct (bufnam)
       (putprop bufnam t 'temporary-buffer))

;;; Retrieve the specified buffer's state
(defun retrieve-buffer-state (bufnam)
       (mapc '(lambda (x)			;get state values
		  (set (car x) (cdr x)))
	   (get bufnam 'buffer-state))
       (instate-local-key-bindings)
       (setq current-buffer bufnam)	;this is not the current buffer
       (mapc '(lambda (x)			;setup local variables
		  (rplaca (cdr x) (and (boundp (car x)) (symeval (car x))))
		  (set (car x) (cddr x)))
	   buffer-locvars)
       (cond (macro-collection-in-progress
	     (assert-minor-mode '|Macro Learn|))
	   (t (negate-minor-mode '|Macro Learn|))))

;;; Get the value of the specified state of the specified buffer
(defun get-buffer-state (bufnam state-name)
       (cond ((eq bufnam current-buffer)
	    (symeval state-name))
	   (t (cdr (or (assq state-name (get bufnam 'buffer-state))
		     (error "get-buffer-state: can't for"
			  (cons bufnam state-name)
			  'fail-act))))))

;;; Delete a mark from the specified buffer
;;; This is used by redisplay, q.v.
(defun del-mark-from-buffer (m bufnam)
       (cond ((eq bufnam current-buffer) (release-mark m))
	   (t (and m bufnam
		 (let ((bufstat (get bufnam 'buffer-state)))
		      (let ((gl-assq-value (assq 'marklist bufstat))
			  (curl-assq-value (assq 'curline bufstat))
			  (lc-assq-value
			    (assq 'curline-marklist bufstat)))
			 (let ((marklist (cdr gl-assq-value))
			       (curline (cdr curl-assq-value))
			       (curline-marklist (cdr lc-assq-value)))
			      (release-mark m)
			      (and gl-assq-value
				 (rplacd gl-assq-value marklist))
			      (and lc-assq-value
				 (rplacd lc-assq-value
				         curline-marklist)))))))))

;;; Instate new minor mode in current buffer
(defun assert-minor-mode (mode)
       (setq damaged-flag t)
       (or (memq mode buffer-minor-modes)
	 (setq buffer-minor-modes (cons mode buffer-minor-modes))))

;;; Remove minor mode from current buffer
(defun negate-minor-mode (mode)
       (setq damaged-flag t)			;oh barf
       ;; Copy for benefit of mode line redisplay.
       (setq buffer-minor-modes
	   (subst nil nil (delq mode buffer-minor-modes))))


(declare (*expr require-symbol))

;;; Register a local buffer variable
(defun register-local-var (v)
       (require-symbol v)
       (or (boundp v) (set v nil))
       (let ((assoc-answer (assq v buffer-locvars)))
	  (cond (assoc-answer (rplacd (cdr assoc-answer) nil))
	        (t (setq buffer-locvars
		       (cons (cons v (ncons (symeval v)))
			   buffer-locvars))))))


;;; Register a local buffer variable supplying default value
(defun establish-local-var (v default)
       (require-symbol v)
       (cond ((assq v buffer-locvars))
	   (t (or (boundp v) (set v default))
	      (register-local-var v))))


;;; Switch to existing buffer
(defun go-to-buffer (bufnam)
       (and minibufferp (command-quit))
       (let ((prop (get bufnam 'buffer-state)))
	  (cond ((eq current-buffer bufnam))
	        (prop
		(hook-function buffer-exit-hook)
		(redisplay-leave-buffer)
		(save-buffer-state)
		(retrieve-buffer-state bufnam)
		(hook-function buffer-entrance-hook))
	        (t (error "go-to-buffer: Non-existent buffer: "
		        bufnam
		        'fail-act)))))

;;; Switch to buffer creating if necessary
(defun go-to-or-create-buffer (bufnam)
       (and minibufferp (command-quit))
       (cond ((eq bufnam current-buffer))
	   ((memq bufnam known-buflist)(go-to-buffer bufnam))
	   ((= (stringlength bufnam) 0)
	    (go-to-or-create-buffer previous-buffer))
	   (t (hook-function buffer-exit-hook)
	      (save-buffer-state)
	      (setq current-buffer bufnam)
	      (buffer-factus-est bufnam)
	      (hook-function buffer-entrance-hook))))


;;; Map supplied function over all buffers
(defun map-over-emacs-buffers (function argument)
       (mapc '(lambda (x)
		  (funcall function x argument))
	   known-buflist))


;;; This predicate returns t if the specified buffer is empty
(defun empty-buffer-p (bufnam)
       (cond ((memq bufnam known-buflist)
	    (and (eq (get-buffer-state bufnam 'firstline)
		   (get-buffer-state bufnam 'lastline))
	         (= (get-buffer-state bufnam 'curlinel) 1)))
	   (t t)))		;not a buffer, claim its empty


;;; Set buffer modified flag, announcing if needed
(defun buffer-has-been-modified--take-note ()
       (cond (read-only-flag
	     (cond ((eq t read-only-flag)
		  (report-error 'read-only))
		 (t (funcall read-only-flag))))
	   (buffer-modified-flag)
	   ((get current-buffer 'temporary-buffer))  ;don't count.
	   ((and (not tty-no-upmotionp)
	         (not (empty-buffer-p current-buffer))
	         (display-error-remark "Modified.")))
	   (t nil))
       (setq buffer-modified-flag t))

;;; Yanking primitives.

(defun make-kill-ring (n)
       (do ((i 1 (1+ i))
	  (this (cons nil (cons nil nil))
	        (cons nil (cons prev nil)))
	  (prev nil this)
	  (first))
	 ((> i n)
	  (rplaca (cdr first) prev)
	  (rplacd (cdr prev) first)
	  prev)

	 (and prev (rplacd (cdr prev) this))
	 (and this (rplaca (cdr this) prev))
	 (and (= i 1)(setq first this))))


(defun killsave-reverse-list (l)(killsave-list (nreverse l)))
(defun killsave-char (c)(killsave-string (ItoC (getcharn c 1))))
(defun killsave-list (l)(killsave-string (apply-catenate l)))
(defun killsave-string (s)
       (cond ((null kill-ring)
	    (let ((c (ncons s))
		(ele (ncons nil)))
	         (rplacd ele c)
	         (rplaca ele c)
	         (rplacd c ele)
	         (setq kill-ring c kill-ring-current-size 1)))
	   ((< kill-ring-current-size kill-ring-max-size)
	    (let ((c (ncons s))
		(ele (ncons nil))
		(forward kill-ring)
		(backward (cadr kill-ring)))
	         (rplacd c ele)
	         (rplaca ele backward)
	         (rplacd ele forward)
	         (let ((eforward (cdr forward))
		     (ebackward (cdr backward)))
		    (rplaca eforward c)
		    (rplacd ebackward c))
	         (setq kill-ring c
		     kill-ring-current-size (1+ kill-ring-current-size))))
	   (t 
	     (setq kill-ring (cadr kill-ring))
	     (rplaca kill-ring s))))

(defun kill-ring-top ()
       (or kill-ring (report-error 'empty-kill-ring))
       (car kill-ring))

(defun rotate-kill-ring ()
       (setq kill-ring (cddr kill-ring)))

(defun kill-pop ()				;fixed to close ring 8/3/80
       (prog1 (kill-ring-top)
	    (rotate-kill-ring)))

(defun kill-pop-symbol ()
       (let ((popped (kill-pop)))
	  (cond ((symbolp popped)(intern popped))
	        (t (intern (make_atom popped))))))

(defun merge-kills-forward ()
       (cond ((and (get previous-command 'kills)
	         (> kill-ring-current-size 1)
	         (not dont-stash))
	    (let ((top (kill-pop))
		(bot (kill-pop)))
	         (killsave-string (catenate bot top))))))

(defun merge-kills-reverse ()
       (cond ((and (get previous-command 'kills)
	         (> kill-ring-current-size 1)
	         (not dont-stash))
	    (let ((top (kill-pop))
		(bot (kill-pop)))
	         (killsave-string (catenate top bot))))))

;;;
;;;	Startup time functions.
;;;

(defun editor-main-init ()
       (setq multesque-readtable (get (makreadtable t) 'array))
       (let ((readtable multesque-readtable))
	  (sstatus syntax 56 2)	; = .
	  (sstatus syntax 57 2)	; = /
	  (sstatus syntax 47 2)	; = '
	  (sstatus syntax 73 2))	; = ;
       (putprop 'xr-backquote-macro
	      (catenate lisp-system-dir ">lisp_backquote_")
	      'autoload)
       (setsyntax '/` 'macro 'xr-backquote-macro)
       (setq process-dir (e_lap_$trim (get_pdir_)))
       (setq work-seg (e$get_temporary_seg))
       (setq work-string (e_lap_$make-dat-ol-black-magic-string work-seg))
       (setq building-buf (e_lap_$make-dat-ol-black-magic-string
		        (e$get_temporary_seg)))
       (setq pdir-temp-ename "!!emacs!!tempbufferimage!!"
	   pdir-temp-pathname (catenate process-dir ">" pdir-temp-ename))
       (setq known-buflist nil minibufferp nil)
       (setq default-fill-column 78. default-comment-column 60.)
       (setq last-minibuf-response "")

       ;buffer for start_up to play in
       (buffer-factus-est '|<start_up_emacs_buffer>|)

       (putprop current-buffer t 'temporary-buffer)
       (setq previous-buffer current-buffer)
       (setq dont-stash nil
	   dont-damage-flag nil
	   damaged-flag t
	   target-screen-hpos 0
	   touchy-damaged-flag t)
       (setq kill-ring nil)
       (setq kill-ring-current-size 0)
       (setq search-ring (make-kill-ring 20.))
       (setq last-search-string ""))

;;;(register-option 'kill-ring-max-size 10.) ;;; moved to e_option_defaults_
;;;(register-option 'default-fill-column 78.) ;;; moved to e_option_defaults_
;;;(register-option 'default-comment-column 60.) ;;; moved to e_option_defaults_

(declare (special no-minibuffer-<>))
;;; Whether or not to quit when BREAK is hit during emacs_ invocation.
;;;(register-option 'quit-on-break t) ;;; moved to e_option_defaults_
;;;(register-option 'no-minibuffer-<> nil) ;;; moved to e_option_defaults_
;;;(register-option 'underline-whitespace nil) ;;; moved to e_option_defaults_

;;;
;;;	The minibuffer.
;;;

(defprop minibuf-response minibuffer-response expr)
(declare (special last-minibuffer-response remember-empty-response))
;;; Remember <CR> responses?
;;;(register-option 'remember-empty-response 't) ;;; moved to e_option_defaults_

;;; Updated for splits, Sept 85 EDSchroth

(declare (*expr rdis-enter-split))
(defvar (current-split
	screenlinelen
	screenheight
	main-window-size
	screen
	eline-conts
	windows
	nwindows
	minibuffer-split))

(defun minibuffer-response lexpr
       (close-line)
       (let ((curline (make-eline))
	   (line-control:buffer 0)
	   (curlinel 1)
	   (curpointpos 0)
	   (curstuff (cond ((< lexpr 3) NLCHARSTRING)
		         (t (catenate (arg 3) NLCHARSTRING))))
	   (numarg nil)
	   (firstline nil)
	   (lastline nil)
	   (recursive-minibufferp minibufferp)
	   (minibufferp (cond ((< lexpr 2) NL)
			  ((fixp (arg 2)) (ascii (arg 2)))
			  (t (arg 2))))
	   (marklist nil)
	   (curline-marklist nil)
	   (der-wahrer-mark nil)
	   (fill-prefix "")
	   (buffer-modified-flag t)
	   (read-only-flag nil)
	   (display-linechange-interrupt-hook nil)
	   (damaged-flag t)
	   (touchy-damaged-flag t)
	   (hard-enforce-fill-column nil)
	   (minibuffer-prompt-string (catenate "     " (arg 1)))
	   ;;save current split info away
	   (current-split current-split)
	   (screenlinelen screenlinelen)
	   (screenheight screenheight)
	   (main-window-size main-window-size)
	   (screen screen)
	   (eline-conts eline-conts)
	   (windows windows)
	   (nwindows nwindows))

	  (setq curlinel (stringlength curstuff))
	  (setf (eline-contents curline) curstuff)
	  (setq lastline curline firstline curline)
	  (if (not recursive-minibufferp)
	      (revert-local-key-bindings))
	  (rdis-enter-split minibuffer-split)	;activate correct split
					;this does not actually move
					;cursor, redisplay will.
	  (protect
	    (catch (charlisten) gazonga)
	    &failure
	    (minibuffer-clear)
	    &success
	    (cond ((or macro-execution-in-progress
		     suppress-redisplay-flag
		     rdis-suppress-redisplay
		     no-minibuffer-<>))
		(t (redisplay)
		   (minibuffer-print-noclear
		     minibuffer-end-string))))
	  (if (not recursive-minibufferp)
	      (instate-local-key-bindings))
	  (or macro-execution-in-progress
	      rdis-suppress-redisplay
	      (redisplay))
	  (let ((it (curbuf-as-string)))
	       (or (and (nullstringp it) (not remember-empty-response))
		 (setq last-minibuffer-response
		       (setq last-minibuf-response it)))
	       it)))

(defun jetteur-des-gazongues () (throw 'les-grandes-gazongues gazonga))

;;; Read from the minibuffer and strip whitespace.
(defprop trim-minibuf-response trim-minibuffer-response expr)
(defun trim-minibuffer-response lexpr
       (e_lap_$trim
         (minibuffer-response (arg 1)
			(cond ((> lexpr 1) (arg 2))
			      (t NL)))))

;;; Read from the minibuffer and return a symbol.
(defprop intern-minibuf-response intern-minibuffer-response expr)
(defun intern-minibuffer-response lexpr
       (intern
         (make_atom
	 (e_lap_$trim
	   (minibuffer-response (arg 1)
			    (cond ((> lexpr 1) (arg 2))
				(t NL)))))))

(args 'minibuf-response '(1 . 3))
(args 'trim-minibuf-response '(1 . 2))
(args 'intern-minibuf-response '(1 . 2))
(args 'minibuffer-response '(1 . 3))
(args 'trim-minibuffer-response '(1 . 2))
(args 'intern-minibuffer-response '(1 . 2))

;;; Ask a question requiring a yes/no response
(defun yesp (question)
       (do ((response))
	 (nil)
	 (setq response
	       (trim-minibuf-response (catenate (e_lap_$rtrim question)
					"  ")
				NL))
	 (cond ((samepnamep response "no")  (return nil))
	       ((samepnamep response "yes") (return t))
	       ((samepnamep response "n")   (return nil))
	       ((samepnamep response "y")   (return t))
	       (t (init-local-displays)
		(local-display-generator-nnl
		  "Please answer ""yes"" or ""no"".")
		(ring-tty-bell)))))

;;;
;;;	Manipulate default search string(s)
;;;	 J. Spencer Love, 14 May 1982
;;;

(defun get-search-string (prompt)
       (search:maybe-push-default (search:prompt prompt) 'string))


(declare (special search:ring))

(setq search:ring (make-kill-ring 20.))


(defun search:maybe-push-default (string type)
       (cond ((samepnamep string (search:last-string))
	    (cond ((not (eq type (search:last-type)))
		 (search:set-ring-top string type))))
	   ((< (stringlength (search:last-string)) 2)
	    (search:set-ring-top string type))
	   (t (search:push-ring string type)))
       string)


(defun search:prompt (prompt)
       (let ((completion-list)
	   (default (search:last-string)))
	  (cond ((nullstringp default)
	         (setq prompt (catenate prompt ": ")))
	        (t (setq prompt (catenate prompt " ("
				    default "): "))))
	  (setq completion-list (list default))
	  (setq prompt (minibuffer-response prompt))
	  (cond ((not (nullstringp prompt)) prompt)
	        ((not (nullstringp default)) default)
	        (t (display-error "There is no default search string.")))))


(defun search:numeric-prompt (prompt)
       (cond ((and numarg (not (= numarg 1)))
	    (catenate prompt " [" (decimal-rep numarg) " times]"))
	   (t prompt)))
	     

(defun search:last-string ()
       (cond ((car search:ring) (caar search:ring))
	   (t "")))


(defun search:last-type ()
       (cond ((car search:ring) (cdar search:ring))
	   (t nil)))


(defun search:set-ring-top (string type)
       (cond ((car search:ring)
	    (rplaca (car search:ring) string)
	    (rplacd (car search:ring) type))
	   (t (rplaca search:ring (cons string type))))
       (setq last-search-string string))


(defun search:push-ring (string type)
       (setq search:ring (cadr search:ring))
       (search:set-ring-top string type))


(defun search:pop-ring ()
       (setq last-search-string
	   (cond ((car search:ring)
		(let ((result (caar search:ring)))
		     (setq search:ring (cddr search:ring))
		     result))
	         (t ""))))


(defun search:rotate-ring ()
       (cond ((car search:ring)
	    (let ((result (caar search:ring)))
	         (do () (nil)
		   (setq search:ring (cddr search:ring))
		   (and (car search:ring) (return nil)))
	         result))
	   (t "")))

(defun nullstringp (x)
       (= (stringlength x) 0))

;;; Utility functions.

(defun curline-as-string ()
       (cond((eq curstuff work-string)(substr work-string 1))
	  ((stringp curstuff) curstuff)
	  (t (filerep-to-string curstuff))))


(defun curchar ()
       (ascii (e_lap_$ggcharn curstuff curpointpos)))


(defun insert-string (s)
       (note-modified-buffer)
       ;;open line will unconditionally cause damaged flag.
       (do ((cx 1)
	  (sl (stringlength s))
	  (nlx 0)
	  (chunk-length 0))
	 ((> cx sl))
	 (setq chunk-length (- sl cx -1))
	 (e_lap_$rplacstring-offset building-buf s chunk-length 0 chunk-length (1- cx))
	 (setq nlx (index building-buf NL))
	 (open-line)
	 (let ((insertl (cond ((= 0 nlx) chunk-length)
			  (t (1- nlx)))))
	      (relocate-marks curline insertl 'c+)
	      (e_lap_$insert-chars work-string curpointpos building-buf insertl)
	      (setq curpointpos (+ insertl curpointpos))
	      (setq curlinel (+ insertl curlinel))
	      (setq cx (+ cx insertl)))
	 (cond ((= nlx 0))
	       (t (insert-char NL)		; might like new-line- open to debate. 6/14/78
		(setq cx (1+ cx))))))

(defun apply-catenate (list)			;General utility 7/30/79 BSG
	 (e_lap_$rplacstring building-buf "" 0 0 0)
	 (do ((s list (cdr s))
	      (cl)(ll 0))
	     ((null s)(substr building-buf 1))
	     (setq cl (stringlength (car s)))
	     (e_lap_$rplacstring building-buf (car s)
			     cl ll (setq ll (+ ll cl)))))

(defun curbuf-as-string ()
       (go-to-beginning-of-buffer)
       (with-mark m
	        (go-to-end-of-buffer)
	        (point-mark-to-string m)))

;;;
;;; Error System for Multics Emacs.
;;; Richard Mark Soley, 26 June 1981
;;; To standardize and Multics-ize the error reporting of Emacs.
;;;
;;;
;;; To use the new error-reporting routine, report-error, call:
;;;
;;; (report-error error-code additional_information)
;;;
;;; Where error-code may be:
;;;   (1) An Emacs standard error code  (see list below).
;;;   (2) A Multics standard error code (from PL/1).
;;;   (3) Any error_table type error code (from PL/1, fixed bin (35.))
;;;   (4) Any error code, symbolically (i.e. 'error_table$moderr)
;;;   (5) An asterisk ('*), signifying that the bell should be rung.
;;;   (6) Any string, to be appended to "Error: ".
;;; and additional_information is more information about the error,
;;; to be printed.
;;; 
;;; The function report-error-noabort has an identical calling sequence,
;;; but does not abort the current command as report-error does.
;;;

(declare
  (special SPACE SPACES error-system:error-codes error-system:known-tables
	 null-pointer))

;;; The standard error codes.
;;; An asterisk (*) specifies that no error message should be printed.
(setq error-system:error-codes
      '(
      (bad-error-code	"Invalid error code identifier.")
      (bad-error-message	"Invalid error message: must be string or *.")
      (beginning-of-buffer	*)
      (empty-kill-ring	"Nothing in the kill ring.")
      (end-of-buffer	*)
      (need-mark-name	"You must supply a mark name.")
      (no-named-mark	"Named mark not found in buffer.")
      (mark-not-set		"The mark has not been set.")
      (object-seg		"File is an object segment.")
      (read-only		"Attempt to modify read-only buffer.")
      ))

;;; Add or change an entry in the error table.
(defun add-error-code (code message)
       (or (symbolp code)
	 (report-error 'bad-error-code SPACE code))
       (or (stringp message) (eq message '*)
	 (report-error 'bad-error-message SPACE message))
       (setq error-system:error-codes
	   (cons (list code message)
	         error-system:error-codes)))

;;; Return octal ASCII representation of a number.
(defun octal-rep (number)
       (let ((base 8.)) (maknam (exploden number))))

;;; Toplevel error reporter.
(defun report-error lexpr
       (let ((code (error-system:error-action (arg 1))))
	  (cond ((eq code '*) (command-quit))
	        ('else
		(apply 'display-error
		       (cons code
			   (error-system:canonicalize
			     (cdr (listify lexpr)))))))))

;;; Same as above, but doesn't abort.
(defun report-error-noabort lexpr
       (let ((code (error-system:error-action (arg 1))))
	  (cond ((eq code '*) (ring-tty-bell))
	        ('else
		(apply 'display-error-noabort
		       (cons code
			   (error-system:canonicalize
			     (cdr (listify lexpr)))))))))

;;; Canonicalize objects so that catenate can handle them.
(defun error-system:canonicalize (list)
       (mapcar '(lambda (x)
		    (cond ((numberp x) (decimal-rep x))
			((atom x) x)
			('else (decimal-rep x))))
	     list))

;;; Find out correct error action from error-system:table.
(defun error-system:error-action (code-name)
       (let ((found (assq code-name error-system:error-codes)))
	  (cond (found (cadr found))
	        ((numberp code-name)
	         (e_lap_$rtrim (cadr (convert_status_code_ code-name))))
	        ((eq code-name '*) '*)
	        ((not (zerop (setq found (index code-name "$"))))
	         (e_lap_$rtrim
		 (cadr
		   (convert_status_code_
		     (error-table
		       (substr code-name 1 (1- found))
		       (substr code-name (1+ found)))))))
	        ('else
		(catenate "Error: " code-name)))))

;;; Returns string representation of object, using decimal read base.
(defun decimal-rep (x)
       (let ((base 10.) (ibase 10.) (*nopoint t))
	  (maknam (exploden x))))

;;;
;;; Replacment for BSG's old error_table hack for Emacs, to access
;;; any number of error tables.
;;; Richard Mark Soley, 26 June 1981
;;;

(setq error-system:known-tables () null-pointer 007777000001)

;;; Top level function, called like (error-table 'error_table_ 'badopt)
;;; Returns number convert_status_code_ can grok.
;;; Memoizes values (to conserve hcs_$make_ptr calls) by putting value on
;;; table's name property of code-name. (Thank you, RSL - RMSoley)
(defun error-table (table-name code-name)
       (setq table-name (make_atom table-name)
	   code-name (make_atom code-name))
       (or (get code-name table-name)
	 (putprop code-name
		(arraycall fixnum
			 (error-system:get-array table-name code-name)
			 (error-system:get-code table-name code-name))
		table-name)))

;;; Get ptr to error table, store away if we haven't seen it before.
(defun error-system:get-array (table code)
       (or (cdr (assq table error-system:known-tables))
	 (let ((ptr (hcs_$make_ptr null-pointer table code)))
	      (or (zerop (cadr ptr))
		(display-com-error (cadr ptr) table))
	      (setq error-system:known-tables
		  (cons
		    (cons table
			(*array nil 'external
			        (boole 1 (car ptr) 007777000000)
			        777777))
		    error-system:known-tables))
	      (cdar error-system:known-tables))))

;;; Get ptr to entry in table.
(defun error-system:get-code (table code)
       (let ((ptr (hcs_$make_ptr null-pointer table code)))
	  (or (zerop (cadr ptr))
	      (display-com-error (cadr ptr) table "$" code))
	  (boole 1 (car ptr) 000000777777)))

;;; For compatability: implements access to standard error_table_.

(defun error_table_ (code) (error-table 'error_table_ code))

;;; This is the guts of line control.
;;; 24 June 1981 Richard Mark Soley

;;; The format of a line-control template:
;;;
;;; ( (x1 y1 flag1) (x2 y2 flag2) . . .)
;;;
;;; If the current hpos is in the range x1 <= hpos <= y1, then:
;;; If flag1 = nil, give read-only message.
;;; If flag1 = t, allow modification.
;;; Else, do (funcall flag1)
;;;

(setq line-control:buffer nil line-control:template)

;;; Turn on line control.
(defun line-control:on (template)
       (line-control:instate-template template)
       (register-local-var 'line-control:buffer)
       (setq line-control:buffer current-buffer)
       (setq read-only-flag 'line-control:handler))

;;; Turn off line control.
(defun line-control:off ()
       (setq read-only-flag nil line-control:template nil))

;;; Check validity of line control template and install if OK.
(defun line-control:instate-template (template)
       (do ((tem template (cdr tem)))
	 ((null tem)
	  (register-local-var 'line-control:template)
	  (setq line-control:template template))
	 (let ((x (caar tem))
	       (y (cadar tem))
	       (f (caddar tem)))
	      (and (or (not (symbolp f))
		     (not (numberp x))
		     (and (not (numberp y)) 
			(not (and (eq y '>) (null (cdr tem)))))
		     (and (numberp y)
			(> x y)))
		 (error "Bad line-control template supplied."
		        (car tem)
		        'fail-act)))))

;;; Handler for changes of buffer.
;;; This gets called by buffer-has-been-modified--take-note
(defun line-control:handler ()
       (line-control:check (cur-hpos)))

(defun line-control:validate (function)
       (cond ((null function)
	    (display-error "Attempt to modified protected region."))
	   ((eq function t))
	   ('else (funcall function))))

;;; The guts of line control checking.
;;; Takes three kinds of objects:
;;; 'end => check to the end of the line.
;;; a number => check for that number.
;;; a mark => check forward to the mark.
(defun line-control:check (object)
       (let ((hpos (cur-hpos)))
	  (cond ((eq object 'end)
	         (do ((tem line-control:template (cdr tem)))
		   ((null tem))
		   (let ((x (car tem)))
		        (and (not (< hpos (car x)))
			   (or (eq (cadr x) '>)
			       (not (> hpos (cadr x))))
			   (return
			     (mapc '(lambda (y)
					(line-control:validate
					  (caddr y)))
				 tem))))))
	        ((numberp object)
	         (do ((tem line-control:template (cdr tem)))
		   ((null tem))
		   (let ((x (car tem)))
		        (and (not (< object (car x)))
			   (or (eq (cadr x) '>)
			       (not (> object (cadr x))))
			   (return
			     (line-control:validate (caddr x)))))))
	        ((mark-on-current-line-p object)
	         (line-control:check-region hpos (cdr object)))
	        ('else
		(line-control:check 'end)
		(do ((line curline (eline-next line))
		     (count 0 (1+ count)))
		    ((or (> count 1)
		         (eq line (car object)))
		     (and (> count 1)
			(mapc '(lambda (y) 
				     (line-control:validate (caddr y)))
			      line-control:template))
		     (line-control:check-region 0 (cdr object))))))))
		    
(defun line-control:check-region (from to)
       (do ((tem line-control:template (cdr tem))
	  (found-from nil)
	  (last nil))
	 ((or last (null tem)))
	 (let ((x (caar tem))
	       (y (cadar tem))
	       (f (caddar tem)))
	      (cond (found-from
		    (and (not (< to x))
		         (or (eq y '>)
			   (not (> to y)))
		         (setq last t))
		    (line-control:validate f))
		  ((and (not (< from x))
		        (or (eq y '>)
			  (not (> from y))))
		   (setq found-from t)
		   (line-control:validate f))))))

;;; COMMANDS

;;;
;;;	Character movement and deletion.
;;;

(defun cur-hpos ()			;copped from rdis, 5/8/79, bsg
       (do ((origstrl (1- curlinel))
	  (strx 0)(ocol 0)(tabx)(lies 0))
	 ((not (< strx curpointpos))
	  (+ curpointpos lies))
	 (setq tabx (e_lap_$tabscan curstuff origstrl strx))
	 (setq strx (+ strx tabx) ocol (+ ocol tabx))
	 (cond ((not (< strx curpointpos))
	        (return (+ curpointpos lies))))
	 (let ((ch (e_lap_$ggcharn curstuff strx)))
	      (cond ((= ch 11)
		   (setq tabx (- tab-equivalent (\ ocol tab-equivalent))))
		  ((= ch 10)(setq tabx -1))
		  ((or (= ch 14)(= ch 15))(setq tabx (- ocol)))
		  (t (setq tabx 0))))
	 (setq lies (+ -1 lies tabx) ocol (+ ocol tabx)) ; -1 for orig tab char
	 (and (< ocol 0)(setq ocol 0))
	 (setq strx (1+ strx))))		;end of do- answer in strg

;;; Self-insert with undo function (ACW's idea)
(defcom self-insert
        &no-break
        &numeric-argument (&repeat &lower-bound 0)
        &undo de-self-insert
        (insert-char last-input-char))

(defcom de-self-insert
        (save-excursion
	(cond ((reverse-search-in-line last-input-char)
	       (redisplay)
	       (sleep .2)			;pause at character
	       (delete-char))		;then get rid of it.
	      (t (display-error last-input-char " not found")))))

;;; The \ command: simulate Multics octal escape.
(defcom escape-char
        &numeric-argument (&pass &lower-bound 0)
        (let ((first-char (get-char))
	    (the-char)		; will be result to insert
	    (char-to-execute -1))	; non digit read to be processed
	   (if (or (< first-char (CtoI "0")) (> first-char (CtoI "7")))
	       (if (not (member first-char MCS-editing-characters))
		 (insert-char MCS-escape-character))
	       (setq the-char (ascii first-char))	; insert it
	       ;; an octal digit, read escape sequence
	       else
	       (setq the-char (- first-char (CtoI "0")))	; current value
	       (do-times 2		; at most, two more chars to read
		       (let ((next-char (get-char)))
			  (if (or (< next-char (CtoI "0"))
				(> next-char (CtoI "7")))
			      (setq char-to-execute next-char)
			      (stop-doing))	; non-digit, stop now
			  (setq the-char (+ (* the-char 8.)
					(- next-char (CtoI "0")))))))
	   ;; have value to insert
	   (if (numberp the-char)
	       (setq the-char (ascii the-char)) ;cr fixed 9/12/80 bsg
	       else
	       (if (eq the-char CRET)(setq the-char NL)))
	   (do-times (or numarg 1)
		   (insert-char the-char))
	   (if (not (= char-to-execute -1))
	       (setq numarg nil)
	       (process-char char-to-execute))))

(defcom forward-char-command
        &numeric-argument (&pass)
        &negative-function backward-char-command
        &undo backward-char-command
        (cond (numarg (forward-n-chars numarg))
	    (t (forward-char))))

(defun forward-n-chars (n)
       (declare (fixnum n))
       (and (minusp n) (backward-n-chars (- n)))
       (do ((line-left (- curlinel curpointpos 1) ;curlinel includes the newline
		   (- curlinel curpointpos 1)))
	 (())				;do-forever
	 (cond ((not (> n line-left))		;same line
	        (setq curpointpos (+ curpointpos n))
	        (stop-doing))
	       ((lastlinep) (command-quit))	;can't go down
	       (t (setq n (- n line-left 1))	;go down one
		(next-line)))))

(defcom backward-char-command
        &numeric-argument (&pass)
        &negative-function forward-char-command
        &undo forward-char-command
        (cond (numarg (backward-n-chars numarg))
	    (t (backward-char))))
 
(defun backward-n-chars (n)
       (declare (fixnum n))
       (if (minusp n) (forward-n-chars (- n)))
       (do-forever
         (cond ((not (> n curpointpos))		;same line
	      (setq curpointpos (- curpointpos n))
	      (stop-doing))
	     ((firstlinep) (command-quit))	;can't go up
	     (t (setq n (- n curpointpos 1))	;go up one
	        (prev-line)
	        (go-to-end-of-line)))))

(defcom forward-char
        &numeric-argument (&repeat)
        &negative-function backward-char
        &undo backward-char
        (cond ((eolp)			;go to next line
	     (cond ((lastlinep) (command-quit))
		 (t (next-line))))		;auto to beginning
	    (t (setq curpointpos (1+ curpointpos)))))

(defcom backward-char
        &numeric-argument (&repeat)
        &negative-function forward-char
        &undo forward-char
        (cond ((bolp)
	     (cond ((firstlinep) (command-quit))
		 (t (prev-line) (go-to-end-of-line))))
	    (t (setq curpointpos (1- curpointpos)))))

(defcom delete-char
        &numeric-argument (&repeat)
        &negative-function rubout-char
        (open-line)
        (cond ((eolp)(merge-line))
	    (t (setq curlinel (1- curlinel))
	       (relocate-marks curline -1 'c+)
	       (e_lap_$delete-chars work-string curpointpos 1))))

;;;(register-option 'rubout-tabs-into-spaces nil) ;;; moved to e_option_defaults_
(declare (special rubout-tabs-into-spaces))

;;; Delete one character backwards.
(defcom rubout-char
        &numeric-argument (&repeat)
        &negative-function delete-char
        (let ((here (cur-hpos)))
	   (backward-char)
	   (and rubout-tabs-into-spaces
	        (eq current-command 'rubout-char)
	        (looking-at TAB)
	        (do-times (- here (cur-hpos) 1) (insert-string SPACE)))
	   (delete-char)))

;;; The ^Q command: quote the next input character and insert it.
(defcom quote-char
        &numeric-argument (&pass &lower-bound 0)
        (let ((the-char (ascii (get-char))))
	   (if (eq the-char CRET)(setq the-char NL))
	   (do-times (or numarg 1)
		   (insert-char the-char))))

;;;
;;; Word movement, insertion, and deletion.
;;;

;;; Character table defining what a "word" looks like.
(setq good-word-charactertbl
      (charscan-table
        "A_BCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"))

(defcom forward-word
        &numeric-argument (&repeat)
        &negative-function backward-word
        (do-forever
	(if (search-for-first-charset-line good-word-charactertbl)
	    (or (search-for-first-not-charset-line good-word-charactertbl)
	        (go-to-end-of-line))
	    (stop-doing))
	(if (lastlinep)(go-to-end-of-line)(stop-doing))
	(next-line)
	(go-to-beginning-of-line)))

(defcom backward-word
        &numeric-argument (&repeat)
        &negative-function forward-word
        (do-forever
	(if (search-back-first-charset-line good-word-charactertbl)
	    (or (search-back-first-not-charset-line good-word-charactertbl)
	        (go-to-beginning-of-line))
	    (stop-doing))
	(if (firstlinep)(go-to-beginning-of-line)(stop-doing))
	(prev-line)
	(go-to-end-of-line)))

(defkill delete-word forward)
(defcom delete-word
        &undo yank
        &numeric-argument (&repeat)
        &negative-function rubout-word
        (with-mark m
	         (forward-word)
	         (kill-backwards-to-mark m))
        (merge-kills-forward))

(defkill rubout-word reverse)
(defcom rubout-word
        &undo yank
        &numeric-argument (&repeat)
        &negative-function delete-word
        (with-mark m
	         (backward-word)
	         (kill-forward-to-mark m))
        (merge-kills-reverse))

;;;
;;; Fill routines.
;;;

(defcom set-fill-column
        &arguments ((column &integer
		        &default &eval (if numarg (max numarg 1)
				       else (1+ (cur-hpos)))))
        &numeric-argument (&pass)
        (setq fill-column (1- column))
        (minibuffer-remark "Fill column = " (decimal-rep column)))

(defcom autofill-self-insert
        &undo de-self-insert
        &no-break
        &numeric-argument (&pass)

        (let ((old-numarg numarg))
	   (setq numarg nil)

	   ;; First optimize by inserting numarg-1 of the character.
	   (and old-numarg
	        (do count 2 (1+ count) (< old-numarg count)
		  (self-insert)))

	   ;; Now decide if we need to fill.
	   (unwind-protect
	     (cond ((< (cur-hpos) fill-column))
		 ((or (not (get last-input-char 'whiteness))
		      (and (not (get (lefthand-char) 'whiteness))
			 (not (= (cur-hpos) fill-column)))
		      (save-excursion
		        (skip-back-whitespace-in-line)
		        (> (cur-hpos) fill-column)))
		  (do () ((not (> (cur-hpos) fill-column)))
		      (fill-current-line))))

	     ;; Now insert the character typed.
	     (or (equal old-numarg 0)
	         (self-insert)))))

(defun un-new-line ()
       (without-saving
         (kill-to-beginning-of-line) ; Punt fill prefix.
         (rubout-char)))

(defcom fill-current-line
        (let ((stuff (with-mark
		   end
		   (do ()	;Back up to ends of words until <= fill-column
		       ((not (> (cur-hpos) fill-column)))
		       (skip-back-to-whitespace)
		       (skip-back-whitespace-in-line))
		   (prog2 0
			(point-mark-to-string end)
			(without-saving (wipe-point-mark end))))))

	   (let ((save-hpos (cur-hpos)))

	        (new-line)	   ; fill prefix inserted by this

	        (cond

		;; If fill prefix is longer than fill-column, complain.
		((> (cur-hpos) fill-column)
		 (un-new-line)
		 (insert-string stuff)
		 (new-line)
		 (display-error
		   "Fill column is shorter than fill prefix."))

		;; If had to delete all the way to begin-of-line, barf.
		((zerop save-hpos)
		 (un-new-line)
		 (insert-string stuff)
		 (new-line)
		 (display-error
		   "Word does not fit within fill column."))

		(t (with-mark here
			    (insert-string stuff)
			    (save-excursion
			      (go-to-mark here)
			      (skip-over-whitespace-in-line)
			      (without-saving
			        (wipe-point-mark here)))))))))

(defcom autofill-new-line
        &undo un-new-line
        &numeric-argument &reject
	   (unwind-protect
	     (cond ((< (cur-hpos) fill-column))
		 ((or (not (get last-input-char 'whiteness))
		      (and (not (get (lefthand-char) 'whiteness))
			 (not (= (cur-hpos) fill-column)))
		      (save-excursion
		        (skip-back-whitespace-in-line)
		        (> (cur-hpos) fill-column)))
		  (do () ((not (> (cur-hpos) fill-column)))
		      (fill-current-line))))
	     (new-line)))

(defvar fill-mode-delimiters
        (list SPACE '/: '/. '/, '/; '/? '/! '/( '/) TAB))

(defcom fill-mode
        (prog ()
	    (if (memq 'speedtype buffer-minor-modes)
	        (speedtypeoff)
	        (fill-mode)
	        (speedtype)
	        (return nil))
	    (assert-minor-mode 'fill)
	    (setq hard-enforce-fill-column t)	;see e_interact 5/1/79
	    (mapc '(lambda (x)
		         (set-key x 'autofill-self-insert))
		fill-mode-delimiters)
	    (set-key CR 'autofill-new-line)))

(defcom fill-mode-off
        (cond ((memq 'speedtype buffer-minor-modes)
	     (speedtypeoff)
	     (fill-mode-off)
	     (speedtype))
	    (t (negate-minor-mode 'fill)
	       (setq hard-enforce-fill-column nil)
	       (mapc '(lambda (x)
			  (set-key x 'self-insert))
		   fill-mode-delimiters)
	       (set-key CR 'new-line))))

(defcom-synonym fillon fill-mode)

(defcom-synonym filloff fill-mode-off)

;;; This code replaced by CRDavis' fill routines, 23 November 1981 RMSoley
;;; Reinstalled for UNB installation December 1981.

(defcom runoff-fill-region			;archy, 4/79, this version
        &undo &code
	    (copy-region)
	    (wipe-this-and-yank-previous)
	    &end-code
        &numeric-argument (&pass)
        (or dont-stash (copy-region))
        (let ((bad-lines 0))
	   (with-mark
	     end-of-buffer
	     ;; Main loop
	     (walk-through-region
	       (if (point>markp end-of-buffer)(stop-doing))
	       (with-mark
	         start			;beginning of "word"
	         (skip-over-whitespace)
	         (skip-to-whitespace)
	         (with-mark
		 place			;end of "word"
		 (if (> (cur-hpos) fill-column)
		     ;; If past fill column, move "word" to next line
		     (go-to-mark start)
		     (delete-white-sides)
		     (if (not (bolp))
		         (new-line)
		         ;; Pad completed line if required.
		         (if numarg
			   (save-excursion
			     (prev-line)
			     (go-to-end-of-line)
			     (pad-line (- fill-column (cur-hpos)))))
		         else
		         ;; only done one word, already past fill column
		         (insert-string fill-prefix)
		         (go-to-mark place)
		         (delete-white-sides)
		         (if (not (eolp))(new-line)
			   else (next-line))
		         (delete-white-sides)
		         (insert-string fill-prefix)
		         (setq bad-lines (1+ bad-lines)))
		     else
		     ;; not past fill column
		     (if (< (cur-hpos) fill-column)
		         (delete-white-sides)
		         (do-forever	;get rid of newlines
			 (if (not (eolp))(stop-doing))
			 (if (mark-reached end-of-buffer)(stop-doing))
			 (delete-char)
			 (delete-white-sides))
		         ;; put extra blank after punctuation
		         (if (memq (lefthand-char) '(/. /? /!))
			   (insert-char SPACE))
		         (insert-char SPACE)
		         else
		         ;; at fill column
		         (delete-white-sides)
		         (if (eolp)
			   (next-line)
			   (delete-white-sides)
			   (insert-string fill-prefix)
			   else
			   (if (memq (lefthand-char) '(/. /? /!))
			       (insert-char SPACE))
			   (insert-char SPACE))))))))
	   ;; done with whole region
	   (delete-white-sides)
	   (if (> bad-lines 0)
	       (display-error-remark
	         "Found "
	         (decimal-rep bad-lines)
	         " line"
	         (if (= bad-lines 1) ""
		   else "s")
	         " longer than fill column."))))

(defcom runoff-fill-paragraph
        &undo &code
	    (copy-region)
	    (wipe-this-and-yank-previous)
	    &end-code
        &numeric-argument (&pass)
        (mark-paragraph)
        (runoff-fill-region))

(defun pad-line (howmany)
       (do-forever
        (if (< howmany 1)(stop-doing))
        (go-to-beginning-of-line)
        (let ((orig-howmany howmany))
	   (do-forever
	    (if (< howmany 1)(stop-doing))
	    (skip-over-whitespace)
	    (skip-to-whitespace)
	    (if (eolp)(stop-doing))
	    (insert-char SPACE)
	    (setq howmany (1- howmany)))
	   (if (= howmany orig-howmany)
	       (stop-doing)))))

(defun backward-nonwhite-word ()
   (backward-word)
   (do-forever
	(if (bolp)(stop-doing))
	(if (at-white-char)
	    (forward-char)
	    (stop-doing))
	(backward-char)))

;;; These functions implement a paragraph formatting algorithm that chooses
;;; the "optimal" point at which to break each line.  The algorithm is
;;; adapted from the paper by James O. Achugbue in the June 1981 issue of
;;; SIGPLAN Notices.  The implementation of his algorithm and the extensions
;;; necessary to make it viable in the Emacs environment were performed by
;;; Charles R. Davis in August 1981.
;;;

;;;
;;; The size of these arrays is the number of words in the paragraph.
;;;

;(declare (array*
;	 (fixnum (word-length ?))		;Length of each word
;	 (fixnum (spaces-required ?))		;Spaces after this word
;	 (flonum (cost ?))			;Cost function -- cost of
;					;formatting from this word to
;					;the end of the paragraph.
;	 (fixnum (optimal-break ?))))		;Break index associated with
					;minimal cost.

;;;
;;; The size of these arrays is the number of lines in the paragraph.
;;;

;(declare (array*
;	 (fixnum (latest-break ?))		;Latest possible breaking pts
;	 (fixnum (earliest-break ?))		;Earliest breaking points
;	 (fixnum (line-length ?))))		;Length of the line, using
					;the latest breaking points

;;;
;;; The runoff-fill-paragraph command is used to format a single paragraph.
;;;

;(defcom runoff-fill-paragraph
;        &numeric-argument (&pass)
;        (save-excursion			;Don't disturb cursor
;	(mark-paragraph)			;Make paragraph the region
;	(runoff-fill-region)))		;Fill the region

;;;
;;; The runoff-fill-region command is used to format an arbitrary region.
;;;

;(defcom runoff-fill-region
;        &numeric-argument (&pass)
;        (or dont-stash (copy-region))		;Copy, in case of bad results
;        (with-the-mark-last end
;	(with-mark begin
;	  (format-text-in-region begin end))))

;;;
;;; format-text-in-region does all of the hard work for runoff-fill-region.
;;;

;(defun format-text-in-region (begin end)
;       (go-to-mark begin)
;
;       ;; Remove the fill prefix from the lines if it is present.
;
;       (if (> (stringlength fill-prefix) 0)
;	 (remove-fill-prefix end)
;	 (go-to-mark begin))
;
;       ;; Count the words in the paragraph.  Allocate arrays.
;
;       (let ((nwords (count-words end))
;	   (fill-column (effective-fill-column)))
;	  (*array 'word-length 'fixnum nwords)
;	  (*array 'spaces-required 'fixnum nwords)
;	  (*array 'cost 'flonum nwords)
;	  (*array 'optimal-break 'fixnum nwords)
;
;	  ;; Collect word information.
;
;	  (go-to-mark begin)
;	  (collect-words nwords)
;	  (go-to-mark begin)
;
;	  ;; Count lines (minimal number) in paragraph.  Allocate arrays.
;
;	  (let ((nlines (count-lines nwords)))
;	       (if (> nlines 1)
;		 (*array 'latest-break 'fixnum nlines)
;		 (*array 'line-length 'fixnum nlines)
;		 (*array 'earliest-break 'fixnum nlines)
;
;		 ;; Find the latest possible breaking points, and then the
;		 ;; earliest possible breaking points.  The optimal
;		 ;; breaking points lie somewhere between.
;
;		 (find-latest-breaks nwords)
;		 (find-earliest-breaks nlines)
;		 (find-optimal-breaks nlines)
;		 else
;		 (fillarray 'optimal-break '(0)))
;
;	       ;; Reformat the paragraph, using the optimal breaking points.
;
;	       (go-to-mark begin)
;	       (reformat-text nwords nlines)
;
;	       ;; If a fill prefix is defined, preface each line with it.
;
;	       (if (> (stringlength fill-prefix) 0)
;		 (go-to-mark begin)
;		 (insert-fill-prefix end)))))

;;;
;;; remove-fill-prefix removes the fill prefix from each line of the paragraph.
;;;

;(defun remove-fill-prefix (end)
;       (let ((pos (stringlength fill-prefix)))
;	  (do-forever
;	    (if (looking-at fill-prefix)
;	        (go-to-line-point curline pos)
;	        (without-saving (kill-to-beginning-of-line)))
;	    (if (mark-on-current-line-p end) (stop-doing))
;	    (if (lastlinep) (stop-doing))
;	    (next-line))))

;;;
;;; count-words simply returns the number of words in the paragraph.
;;;

;(defun count-words (end)
;       (let ((count 0))
;	  (do-forever
;	    (skip-over-whitespace)
;	    (if (mark-at-current-point-p end) (return count))
;	    (if (point>markp end) (return count))
;	    (skip-to-whitespace)
;	    (setq count (1+ count))
;	    )))

;;;
;;; effective-fill-column computes the number of columns available for the
;;; text of the paragraph, taking into consideration the fill prefix.
;;;

;(defun effective-fill-column ()
;       (if (= (stringlength fill-prefix) 0)
;	 fill-column
;	 else
;	 (go-to-beginning-of-line)
;	 (insert-string fill-prefix)
;	 (prog1 (- fill-column (cur-hpos))
;	        (kill-to-beginning-of-line))))

;;;
;;; collect-words collects the word-length and spaces-required information for
;;; every word in the paragraph.
;;;

;(defun collect-words (nwords)
;       (let ((begin-pos (cur-hpos)))
;	  (skip-over-whitespace)
;	  (skip-to-whitespace)
;	  (collect-one-word begin-pos 0)
;	  (do ((i 1 (1+ i)))
;	      ((= i nwords))
;	      (skip-over-whitespace)
;	      (setq begin-pos (cur-hpos))
;	      (skip-to-whitespace)
;	      (collect-one-word begin-pos i))))

;;;
;;; collect-one-word collects the word-length and spaces-required information
;;; for a single word.
;;;

;(defun collect-one-word (begin-pos wordno)
;       (let ((len (- (cur-hpos) begin-pos))
;	   (spaces 1))
;	  (if (> len fill-column)
;	      (display-error "The fill column is too small."))
;	  (store (word-length wordno) len)
;	  (and (memq (lefthand-char) '(/. /? /!))
;	       (setq spaces (1+ spaces)))
;	  (store (spaces-required wordno) spaces)))

;;;
;;; count-lines counts the number of lines required by the paragraph.  It
;;; simulates the use of the latest breaking indices, so the number of lines
;;; it computes is minimal.
;;;

;(defun count-lines (nwords)
;       (do ((i 1 (1+ i))
;	  (lines 1)
;	  (len (word-length 0)))
;	 ((= i nwords) lines)
;	 (setq len (+ len (spaces-required (1- i)) (word-length i)))
;	 (if (> len fill-column)
;	     (setq lines (1+ lines))
;	     (setq len (word-length i)))))

;;;
;;; find-latest-breaks determines the latest breaking points.  (latest-break n)
;;; is the number of the word with which line n begins using the latest
;;; breaking points.  The latest breaking points are determined by trying to
;;; put as many words as possible on one line before going to the next.
;;; This is the algorithm used by most simple formatters.
;;;

;(defun find-latest-breaks (nwords)
;       (store (latest-break 0) 0)
;       (do ((i 1 (1+ i))
;	  (line 0)
;	  (len (word-length 0)))
;	 ((= i nwords)
;	  (store (line-length line) len))
;	 (setq len (+ len (spaces-required (1- i)) (word-length i)))
;	 (if (> len fill-column)
;	     (store (line-length line)
;		  (- len (+ (spaces-required (1- i)) (word-length i))))
;	     (setq line (1+ line))
;	     (store (latest-break line) i)
;	     (setq len (word-length i)))))

;;;
;;; find-earliest-breaks finds the earliest breaking point for each line.
;;; This is done by essentially running the find-latest-breaks algorithm in
;;; reverse, putting as many words on a line from right to left as possible
;;; before going to the previous line.  The earliest breaking point of the
;;; last line is always set equal to the latest breaking point of that line,
;;; since putting more words on the last (partial) line would only increase
;;; the total white space in the filled portion of the paragraph.
;;;

;(defun find-earliest-breaks (nlines)
;       (store (earliest-break 0) 0)
;       (store (earliest-break (1- nlines)) (latest-break (1- nlines)))
;       (do ((i (- (latest-break (1- nlines)) 2) (1- i))
;	  (line (- nlines 2))
;	  (len (word-length (1- (latest-break (1- nlines))))))
;	 ((< i 0))
;	 (setq len (+ len (word-length i) (spaces-required i)))
;	 (if (> len fill-column)
;	     (store (earliest-break line) (1+ i))
;	     (setq len (word-length i))
;	     (setq line (1- line)))))


;;;
;;; find-optimal-breaks computes the optimal line breaking points.  It uses
;;; the earliest-break and latest-break arrays as input.  This algorithm is
;;; described (although not lucidly) in the SIGPLAN article.
;;;

;(defun find-optimal-breaks (nlines)
;
;       ;; The cost of formatting the last (partial) line is fixed.
;
;       (store (cost (latest-break (1- nlines))) 2.0)
;
;       ;; Loop backwards over the lines in the paragraph.
;
;       (do ((i (- nlines 2) (1- i))
;	  (x))
;	 ((< i 0))
;
;	 ;; x measures the length of the longest string being considered
;	 ;; for the current line.  That is, from the chosen beginning word
;	 ;; to the word before the latest-break of the next line.
;
;	 (setq x (- (line-length i)
;		  (word-length (latest-break i))
;		  (spaces-required (latest-break i))))
;
;	 ;; Loop over the slack in the current line.
;
;	 (do ((j (latest-break i) (1- j))
;	      (y))
;	     ((< j (earliest-break i)))
;	     (setq x (+ x (word-length j) (spaces-required j)))
;
;	     ;; y measures the length of the string being considered for
;	     ;; the current line.
;
;	     (setq y (+ x
;		      (word-length (latest-break (1+ i)))
;		      (spaces-required (1- (latest-break (1+ i))))))
;	     (store (cost j) 99999.0)		;Initialize cost to infinity
;
;	     ;; Loop over the slack in the next line.
;
;	     (do ((k (latest-break (1+ i)) (1- k))
;		(z))
;	         ((< k (earliest-break (1+ i))))
;	         (setq y (- y (spaces-required (1- k)) (word-length k)))
;
;	         ;; If the string under consideration is short enough to fit
;	         ;; within the fill-column, determine the cost of formatting
;	         ;; from this string to the end of the paragraph.
;
;	         (if (or (< y fill-column) (= y fill-column))
;		   (setq z (*$ (+$ 1.0 (//$ 1.0 (float y))) (cost k)))
;
;		   ;; If the cost is less than the minimum cost so far,
;		   ;; update the cost and remember the breaking point
;		   ;; associated with this cost.
;
;		   (if (< z (cost j))
;		       (store (cost j) z)
;		       (store (optimal-break j) k))))))
;
;       ;;; At this point, the optimal breaking points have been computed and
;       ;;; are linked together in the optimal-break array.  This loop brings
;       ;;; them up to the top, so that optimal-break can be indexed by line
;       ;;; number to retrive the optimal breaking points.
;
;       (let ((tem1 (optimal-break 0))
;	   (tem2 0))
;	  (store (optimal-break 0) 0)
;	  (do ((i 1 (1+ i)))
;	      ((= i (1- nlines)))
;	      (setq tem2 (optimal-break tem1))
;	      (store (optimal-break i) tem1)
;	      (setq tem1 tem2)))
;       (store (optimal-break (1- nlines)) (latest-break (1- nlines))))

;;;
;;; reformat-text uses the optimal breaking points to reformat the paragraph,
;;; whose text is still in the buffer.  If the buffer already contains line
;;; breaks at the right places, reformat-text will not disturb them so as to
;;; improve the efficiency of the redisplay.
;;;

;(defun reformat-text (nwords nlines)
;       (skip-over-whitespace)
;       (skip-to-whitespace)
;       (do ((i 1 (1+ i))
;	  (line 1))
;	 ((= i nwords))
;	 (delete-white-sides)
;	 (if (and (< line nlines)
;		(= i (optimal-break line)))
;	     (and numarg (pad-line line))
;	     (if (eolp)
;	         (forward-char)
;	         (delete-white-sides)
;	         else
;	         (insert-char NL))
;	     (setq line (1+ line))
;	     else
;	     (if (eolp)
;	         (delete-char)
;	         (delete-white-sides))
;	     (insert-string (substr SPACES 1 (spaces-required (1- i)))))
;	 (skip-to-whitespace)))

;;;
;;; pad-line inserts extra spaces in a line when adjusting, rather than simple
;;; filling, is requested.  It distributes extra spaces alternating from the
;;; left and right on subsequent lines.  This could be improved.
;;;

;(defun pad-line (line)
;       (prog (needed nbreaks uniform extra)
;	   (setq needed (- fill-column (cur-hpos)))
;	   (and (= needed 0) (return nil))
;	   (setq nbreaks
;	         (- (optimal-break line) (optimal-break (1- line)) 1))
;	   (and (= nbreaks 0) (return nil))
;	   (setq uniform (// needed nbreaks))
;	   (setq extra (\ needed nbreaks))
;	   (save-excursion
;	     (if (oddp line)
;	         (go-to-beginning-of-line)
;	         (do ((i 0 (1+ i))
;		    (n uniform uniform))
;		   ((= i nbreaks))
;		   (skip-over-whitespace)
;		   (skip-to-whitespace)
;		   (if (> extra 0)
;		       (setq n (1+ n) extra (1- extra)))
;		   (insert-string (substr SPACES 1 n)))
;	         else
;	         (do ((i 0 (1+ i))
;		    (n uniform uniform))
;		   ((= i nbreaks))
;		   (skip-back-to-whitespace)
;		   (if (> extra 0)
;		       (setq n (1+ n) extra (1- extra)))
;		   (insert-string (substr SPACES 1 n))
;		   (skip-back-whitespace))))))

;;;
;;; insert-fill-prefix inserts the fill prefix at the beginning of every line
;;; of the paragraph.
;;;

;(defun insert-fill-prefix (end)
;       (do-forever
;         (or (not (bolp)) (line-is-blank) (insert-string fill-prefix))
;         (if (mark-on-current-line-p end) (stop-doing))
;         (if (lastlinep) (stop-doing))
;         (next-line)))

;;;	Horizontal position maintenance

(defun go-to-hpos (hp)
       (prog (curpos)
	   (go-to-beginning-of-line)
	   (setq curpos 0)
	   (return (do-forever
		   (if (not (> hp curpos))(return curpos))
		   (if (eolp)(return nil))
		   (dispatch-on-current-char
		     (BACKSPACE (setq curpos (1- curpos)))
		     (TAB	 (setq curpos
			       (+ curpos
				(- tab-equivalent
				   (\ curpos tab-equivalent)))))
		     (else (setq curpos (1+ curpos))))
		   (forward-char)))))

(defun whitespace-to-hpos (h)			;give whitespace till at h.
       (prog (targ-tabstops targ-rem curhpos cur-tabstops cur-rem)
	   (setq curhpos (cur-hpos))
	   (if (= h curhpos)(return t))
	   (if (< h curhpos)(return t))
	   (if (= h (1+ curhpos))(insert-char SPACE)(return t))
	   (setq targ-tabstops (// h tab-equivalent)
	         targ-rem (\ h tab-equivalent))
	   (setq cur-tabstops (// curhpos tab-equivalent)
	         cur-rem (\ curhpos tab-equivalent))
	   (do-times (- targ-tabstops cur-tabstops)(insert-char TAB))
	   (if (not (= targ-tabstops cur-tabstops))(setq cur-rem 0))
	   (do-times (- targ-rem cur-rem)(insert-char SPACE))))

;;;
;;; Line movement, insertion, and deletion.
;;;

(defcom kill-to-beginning-of-line
        &undo yank
        (if (bolp)
	  else (with-mark m
		        (go-to-beginning-of-line)
		        (kill-forward-to-mark m))))

(defcom kill-contents-of-line
        &undo yank
        (go-to-beginning-of-line)
        (kill-to-end-of-line))

(defkill kill-lines forward)
(defcom kill-lines
        &undo yank
        &numeric-argument (&pass &lower-bound 0)
        (cond ((not numarg)
	     (cond ((eolp)
		  (or dont-stash (killsave-string NL))
		  (merge-line))
		 (t (kill-to-end-of-line))))
	    (t (do ((j numarg (1- j)))
		 ((= j 0)
		  (or dont-stash
		      (killsave-string (catenate (kill-pop) NL))))
		 (kill-to-end-of-line)
		 (or dont-stash (= j numarg)	;merge kills
		     (let ((first (kill-pop))
			 (second (kill-pop)))
			(killsave-string
			  (catenate second NL first))))
		 (merge-line))))
        (merge-kills-forward))

;;;
;;; Yank commands.
;;;

(defcom yank
        &undo wipe-region
        &numeric-argument (&pass &lower-bound 0)
        (let ((n (or numarg 1)))
	   (and (> n kill-ring-current-size)
	        (report-error 'empty-kill-ring))
	   (do ((i 1 (1+ i))
	        (ybp kill-ring (cddr ybp)))
	       ((not (< i n))
	        (set-the-mark)
	        (insert-string (car ybp))))))

(defcom wipe-this-and-yank-previous
        &numeric-argument (&reject)
        (or der-wahrer-mark (display-error "There was no previous yank."))
        (let ((what-to-wipe (point-mark-to-string der-wahrer-mark)))
	   (cond ((samepnamep (kill-ring-top) what-to-wipe)
		(without-saving (wipe-region))
		(rotate-kill-ring)
		(insert-string (kill-ring-top)))
	         (t (display-error "Yank region doesn't match kill ring.")))))

;;;
;;;
;;;	Random visible command functions
;;;

(declare (special track-eol-opt))
;;;(register-option 'track-eol-opt nil) ;;; moved to e_option_defaults_

(defcom next-line-command
        &undo prev-line-command
        &numeric-argument (&pass)
        &negative-function prev-line-command
        (or (memq previous-command '(next-line-command prev-line-command))
	  (setq target-screen-hpos (cond ((bolp) 0)  ;for 0-char case
				   ((and (eolp) track-eol-opt) 'eol)
				   (t (cur-screen-hpos)))))
        (cond (numarg (do n numarg (1- n)(= 0 n)
		      (cond ((lastlinep) (return nil)))
		      (next-line)))
	    ((lastlinep) (cond (macro-execution-in-progress (command-quit)))
		       (add-new-empty-line) (next-line))
	    (t (next-line)))
        (cond ((eq target-screen-hpos 'eol) (go-to-end-of-line))
	    (t (go-to-screen-hpos target-screen-hpos))))


(defcom prev-line-command
        &undo next-line-command
        &numeric-argument (&pass)
        &negative-function next-line-command
        (or (memq previous-command '(next-line-command prev-line-command))
	  (setq target-screen-hpos (cond ((bolp) 0)  ;for 0-char case
				   ((and (eolp) track-eol-opt) 'eol)
				   (t (cur-screen-hpos)))))
        (cond (numarg (do n numarg (1- n)(= 0 n)
		      (cond ((firstlinep) (command-quit)))
		      (prev-line)))
	    (t (prev-line)))
        (cond ((eq target-screen-hpos 'eol) (go-to-end-of-line))
	    (t (go-to-screen-hpos target-screen-hpos))))


(defcom new-line
        (cond ((eq minibufferp NL)(jetteur-des-gazongues))
	    ((not (eolp))(insert-char NL))
	    ((lastlinep)(insert-char NL))
	    ((e_lap_$compare_strings (eline-contents (nextline)) 0
			         NLCHARSTRING 0 1)
	     (next-line)
	     (cond ((lastlinep))
		 ((e_lap_$compare_strings (eline-contents (nextline)) 0
				      NLCHARSTRING 0 1))
		 (t (insert-char NL)(backward-char))))
	    (t (insert-char NL)))
        (or (= 0 (stringlength fill-prefix))(insert-string fill-prefix)))

(declare (special gratuitous-marks))
;;;(register-option 'gratuitous-marks nil) ;;; moved to e_option_defaults_

(defun gratuitous-mark-setter lexpr
       (cond ((or minibufferp (not gratuitous-marks)))
	   ((zerop lexpr) (set-or-pop-the-mark))
	   ('else (set-the-mark-here (arg 1)) (minibuffer-remark "Set."))))

(defcom go-to-beginning-of-buffer
        &undo-function go-to-end-of-buffer
        &prologue gratuitous-mark-setter
        (go-to-line-point firstline 0))

(defcom go-to-end-of-buffer
        &undo-function go-to-beginning-of-buffer
        &prologue gratuitous-mark-setter
        (go-to-line-point lastline 0)
        (go-to-end-of-line))

(defcom go-to-beginning-of-line
        &undo-function go-to-end-of-line
        (setq curpointpos 0))

(defcom go-to-end-of-line
        &undo-function go-to-beginning-of-line
        (setq curpointpos (1- curlinel)))

;;;  Debugging functions

(defprop %dccl display-cursed-current-line expr)

(defun display-cursed-current-line ()
       (let ((str (curline-as-string)))
	  (princ (substr str 1 curpointpos))
	  (princ "<")(tyo 10)(princ ">")
	  (princ (substr str (1+ curpointpos)))))

(defun %dbp () (print (list (cond ((curline-openp) 'open)(t 'closed))
		       (curline-as-string))))






		    e_binding_table_.lisp           08/20/86  2312.3rew 08/20/86  2252.6       94419



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

;;;
;;;
;;;	The default bindings for all characters in Multics EMACS.
;;;


;;; HISTORY COMMENTS:
;;;  1) change(84-01-23,Margolin), approve(), audit(),
;;;     install(86-08-20,MR12.0-1136):
;;;     pre-hcom history:
;;;               Extracted from e_.lisp, 7/27/78 by bsg & archy
     
;;;               Changed to use per-process erase
;;;                    and kill chars 11/27/78 by Richard S. Lamson
;;;               ^Z as prefix char, 4/16/79 by BSG
;;;               Added ^Z^F and ESC-~, 7/24/79 by GMP
;;;               Modified:  August-September 1979 by GMP for new dispatcher
;;;                    and new commands
;;;               Modified:  17 April 1981 for esc-T Richard Soley
;;;               Modified:   7 May   1981 for object-mode-find-file Richard Soley
;;;               Modified:  31 March 1982 for ^\ Richard Soley
;;;       Modified:  26 August 1982 to remove MCR-mode, add some more
;;;                          Fundamental/.ext-commands.  B. Margolin
;;;               Modified:  30 August 1982 to rename emacs-ITS-searches to
;;;                          emacs-extended-searches and add more autoloads
;;;                          from it.  B. Margolin
;;;               Modified:  29 November 1983 to add forward-char-command and
;;;                          backward-char-command as the default bindings of
;;;                          ^F and ^B.  B. Margolin
;;;               Modified:  23 January 1984 to bind permit-setting-esc-number.
;;;  2) change(84-12-25,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     to slashify #'s.
;;;  3) change(86-03-18,LJAdams), approve(86-03-18,MCR7361),
;;;     audit(86-04-17,Margolin), install(86-08-20,MR12.0-1136):
;;;     Added emacs-history-comment.
;;;                                                      END HISTORY COMMENTS


;;;
;;;	Character function bindings.
;;;

(let ((permit-setting-esc-number t))
     (mapc '(lambda (x) (set-key (car x) (cadr x)))

	 '((\177 rubout-char)

	   (ESC escape)
	   (^@ set-or-pop-the-mark)
	   (^A go-to-beginning-of-line)
	   (^B backward-char-command)
	   (^C re-execute-command)
	   (^D delete-char)
	   (^E go-to-end-of-line)
	   (^F forward-char-command)
	   (^G command-prompt-abort)
	   (^J noop)
	   (^K kill-lines)
	   (^L redisplay-command)
	   (^M new-line)			;carriage return
	   (^N next-line-command)
	   (^O open-space)
	   (^P prev-line-command)
	   (^Q quote-char)
	   (^R reverse-string-search)
	   (^S string-search)
	   (^T twiddle-chars)
	   (^U multiplier)
	   (^V next-screen)
	   (^W wipe-region)
					;^X  is a char prefix
	   (^Y yank)
					;^Z  is a char prefix
	   (^\ undo-prefix)
	   (^_ help-on-tap)

	   (ESC-CR cret-and-indent-relative)
	   (ESC-SPACE complete-command)
	   (ESC-% query-replace)
	   (ESC-/# rubout-word)
	   (ESC-\177 rubout-word)
	   (ESC-< go-to-beginning-of-buffer)
	   (ESC-> go-to-end-of-buffer)
	   (ESC-/; indent-for-comment)
	   (ESC-/? describe-key)
	   (ESC-// regexp-search)
	   (ESC-[ beginning-of-paragraph)
	   (ESC-\ delete-white-sides)
	   (ESC-] end-of-paragraph)
	   (ESC-_ underline-word)
	   (ESC-^ delete-line-indentation)
	   (ESC-~ unmodify-buffer)
	   (ESC-+ read-meta-argument)
	   (ESC-- read-meta-argument)
	   (ESC-0 read-meta-argument)
	   (ESC-1 read-meta-argument)
	   (ESC-2 read-meta-argument)
	   (ESC-3 read-meta-argument)
	   (ESC-4 read-meta-argument)
	   (ESC-5 read-meta-argument)
	   (ESC-6 read-meta-argument)
	   (ESC-7 read-meta-argument)
	   (ESC-8 read-meta-argument)
	   (ESC-9 read-meta-argument)
	   (ESC-A backward-sentence)
	   (ESC-B backward-word)
	   (ESC-C capitalize-initial-word)
	   (ESC-D delete-word)
	   (ESC-E forward-sentence)
	   (ESC-F forward-word)
	   (ESC-G go-to-line-number)
	   (ESC-H mark-paragraph)
	   (ESC-I tab-to-previous-columns)
	   (ESC-K kill-to-end-of-sentence)
	   (ESC-L lower-case-word)
	   (ESC-M skip-over-indentation)
	   (ESC-N down-comment-line)
	   (ESC-P prev-comment-line)
	   (ESC-Q runoff-fill-paragraph)
	   (ESC-R move-to-screen-edge)
	   (ESC-S center-line)
	   (ESC-T twiddle-words)
	   (ESC-U upper-case-word)
	   (ESC-V prev-screen)
	   (ESC-W copy-region)
	   (ESC-X extended-command)
	   (ESC-Y wipe-this-and-yank-previous)
	   (ESC-ESC eval-lisp-line)
	   (ESC-^B balance-parens-backward)
	   (ESC-^F balance-parens-forward)
	   (ESC-^G ignore-prefix)
	   (ESC-^I indent-to-fill-prefix)
	   (ESC-^O split-line)
	   (ESC-^V page-other-window)
	   (ESC-^W merge-last-kills-with-next)
	   (ESC-^Y yank-minibuf)

	   (^X-ESC escape-dont-exit-minibuf)
	   (^X/# kill-backward-sentence)
	   (^X/( begin-macro-collection)
	   (^X/) end-macro-collection)
	   (^X* show-last-or-current-macro)
	   (^X/. set-fill-prefix)
	   (^X/; set-comment-column)
	   (^X= linecounter)
	   (^X0 remove-window)
	   (^X1 expand-window-to-whole-screen)
	   (^X2 create-new-window-and-go-there)
	   (^X3 create-new-window-and-stay-here)
	   (^X4 select-another-window)
	   (^XB select-buffer)
	   (^XD edit-dir)
	   (^XE execute-last-editor-macro)
	   (^XF set-fill-column)
	   (^XG get-variable)
	   (^XH mark-whole-buffer)
	   (^XI insert-file)
	   (^XK kill-buffer)
	   (^XM send-mail)
	   (^XO select-other-window)
	   (^XQ macro-query)
	   (^XR rmail)
	   (^XS global-print)
	   (^XV view-lines)
	   (^XW multi-word-search)
	   (^XX put-variable)
	   (^X_ underline-region)
	   (^X^B list-buffers)
	   (^X^C quit-the-editor)
	   (^X^E comout-command)
	   (^X^F find-file)
	   (^X^I indent-rigidly)
	   (^X^L lower-case-region)
	   (^X^M eval-multics-command-line)
	   (^X^O delete-blank-lines)
	   (^X^R read-file)
	   (^X^S save-same-file)
	   (^X^T toggle-redisplay)
	   (^X^U upper-case-region)
	   (^X^W write-file)
	   (^X^X exchange-point-and-mark)
	   (^X\177 kill-backward-sentence)

	   (^ZF object-mode-find-file)
	   (^Z_ remove-underlining-from-word)
	   (^Z^@ set-named-mark)
	   (^Z^B edit-buffers)
	   (^Z^F get-filename)
	   (^Z^L redisplay-this-line)
	   (^Z^W edit-windows)
	   (^Z^V scroll-current-window)
	   (^Z^Z signalquit)
	   (^Z/; kill-comment)
	   (^ZG  go-to-named-mark)
	   )))


(mapc '(lambda (x)
	     (set-key x 'self-insert))
      (append (explodec "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
	    (explodec "0123456789")
	    (explodec "!""$%&'()*[=]|_:;/<->{}.,+^?~`@#\")
	    (list TAB SPACE (ascii 010))))


(mapc '(lambda (x)
	     (putprop x 'repeat 'argwants))
      '(self-insert delete-char forward-char forward-char-command
		forward-word backward-word
		delete-word rubout-word
		forward-sentence backward-sentence kill-to-end-of-sentence
		kill-backward-sentence
		beginning-of-paragraph end-of-paragraph
		open-space backward-char backward-char-command
		rubout-char
		forward-sexp backward-sexp kill-sexp))

;;; THE FOLLOWING TWO mapc's MUST BE KEPT ACCURATE
;;; WITH THE ABOVE LIST OF argwants FUNTIONS
(mapc '(lambda (x)
	     (putprop (car x) (cadr x) 'negative-arg-function)
	     (putprop (cadr x) (car x) 'negative-arg-function))
      '((delete-char rubout-char)
        (forward-char backward-char)
        (forward-char-command backward-char-command)
        (forward-word backward-word)
        (delete-word rubout-word)
        (forward-sentence backward-sentence)
        (kill-to-end-of-sentence kill-backward-sentence)
        (beginning-of-paragraph end-of-paragraph)
        (forward-sexp backward-sexp)))

(mapc '(lambda (x)
	     (putprop x 'bad-negative-argument 'negative-arg-function))
      '(self-insert open-space kill-sexp))


(define-autoload-lib emacs-dir-edit dired-mode edit-dir)
(define-autoload-lib emacs_pl1_mode_ pl1-mode electric-pl1-mode)
(define-autoload-lib emacs-compilations locate-next-error build-error-list
		 exit-error-scan-mode conditional-new-line compile-buffer
		 set-compiler set-compile-options)
(define-autoload-lib emacs-fortran-mode fortran-mode)
(define-autoload-lib emacs_rmail_ rmail send-mail)
(define-autoload-lib emacs-meter-redisplay mrds)
(define-autoload-lib emacs-console-messages accept-msgs accept-messages-path
		 accept-messages)
(define-autoload-lib emacs-lisp-mode lisp-mode)
(define-autoload-lib emacs-alm-mode alm-mode electric-alm-mode)
(define-autoload-lib emacs-text-mode text-mode runoff-mode compose-mode)
(define-autoload-lib emacs-buffer-edit edit-buffers edit-windows)
(define-autoload-lib emacs-extended-searches set-search-mode
		 character-search reverse-character-search
		 ITS-string-search reverse-ITS-string-search
		 incremental-search reverse-incremental-search
		 regexp-search reverse-regexp-search
		 character-search reverse-character-search query-replace
		 global-regexp-print)
(define-autoload-lib emacs-macro-edit edit-macros macro-edit-mode load-macrofile)
(define-autoload-lib emacs-lisp-debug-mode ldebug ldebug-trace-printer ldebug-trace-break)
(define-autoload-lib emacs-overwrite-mode overwrite-mode)
(define-autoload-lib emacs-object-mode object-mode-find-file object-mode)
(define-autoload-lib emacs-completions complete-command)
(define-autoload-lib emacs-history-comment add-history-comment add-hcom)

(defprop emacro macro-edit-mode suffix-mode)
(defprop cds pl1-mode suffix-mode)
(defprop rd pl1-mode suffix-mode)
(defprop lap lisp-mode suffix-mode)

(setq Fundamental/.ext-commands
  '(replace speedtype speedtypeoff setab fillon filloff lvars apropos
    describe make-wall-chart pl1-mode electric-pl1-mode set-screen-size
    set-comment-prefix accept-messages opt loadlib loadfile alm-mode lisp-mode
    accept-messages-path
    set-key set-permanent-key fundamental-mode show-macro save-macro
    set-search-mode runoff-fill-region fortran-mode reset-screen-size
    set-minibuffer-size reset-minibuffer-size ldebug edit-macros
    set-compiler set-compile-options
    list-named-marks
    fill-mode signalquit quit-the-editor alm-mode query-replace
    kill-contents-of-line
    add-history-comment
      ))

(setq trace-printer 'ldebug-trace-printer trace-break-fun 'ldebug-trace-break)






		    e_defpl1_.lisp                  04/24/89  1347.9rew 04/24/89  1341.4      100791



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

;;;
;;;
;;;	PL/1 Entries Used by EMACS
;;;


;;; HISTORY COMMENTS:
;;;  1) change(84-01-23,Margolin), approve(), audit(), install():
;;;     Pre-hcom journalization:
;;;     Modified: 26 November 1983 B. Margolin to remove network entrypoints.
;;;     Modified: 23 January 1984 B. Margolin to add terminate_file_.
;;;  2) change(84-12-25,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     add e_pl1_$object_check and iox_$control.
;;;  3) change(86-02-24,Margolin), approve(86-02-24,MCR7325),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Changed default input base to 10.  Added new e_multics_files_
;;;     entrypoints, corrected declaration of expand_pathname_$component,
;;;     added hcs_$get_max_length_seg, hcs_$get_uid_file,
;;;     initiate_file_$component, mlr_, several msf_manager_ entrypoints,
;;;     pathname_ and pathname_$component.
;;;  4) change(86-03-12,LJAdams), approve(86-03-12,MCR7361),
;;;     audit(86-04-17,Margolin), install(86-08-20,MR12.0-1136):
;;;     Added requote_string_.
;;;  5) change(88-01-05,Schroth), approve(88-02-29,MCR7851),
;;;     audit(88-06-08,RBarstad), install(88-08-01,MR12.2-1071):
;;;     For 8-bit I/O:  added e_pl1_$set_extended_ascii, and
;;;     e_pl1_$get_output_conv_table and changed e_pl1_$set_break_sequence.
;;;     Removed e_pl1_$get_network_flag, e_pl1_$set_dbo_sw,
;;;     e_pl1_$set_ignore_lf, and e_tasking_$get_death_flag: unused and
;;;     undocumented (also avoids lcp link limit).
;;;  6) change(89-02-08,Flegel), approve(89-02-28,MCR8065),
;;;     audit(89-03-06,Lee), install(89-04-24,MR12.3-1035):
;;;     phx21199 - added cv_dec_check_ defpl1
;;;                                                      END HISTORY COMMENTS



(eval-when (compile)
	 (setq ibase 10.))			;so numbers read in decimal

(declare

;;;	Entries in e_pl1_

(defpl1 e_pl1_$get_terminal_type "" (return char (256.) varying))

(defpl1 e_pl1_$get_real_terminal_type "" (return char (32.) varying))

(defpl1 e_pl1_$get_editing_chars "" (return char (1)) (return char (1))
        (return char (1)))

(defpl1 e_pl1_$get_iocb "" (return pointer))

(defpl1 e_pl1_$set_terminal_type "" (char (*)))

(defpl1 e_pl1_$set_line_speed_ "" (fixed bin))

(defpl1 e_pl1_$init "")

(defpl1 e_pl1_$get_char "" (return fixed bin))

(defpl1 e_pl1_$echo_negotiate_get_char "" (lisp)(lisp)(fixed bin)
        (return fixed bin))

(defpl1 e_pl1_$set_break_char "" (fixed bin)(fixed bin))

(defpl1 e_pl1_$set_break_sequence "" (fixed bin (32.)) (fixed bin (32.))
        (fixed bin (32.)) (fixed bin (32.)) (fixed bin (32.)) (fixed bin (32.))
        (fixed bin (32.)) (fixed bin (32.)))

(defpl1 e_pl1_$real_have_chars "" (return fixed bin))

(defpl1 Rtyo "e_pl1_$tyo" (fixed bin))

(defpl1 Rprinc "e_pl1_$princ" (char (*)))

(defpl1 e_pl1_$dump_output_buffer "")

(defpl1 e_pl1_$get_line_speed "" (return fixed bin))

(defpl1 e_pl1_$resetwrite "")

(defpl1 e_pl1_$will_supdup_output "" (return fixed bin (1)))

(defpl1 e_pl1_$set_line_speed_ "" (fixed bin))

(defpl1 e_pl1_$set_emacs_tty_modes "")

(defpl1 e_pl1_$set_multics_tty_modes "")

(defpl1 e_cline_ "e_pl1_$cline_executor" (char (*)))

(defpl1 e_pl1_$get_emacs_interrupt_array "" (return ptr))

(defpl1 e_pl1_$assign_channel "" (fixed binary) (return fixed binary))

(defpl1 e_pl1_$get_emacs_interrupt "" (return fixed bin)(return fixed bin))

(defpl1 e_pl1_$object_check "" (fixed bin (24.)) (pointer) (return fixed bin))

(defpl1 e_pl1_$set_extended_ascii "" (fixed bin (1)))

(defpl1 e_pl1_$get_output_conv_table "" (array (64.) fixed bin (35.)))

;;; Entries in e_terminal_io_

(defpl1 e_terminal_io_$check_printing "" (char (*)) (return fixed bin))

;;; Entries in e_info_vfilesman_

(defpl1 e_info_vfilesman_$open "" (char (*))(fixed bin (1))
        (return fixed bin (35.)))

(defpl1 e_info_vfilesman_$seek "" (char (*))(return fixed bin (35.)))

(defpl1 e_info_vfilesman_$get_recp "" (return ptr)(return fixed bin (21.))
        (return fixed bin (35.)))

(defpl1 e_info_vfilesman_$update "" (char (*))(fixed bin (1))
        (return fixed bin (35.)))

(defpl1 e_info_vfilesman_$close "")

;;;	Entries in multics_emacs

(defpl1 emacs$set_emacs_return_code "multics_emacs$set_emacs_return_code"
        (fixed bin (35.)))

(defpl1 emacs$get_my_name "multics_emacs$get_my_name" (return char (32.)))

(defpl1 emacs$get_version "" (return char (10.)))

(defpl1 emacs$get_info_ptr "" (return pointer))

(defpl1 e$get_temporary_seg "multics_emacs$get_temporary_seg" (return ptr))

(defpl1 e$release_temporary_seg "multics_emacs$release_temporary_seg" (ptr))

(defpl1 emacs$set_lisp_rdis_meters "multics_emacs$set_lisp_rdis_meters"
        (fixed bin) (fixed bin) (fixed bin) (fixed bin) (fixed bin) 
        (fixed bin) (fixed bin) (fixed bin) (fixed bin) (fixed bin))

;;; Entries in e_tasking_

(defpl1 e_tasking_$destroy_me "")

(defpl1 e_tasking_$get_tasking_flag "" (return fixed bin))

(defpl1 e_tasking_$quit "" (return fixed bin (35.)))

;;; Entries in e_multics_files_util_

(defpl1 e_multics_files_util_$force_access "" (char (*)) (return ptr)
        (return fixed bin (35.)))

(defpl1 e_multics_files_util_$force_msf_access "" (ptr) (return ptr)
        (return fixed bin (35.)))

(defpl1 e_multics_files_util_$get_dtcm "" (ptr)
        (return fixed bin (35)) (return fixed bin (35)))

(defpl1 e_multics_files_util_$get_dtcm_file "" (char (*)) (char (*))
        (return fixed bin (35)) (return fixed bin (35)))

(defpl1 e_multics_files_util_$nth_star_match "" (ptr) (fixed bin)
        (return char (32)) (return char (32)))

(defpl1 e_multics_files_util_$restore_access "" (ptr))

(defpl1 e_multics_files_util_$restore_msf_access "" (ptr) (ptr))

(defpl1 e_multics_files_util_$star_list_cleanup "" (ptr))

(defpl1 e_multics_files_util_$star_list_init "" (char (*)) (char (*))
        (char (*)) (return ptr) (return fixed bin) (return fixed bin (35)))

;;; Entries in e_argument_parse_

(defpl1 e_argument_parse_$get_ttp_info "" (return fixed bin)
        (return char (168.)))

(defpl1 e_argument_parse_$get_startup_info "" (return fixed bin)
        (return fixed bin) (return fixed bin) (return fixed bin)
        (return fixed bin) (return fixed bin) (return fixed bin))

(defpl1 e_argument_parse_$get_one_path "" (return char (168.))
        (return fixed bin))

(defpl1 e_argument_parse_$new_arguments "" (return fixed bin))

;;; Entry in emacs_search_file_caller_

(defpl1 emacs_search_file_caller_ "" (char (*)) (fixed bin) (ptr)
        (fixed bin) (char (*)) (return bit (36.)))

;;; Entries in list_emacs_ctls

(defpl1 list_emacs_ctls$list_emacs_ctls "" (char (*)))

(defpl1 list_emacs_ctls$find_ctl "" (char (*)) (return char (168.)))

;;;	Multics supplied routines

(defpl1 absolute_pathname_ "" (char (*)) (return char (168.))
        (return fixed bin (35.)))

(defpl1 absolute_pathname_$add_suffix "" (char (*)) (char (*))
        (return char (168.)) (return fixed bin (35.)))

(defpl1 archive_util_$disected_element "" (update ptr) (return ptr)
        (return char (32.)) (return fixed bin (24.))
        (return fixed bin (35.)))

(defpl1 archive_util_$first_disected "" (update ptr) (return ptr)
        (return char (32.)) (return fixed bin (24.))
        (return fixed bin (35.)))

(defpl1 check_entryname_ "" (char (*)) (return fixed bin (35.)))

(defpl1 check_star_name_$entry "" (char (*))(return fixed bin))

(defpl1 check_star_name_$path "" (char (*))(return fixed bin))

(defpl1 convert_status_code_ "" (fixed bin (35.))
        (return char (8.)) (return char (100.)))

(defpl1 delete_$path "" (char (*))(char (*))(bit (6))(char (*))
        (return fixed bin (35.)))

(defpl1 expand_pathname_ "" (char (*)) (return char (168.))
        (return char (32.)) (return fixed bin (35.)))

(defpl1 expand_pathname_$add_suffix "" (char (*)) (char (*))
        (return char (168.)) (return char (32.))
        (return fixed bin (35.)))

(defpl1 expand_pathname_$component "" (char (*))(return char (168.))
        (return char (32.))(return char (32.)) (return fixed bin (35)))

(defpl1 get_pdir_ "" (return char (168.)))

(defpl1 hcs_$get_max_length_seg "" (ptr) (return fixed bin (19))
        (return fixed bin (19)))

(defpl1 hcs_$fs_get_mode "" (ptr) (return fixed bin (5))
        (return fixed bin (35.)))

(defpl1 hcs_$get_uid_file "" (char (*)) (char (*)) (return fixed bin (35))
        (return fixed bin (35)))

(defpl1 hcs_$get_uid_seg "" (ptr) (return fixed bin (35.))
        (return fixed bin (35.)))

(defpl1 hcs_$initiate_count "" (char (*)) (char (*)) (char (*))
        (return fixed bin (24.)) (fixed bin (2)) (return ptr)
        (return fixed bin (35.)))

(defpl1 hcs_$make_ptr "" (ptr)(char (*))(char (*))(return ptr)
        (return fixed bin (35.)))

(defpl1 hcs_$make_seg "" (char (*)) (char (*)) (char (*))
        (fixed bin (5)) (return ptr) (return fixed bin (35.)))

(defpl1 hcs_$set_bc "" (char (*))(char (*))(fixed bin)(return fixed bin (35.)))

(defpl1 hcs_$set_bc_seg "" (ptr) (fixed bin (24.)) (return fixed bin (35.)))

(defpl1 hcs_$terminate_noname "" (ptr) (return fixed bin (35.)))

(defpl1 hcs_$truncate_file "" (char (*))(char (*))(fixed bin)
        (return fixed bin (35.)))

(defpl1 hcs_$truncate_seg "" (ptr) (fixed bin (18.)) (return fixed bin (35.)))

(defpl1 initiate_file_$component "" (char (*)) (char (*)) (char (*))
        (bit (3)) (return ptr) (return fixed bin (21))
        (return fixed bin (35)))

(defpl1 iox_$control "" (ptr) (char (*)) (ptr) (return fixed bin (35.)))

(defpl1 match_star_name_ "" (char (*))(char (*))(return fixed bin))

(defpl1 msf_manager_$adjust "" (ptr) (fixed bin) (fixed bin (24)) (bit (3))
        (return fixed bin (35)))

(defpl1 msf_manager_$close "" (ptr))

(defpl1 msf_manager_$get_ptr "" (ptr) (fixed bin) (bit (1)) (return ptr)
        (return fixed bin (24)) (return fixed bin (35)))

(defpl1 msf_manager_$open "" (char (*)) (char (*)) (return ptr)
        (return fixed bin (35)))

(defpl1 pathname_ "" (char (*)) (char (*)) (return char (168.)))

(defpl1 pathname_$component "" (char (*)) (char (*)) (char (*))
        (return char (194.)))

(defpl1 requote_string_ "" (char (*)) (return char(*)))

(defpl1 terminate_file_ "" (ptr) (fixed bin (24.)) (bit (4)) (return fixed bin (35)))

(defpl1 user_info_$homedir "" (return char (168.)))

(defpl1 user_info_$whoami "" (return char (32.)) (return char (32.))
        (return char (32.)))

(defpl1 cv_dec_check_ "" (char(*)) (return fixed bin(35.))
        (return fixed bin(35.)))

)	; End of big declare.




		    e_find_invocation_.alm          08/01/88  1002.5r w 08/01/88  0952.6       30195



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1978 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************
"
"
" This module is used by emacs to find the appropriate invocation to use.
" It's operation is as follows:
"
" (1) If there are no invocations, return null.
" (2) If all invocations are on the same stack, return most recent invocation.
" (3) If there are tasking invocations on the current stack, return most recent
"	of those.
" (4) If there are nontasking invocations, return most recent of those.
" (5) Return the most recent invocation.
"
" Note that we assume that an invocation closer to the head if the
" invocation chain is more recent than one further away.
" (I.e., we assume that emacs_data_$invocation_list -> emacs_data
" is more recent than
" emacs_data_$invocation_list -> emacs_data.next_invocation -> emacs_data)
"
" pr0 points to caller's arg list: 1 output argument, type ptr.
" pr1 points to the emacs invocation being considered.
" pr3 saves the first or first nontask invocation ptr for failing search.
" pr6 points to the current stack frame.
" x0  contains a branch address to only save the first nontask invocation.
" x1  contains the segno of the current execution stack.
"
" Written 7 August 1981 by J. Spencer Love.
" Modified 8 August 1981 Benson Margulies and Richard Soley to correct,
"	clean, and debug.
" 

	name	e_find_invocation_

	include	emacs_data

	entry	e_find_invocation_

e_find_invocation_:
	epp1	emacs_data_$invocation_list,*

	epaq	pr1|0		" See if list is empty.
	ana	=o77777,du	" Mask off uninteresting ring number.
	cmpaq	EPAQ_NULL_PTR	" See if pointer is null.
	tze	EGRESS		" If so, return it.

	epp3	pr1|0		" Save first invocation for no tasking.
	eax0	SAVE_NONTASK_INVOCATION " Replace first with first nontask.
	
	epaq	pr6|0		" Get a pointer to the current stack.
	eax1	0,au		" Put the segno in x1 for compare.

FIND_TASK_LOOP:
	ldq	pr1|emacs_data.task_flags " See if this is a tasking invocation.
	canq	emacs_data.in_task,du
	tnz	0,x0

	cmpx1	pr1|emacs_data.frame_ptr " Check if task stack segno is equal.
	tze	EGRESS		" If so, return this invocation.

FIND_NEXT_TASK:
	epp1	pr1|emacs_data.next_invocation,* " Get next invocation in chain.

	epaq	pr1|0		" See if we have reached the end.
	ana	=o77777,du	" Mask off uninteresting ring number.
	cmpaq	EPAQ_NULL_PTR	" See if pointer is null.
	tnz	FIND_TASK_LOOP	" If not, check out this invocation.

	epp1	pr3|0		" Else, use most recent invocation.

EGRESS:
	spri1	pr0|2,*		" Return the invocation ptr to caller.

	short_return

SAVE_NONTASK_INVOCATION:
	epp3	pr1|0		" Replace first with first nontask.
	eax0	FIND_NEXT_TASK	" Arrange not to come here again.
	tra	FIND_NEXT_TASK	" Go back into search loop.

	even

EPAQ_NULL_PTR:
	oct	077777000000
	oct	000001000000

	end




		    e_info_vfilesman_.pl1           11/30/82  1504.2rew 11/30/82  1332.4       30519



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


e_info_vfilesman_$open:
     proc (a_env_dir, a_upd_sw, a_code);

/* This program manipulates the EMACS command info vfile. BSG 9/26/78 */
%include rs_info;
%include iox_modes;
	dcl     iox_$seek_key	 entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     iox_$write_record	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     iox_$rewrite_record	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     viocbp		 ptr init (null ()) static;
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     s_upd_sw		 fixed bin (1) static;
	dcl	null		 builtin;
	dcl     a_env_dir		 char (*);
	dcl     a_upd_sw		 fixed bin (1);
	dcl     info_ptr		 ptr,
	        1 rsi		 like rs_info aligned automatic;
	dcl     a_code		 fixed bin (35);
	dcl     code		 fixed bin (35);

	if viocbp ^= null & a_upd_sw = 1 & s_upd_sw = 0
	then call close;
	if viocbp = null
	then do;
		call iox_$attach_name ("emacs_info_vfile_", viocbp,
		     "vfile_ " || rtrim (a_env_dir) || ">emacs_info_vfile_ -share",
		     null (), a_code);
		if a_code = 0
		then do;
			if a_upd_sw = 0
			then call iox_$open (viocbp, Keyed_sequential_input, "0"b, a_code);
			else call iox_$open (viocbp, Keyed_sequential_update, "0"b, a_code);
			if a_code ^= 0
			then call iox_$detach_iocb (viocbp, (0));
		     end;
		if a_code = 0
		then s_upd_sw = a_upd_sw;
		else viocbp = null;
	     end;
	else a_code = 0;
	return;



seek:
	entry (a_key, a_code);

	dcl     a_key		 char (*) varying;
	dcl     key		 char (256) varying;

	key = a_key;				/* Copy for dcl compat */
	call iox_$seek_key (viocbp, key, (0), a_code);
	return;


get_recp:
	entry (a_recp, a_recl, a_code);

	dcl     a_recp		 ptr,
	        a_recl		 fixed bin (21);

	a_recp = null ();
	unspec (rsi) = "0"b;
	rsi.version = rs_info_version_2;
	call iox_$control (viocbp, "record_status", addr (rsi), a_code);

	if a_code ^= 0
	then return;
	a_recp = rsi.record_ptr;
	a_recl = rsi.record_length;
	return;


update:
	entry (a_data, a_updsw1, a_code);

	dcl     a_data		 char (*);
	dcl     a_updsw1		 fixed bin (1);
	if a_updsw1 = 1
	then call iox_$write_record (viocbp, addr (a_data), length (a_data), a_code);
	else call iox_$rewrite_record (viocbp, addr (a_data), length (a_data), a_code);
	return;

close:
	entry ();


	if viocbp ^= null
	then do;
		call iox_$close (viocbp, (0));
		call iox_$detach_iocb (viocbp, (0));
	     end;
	viocbp = null;
	return;
     end;





		    e_interact_.lisp                08/01/88  1002.5rew 08/01/88  0945.0      861138



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

;;;
;;;
;;;	e_interact_
;;;
;;;	All that of the basic editor which deals with being interactive
;;;	commands, prefixes, etc., as opposed to being an editor.


;;; HISTORY COMMENTS:
;;;  1) change(84-01-30,Margolin), approve(), audit(), install():
;;;     pre-hcom history:
;;;               Split off from e_ when he grew too gravid.
;;;               BSG 8/4/78
     
;;;               Modified 1978.11.27-29 to reorganize interrupt stuff, etc. by rsl.
;;;               Macro facility redone 2/11/79 by BSG.
;;;               Modified 06/20/79 by GMP for CTL prologue/epilogue handlers.
;;;               Modified 08/21/79 by GMP for negative arguments.
;;;               Modified: August 1979 by GMP for new command invocation mechanism.
;;;               Modified: June 1981 by RMSoley for understanding of emacs_ call.
;;;               Modified: July 1981 RMSoley for pl1 argument parsing, and support
;;;                         of multiple emacs's, tasking.
;;;               Modified: March 1982 RMSoley for undo.
;;;               Modified: June 1982 B Margolin - get-top-level-char-innards nulls
;;;                         out previous-command after echo-negotiation.  Also, last-input-char
;;;                         is maintained by get-a-char, not process-char, so it is
;;;                         more correct.  Added JSL's new command executor stuff.
;;;                         Set up the &undo property on more commands.
;;;               Modified: 25 November 1983 B. Margolin to add "^[" as a valid
;;;                         escape prefix in parse-key-description.
;;;               Modified: 19 January 1984 B. Margolin to comment out register-option
;;;                         forms, as they were moved to e_option_defaults_.
;;;               Modified: 19 January 1984 Barmar to reject esc-<number> in genset-key.
;;;               Modified: 30 January 1984 Barmar to fix kmacro-display-interpret to
;;;               properly interpret "ESC +NUM" and meta characters.
;;;  2) change(84-12-25,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     to fix wrong-type-arg error
;;;     in multiplier command, change lambda into let, use defmacro.
;;;  3) change(84-12-26,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     to fix bug in the rewrite of permanently-set.
;;;  4) change(84-12-30,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     to remove top-level setq of
;;;     suppress-remarks, as it has been set in e_option_defaults_; changed
;;;     set-emacs-interrupt to grow the handler and handle arrays if
;;;     necessary, changed extended-command to ignore null command lines,
;;;     fixed some problems in key binding management, changed special
;;;     declaration to defvar, moved %include's to before declarations.
;;;  5) change(88-01-07,Schroth), approve(88-02-29,MCR7851),
;;;     audit(88-06-08,RBarstad), install(88-08-01,MR12.2-1071):
;;;     Implement 8-bit extended ASCII I/O.  Used 'new' macros in various
;;;     places to improve readibility.
;;;  6) change(88-01-07,Schroth), approve(88-02-29,MCR7852),
;;;     audit(88-06-08,RBarstad), install(88-08-01,MR12.2-1071):
;;;     Added support for split-screen display: revert to one split on
;;;     exit and restore screen splits when later restarted.
;;;                                                      END HISTORY COMMENTS


(declare (genprefix /!eia_))

(%include e-macros)
(%include backquote)
(%include defmacro)
(declare (macros nil))
(%include e-define-command)
(%include other_other)
(%include sharpsign)

(declare (*lexpr display-error display-com-error display-error-noabort
	       display-com-error-noabort minibuffer-print
	       minibuffer-print-noclear minibuffer-remark))
(declare (*expr DCTL-epilogue DCTL-prologue assert-minor-mode clear-the-screen
	      convert_status_code_ cur-hpos decimal-rep display-init
	      e_argument_parse_$get_one_path e_pl1_$init
	      e_argument_parse_$get_startup_info
	      e_argument_parse_$new_arguments e_lap_$rtrim e_lap_$trim
	      e_pl1_$assign_channel e_pl1_$dump_output_buffer
	      e_pl1_$echo_negotiate_get_char e_pl1_$get_char
	      e_pl1_$get_editing_chars e_pl1_$get_emacs_interrupt 
	      e_pl1_$get_emacs_interrupt_array e_pl1_$real_have_chars
	      e_pl1_$set_break_char e_pl1_$set_emacs_tty_modes 
	      e_pl1_$set_multics_tty_modes e_tasking_$destroy_me
	      e_pl1_$set_extended_ascii e_pl1_$get_output_conv_table
	      e_tasking_$get_tasking_flag e_tasking_$quit echo-buffer-clear
	      echo-buffer-clear-all echo-buffer-outprint echo-buffer-print
	      echo-buffer-rubout echo-buffer-utter editor-main-init
	      emacs$set_emacs_return_code empty-buffer-p end-local-displays
	      error_table_ exists-file find-file-subr full-redisplay
	      get-buffer-state go-to-or-create-buffer init-local-displays
	      intern-minibuf-response jetteur-des-gazongues
 	      lisp-quit-function loadfile local-display-generator-nnl
	      map-over-emacs-buffers minibuf-response negate-minor-mode
	      nullstringp randomize-redisplay rdis-find-non-displayable
	      redisplay ring-tty-bell
	      set-autoload-lib set-lisp-rdis-meters user_info_$homedir
 	      user_info_$whoami yesp))
(declare (array* (notype (key-bindings 256. 2))))
(declare (array* (notype (saved-command-history 50.))))
(array saved-command-history t 50.)

;;; The key binding arrays.
;;; These are created and initialized at dump time so that the
;;; user needn't wait through them at startup time.

(array key-bindings t 256. 2)
(fillarray 'key-bindings '(undefined-command))

(array alternate-key-bindings t 256. 2)
(fillarray 'alternate-key-bindings '(undefined-command))

(setq permanize-key-bindings t)

(defvar (

	 network-flag		;tty is a TELNET connection
	 *transparent-commands*	;never becomes previous-command
	 last-time-sample		;for command bell
	 command-bell		;option for command bell
	 command-bell-count		;also
	 meter-commands		;option for command metering
	 completion-list		;for complete-command, ESC-SPACE
	 tty-type			;Terminal type.
	 NowDumpingEmacs		;t at dump time
	 tasking-emacs		;t if we are running tasked.
	 tasking-restarted		;t if we've been restarted.
	 emacs-name		;called name of this incarnation:
				;emacs/new_emacs/emacs_
	 suppress-remarks		;suppress utterances by mbuf-remark
	 quit-on-break		;whether or not to quit on typed BREAK
				;during emacs_ invocation.
	 documentation-dir		;for help command
	 history-next-index		;for command history
	 next-multics-argno
	 buffer-minor-modes		;used for checking macro hack
	 buffer-modified-flag
	 suppress-redisplay-flag	;controls whether redisplay is enabled
	 e-quit-transparency	;Allows quits not to screen-hack
	 DCTL-prologue-availablep	;terminal needs hacking on setting Emacs tty modes
	 DCTL-epilogue-availablep	;terminal needs hacking on setting Multics tty modes
	 delayed-interrupt		;interrupt went off in minibuffer
	 damaged-flag		;redisplay, do all the work!
	 minibufferp		;in Minny Buffer.
	 known-buflist		;list of known buffers
	 kparse-list		;used in key parsing.
	 numarg			;numeric argument to current function, or nil if none
	 undo			;whether or not to undo; like numarg
	 MCS-editing-characters	;list of MCS escape (\), erase (#), and kill (@) characters
	 MCS-escape-character	;MCS escape character (\)
	 emacs-epilogue-action-list	;things to be done on exit
	 last-input-char		;current char, for self-inserts
	 last-command-triplet-1	;current/last command being executed
	 last-command-triplet-mpfxk	;continuation of above, encoded.
	 current-buffer		;symbol name of current buffer
	 list-of-known-options	;for option mechanism, list thereof.
	 macrostack		;format is (macro restart count)
	 macro-collection-in-progress
	 last-macro-definition
	 macro-execution-in-progress	;pointer on current xec list
	 nobreak-functions		;functions that don't break echnego
	 (per-buffer-key-bindings nil)	;as it says, assq list
	 permanize-key-bindings	;on at init time, until start-up over
	 previous-buffer		;buffer we came from
	 current-command		;command being executed
	 previous-command		;last command invoked in this Emacs
	 previous-argument-list	;argument list used to invoke last cmd
	 user-display-variable	;for user opinion on mode line
	 locechnego-ctr		;meters
	 locechnego-meter	
	 next-interrupt-channel	;lowest unused entry in interrupt handler table
	 recursion-level		;records when interrupt handler may cause a redisplay
	 e-lisp-error-mode		;how to treat lisp errors
	 inhibit-default-start-up-execution
	 emacs-start-ups-need-running
	 NLCHARSTRING		;a newline as string object
	 TAB			;ascii TAB
	 ESC			;ascii escape
	 CRET			;carriage return symbol
	 CR			;that too
	 NL
	 FF			;Formfeed
	 VT			;Vertical Tab
	 pi-handler-minibuffer-print	;put in mbuf by pi-handler
	 args:apply-arg
	 args:ns
	 args:paths
	 args:ll
	 args:pl
	 tasking-arg
	(DCTL-extended-ascii nil)		;terminal can do 8bit ASCII
	 char-input-mask			;177 normally or 377 if 8-bit
	 ))

(defvar (
	split-mode-p			;on if split screens
	))
(declare (*expr rdis-restore-screen-to-one-split
	      rdis-recreate-splits-on-screen))

(defun display-load-time-error n
       (princ (apply 'catenate (listify n)))
       (terpri)
       (break load-time-error t))

(putprop 'display-error
         '(lambda n (apply 'display-load-time-error (listify n))) 'expr)
(putprop 'minibuffer-print
         '(lambda n (apply 'display-load-time-error (listify n))) 'expr)




;;; Macros to test bits in left-half of a fixnum: (tlnX value mask)
(defmacro tlnn (value mask)			;t if any bit is on
	`(not (tlne ,value ,mask)))

(defmacro tlne (value mask)			;t if all bits are off
	`(zerop (logand ,value (lsh ,mask 18.))))
;;;

;;;
;;;	Character function binding generators.
;;;


(defmacro permanently-set (&body forms)
	`(let ((permanize-key-bindings t))
	      .,forms))


(defcom set-perm-key
        &arguments ((key &symbol &prompt "Key: ")
		(function &symbol &prompt "Function: "))
        &numeric-argument (&reject)
        (permanently-set (set-key key function)))

(defcom-synonym set-permanent-key set-perm-key)


(defcom set-key
        &arguments ((key &symbol &prompt "Key: ")
		(function &symbol &prompt "Function: "))
        &numeric-argument (&reject)
        (let ((result (parse-key-description key)))
	   (genset-key (caddr result) (car result) (cadr result) function)))


;;;
;;;	This is the setter of all keys.
;;;

(defvar permit-setting-esc-number nil)

(defun genset-key (prefix metap key function)
       (or permit-setting-esc-number
	 (= metap 0)
	 (and (not (= key (CtoI "+")))
	      (not (= key (CtoI "-")))
	      (or (< key (CtoI "0"))
		(> key (CtoI "9"))))
	 ;; esc-<number>
	 (display-error "esc-<number> may not be bound."))
       (and (or prefix (= metap 1)) (> key (1- (CtoI "a"))) (< key (1+ (CtoI "z")))
	  (setq key (- key 40)))
       (cond (prefix
	     (or (not (symbolp (key-bindings prefix 0)))
	         (genset-key nil 0 prefix
			 (let ((x (fillarray (*array (gensym) t 256.) '(undefined-command))))
			      (store (x 7) 'ignore-prefix)
			      x)))	;make ^G punt prefix only
	     (setq metap (key-bindings prefix 0))    ; this is array.
	     (cond (permanize-key-bindings
		   (remove-local-key-binding 0 key prefix))  ;override
		 ((arraycall t metap key)     ;one there already
		  (update-perm-key-bindings 0 key prefix (arraycall t metap key))
		  (update-local-key-bindings 0 key prefix function)))
	     (store (arraycall t metap key) function))
	   (t (cond (permanize-key-bindings
		    (remove-local-key-binding metap key nil))
		  ((key-bindings key metap)
		   (update-perm-key-bindings metap key nil (key-bindings key metap))
		   (update-local-key-bindings metap key nil function)))
	      (or NowDumpingEmacs
		(cond ((memq (key-bindings key metap) nobreak-functions)
		       (e_pl1_$set_break_char key 1)))
		(cond ((memq function nobreak-functions)
		       (e_pl1_$set_break_char key 0))))
	      (store (key-bindings key metap) function))))

(defun update-perm-key-bindings (metap key prefix function)
       (let ((keyrep (key-total-printed-symbol metap key prefix)))
	  (or (and (not permanize-key-bindings)  ;this redundant clause is a way out
		 (assq keyrep per-buffer-key-bindings))  ;dont overpush
	      (putprop keyrep function 'perm-key-function))))

(defun update-local-key-bindings (metap key prefix function)
       (let ((keyrep (key-total-printed-symbol metap key prefix))
	   (listrep (key-fixnum-rep-encode metap key prefix)))
	  (let ((assq-answer (assq keyrep per-buffer-key-bindings)))
	       (cond (assq-answer (rplaca (cdr assq-answer) function))
		   (t (setq per-buffer-key-bindings
			  (cons (cons keyrep (cons function listrep))
			        per-buffer-key-bindings)))))))

(defun remove-local-key-binding (metap key prefix)
       (let ((key-symbol (key-total-printed-symbol metap key prefix)))
	  (let ((assq-answer
		(assq key-symbol per-buffer-key-bindings)))
	       (if assq-answer
		 (setq per-buffer-key-bindings
		       (delq assq-answer per-buffer-key-bindings))))))

(defun key-total-printed-symbol (metap key prefix)
       (intern (make_atom (cond (prefix (catenate (printable prefix)(printable key)))
			  ((= 0 metap)(printable key))
			  (t (catenate "esc-" (printable key)))))))


;;; Get printable name of a key
(defun get-key-name (key-list)
       (apply 'key-total-printed-symbol key-list))


(defun key-fixnum-rep-encode (metap key prefix)
       (list metap key prefix))


(defun reorganize-local-key-bindings (revert)
       (let ((permanize-key-bindings t)
	   (saved-local-bindings (append per-buffer-key-bindings nil)))  ;copy list
	  (unwind-protect
	    (progn (mapc '(lambda (x)
			      (prog (y)
				  (setq y (cond (revert (get (car x) 'perm-key-function))
					      (t (cadr x))))
				  (or (caddr (cddr x))   ;-non-prefix first
				      (genset-key nil (car (cddr x)) (cadr (cddr x)) y))))
		       per-buffer-key-bindings)
		 (mapc '(lambda (x)
			      (prog (y)
				  (setq y (cond (revert (get (car x) 'perm-key-function))
					      (t (cadr x))))
				  (and (caddr (cddr x))  ; prefixed ones
				       (genset-key (caddr (cddr x)) 0 (cadr (cddr x)) y))))
		       per-buffer-key-bindings))
	    (setq per-buffer-key-bindings saved-local-bindings))))

(defun revert-local-key-bindings ()(reorganize-local-key-bindings t))

(defun instate-local-key-bindings ()(reorganize-local-key-bindings nil))


(defun printable (x)
       (let ((y (cond ((numberp x) x)
		  (t (getcharn x 1)))))
	  (cond ((bit-test 200 y) (printable-8-bit-char y))    ;8-bit or META
	        ((= y 33) "ESC")
	        ((= y 15) "CR")
	        ((= y 177) "\177")
	        ((= y 40) "SPACE")
	        ((< y 40) (catenate "^" (ascii (bit-set 100 y))))
	        ((numberp x)(ascii x))
	        (t x))))

(defun printable-8-bit-char (ch-num)
       ;; the display rep of char that is either an 8-bit ASCII or a meta char
       (cond (DCTL-extended-ascii (printable-extended-ascii ch-num))
	   (t (printable-meta-char ch-num))))

(defun printable-extended-ascii (ch-num)
       ;; returns the display representation of an 8-bit ASCII code
       (let ((ch (ascii ch-num)))
	  (cond ((> (rdis-find-non-displayable ch 1 0) 0) ch)  ;displayable
	        (t (catenate "ext-" (printable (bit-clear 200 ch-num)))))))	;not displayable

(defun printable-meta-char (ch-num)
       ;; returns the display rep of a meta-char
       ;; For R11/ITS telnet ^_l
       (catenate "meta-" (printable (bit-clear 200 ch-num))))

(defun prinkeyrep-to-num (x) (cadr (parse-key-description x)))   ;compatibility

;;; Swaps "alternate-key-bindings" (the emacs_ table) with "key-bindings,"
;;; the standard full-emacs table.
(defun swap-binding-tables ()
       (do a 0 (1+ a) (= a 2)
	 (do b 0 (1+ b) (= b 256.)
	     (store (key-bindings b a)
		  (prog1 (alternate-key-bindings b a)
		         (store (alternate-key-bindings b a)
			      (key-bindings b a)))))))

;;;
;;;	Full-hog key parser,
;;;	BSG 8/5/78 Saturday morning.
;;;


(defun parse-key-description (desc)		;returns  (m k p)
       (prog (prefix metap key)
	   (setq kparse-list (exploden desc))	;char-by-char
	   (cond ((or (parse-key-match-list '(e s c a p e -))
		    (parse-key-match-list '(e s c -))
		    (parse-key-match-list '(m e t a -))
		    (parse-key-match-list '(m -))
		    (parse-key-match-list '(^ [ -))
		    (parse-key-match-list '(^ [)))
		(setq metap 1))
	         (t (setq metap 0)
		  (setq prefix (parse-key-description-syllable desc))  ;try for 1 frob.
		  (or kparse-list (return (list 0 prefix nil)))	;non-meta, non-prefix
		  (parse-key-match-list '(-))	;rip out minus
		  (or kparse-list (kparse-error desc))
		  (or (< prefix (CtoI " "))
		      (kparse-error (catenate (printable prefix)
					" may not be a prefix character.")))))

	   (setq key (parse-key-description-syllable desc))
	   (and (or (= 1 metap) prefix) (> key (1- (CtoI "a")))
	        (< key (1+ (CtoI "z")))(setq key (- key 40)))
	   (and kparse-list (kparse-error desc))
	   (return (list metap key prefix))))


(defun parse-key-description-syllable (desc)
       (cond ((not kparse-list)(kparse-error desc))
	   ((= (car kparse-list) 136)		;control frob, = "^"
	    (setq kparse-list (cdr kparse-list))
	    (cond ((not kparse-list) 136)	;plain old hat
		(t (parse-key-controllify))))
	   ((or (parse-key-match-list '(c -))
	        (parse-key-match-list '(c t l -))
	        (parse-key-match-list '(c o n t r o l -)))
	    (parse-key-controllify))
	   ((and DCTL-extended-ascii		;added Dec 84 EDSchroth
	         (or (parse-key-match-list '(x -))
		   (parse-key-match-list '(e x t -))
		   (parse-key-match-list '(e x t e n d e d -))))
	    (parse-key-extendify desc))	;make it an extended ASCII
	   ((parse-key-match-list '(e s c)) 33)
	   ((parse-key-match-list '(c r)) 15)
	   ((parse-key-match-list '(\ /1 /7 /7)) 177)
	   ((parse-key-match-list '(t a b)) 11)
	   ((parse-key-match-list '(s p a c e)) 40)
	   ((parse-key-match-list '(s p)) 40)
	   (t (prog1 (car kparse-list)
		   (setq kparse-list (cdr kparse-list))))))


(defun parse-key-controllify ()
       (or kparse-list (kparse-error "Unspecified control character."))
       (let ((kdesc (car kparse-list)))
	  (and (> kdesc (1- (CtoI "a")))
	       (< kdesc (1+ (CtoI "z")))
	       (setq kdesc (- kdesc 40)))
	  (or (and (< kdesc (1+ (CtoI "_")))
		 (> kdesc (1- (CtoI "@"))))
	      (kparse-error (catenate "^" (ascii kdesc) " is not ASCII.")))
	  (setq kparse-list (cdr kparse-list))
	  (- kdesc 100)))

;;; Handles extended ascii key descriptions. Dec 84 EDSchroth
(defun parse-key-extendify (desc)
       (or kparse-list (kparse-error "Unspecified extended character."))
       (bit-set 200 (parse-key-description-syllable desc))) ;make 8-bit ASCII

(defun parse-key-match-list (matchee)
       (do ((data kparse-list (cdr data))
	  (pattern matchee (cdr pattern))
	  (chara)(charb)(chardata))
	 ((null pattern)(setq kparse-list data) t)
	 (or data (return nil))		;nothing more
	 (setq chardata  (car data))
	 (setq chara (getcharn (car pattern) 1))
	 (setq charb (cond ((and (< chara (1+ (CtoI "z")))
			     (> chara (1- (CtoI "a"))))
			(- chara 40))
		         (t chara)))
	 (or (= chardata chara)(= chardata charb)(return nil))))


(defun kparse-error (desc)
       (display-error "Invalid key description: " desc))


;;;
;;;  Randomness
;;;


(setq NLCHARSTRING (ItoC 012) ESC (ascii 033))
(setq TAB (ascii 011) BACKSPACE (ascii 010) SPACE (ascii 040) CR (ascii 15)
      CRET (ascii 015) NL (ascii 012) FF (ascii 14) VT (ascii 13))

;;;

;;;
;;;	Initialize the option mechanism first.
;;;


(setq list-of-known-options nil)

(defun require-symbol (putative-symbol)
       (cond ((not (symbolp putative-symbol))
	    (display-error "This function requires a symbol."))))


(defun register-option (sym val)
       (require-symbol sym)
       (or (memq sym list-of-known-options)
	 (setq list-of-known-options
	       (sort (cons sym list-of-known-options) 'alphalessp)))
       (remprop sym 'value-must-be-numeric)
       (remprop sym 'value-ok-true-false)
       (or (boundp sym)(set sym val)))


;;;(register-option 'eval:eval t) ; Unfortunately ;;; moved to e_option_defaults_
;;;(register-option 'eval:assume-atom nil) ;;; moved to e_option_defaults_
;;;(register-option 'eval:correct-errors nil) ;;; moved to e_option_defaults_
;;;(register-option 'eval:prinlevel 3) ;;; moved to e_option_defaults_
;;;(register-option 'eval:prinlength 6) ;;; moved to e_option_defaults_

;;;
;;;	Listener
;;;	and toplevels.
;;;


(defun listener-level () (start) (std-yggdrasil))

(defun start ()
       (setq emacs-start-ups-need-running nil)	;11/3/80
       (setq e-quit-transparency nil)
       (setq e-lisp-error-mode nil)		;Lisp errors to minibuf
       (and (eq emacs-name 'emacs_) (swap-binding-tables))
       (get-editing-characters)		;read erase, kill, escape chars
       (editor-main-init)			;init the guts of the editor.
       (or (boundp 'next-multics-argno) (setq next-multics-argno 1))
       (setq history-next-index 0)
       (setq macro-collection-in-progress nil previous-command nil
	   last-macro-definition nil)
       (setq emacs-epilogue-action-list nil)
       (sstatus cleanup '((run-emacs-epilogue-actions)))
       (*rset nil)
       (e_pl1_$set_emacs_tty_modes)
       (sstatus mulpi t)
       (sstatus interrupt 16. 'emacs-quit-handler)
       (sstatus mulquit 16.)
       (init-echnego-bittab)
       (setq errlist '((pi-handler)))		;CTRL/g escapes lossages
       (setq user-display-variable nil)		;init rsl's hack.
       (display-init)			;initialize the redisplay
       (init-extended-ascii-land)		;fix up for possible 8-bit
       (setq locechnego-ctr 0 locechnego-meter 0) ;And the PL/I redisplay.
       (interrupt-init)			;And the interrupt scheme.
       (setq permanize-key-bindings nil)
       (reset-top-level-editor-state)
       (setq emacs-start-ups-need-running t))

;;; Initialize the 8-bit printing character scan table at dump time
;;; This should be in e_redisplay_ but is done here as the per invocation
;;; stuff is done here.

(declare
  (array* (fixnum (7bit-tabscan-table 128.)))	;7bit non-printing
  (array* (fixnum (8bit-tabscan-table 128.))))	;8bit non-printing
(defvar 7bit-tabscan-table
        (fillarray (*array '7bit-tabscan-table 'fixnum 128.) '(-1)))
(defvar 8bit-tabscan-table
        (fillarray (*array '8bit-tabscan-table 'fixnum 128.) '(-1)))

(do ((i 8. (1+ i)))				;040...173 print nicely
    ((= i 31.))
    (store (arraycall fixnum 7bit-tabscan-table i) 0)
    (store (arraycall fixnum 8bit-tabscan-table i) 0))
(store (arraycall fixnum 7bit-tabscan-table 31.) 777)	;nix 177
(store (arraycall fixnum 8bit-tabscan-table 31.) 777)	;nix 177

;;; Takes care of per invocation set-up for extended ASCII
;;; Dec 1984 EDSchroth
(defun init-extended-ascii-land ()
       (setq char-input-mask 177)
       (cond (DCTL-extended-ascii		;the ctl knows about 8-bit!
	     (setq char-input-mask 377)
	     (e_pl1_$set_extended_ascii 1)
	     ;; add 8-bit self-inserts based on TTT output conversion table
	     ;; Also, define 8-bit non-printing scan table
	     (let ((convtab (*array nil 'fixnum 64.)))
		(e_pl1_$get_output_conv_table convtab)
		(do ((i 128. (1+ i))	;do 8-bit chars only
		     (next-byte-of (rot 777 -9.) (rot next-byte-of -9.)))	;successive bytes
		    ((= i 256.))		;stop after #o377
		    (or (bit-test next-byte-of (arraycall fixnum convtab (// i 4)))	;pick a byte
		        (set-perm-key (ascii i) 'self-insert)))	;if zero
		(do ((i 32. (1+ i)))	;copy entries for 200...377
		    ((= i 64.))		;to scan table
		    (store (arraycall fixnum 8bit-tabscan-table i)
			 (arraycall fixnum convtab i))))
	     (e_pl1_$set_emacs_tty_modes))))	;fix-up modes
				   
(defvar emacs-start-up-error-message)

(defun run-emacs-start-up-error (arg)
       arg
       (display-error-noabort emacs-start-up-error-message)
       (throw () emacs-start-up-tag))

(defun run-emacs-start-up-actions ()
       (setq inhibit-default-start-up-execution nil)
       (or (eq emacs-name 'emacs_)
	 (run-user-start-up (catenate (e_lap_$trim (user_info_$homedir))
				">start_up.emacs"))
	 (run-user-start-up (catenate (user-project-dir)
				">start_up.emacs"))
	 (run-user-start-up ">site>start_up.emacs"))
       (and (eq emacs-name 'emacs_) (go-to-or-create-buffer 'main))
       (or inhibit-default-start-up-execution (default-emacs-start-up))
       (cond ((eq current-buffer '|<start_up_emacs_buffer>|)
	    (go-to-or-create-buffer 'main)
	    (setq previous-buffer 'main))
	   ((eq previous-buffer '|<start_up_emacs_buffer>|)
	    (setq previous-buffer current-buffer)))
       (setq known-buflist (delq '|<start_up_emacs_buffer>| known-buflist)))

(defun user-project-dir ()
       (catenate ">user_dir_dir>"
	       (e_lap_$trim (cadr (user_info_$whoami)))))

(defun run-user-start-up (filename)
       (cond (args:ns 't)
	   ((exists-file filename 4)
	    (setq emacs-start-up-error-message "Error in start_up.emacs")
	    (catch
	      (let ((e-lisp-error-mode 'run-emacs-start-up-error))
		 (loadfile filename))
	      emacs-start-up-tag) 't)
	   ('else nil)))

;;; Re-written by GMP, 9/4/78.
;;; Re-written by RMSoley, 21 July 1981
(defun default-emacs-start-up ()
       (setq inhibit-default-start-up-execution t)
       ;; File-file the pathnames and macro files.
       (do ((paths args:paths (1- paths)))
	 ((zerop paths))
	 (let ((info (e_argument_parse_$get_one_path)))
	      (cond ((zerop (cadr info))
		   (setq emacs-start-up-error-message
		         (catenate "Can't load file " (car info)))
		   (catch
		     (let ((e-lisp-error-mode 'run-emacs-start-up-error))
			(load (e_lap_$trim (car info))))
		     emacs-start-up-tag))
		  (t
		    (catch
		      (find-file-subr (e_lap_$trim (car info)))
		      pgazonga)))))
       ;; Do -apply arguments.
       (cond ((> args:apply-arg -1)
	    (setq emacs-start-up-error-message "Can't do -apply.")
	    (catch
	      (let ((e-lisp-error-mode 'run-emacs-start-up-error))
		 (apply (make_atom (status arg args:apply-arg))
		        (multics-args-as-list (1+ args:apply-arg))))
	      emacs-start-up-tag)))
       (and tasking-restarted (full-redisplay))
       (setq tasking-restarted nil))

(defun multics-args-as-list (first-argno)
       (do ((count first-argno (1+ count))
	  (l))
	 ((not (status arg count)) (nreverse l))
	 (setq l (cons (status arg count) l))))

(setq pi-handler-minibuffer-print nil tasking-restarted nil)

(defun pi-handler ()
       (e_pl1_$set_emacs_tty_modes)
       (randomize-redisplay)
       (and DCTL-prologue-availablep (DCTL-prologue))
       (and split-mode-p (rdis-recreate-splits-on-screen))
       (reset-top-level-editor-state)
       (cond ((zerop (e_argument_parse_$new_arguments))
	    (full-redisplay))
	   (t (tasking-restart-internal)))
       (cond (pi-handler-minibuffer-print
	     (minibuffer-print pi-handler-minibuffer-print)
	     (setq pi-handler-minibuffer-print nil)))
       (std-yggdrasil))

(defun reset-top-level-editor-state ()
       (or minibufferp (instate-local-key-bindings))
       (setq suppress-redisplay-flag nil)	;restart redisplay if stopped
       (cond ((memq 'Macro/ Learn buffer-minor-modes)
	    (negate-minor-mode 'Macro/ Learn)))
       (setq damaged-flag t			;force redisplay to work on it
	   numarg nil
	   undo nil
	   macro-execution-in-progress nil
	   macro-collection-in-progress nil
	   macrostack nil)
       (or minibufferp (setq recursion-level 0)))

;;; Modified 28 June 1981 RMSoley to use set_break_sequence
;;; Modified Dec 1984 EDSchroth for 8bit ASCII.
;;;    Extended chars break echonego by default
(defun init-echnego-bittab ()
       (do ((char 0 (1+ char))
	  (number 0)
	  (nlist ())
	  (count 0 (1+ count)))
	 ((= char 256.)
	  (apply 'e_pl1_$set_break_sequence
	         (nreverse (cons number nlist))))
	 (and (not (zerop char))
	      (zerop (\ count 32.))
	      (setq nlist (cons number nlist)
		  count 0
		  number 0))
	 (setq number (lsh number 1))
	 (or (and (> char 31.) (< char 127.)
		(memq (key-bindings char 0) nobreak-functions))
	     (setq number (1+ number)))))

(defcom debug-e
        &numeric-argument (&reject)
        (*rset t) (nouuo t) (sstatus uuolinks nil)     ;et in saecula saeculorum amen
        (setq e-lisp-error-mode 'lisp-break)
        (sstatus mulpi 1)			;pi -> ^b interrupt
        (sstatus interrupt 2 '(lambda (z)(pi-handler) z)))	;CTRL/a -> reenter


(defun get-editing-characters ()
       (let ((editing-chars (e_pl1_$get_editing_chars)))
	  (setq MCS-editing-characters (mapcar 'CtoI editing-chars)
	        MCS-escape-character (car editing-chars))
	  (set-editing-key (car editing-chars) 'escape-char)
	  (set-editing-key (cadr editing-chars) 'rubout-char)
	  (set-editing-key (caddr editing-chars) 'kill-to-beginning-of-line)))


(defun set-editing-key (character function)
       (cond ((eq (get-key-binding (parse-key-description character))
	        'self-insert)
	    (set-perm-key character function))))

;;;
;;;	Following is all of Multics EMACS.
;;;

(defun std-yggdrasil ()			;Root tree of universe
       (do ()(nil)
	 (catch (charlisten) gazongue-a-l/'yggdrasil) ;ceci est jet'e
					;seulement par ^G
	 (redisplay)  ;gratuitous
           (ring-tty-bell)
	 (reset-top-level-editor-state)))


(defun charlisten ()
       (let ((recursion-level recursion-level))
	  (do nil (nil)
	      (or macro-execution-in-progress
		emacs-start-ups-need-running
		(redisplay))
	      (catch
	        (errset (let ((fail-act 'e-lisp-lossage-handler)
			  (pdl-overflow 'e-lisp-lossage-handler)
			  (wrng-type-arg 'e-lisp-lossage-handler)
			  (*rset-trap 'e-lisp-lossage-handler)
			  (unbnd-vrbl 'e-lisp-lossage-handler)
			  (undf-fnctn 'e-lisp-lossage-handler)
			  (unseen-go-tag 'e-lisp-lossage-handler)
			  (wrng-no-args 'e-lisp-lossage-handler)
			  (errset 'e-lisp-lossage-handler))

			 (cond
			   ((eq emacs-start-ups-need-running t)
			    (setq emacs-start-ups-need-running nil)
			    (run-emacs-start-up-actions))
			   (emacs-start-ups-need-running
			     (funcall
			       (prog1 emacs-start-ups-need-running
				    (setq emacs-start-ups-need-running
					nil)))))

			 (do ((numarg nil nil) (undo nil nil)) (nil)
			     (process-char (get-top-level-char))))
		      nil)
	        pgazonga)
	      (reset-top-level-editor-state))))

(defun e-lisp-lossage-handler (arg)
       (setq arg (caddr (errframe nil)))
       (cond (e-quit-transparency (errprint nil))
	   (t (minibuffer-print
	        (car arg) " " (maknam (explodec (cadr arg))))))
       (cond ((eq e-lisp-error-mode 'lisp-break)
	    (let ((e-quit-transparency 'transparent))
	         (e_pl1_$set_multics_tty_modes)
	         (terpri)(terpri)
	         (princ
		 (catenate "Lisp error in buffer " current-buffer))
	         (terpri)
	         (setq arg (eval (list 'break (caddr arg) t)))
	         (e_pl1_$set_emacs_tty_modes)
	         (full-redisplay))
	    (cond (arg)(t (command-prompt-abort))))
	   ((null e-lisp-error-mode)(command-quit))
	   (t (funcall e-lisp-error-mode arg))))


(defcom lisp-error-mode
        &arguments ((mode &symbol &prompt "Mode: "   ;&valid on off, when ready
		      &default off))	;default to "normal"
        &numeric-argument (&reject)
        (cond ((memq mode '(nil reset off 0))	;ick
	     (setq e-lisp-error-mode nil))
	    ((memq mode '(t set on 1 lisp-break))
	     (setq e-lisp-error-mode 'lisp-break))
	    (t (display-error "Unknown lisp error mode: " mode))))

;;;
;;;
;;;	Character readers
;;;

(declare (array* (notype (emacs-interrupt-handlers ?)(emacs-interrupt-handles ?))
	       (fixnum (emacs-interrupt-array ?))))


(defun get-top-level-char ()
       (get-a-char 'toplevel-char 'get-top-level-char-innards))

(defun get-char ()
       (get-a-char 'input-char 'e_pl1_$get_char))

(defun get-a-char (type get-char-function)
       (let ((new-ch
	     (cond ((and macro-execution-in-progress (kmacro-get-one-cmd type)))
	   (t (do ((ch (funcall get-char-function) (funcall get-char-function)))
		(nil)
		(or (= 0 (emacs-interrupt-array 0)) (setq delayed-interrupt t))
		(store (emacs-interrupt-array 0) 0)
		(and (not minibufferp) delayed-interrupt (emacs-interrupt-processor))
		(or (= ch -1)
		    (progn (store (saved-command-history history-next-index) ch)
			 (setq history-next-index
			       (cond ((= history-next-index 49.) 0)
				   (t (1+ history-next-index))))
			 (and macro-collection-in-progress
			      (kmacro-record-input ch type))
			 (return ch))))))))
	  (setq last-input-char (ascii (logand char-input-mask new-ch)))	;last-input-char = char without META
	  new-ch))

;;;
;;;Highly local specials for gran kludge redisplay (echo negotiation).
;;; Goddamn backpanel wires to every board in the machine.
(defvar (X howmuchigot-sym rdis-upd-locecho-flg screenlinelen touchy-damaged-flag rdis-suppress-redisplay))
(defvar (rdis-multiwindowed-buflist rdis-inhibit-echnego))
(defvar (curlinel curstuff work-string curpointpos hard-enforce-fill-column fill-column))

(defun get-top-level-char-innards ()

       (let ((ordi rdis-suppress-redisplay)
	   (chpos 0))

	  
;;; THIS NEXT STATEMENT IS PERHAPS THE MOST IMPORTANT IN MULTICS EMACS
;;; IT CAUSES REDISPLAY TO OCCUR WHEN THERE IS NO PENDING INPUT.
;;; ALMOST ALL REDISPLAY IN THE WORLD IS INVOKED RIGHT HERE.


	  (and (= 0 (e_pl1_$real_have_chars))(redisplay))


;;; Attempt PL/I (and poss. better) echo negotiation.

	  (cond ((and			;try super-opt
		 (eq curstuff work-string)	;line gotta be open
		 (= curpointpos (1- curlinel))     ;gotta be at eol
		 (not macro-collection-in-progress)
		 (not ordi)		;old rdis-suppr-rdis
		 (not suppress-redisplay-flag)
		 (not (and hard-enforce-fill-column
			 (not (< (setq chpos (cur-hpos)) fill-column))))
		 (not rdis-inhibit-echnego)
		 (prog2 (redisplay)		;update all parms
		        (not (and minibufferp (> X (- screenlinelen 10.)))))
		 (or (not (memq current-buffer rdis-multiwindowed-buflist))
		     minibufferp))		;echnego ok minibuf even so
	         (setq locechnego-ctr (1+ locechnego-ctr))
	         (prog2 (set 'howmuchigot-sym 0)
		      (e_pl1_$echo_negotiate_get_char
		        work-string
		        'howmuchigot-sym
		        (cond (hard-enforce-fill-column
			      (min (- screenlinelen X)
				 (- fill-column chpos)))
			    (minibufferp
			      (- screenlinelen X 7))
			    (t (- screenlinelen X))))
		      (cond ((> howmuchigot-sym 0)
			   (store (saved-command-history history-next-index)
				(substr work-string (1+ curpointpos) howmuchigot-sym))
			   (setq history-next-index
			         (cond ((= history-next-index 49.) 0)
				     (t (1+ history-next-index))))
			   (setq X (+ X howmuchigot-sym))
			   (setq locechnego-meter (+ locechnego-meter howmuchigot-sym))
			   (setq curpointpos (+ curpointpos howmuchigot-sym))
			   (setq curlinel (+ curlinel howmuchigot-sym))
			   (setq touchy-damaged-flag t)
			   (setq previous-command nil)     ;since we never actually execute a command
			   (let ((rdis-upd-locecho-flg t))
			        (redisplay))))))
	        (t (e_pl1_$get_char)))))

;;;
;;;
;;;	interrupt handling integrated into e_interact_ 1978.11.21 by Richard S. Lamson
;;;

;;;
;;;	how it works:
;;;
;;;		There are two types of interrupt numbers, namely 
;;;		internal and external.  Internal numbers are assigned 
;;;		sequentially from the variable next-interrupt-channel.
;;;		Internal numbers are used to index into the array 
;;;		emacs-interrupt-handlers, and are returned by 
;;;		e_pl1_$get_emacs_interrupt.  External numbers are
;;;		assigned by e_pl1_$assign_channel, and are computed
;;;		as 64*emacs_recursion_level + internal_number.  It is 
;;;		these external numbers which must be passed to 
;;;		e_pl1_$set_emacs_interrupt, and therefore it is these
;;;		which set-emacs-interrupt-handler returns.
;;;


(defun emacs-interrupt-processor ()
       (setq delayed-interrupt nil)
       (do ((int-info (e_pl1_$get_emacs_interrupt) (e_pl1_$get_emacs_interrupt)))
	 ((< (car int-info) 0) (and (= recursion-level 0)
			        (not rdis-suppress-redisplay)	; don't destroy local display
			        (redisplay)))
	 (let ((intno (car int-info)))
	      (cond ((emacs-interrupt-handlers intno)
		   (funcall (emacs-interrupt-handlers intno)
			  intno
			  (emacs-interrupt-handles intno)
			  (cadr int-info)))))))

(defvar max-emacs-interrupt-channel 64.)

(defun set-emacs-interrupt-handler (handler handle)    ; returns interrupt channel number
       (setq next-interrupt-channel (1+ next-interrupt-channel))
       (if (= next-interrupt-channel max-emacs-interrupt-channel)	;ran out of channels
	 (setq max-emacs-interrupt-channel (* 2 max-emacs-interrupt-channel))
	 (*rearray 'emacs-interrupt-handlers t max-emacs-interrupt-channel)
	 (*rearray 'emacs-interrupt-handles t max-emacs-interrupt-channel))
       (store (emacs-interrupt-handlers next-interrupt-channel) handler)
       (store (emacs-interrupt-handles next-interrupt-channel) handle)
       (e_pl1_$assign_channel next-interrupt-channel))

(defun interrupt-init ()
       (*array 'emacs-interrupt-array 'external (e_pl1_$get_emacs_interrupt_array) 2)
       (*array 'emacs-interrupt-handlers t max-emacs-interrupt-channel)
       (*array 'emacs-interrupt-handles  t max-emacs-interrupt-channel)
       (setq delayed-interrupt nil)
       (setq next-interrupt-channel -1))

;;; 

;;;
;;;	Functions to print errors/messages in the minibuffer
;;;

(defvar (suppress-minibuffer))
;;;(register-option 'suppress-minibuffer nil) ;;; moved to e_option_defaults_

;;; Print an error message.
(defun display-error-noabort n
       (or suppress-minibuffer
	 (echo-buffer-print (apply 'catenate (listify n)))))

;;; Print an error message and abort.
(defun display-error n
       (or suppress-minibuffer
	 (apply 'display-error-noabort (listify n)))
       (command-quit))

;;; Print an error message: first argument is Multics error code.
(defun display-com-error-noabort n
       (or suppress-minibuffer
	 (let ((prefix
	         (cond ((= 0 (arg 1)) "")
		     (t (catenate
			(e_lap_$rtrim
			  (cadr (convert_status_code_ (arg 1))))
			(cond ((> n 1) "  ")
			      (t ""))))))
	       (message (cond ((> n 1)
			   (apply 'catenate (listify (- 1 n))))
			  (t ""))))
	      (echo-buffer-print (catenate prefix message)))))

;;; Print an error message and abort: first argument is Multics error code.
(defun display-com-error n
       (apply 'display-com-error-noabort (listify n))
       (command-quit))

;;; Clear out the minibuffer.
(defun minibuffer-clear-all ()
       (echo-buffer-clear-all))

;;; Print a message in the minibuffer.
(defun minibuffer-print n
       (or macro-execution-in-progress suppress-minibuffer
	 (echo-buffer-print (apply 'catenate (listify n)))))

;;; Print a message in the minibuffer without clearing current contents.
(defun minibuffer-print-noclear n
       (or macro-execution-in-progress suppress-minibuffer
	 (echo-buffer-outprint (apply 'catenate (listify n)))))

;;; Delete the last N characters from the minibuffer.
(defun minibuffer-rubout (n)
       (or macro-execution-in-progress
	 (echo-buffer-rubout n)))

;;; Make a very transient remark.
(defun minibuffer-remark n
       (or macro-execution-in-progress suppress-remarks suppress-minibuffer
	 (echo-buffer-utter (apply 'catenate (listify n)))))

(defun display-error-remark n
       (or suppress-minibuffer
	 (echo-buffer-utter (apply 'catenate (listify n)))))

;;; Clear the last minibuffer statement.
(defun minibuffer-clear ()(echo-buffer-clear))

;;;
;;;	Self-documentation primitives - see e_self_documentor_.
;;;


(defun get-cmd-symbol-3args (metap key prefix)
       (cond ((and (= metap 1) prefix) nil)
	   ((not prefix)
	    (cond ((subrp (key-bindings key metap)) nil)
		(t (key-bindings key metap))))
	   (t (cond ((not (subrp (key-bindings prefix 0))) nil)
		  (t (arraycall t (key-bindings prefix 0) key))))))


;;; Get the function bound to a key
(defun get-key-binding (key-list)
       (apply 'get-cmd-symbol-3args key-list))


;;; Read the name of key
(defun key-prompt (prompt)
       (prog (ch1)
	   (minibuffer-print prompt)
	   (setq ch1 (get-char))
	   (return (cond ((= ch1 377)
		        (setq ch1 (get-char))
		        (cond ((= ch1 377)
			     (minibuffer-print-noclear "esc-" (printable 177))
			     '(1 177 nil))
			    (t (return (telnet-loser ch1)))))
		       ((> ch1 char-input-mask)
		        (minibuffer-print-noclear "esc-")
		        (key-prompt-1 1 (bit-clear 200 ch1) nil))
		       (t (key-prompt-1 0 ch1 nil))))))

(defun key-prompt-1 (metap key prefix)
       (prog (mf1)
	   (and (or prefix (= metap 1))
	        (< key (1+ (CtoI "z")))(> key (1- (CtoI "a")))
	        (setq key (- key 40)))
	   (setq mf1 (cond (prefix (arraycall t (key-bindings prefix 0) key))
		         (t (key-bindings key metap))))
	   (cond ((eq mf1 'escape)
		(minibuffer-print-noclear "esc-")
		(return (key-prompt-1 1 (get-char) nil)))
	         ((not (symbolp mf1))
		(minibuffer-print-noclear (printable key)
				      " (prefix char): ")
		(return (key-prompt-1 0 (get-char) key)))
	         (t (minibuffer-print-noclear (printable key))
		  (return (list metap key prefix))))))


;;; Compatability
(defun key-prompt-3args ()
       (key-prompt "?: "))


;;; Execute supplied function on all keys defined in current buffer
(defun map-over-emacs-commands (fun arg)
       (do i 0 (1+ i) (= i 256.)		;i hated fortran as a child
	 (do j 0 (1+ j) (= j 2)		;and i hate it now as a programmer.
	     (let ((element (key-bindings i j)))
		(cond ((not (symbolp element))
		       (do k 0 (1+ k)(= k 256.)
			 (or (not (arraycall t element k))
			     (eq (arraycall t element k) 'undefined-command)
			     (funcall fun (key-total-printed-symbol 0 k i)
				    (arraycall t element k) arg))))
		      ((eq element 'undefined-command))
		      (element
		        (funcall fun (key-total-printed-symbol j i nil) element arg)))))))


;;;

;;;
;;;	ESC Processing and Numeric Argument Readers
;;;


;;; Command to quit to editor top level
(defcom command-quit
        &numeric-argument (&ignore)
        &undo &ignore
        (ring-tty-bell)
        (throw 'les-petites-gazongues pgazonga))


;;; Command to "ignore" a prefix character, by default on prefix-^G
(defcom ignore-prefix
        &undo &ignore
        &numeric-argument (&ignore)
        (ring-tty-bell))

;;; Command to throw to top level or nearest yggdrasil (ldebug, multics mode
;;; are the only others beside top level)
(defcom command-prompt-abort
        &numeric-argument (&ignore)
        &undo &ignore
        (throw nil gazongue-a-l/'yggdrasil))

;;; Command bound to ESC key
(defcom escape
        &undo-function &pass
        &numeric-argument (&pass)
        (and (eq minibufferp ESC) (jetteur-des-gazongues))
        (escape-dont-exit-minibuf))

(defprop throw-to-toplevel jetteur-des-gazongues expr)

(defcom-synonym escape-dont-exit-minibuffer escape-dont-exit-minibuf)

;;; Set the undo switch.
(defcom undo-prefix
        &numeric-argument &pass
        &undo &pass
        (setq undo (not undo))
        (process-char (get-char)))

;;; Command that does real work of ESC
(defcom escape-dont-exit-minibuf
        &numeric-argument (&pass)
        &undo &pass
        (prog (nxcn numf negate)
a 	    (setq nxcn (get-char))
	    (cond ((and (> nxcn (1- (CtoI "0"))) (< nxcn (1+ (CtoI "9"))))	;number
		 (or numarg (setq numarg 0))
		 (setq numarg (+ (- nxcn (CtoI "0")) (* 10. numarg)))
		 (setq numf t)
		 (go a))
		((and (not numf) (= nxcn (CtoI "-")))	;want negative argument
		 (setq negate t numf t) (go a))
		((and (not numf) (= nxcn (CtoI "+")))	;want positive argument
		 (setq numf t) (go a))
		(t (and numf negate		;negative argument (default -1)
		        (setq numarg (- (or numarg 1))))
		   (cond (numf (process-char nxcn))
		         (t (execute-key 1 nxcn nil)))))))


;;; Command to collect numeric argument or use powers of 4
(defcom multiplier
        &undo &pass
        &numeric-argument (&pass)
        (prog (nxcn numf multf negate plus-given my-char)
	    (setq my-char last-input-char)	;character used to invoke this
a 	    (setq nxcn (get-char))
	    (cond ((and (> nxcn (1- (CtoI "0"))) (< nxcn (1+ (CtoI "9"))))	;number
		 (or numf (setq numf 0))
		 (setq numf (+ (- nxcn (CtoI "0"))(* 10. numf)))
		 (go a))
		((and (not numf) (= nxcn (CtoI "-")))	;negative argument
		 (setq numf 0 negate t) (go a))
		((and (not numf) (= nxcn (CtoI "+")))	;positive argument
		 (setq numf 0 plus-given t) (go a))
		((and (< nxcn 200) (eq (ascii nxcn) my-char))  ;NOTE- this code is buggy
		 (cond ((and (not numf) (not multf))
		        (setq multf 4))
		       ((not numf) (setq multf (* multf 4)))
		       (numf (setq numf nil))
		       (t (setq multf nil numf nil)))
		 (go a))
		(t (and (or negate plus-given) (= numf 0)
		        (setq numf 1))	;default number if only + given
		   (and negate (setq numf (- numf)))	;negate number (with -1 as default)
		   (setq numarg (cond ((and numf multf) (* numf multf))
				  (numf)
				  (multf (* 4 multf))
				  (t 4)))
		   (process-char nxcn)))))


;;; Read a "metazied" number (from Network mostly)
(defcom read-meta-argument
        &undo &pass
        &numeric-argument (&ignore)
        (prog (negate nxcn plus-given)
	    (setq nxcn (CtoI last-input-char))	;get charater invoked by (without meta-bit)
	    (setq numarg 0)
	    (cond ((= nxcn (CtoI "+")) (setq plus-given t))
		((= nxcn (CtoI "-")) (setq negate t))
		(t			;assume a digit
		  (setq numarg (- nxcn (CtoI "0")))))
a 	    (setq nxcn (get-char))
	    (cond ((and (> nxcn (1- (+ 200 (CtoI "0")))) (< nxcn (1+ (+ 200 (CtoI "9")))))
		 (setq numarg (+ (- nxcn (+ 200 (CtoI "0"))) (* 10. numarg)))
		 (go a))
		(t			;have character to execute
		  (and (= numarg 0) (or negate plus-given)
		       (setq numarg 1))	;a sign given, set default
		  (and negate (setq numarg (- numarg)))
		  (process-char nxcn)))))

;;; 

;;;
;;;	Character/Key/Command Execution
;;;

;;; Process a character: determine if it is a "meta" character and then
;;;  execute the key corresponding to the character
(defun process-char (ch)
       (or (fixp ch)
	 (setq ch (CtoI ch)))
       (let ((recursion-level (1+ recursion-level)))
	  (cond ((and (not (zerop network-flag))
		    (= ch 377))		;TELNET IAC
	         (setq ch (get-char))
	         (cond ((= ch 377)
		      (execute-key 1 177 nil))
		     (t (telnet-loser ch))))
	        ((> ch char-input-mask)	;meta-foo
	         (setq ch (logand char-input-mask ch))	;non-meta foo
	         (execute-key 1 ch nil))
	        (t (execute-key 0 ch nil)))))


;;; Execute a "key" as an Emacs command:  A "key" is the triplet consisting
;;;  of a character, "meta"-bit, and prefix character used to determine the
;;;  exact command to be executed.
(defun execute-key (metap ch prefix)
       (let ((command))			;the command to execute
	  (and (or (= metap 1) prefix)
	       (and (< ch (1+ (CtoI "z")))
		  (> ch (1- (CtoI "a")))
		  (setq ch (- ch 40))))
	  (cond ((not prefix) (setq command (key-bindings ch metap)))
	        (t (setq command (arraycall t (key-bindings prefix 0) ch))))
	  (cond ((symbolp command)		;normal command
	         (setq last-command-triplet-mpfxk (cond ((= metap 1) 'meta)
					        (t prefix))
		     last-command-triplet-1 ch)
	         (execute-command command (last-command-triplet) nil))
	        (t			;a prefix character
		(execute-key 0 (get-char) ch)))))

(defvar (autoload-inform))
;;;(register-option 'autoload-inform nil) ;;; moved to e_option_defaults_

;;; Ensure that autoloads are done early in the execution phase.
(defun ensure-autoload (command)
       (cond ((getl command '(editor-macro subr expr)))
	   ((not (get command 'autoload)))
	   ('else
	     (if autoload-inform
	         (minibuffer-print "Autoloading " command " ... "))
	     (protect (loadfile (get command 'autoload))
		    &success
		    (if autoload-inform
		        (minibuffer-print-noclear "done."))
		    &failure
		    (if autoload-inform
		        (minibuffer-print-noclear "failed."))))))

(setq last-time-sample nil)

;;; Execute an Emacs command
(defun execute-command (command key argument-list)
       (ensure-autoload command)
       (setq current-command command)
       (or last-time-sample (setq last-time-sample (time)))
       (let  ((last-time-sample 'dont-sample))
	   (cond ((get command 'editor-macro)	;keyboard macro
		(or (null argument-list)
		    (display-error (ed-get-name command key)
			         " does not accept arguments."))
		(push-editor-macro-level (get command 'editor-macro)
				     (editor-macro-arg-interp numarg))
		(setq previous-command command
		      previous-argument-list nil))
	         ((get command 'editor-command)	;new-style command
		(execute-new-command command key argument-list))
	         (t		;old-style command
		 (or (null argument-list)
		     (display-error (ed-get-name command key)
				" does not accept arguments."))
		 (execute-old-command command (last-command-triplet)))))
       (and (or command-bell meter-commands) ;Avoid call if we can.
	  (command-timing last-time-sample))
       (setq numarg nil undo nil last-time-sample nil))

;;; Handle command timing.
;;; nil=> no bell.  otherwise threshhold in seconds
;;;(register-option 'command-bell nil) ;;; moved to e_option_defaults_
;;; nil=> no bell.  fixnum=>number of bells.  otherwise function to call.
;;;(register-option 'command-bell-count nil) ;;; moved to e_option_defaults_
;;; nil=> no metering. t=> minibuffer metering. otherwise function.
;;;(register-option 'meter-commands nil) ;;; moved to e_option_defaults_

;;; Moved to e_option_defaults
;;;(defprop command-bell t value-ok-anything)
;;;(defprop command-bell-count t value-ok-anything)
;;;(defprop meter-commands t value-ok-anything)

(defun command-timing (sample)
       (or (null sample) (not (floatp sample))
	 (let ((difference (-$ (time) sample)))
	      (and command-bell (> difference (float command-bell))
		 (cond ((fixp command-bell-count)
		        (do-times command-bell-count (ring-tty-bell)))
		       (command-bell-count
		         (funcall command-bell-count difference))))
	      (cond ((eq meter-commands 't)
		   (minibuffer-print (decimal-rep difference) "s"))
		  (meter-commands
		    (funcall meter-commands difference))))))

;;; Returns command name for error messages
(defun ed-get-name (command key)
       (catenate command
	       (cond ((get command 'editor-macro) " (keyboard macro)")
		   (t ""))
	       (cond (key
		     (catenate " (" (get-key-name key) ")"))
		   (t ""))))


;;; Try to convert an argument to a fixnum and return nil if not valid
(defun ed-cv-fixnum-check (argument)
       (let ((argument-list (exploden argument)))
	  (do ((digit (car argument-list) (car argument-list))
	       (negate)
	       (value))
	      ((not digit)
	       (and negate (setq value (- value)))
	       value)
	      (cond ((and (= digit #/+) (not value)) ;+ as first char
		   (setq value 0))
		  ((and (= digit #/-) (not value))
		   (setq value 0 negate t))
		  ((and (> digit (1- #/0)) (< digit (1+ #/9)))
		   (setq value (+ (- digit #/0) (* 10. (or value 0)))))
		  (t			;not valid in a number
		    (return nil)))
	      (setq argument-list (cdr argument-list)))))

;;; 

(setq *transparent-commands*  '(escape multiplier noop re-execute-command
			 extended-command))

;;; Invoke a new-style Emacs command
;;; JSL's new version - June 1982
(defun execute-new-command (command key argument-list)
       (do ((done)
	  (flags (get command 'editor-command))
	  (function command)
	  (ignore-rejected-numarg)
	  (prologue-info)
	  (result)
	  (times))
	 (done result)
	 ;;
	 ;; Check for synonym command.
	 ;;
	 (and (symbolp flags)
	      (return (execute-command flags key argument-list)))
	 ;;
	 ;; Check for undo.
	 ;;
	 (if undo
	     (and (tlnn flags 000500)
		(setq undo nil))
	     (and (tlnn flags 000400)
		(return (execute-command (get command 'ed-undo-function)
				     key argument-list)))
	     (and (tlne flags 000700)
		(display-error (ed-get-name command key)
			     " does not accept the undo prefix.")))
	 ;;
	 ;; Here to process numeric arguments.
	 ;;
	 (if numarg
	     ;;
	     ;; Check for &numeric-function.
	     ;;
	     (if (tlnn flags 001000)
	         (setq function (get function 'ed-numeric-function))
	         (ensure-autoload function)
	         (or (and function (getl function '(subr lsubr fsubr
					    expr lexpr fexpr)))
		   (display-error (ed-get-name command key)
			        " does not accept a numeric argument."))
	         (setq flags (or (get function 'editor-command) 0)
		     ignore-rejected-numarg t))
	     ;;
	     ;; Check for &negative function.
	     ;;
	     (if (and (< numarg 0) (tlnn flags 200000))
	         (setq function (get function 'ed-negative-function))
	         (ensure-autoload function)
	         (or (and function (getl function '(subr lsubr fsubr
					    expr lexpr fexpr)))
		   (display-error (ed-get-name command key) " does not "
			        "accept a negative numeric argument."))
	         (setq flags (or (get function 'editor-command) 0)
		     numarg (- numarg)
		     ignore-rejected-numarg t))
	     ;;
	     ;; Now process &repeat, &reject, &ignore and check bounds.
	     ;;
	     (let ((numarg-type (logand flags (lsh 070000 18.)))
		 (numarg-range (and (tlnn flags 100000)
				(get function 'ed-numeric-range))))
		(setq times (ed-interpret-numarg command key numarg-type
					   numarg-range
					   ignore-rejected-numarg))))
	 ;;
	 ;; Simple case.
	 ;;
	 (if (and (null argument-list)
		(tlne flags 406040))	; Has no special handling needed.
	     ;;
	     ;; Deal with numeric argument, if any.
	     ;;
	     (cond (times (setq numarg nil))
		 (t (setq times 1)))
	     ;;
	     ;; Call the function, and return its result.
	     ;;
	     (return
	       (cond ((eq (cadr function) 'subr)
		    (do ((i 1 (1+ i))
		         (f (caddr function))
		         (inv (or (memq command *transparent-commands*)
			        (memq command nobreak-functions))))
		        ((> i times) result)
		        (setq result (subrcall t f))
		        (or inv
			  (setq previous-command command
			        previous-argument-list nil))))
		   (t (do ((i 1 (1+ i))
			 (inv (or (memq command *transparent-commands*)
				(memq command nobreak-functions))))
			((> i times) result)
			(setq result (funcall function))
			(or inv
			    (setq previous-command command
				previous-argument-list nil)))))))
	 ;;
	 ;; Prepare for cleanup handler, in case specified.
	 ;;
	 (unwind-protect
	   (progn
	     ;;
	     ;; Do prologue if specified.
	     ;;
	     (and (tlnn flags 004000)	;has prologue code.
		(setq prologue-info
		      (funcall (get function 'ed-prologue-function))))
	     ;;
	     ;; Process arguments.
	     ;;
	     (and (or (tlnn flags 400000)	;wants arguments
		    (not (null argument-list)))
		(setq argument-list
		      (ed-interpret-arguments command key function flags
					argument-list)))
	     ;;
	     ;; Clear numarg for &repeat case.
	     ;;
	     (cond (times (setq numarg nil))
		 (t (setq times 1)))
	     ;;
	     ;; Do the command as many times as necessary, calling the
	     ;; prologue after each invocation, if there is one.
	     ;;
	     (do ((epilogue (and (tlnn flags 002000)
			     (get function 'ed-epilogue-function)))
		(i 1 (1+ i))
		(inv (or (memq command *transparent-commands*)
		         (memq command nobreak-functions))))
	         ((> i times))
	         (setq result (apply function argument-list))
	         (and epilogue
		    (setq result (funcall epilogue prologue-info
				      result (= i times))))
	         (or inv
		   (setq previous-command command
		         previous-argument-list argument-list)))
	     ;;
	     ;; We won't need cleanup handler anymore.
	     ;;
	     (setq done (> times 0)))
	   ;;
	   ;; Here we check for cleanup handler.
	   ;;
	   (and (not done) (setq done t)
	        (tlnn flags 000040)
	        (setq flags (get function 'ed-cleanup-function))
	        (funcall flags prologue-info)))))


;;; Interpret the numeric argument
;;; JSL's new version - June 1982
(defun ed-interpret-numarg (command key numarg-type numarg-range
		        ignore-rejected-numarg)
       (and numarg-range		;a range is specified
	  (let ((lower (car numarg-range))
	        (upper (cdr numarg-range)))
	       (cond (lower		;lower bound specified
		     (setq lower (ed-get-encoded-value lower))
		     (and (< numarg lower)  ;lose, lose
			(display-error
			  (ed-get-name command key)
			  " does not accept a "
			  (cond ((= lower 0)	;a special case
			         "negative numeric argument.")
			        (t (catenate
				   "numeric argument < "
				   (decimal-rep lower)
				   "; you supplied "
				   (decimal-rep numarg) ".")))))))
	       (cond (upper		;upper bound specified
		     (setq upper (ed-get-encoded-value upper))
		     (and (> numarg upper)  ;lose, lose
			(display-error
			  (ed-get-name command key)
			  " does not accept a "
			  (cond ((= upper -1)	;a special case
			         "positive numeric argument.")
			        (t (catenate
				   "numeric argument > "
				   (decimal-rep upper)
				   "; you supplied "
				   (decimal-rep numarg) ".")))))))))
       (cond ((zerop numarg-type)		; Pass numeric argument.
	    nil)
	   ((= numarg-type (lsh 010000 18.))	; Repeat numeric argument.
	    numarg)
	   ((= numarg-type (lsh 020000 18.))	; Ignore numeric argument.
	    (setq numarg nil))
	   ;;
	   ;; If we get here, numarg-type = (lsh 030000 18.) Reject.
	   ;;
	   (ignore-rejected-numarg
	     (setq numarg nil))
	   (t (display-error (ed-get-name command key)
			 " does not accept a numeric argument."))))


;;; Interpret and complete the command's argument list
;;; Slightly modified by JSL summer '82
(defun ed-interpret-arguments (command key function flags argument-list)
       (let ((nargs-given (length argument-list))
	   (nargs-wanted (logand flags 777777))
	   (args-template (get function 'ed-argument-list)))
	  (and (= nargs-wanted 0)		;no arguments allowed
	       (> nargs-given 0)		;but some were supplied
	       (display-error (ed-get-name command key)
			  " does not accept arguments."))
	  (do ((i 1 (1+ i))			;go through the arguments
	       (args-wanted args-template (cdr args-wanted))
	       (args-given argument-list (cdr args-given))
	       (new-arguments))
	      ((> i nargs-wanted)		;until all args processed
	       (nreverse new-arguments))	;'twas built in reverse
	      (setq new-arguments (cons
			        (ed-interpret-single-arg
				command key nargs-wanted nargs-given i
				(car args-wanted)
				(car args-given)
				(= i nargs-wanted) (cdr args-given))
			        new-arguments)))))


;;; Interpretation of a single argument
(defun ed-interpret-single-arg (command key nargs-wanted nargs-given
			  arg-no arg-template arg-supplied
			  last-argp rest-of-args-supplied)
       (let ((data-type		;data type of argument
	     (logand (car arg-template) (lsh 700000 18.)))
	   (have-prompt		;non-zero => prompt if missing
	     (tlnn (car arg-template) 040000))
	   (have-default		;non-zero => default value exists
	     (tlnn (car arg-template) 020000))
	   (have-restrictions	;non-zero => value is restricted
	     (tlnn (car arg-template) 010000))
	   (prompt-info (cadr arg-template))
	   (default-info (caddr arg-template))
	   (restriction-info (cadddr arg-template))
	   (show-error (cond ((tlnn (car arg-template) 040000)
			  ;;can prompt for new value
			  'display-error-noabort)
			 (t 'display-error)))
	   (completion-list (eval (car (cddddr arg-template)))))
	  (do ((the-argument arg-supplied)	;start with what's given
	       (have-argument))
	      (have-argument the-argument)	;return constructed arg
	      (cond
	        ((or (= data-type (lsh 300000 18.))	;&rest-as-string
		   (= data-type (lsh 400000 18.)))	;&rest-as-list
	         (or last-argp
		   (display-error "Argument #" (decimal-rep arg-no)
			        " of " (ed-get-name command key)
			        " is a rest-of-arguments type, but "
			        "is not the last argument."))
	         (setq have-argument t	;this will succeed
		     the-argument (cond
				((= data-type (lsh 300000 18.))
				 ;;wants a string
				 (catenate
				   (or arg-supplied "")
				   (do ((args
					rest-of-args-supplied
					(cdr args))
				        (x "" (catenate
					      x " " (car args))))
				       ((null args) x))))
				(t	;wants a list
				  (append (and arg-supplied
					     (list arg-supplied))
					rest-of-args-supplied)))))
	        ((and last-argp rest-of-args-supplied)
	         (display-error (ed-get-name command key) " expects "
			    (decimal-rep nargs-wanted) " arguments;"
			    " you supplied " (decimal-rep nargs-given)
			    "."))
	        (the-argument
		;;something here, check it for legality
		(cond ((zerop data-type)	;string argument, no checking
		       (setq have-argument t))
		      ((= data-type (lsh 100000 18.))    ;wants a symbol
		       (let ((x (ed-interpret-symbol-arg
			        command key arg-no the-argument
			        show-error have-restrictions
			        restriction-info)))
			  (setq the-argument (car x)
			        have-argument (cdr x))))
		      ((= data-type (lsh 200000 18.))
		       ;;wants an integer
		       (let ((x (ed-interpret-integer-arg
			        command key arg-no the-argument
			        show-error have-restrictions
			        restriction-info)))
			  (setq the-argument (car x)
			        have-argument (cdr x))))
		      (t		;unknown data type
		        (display-error "Argument #" (decimal-rep arg-no)
				   " of " (ed-get-name command key)
				   " has an unknown data type."))))
	        (t			;prompt or use default
		(cond (have-prompt	;prompt for it
		        (setq the-argument (minibuf-response
				         (ed-get-encoded-value
					 (car prompt-info))
				         (cdr prompt-info)))
		        (and have-default ;if there's a default
			   (nullstringp the-argument)  ;no value given
			   (setq the-argument (ed-get-encoded-value
					    default-info))))
		      (have-default	;have default value
		        (setq the-argument (ed-get-encoded-value
				         default-info)))
		      (t		;no prompt, no default
		        (display-error "Argument #" (decimal-rep arg-no)
				   " of " (ed-get-name command key)
				   " has no prompt or default value.")
		        )))))))


;;;
;;; Interpretation of an argument which should be a symbol
;;;

(defun ed-interpret-symbol-arg (command key arg-no the-argument show-error
				have-restrictions restriction-info)
       (let ((argument (intern (make_atom (e_lap_$trim the-argument))))
	   (have-argument nil))		;not found yet
	  (cond (have-restrictions		;but it's value is limited
		(let ((possible-values (ed-get-encoded-value
				     restriction-info)))
		     (cond ((memq the-argument possible-values)
			  (setq have-argument t))
			 (t		;not good
			   (funcall show-error
				  "Argument # " (decimal-rep arg-no)
				  " of " (ed-get-name command key)
				  " must be one of:"
				  (do ((values possible-values
					     (cdr possible-values))
				       (x "" (catenate x " "
						   (car values))))
				      ((null values) x)))
			   (setq argument nil)))))	;force prompt
	        (t			;value not restricted, got it
		(setq have-argument t)))
	  (cons argument have-argument)))

;;;
;;; Interpretation of an argument which should be an integer
;;;

(defun ed-interpret-integer-arg (command key arg-no the-argument show-error
				 have-restrictions restriction-info)
       (let ((value (cond ((fixp the-argument) the-argument)
		      (t (ed-cv-fixnum-check the-argument))))
	   (have-argument))			;none yet
	  (cond (value			;got something
		(cond (have-restrictions	;but restricted
		        (let ((lower (car restriction-info))
			    (upper (cdr restriction-info)))
			   (cond (lower	;has lower bound
				 (setq lower (ed-get-encoded-value
					     lower))
				 (cond ((< value lower)
				        (cond ((= lower 0)
					     (funcall
					       show-error
					       "Argument #"
					       (decimal-rep arg-no)
					       " of "
					       (ed-get-name
					         command key)
					       " must not be "
					       "negative."))
					    (t
					      (funcall
					        show-error
					        "Argument #"
					        (decimal-rep arg-no)
					        " of "
					        (ed-get-name
						command key)
					        " must be >= "
					        (decimal-rep lower)
					        "; you supplied "
					        (decimal-rep value)
					        ".")))
				        (setq value nil)))))
					;;force prompt
			   (cond (upper	;has upper bound
				 (setq upper (ed-get-encoded-value
					     upper))
				 (cond ((> value upper)
				        (cond ((= upper -1)
					     (funcall
					       show-error
					       "Argument #"
					       (decimal-rep arg-no)
					       " of "
					       (ed-get-name
					         command key)
					       " must not be "
					       "positive."))
					    (t (funcall
					         show-error
					         "Argument #"
					         (decimal-rep arg-no)
					         " of "
					         (ed-get-name
						 command key)
					         " must be <= "
					         (decimal-rep upper)
					         "; you supplied "
					         (decimal-rep value)
					         ".")))
				        (setq value nil))))))
					;force prompt
		        (and value		;passed the tests
			   (setq have-argument t)))
		      (t			;unrestricted, got it
		        (setq have-argument t))))
	        (t			;not a number
		(funcall show-error
		         "Argument #" (decimal-rep arg-no) " of "
		         (ed-get-name command key)
		         " must be an integer, not " the-argument ".")
		(setq have-argument nil)))	;force prompt
	  (cons value have-argument)))

;;;
;;; Evaluate an encoded value.
;;;

(defun ed-get-encoded-value (encoded-value)
        (let ((type (car encoded-value))
	    (value (cadr encoded-value)))
	   (cond ((eq type 'quote) value)	;actual value is here
	         ((eq type 'eval) (funcall value))   ;value from function
	         (t			;unknown
		 (display-error "Unknown value encoding: " type)))))

;;; 

;;; Execute an old style Emacs command
;;; Slightly modified by JSL (mostly format) - June 1982
(defun execute-old-command (command key)
       (let ((function command)
	   (numarg-repeat))
	  (setq numarg-repeat (get command 'argwants))
	  (and (< (or numarg 1) 0)
	       numarg-repeat
	       (setq numarg (- numarg)
		   function (or (get command 'negative-arg-function)
			      'bad-negative-argument)))
	  (or (eq (cadr function) 'subr)
	      (get function 'subr)
	      (get function 'expr)
	      (get function 'autoload)
	      (display-error "Undefined function " function " for "
			 command " (" (get-key-name key) ")"))
	  (setq numarg-repeat (cond (numarg-repeat (or numarg 1))
			        (t 1)))
	  (cond ((eq (cadr function) 'subr)
	         (do ((i 1 (1+ i))
		    (f (caddr function)))
		   ((> i numarg-repeat))
		   (subrcall t f)
		   (setq previous-command command
		         previous-argument-list nil)))
	        (t (do ((i 1 (1+ i)))
		     ((> i numarg-repeat))
		     (funcall function)
		     (setq previous-command command
			 previous-argument-list nil))))))


;;; Execute an actual command the specified number of times
;;; with the given arguments.
(defun execute-command-function (command function ntimes argument-list)
       (cond ((and (eq (cadr function) 'subr) (< (length argument-list) 5))
	    (do ((i 1 (1+ i))
	         (f (caddr function))
	         (nargs (length argument-list)))
	        ((> i ntimes))
	        (cond ((= nargs 0)
		     (subrcall t f))
		    ((= nargs 1)
		     (subrcall t f (car argument-list)))
		    ((= nargs 2)
		     (subrcall t f (car argument-list)
			     (cadr argument-list)))
		    ((= nargs 3)
		     (subrcall t f (car argument-list)
			     (cadr argument-list) (caddr argument-list)))
		    ((= nargs 4)
		     (subrcall t f (car argument-list)
			     (cadr argument-list) (caddr argument-list)
			     (car (cdddr argument-list)))))
	        (or (memq command '(escape multiplier noop
			        re-execute-command extended-command))
		  (setq previous-command command
		        previous-argument-list argument-list))))
	   (t (do i 1 (1+ i) (> i ntimes) (apply function argument-list)
		(or (memq command '(escape multiplier noop
				re-execute-command extended-command))
		    (setq previous-command command
			previous-argument-list argument-list))))))


;;; Emacs command to re-execute the last command
(defcom re-execute-command
        &undo &pass
        &numeric-argument (&pass)
        (or previous-command
	  (display-error "No saved previous command"))
        (execute-command previous-command  nil previous-argument-list))


;;; Emacs command invoked for an unbound key
(defcom undefined-command
        &numeric-argument (&ignore)
        &undo &ignore
        (display-error "Unknown command: " (get-key-name (last-command-triplet))))


;;; Emacs command invoked for a key whose command doesn't accept negative arguments
(defcom bad-negative-argument
        &undo &ignore
        &numeric-argument (&ignore)
        (display-error "Command rejected negative argument: " (get-key-name (last-command-triplet))))


;;; Function to return the last key typed by the user
(defun last-command-triplet ()
       (cond ((eq last-command-triplet-mpfxk 'meta)
	    (list 1 last-command-triplet-1 nil))
	   (t (list 0 last-command-triplet-1 last-command-triplet-mpfxk))))

;;; 

;;;
;;;	ESC-X Command
;;;	 New version: 27 August 1979 by GMP
;;;

;;; Invoke an Emacs command with arguments as read from mini-buffer
(defcom extended-command
        &arguments ((command-line &prompt "Command: "
			    &completions Fundamental/.ext-commands))
        &numeric-argument (&pass)
        &undo &pass
        (let ((command-list (parse-command-line command-line)))  ;split into pieces
	   (if (not (null command-list))
	       (let ((command-name (car command-list))
		   (arguments (cdr command-list)))
		  (or (nullstringp command-name)   ;if nothing there
		      (let ((command (intern (make_atom command-name))))
			 (ensure-autoload command)
			 (cond ((getl command '(editor-command editor-macro))
			        (execute-command command nil arguments))
			       (t (execute-old-extended-command command arguments)))))))))


;;; Parse a line into tokens, obeying the Multics quoting convention
(defun parse-command-line (line)
       (do ((input (exploden line))
	  (answer nil))
	 (nil)
	 (setq input
	       (do ((input1 input (cdr input1)))
		 ((or (null input1)
		      (not (member (car input1) '(#^I #^J #/ ))))
		  input1)))
	 (cond ((null input)
	        (return (nreverse answer)))
	       (t
	         (setq answer
		     (cons
		       (do ((result ""))
			 ((or (null input)
			      (member (car input) '(#^I #^J #/ )))
			  result)
			 (setq result
			       (catenate result
				       (cond
				         ((= (car input) #/")
					(do ((input1 (cdr input) (cdr input1))
					     (quoted t)
					     (piece ""))
					    ((not quoted)
					     (setq input input1)
					     piece)
					    (cond
					      ((null input1)
					       (display-error "Unbalanced quotes."))
					      ((and (= (car input1) #/")
						  (equal (cadr input1) #/"))
					       (setq input1 (cdr input1)
						   piece (catenate piece """")))
					      ((= (car input1) #/")
					       (setq quoted nil))
					      (t
					        (setq piece (catenate piece
								(ItoC (car input1))))))))
				         (t
					 (do ((input1 (cdr input) (cdr input1))
					      (piece (ItoC (car input))
						   (catenate piece (ItoC (car input1)))))
					     ((or (null input1)
						(member (car input1) '(#^I #^J #/  #/")))
					      (setq input input1)
					      piece)))))))
		       answer))))))


;;; Invoke an old-style extended command (no prompting, etc.)
(defun execute-old-extended-command (command arguments)
       (or (getl command '(expr subr lsubr autoload))
	 (display-error "Unknown command: " command))
       (ensure-autoload command)
       (let ((argsprop (args command))
	   (nargs (length arguments)))
	  (cond ((null argsprop) nil)		;unknown number wanted
	        ((and (not (< nargs (or (car argsprop)
				  (cdr argsprop))))
		    (not (> nargs (cdr argsprop))))
	         nil)			;correct number supplied
	        (t
		(display-error "Wrong number of arguments to extended command " command "."))))
       (apply command			;execute command
	    (do ((args arguments (cdr args))	;intern/convert all arguments
	         (new-arg-list nil
			   (cons (let ((argument (car args))
				     (value))
				    (setq value (ed-cv-fixnum-check argument))
				    (cond (value value)
					(t (intern (make_atom argument)))))
			         new-arg-list)))
	        ((null args) (nreverse new-arg-list)))))

;;; 

;;;
;;;	O boy hairy "macro" feature.
;;;	Appreciations to Dan Weinreb's "EINE" E.L.E.,
;;;	The state of the art advances now with my cursor.

;;;	Redone pretty much wholesale 2/11/79 to allow "input chars".
;;;	Have a good time in California, DLW, thanks for everything, -bsg.

;;; When a macro is being executed, this is called to supply input from the
;;; executing macro.
(defun kmacro-get-one-cmd (expected-type)
       (let ((this (car macro-execution-in-progress))
	   (rest (cdr macro-execution-in-progress)))
	  (cond ((and (numberp this)(eq expected-type 'input-char))
	         (setq macro-execution-in-progress rest)
	         this)
	        ((eq expected-type 'toplevel-char)
	         (cond ((eq this 'macend)
		      (execute-single-editor-enmacroed-command 'macend)
		      (cond (macro-execution-in-progress
			    (kmacro-get-one-cmd expected-type))
			  (t nil)))
		     ((atom this)
		      (display-error "Keyboard macro lost synchrony."))
		     ((eq (car this) 'toplevel-char)
		      (setq macro-execution-in-progress rest)
		      (cdr this))
		     (t nil)))
	        ((eq expected-type 'input-char)
	         ;;^U ^F, the ^F is like this in "articifially generated"
	         ;;macros.  char will get this, i.e., nothing at all,
	         ;;and go to the tty for input
	         (setq macro-execution-in-progress rest) ;1/29/80 fix bsg
	         (cdr this)))))
		
       

;;; When a macro is being recorded, this is called to record a single input
;;; character. Toplevelness is stored for ease in displaying definition.
;;;  (An idea by R. M. Stallman)

(defun kmacro-record-input (ch type)
       (setq macro-collection-in-progress
	   (cons (cond ((eq type 'toplevel-char)
		      (cons 'toplevel-char ch))
		     (t ch))
	         macro-collection-in-progress)))

;;; The commands to start and stop collecting macroes (macros?, macreaux?)

(defcom begin-macro-collection
        &numeric-argument (&reject)
        (cond (macro-collection-in-progress
	      (display-error "Macro already in collection."))
	    (minibufferp			;aaah, mustatio patris
	      (command-quit))
	    (t (assert-minor-mode 'Macro/ Learn)
	       (setq macro-collection-in-progress (list nil)))))


(defcom end-macro-collection
        &numeric-argument (&pass)
        (wrap-up-macro-definition)
        (and numarg (execute-last-editor-macro)))


(defun editor-macro-arg-interp (arg)
       (cond ((not arg) 1)			;once
	   ((= arg 0) 'query)
	   ((< arg 0) 'forever)
	   ((> arg 9999.) 'forever)
	   (t arg)))


(defun push-editor-macro-level (mac ntimes)
       (and (> (length macrostack) 20.)
	  (display-error "Too much macro recursion."))
       (and macrostack (rplaca (cdr (car macrostack)) macro-execution-in-progress))
       (setq macrostack (cons (list mac mac ntimes) macrostack))
       (setq macro-execution-in-progress (cadr (car macrostack))))


(defun wrap-up-macro-definition ()
       (or macro-collection-in-progress (display-error "No macro in progress."))
       (negate-minor-mode 'Macro/ Learn)
       (setq last-macro-definition
	   (cdr (nreverse (cons 'macend
			    (do ((l macro-collection-in-progress (cdr l)))
			        ((null l)(display-error "Void macro."))
			        (and (not (atom (car l)))
				   (eq (caar l) 'toplevel-char)
				   (return (cdr l))))))))
       (setq macro-collection-in-progress nil))


(defcom execute-last-editor-macro
        &numeric-argument (&pass)
        (or last-macro-definition (display-error "No macro to run."))
        (push-editor-macro-level last-macro-definition (editor-macro-arg-interp numarg)))


(defun execute-single-editor-enmacroed-command (x)
       (cond ((eq x nil))			;empty in list
	   ((eq x 'halt)
	    (setq macrostack (cdr macrostack))
	    (setq macro-execution-in-progress (cadar macrostack)))
	   ((eq x 'repeat)
	    (setq macro-execution-in-progress (caar macrostack))
	    (rplaca (cdar macrostack) macro-execution-in-progress))
	   ((eq x 'macend)
	    (let ((count (caddar macrostack)))
	         (cond ((eq count 'query)
		      (cond ((macro-query-get-answer)
			   (execute-single-editor-enmacroed-command 'repeat))
			  (t (execute-single-editor-enmacroed-command 'halt))))
		     ((eq count 'forever)
		      (execute-single-editor-enmacroed-command 'repeat))
		     ((< count 2)
		      (execute-single-editor-enmacroed-command 'halt))
		     (t (rplaca (cddar macrostack) (1- count))
		        (setq macro-execution-in-progress (caar macrostack))
		        (rplaca (cdar macrostack) macro-execution-in-progress)))))
	   (t (display-error "Internal macro format error: " x)))))))

;;;
;;;
;;;	Macro utilities
;;;

;;; Save a macro definition
(defcom save-macro
        &prologue &eval (or last-macro-definition
		        (display-error "No macro defintion to store."))
        &arguments ((macro-name &symbol
			  &default &eval
				 (let ((name (intern-minibuf-response "Macro name? " NL)))
				      (cond ((getl name '(editor-command expr subr autoload))
					   (display-error name " is not an acceptable name."))
					  (t name))))
		(macro-key &symbol
			 &default &eval
				(get-key-name (key-prompt "On what key? "))))
        &numeric-argument (&reject)
        (putprop macro-name last-macro-definition 'editor-macro)
        (or (memq macro-key '(CR ^J))		;don't want it anywhere
	  (set-key macro-key macro-name)))


(defcom show-last-or-current-macro
        &numeric-argument (&pass)
        (cond (macro-collection-in-progress (wrap-up-macro-definition)))
        (show-editor-macro last-macro-definition))


(defcom show-macro
        &arguments ((macro-name &symbol &prompt "Macro name: "))
        &numeric-argument (&pass)
        (cond ((get macro-name 'editor-macro)
	     (show-editor-macro (get macro-name 'editor-macro)))
	    (t (display-error macro-name " is not a defined macro."))))


(defun kmacro-display-interpret (x)
       (prog (the-interpretation the-input fun prefix metap numbering stringing l2list whoops)
	   (setq the-input (nreverse (cdr (reverse x))))
tlc 	   (cond ((null the-input)
		(cond (stringing
		        (setq the-interpretation
			    (kmacro-stringing-util stringing the-interpretation))))
		(return (nreverse the-interpretation))))
	   (setq x (car the-input) the-input (cdr the-input))
	   (cond ((not (atom x))(setq x (cdr x))))   ;ignore tlc, ok here.
	   (setq prefix nil)
	   (cond ((> x char-input-mask) (setq x (bit-clear 200 x) metap 1))
	         (t (setq metap 0)))
	   (setq fun (get-key-binding (list metap x nil)) whoops x)
	   (cond (numbering
		 (cond ((kmacro-numberp x)
		        (setq numbering (cons x numbering))
		        (go tlc))
		       (t (setq the-interpretation
			      (cons (cons (implode (nreverse numbering))
				        'Numeric/ argument) the-interpretation)
			      numbering nil)))))
	   (cond ((and (null fun)(not (symbolp 3)))   ;ARRAYP
		(setq prefix x))
	         ((or (eq fun 'escape)
		    (eq fun 'escape-dont-exit-minibuf))
		(and stringing (setq the-interpretation
				 (kmacro-stringing-util stringing the-interpretation)
				 stringing nil))
		(cond ((and (eq fun 'escape)
			  the-input (not (atom (car the-input)))))
		      ;;probbly was ESC ending minibuffer, next was tlc.
 		      ((and the-input (kmacro-number-or-plusminusp (car the-input)))
		       (setq numbering (list (kmacro-number-or-plusminusp (car the-input)))
			   the-input (cdr the-input))
		       (setq the-interpretation
			   (cons (cons (key-total-printed-symbol metap x prefix) fun)
			         the-interpretation))
		       (go tlc))
		      (t (setq metap 1)
		         (cond ((null the-input)
			      (setq x whoops prefix nil metap 0))
			     (t (setq x (cond ((numberp (car the-input))
					   (car the-input))
					  (t (cdar the-input)))
				    the-input (cdr the-input))
			        (and (> x (1- (CtoI "a")))
				   (< x (1+ (CtoI "z")))
				   (setq x (- x 40))))))))
	         ((eq fun 'multiplier)
		(and stringing (setq the-interpretation
				 (kmacro-stringing-util stringing the-interpretation)
				 stringing nil))
		(setq the-interpretation
		      (cons (cons (key-total-printed-symbol metap x prefix)
			        fun)
			  the-interpretation))
		(cond ((and the-input (kmacro-number-or-plusminusp (car the-input)))
		       (setq numbering (list (kmacro-number-or-plusminusp (car the-input)))
			   the-input (cdr the-input))))
		(go tlc)))
	   (cond ((not (null prefix))
		(cond ((null the-input)(setq x whoops prefix nil metap 0))
		      (t (setq x (cond ((numberp (car the-input))
				    (car the-input))
				   (t (cdar the-input)))
			     the-input (cdr the-input))
		         (and (> x (1- (CtoI "a")))(< x (1+ (CtoI "z")))
			    (setq x (- x 40)))))))
	   (setq fun (get-cmd-symbol-3args metap x prefix))
	   (cond ((memq fun '(self-insert overwrite-mode-self-insert))
		(setq stringing (cons (ascii x) stringing)))
	         (t (cond (stringing
			(setq the-interpretation
			      (kmacro-stringing-util
			        stringing the-interpretation)
			      stringing nil)))
		  (setq the-interpretation
		        (cons (cons (key-total-printed-symbol metap x prefix)
				(get-cmd-symbol-3args metap x prefix))
			    the-interpretation))))
	   (setq l2list nil)
cl2c	   (cond ((or (null the-input)
		    (and (not (atom (car the-input)))	;collect lev 2 ch
		         (eq (caar the-input) 'toplevel-char)))
		(cond (l2list
		        (setq the-interpretation
			    (cons (cons (apply 'catenate
					   (nreverse l2list))
				      'Input/ Characters)
				the-interpretation))))
		(go tlc))
	         (t (setq l2list (cons (ascii (car the-input)) l2list)
		        the-input (cdr the-input))
		  (go cl2c)))))

(defun kmacro-stringing-util (s int)
       (map '(lambda (x)(cond ((eq (car x) '/")(rplaca x """""")))) s)
       (cons (cons (catenate """" (apply 'catenate (nreverse s)) """")
	         'String)
	   int))

(defun kmacro-numberp (x)
       (cond ((numberp x))
	   ((not (atom x))(setq x (cdr x))))
       (and (> x (1- (CtoI "0"))) (< x (1+ (CtoI "9"))) x))

(defun kmacro-number-or-plusminusp (x)
       (cond ((numberp x))
	   ((not (atom x)) (setq x (cdr x))))
       (cond ((and (> x (1- (CtoI "0"))) (< x (1+ (CtoI "9")))) x)
	   ((= x (CtoI "+")) '+)
	   ((= x (CtoI "-")) '-)))


(defun show-editor-macro (x)
       (setq x (kmacro-display-interpret x))	;Figger out what it means.
       (init-local-displays)
       (cond (numarg (mapc 'show-editor-macro-2 x))    ;hairy kind
	   (t (local-display-generator-nnl
	        (do ((mac x (cdr mac))
		   (stuff nil (cons (caar mac) stuff)))
		  ((null mac)(apply 'catenate	;WARNING 511 limit
				(mapcar '(lambda (y)(catenate " " y)) (nreverse stuff))))))))
       (end-local-displays))

(defun show-editor-macro-2 (x)
       (local-display-generator-nnl
         (catenate (car x) TAB
	         (cond ((getl (setq x (cdr x))
			  '(expr subr autoload)) x)
		     ((memq x '(String Input/ Characters Numeric/ argument)) x)
		     ((get x 'editor-macro)
		      (catenate x " (keyboard macro)"))
		     (t "--????--")))))


(defcom macro-query
        &numeric-argument (&reject)
        (cond (macro-collection-in-progress
	      (display-error-noabort "Inserting query at this point."))
	    ((not macro-execution-in-progress)
	     (display-error "macro query: no macro running."))
	    (t (cond ((not (macro-query-get-answer))
		    (setq macro-execution-in-progress (caar macrostack)))))))


(defun macro-query-get-answer ()
       (let ((macro-execution-in-progress nil)
	   (macro-collection-in-progress nil))
	  (echo-buffer-print "ok? :")
	  (redisplay)
	  (do ((ans (get-char)(get-char)))
	      (nil)
	      (cond ((= ans 7)(command-quit))
		  ((= ans 161)(command-quit))
		  ((= ans 12))
		  ((= ans 40)(return t))
		  ((= ans 15)(return nil))
		  ((= ans 131)(return t))	;y
		  ((= ans 156)(return nil))	;n
		  (t (return nil))))))

;;;	

;;;
;;;	Quit handling and no-op department - done right BSG 3/28/79
;;;	Improvements for process preservation - BSG 3 December '79


(defun emacs-quit-handler (arg)
       (setq arg arg)
       (signalquit))


(defcom signalquit
        &undo &ignore
        &numeric-argument (&ignore)
        (cond ((eq e-quit-transparency 'transparent)
	     (ioc z))			;This is to check flag safely even if NIL gets clobbered!
					;If this thing blows, you simply can't hit quit on Emacs.
	    (t (let ((oqt e-quit-transparency)	;So that we can quit cleanly
		   (e-quit-transparency 'transparent))
		  (randomize-redisplay)	;in case quit was caused by
		  (or oqt
		      (progn
		        (e_pl1_$set_emacs_tty_modes)	;tty reconnect
		        (clear-the-screen)
		        (and split-mode-p (rdis-restore-screen-to-one-split))))
		  (and DCTL-epilogue-availablep (DCTL-epilogue))
		  (e_pl1_$dump_output_buffer)
		  (e_pl1_$set_multics_tty_modes)
		  (terpri)
		  (cond ((and (eq emacs-name 'emacs_) quit-on-break)
		         (emacs$set_emacs_return_code
			 (error_table_ 'action_not_performed))
		         (or tasking-emacs (lisp-quit-function))))
		  (signalquit-hardcore-vt132-writearound)
		  (ioc z)
		  (e_pl1_$set_emacs_tty_modes)
		  (and DCTL-prologue-availablep (DCTL-prologue))
		  (and split-mode-p (rdis-recreate-splits-on-screen))
		  (or oqt (progn		;Redisplay suppressed
			  (full-redisplay)
			  (display-error-noabort
			    "Restarting from QUIT... ")
			  (redisplay)))))))

;;; Writearound for the hardcore/vt132 bug that causes screen to not
;;; be cleared on ^Z^Z or BREAK.  The problem looks like this:
;;;
;;; (1) Emacs sends characters to fix up screen.
;;; (2) Emacs does (ioc z), causing signal_ quit.
;;; (3) default_error_handler_ does a resetwrite.
;;; (4) Hardcore has not yet sent the clearing characters; they get eaten.
;;; (5) Screen stays screwed, though no longer in Emacs.
;;; (6) User gets confused.
;;;
;;; The only solutions are: (1) Do write_status's until all output is out,
;;; or (2) Just do a (sleep) of some interesting length.  I chose the sleep
;;; option.  If hardcore ever gets fixed, it would be nice to do a
;;; force_out operation to make sure the characters get out.
;;; Richard Mark Soley 14 November 1981
(defun signalquit-hardcore-vt132-writearound ()
       (and (eq tty-type 'vt132) (sleep 2)))

(defcom noop
        &numeric-argument (&ignore)
        &undo &ignore
        )

;;; This hack hides the lisp "quit" function, rebinding "quit"
;;; to "quit-the-editor", a much nicer function from Emacs' point of view.

(putprop 'lisp-quit-function (get 'quit 'subr) 'subr)
(remprop 'quit 'subr)
(defcom-synonym quit quit-the-editor)

;;; Exit from EMACS
(defcom quit-force
        &numeric-argument (&reject)
        (clear-reset)
        (set-lisp-rdis-meters)
        (alarmclock 'time nil) (alarmclock 'runtime nil)
        (cond ((zerop (e_tasking_$quit)) (tasking-restart))
	    (t (lisp-quit-function))))

(defun clear-reset ()
       (clear-the-screen)
       (and split-mode-p (rdis-restore-screen-to-one-split))
       (and DCTL-epilogue-availablep (DCTL-epilogue))
       (e_pl1_$dump_output_buffer)
       (e_pl1_$set_multics_tty_modes))

;;; Restart a tasking Emacs.
(defun tasking-restart () (tasking-restart-internal) (pi-handler))

(defun tasking-restart-internal ()
       (e_pl1_$init)
       (e_pl1_$set_emacs_tty_modes)
       (randomize-redisplay)
       (and DCTL-prologue-availablep (DCTL-prologue))
       (let ((su-args (e_argument_parse_$get_startup_info)))
	  (setq args:apply-arg (caddr (cddddr su-args))
	        args:paths (caddr su-args))
	  (setq emacs-start-ups-need-running 'default-emacs-start-up)
	  (init-echnego-bittab))
       (clear-the-screen)
       (setq tasking-restarted t))

;;; Decide if it's okay to quit now.
(defun okay-to-quit? ()
       (do ((buffers known-buflist (cdr buffers))
	  (found nil))
	 ((null buffers)
	  (cond ((not found) t)
	        (t (init-local-displays)
		 (local-display-generator-nnl "Modified Buffers:")
		 (local-display-generator-nnl "")
		 (mapc 'local-display-buffer-info found)
		 (local-display-generator-nnl "-------------------------")
		 (yesp "Modified buffers exist.  Quit?"))))
	 (and (not (get (car buffers) 'dont-notice-modified-buffer))
	      (not (empty-buffer-p (car buffers)))
	      (get-buffer-state (car buffers) 'buffer-modified-flag)
	      (setq found (cons (car buffers) found)))))

(defun local-display-buffer-info (buffer)
       (let ((path (get-buffer-state buffer 'fpathname)))
	  (local-display-generator-nnl
	    (catenate
	      (cond ((eq current-buffer buffer) ">")
		  ((eq previous-buffer buffer) "<")
		  (t " "))
	      (cond ((get-buffer-state buffer 'buffer-modified-flag) "*")
		  (t " "))
	      (cond (path
		    (catenate buffer
			    (substr "                         "
				  1 (max (- 25.
					  (stringlength buffer))
				         1))
			    path))
		  (t buffer))))))

;;; Mark this Emacs as dead if tasking, then quit.
(defcom destroy-task
        (and minibufferp
	   (display-error "No quitting while in the minibuffer."))
        (cond ((not tasking-emacs)
	     (display-error "This is not a tasking Emacs."))
	    ((not (okay-to-quit?)) (command-quit))
	    (t (e_tasking_$destroy_me)
	       (run-emacs-epilogue-actions)
	       (quit-force))))

;;; Exit from EMACS if no buffers are modified or user says OK
(defcom quit-the-editor
        &numeric-argument (&reject)
        (and minibufferp
	   (display-error "No quitting while in the minibuffer."))
        (cond (tasking-emacs (clear-reset) (e_tasking_$quit) (tasking-restart))
	    ((okay-to-quit?)
	     (run-emacs-epilogue-actions)
	     (quit-force))
	    (t (command-quit))))	      

(defun run-emacs-epilogue-actions ()		;5/6/80
       (do nil ((null emacs-epilogue-action-list))
	 (errset (apply (caar emacs-epilogue-action-list)
		      (cdar emacs-epilogue-action-list)))
	 (setq emacs-epilogue-action-list (cdr emacs-epilogue-action-list))))


(defun set-emacs-epilogue-handler (fnandargs dupflg)
       (or (and dupflg (assq (car fnandargs) emacs-epilogue-action-list))
	 (setq emacs-epilogue-action-list (cons fnandargs emacs-epilogue-action-list))))

;;;

(defun telnet-loser (c)
       (cond ((or (= c 363)(= c 364))		;BREAK, IP
	    (signalquit))
	   ((= c 253.)			;IAC DO
	    (setq c (e_pl1_$get_char))
	    (cond ((not (= c 1))		;DO ECHO
		 (display-error-noabort "Ignoring TELNET IAC DO " (implode (explodec c))))))
	   ((= c 254.)			;IAC DONT
	    (setq c (e_pl1_$get_char))
	    (cond ((not (= c 1))		;DONT ECHO
		 (display-error-noabort "Ignoring TELNET IAC DONT " (implode (explodec c))))))
	   (t (display-error-noabort "Ignoring TELNET IAC " (implode (explodec c)) "(octal). Good luck."))))


(defun define-autoload-lib fexpr (x)
       (mapc '(lambda (y)(set-autoload-lib y (car x)))(cdr x)))

;;;
;;;
;;;	HELP! What did I type?!?!? 2/11/79
;;;

(defcom help
        &undo &ignore
        &numeric-argument (&ignore)
        (init-local-displays)
        (local-display-generator-nnl
	(catenate "Help segments on Emacs are found in " documentation-dir "."))
        (mapc 'local-display-generator-nnl
	    '("See emacs.gi.info there for full information on everything."
	       "Type the escape key, the question mark key, and some key that"
	       "you want to know about to find out about it.  Type a control underscore"
	       "at any time to get more help.  Type control underscore"
	       "and a question mark for all help commands."
	       "Type two linefeeds to remove this display,"
	       "or any other display that ends with -- * * * * * * * --,"
	       "from your screen."))
        (end-local-displays))

(defcom-synonym ? help)


(defcom help-on-tap
        &numeric-argument (&ignore)
        &undo &ignore
        (minibuffer-print "HELP: (? for more info): ")
        (do x (get-char)(get-char) nil
	  (and (> x (1- #/a))
	       (< x (1+ #/z))
	       (setq x (- x 40)))
	  (cond ((= x 12))
	        ((= x #/H)(help))
	        ((= x #/C)(execute-command 'describe-key nil nil))
	        ((= x #/D)(execute-command 'describe nil nil))
	        ((= x #/A)(execute-command 'apropos nil nil))
	        ((= x #/L)(help-list-typin))
	        ((= x #/?)(help-whats-on-tap))
	        ((= x 7)(command-quit))	;^G
	        (t (help-whats-on-tap)))
	  (or (= x 12)(return nil)))
        (minibuffer-print ""))


(defun help-whats-on-tap ()
       (init-local-displays)
       (mapc 'local-display-generator-nnl
	   '("^_ H gives general help info."
	     "^_ ? gives this list of what ^_ can do."
	     "^_ A followed by a word and a CR looks for appropriate"
	     "     matching commands. Type ^_ D apropos CR for more on this."
	     "^_ C prompts for a character (or key sequence) and tells what it does."
	     "^_ D followed by an extended command name and a CR tells"
	     "     about the extended command."
	     "^_ L Lists the last 50 characters or commands typed."))
       (local-display-generator-nnl
         "Type two linefeeds to remove this display from your screen.")
       (end-local-displays))


(defun help-list-typin ()
       (do ((stop (cond ((= history-next-index 0) 50.)
		    (t history-next-index)))
	  (cur history-next-index (1+ cur))
	  (first t nil)
	  (nl)
	  (l))
	 ((and (not first)(= cur stop))
	  (do c 0 (1+ c)(= c 50.)
	      (or l (return nil))
	      (setq nl (cons (car l) nl) l (cdr l)))
	  (init-local-displays)
	  (do ((line (catenate (printable (car nl)) " ")
		   (catenate line (cond (nl (printable (car nl)))
				    (t ""))
			   " ")))
	      ((null nl)
	       (or (nullstringp line)(samepnamep line " ")
		 (local-display-generator-nnl line)))
	      
	      (cond ((> (stringlength line)(- screenlinelen 6))
		   (local-display-generator-nnl line)
		   (setq line "")))
	      (setq nl (cdr nl))))
	 (and (= cur 50.)(setq cur 0))
	 (cond ((numberp (saved-command-history cur))
	        (setq l (cons (saved-command-history cur) l)))
	       ((null (saved-command-history cur)))
	       ;; Next case is combined chars from get-top-level-char-innards
	       (t (setq l (append (nreverse (explodec (saved-command-history cur)))
			      l)))))
       (local-display-generator-nnl "Type two linefeeds to remove this display from the screen.")
       (end-local-displays))




		    e_lap_.lap                      08/01/88  1005.0rew 08/01/88  1004.6      154566



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

;;; HISTORY COMMENTS:
;;;  1) change(88-01-07,Schroth), approve(88-02-29,MCR7851),
;;;     audit(88-06-08,RBarstad):
;;;     Originally created by Bernie Greenberg in 1978.
     
;;;     Changed for 8-bit extended ASCII I/O by removing e_lap_$tabscan and
;;;     adding e_lap_$tabscan_table.
;;;                                                      END HISTORY COMMENTS

;;;
;;;
;;;	LAP String Hackery
;;;	 BSG
;;;

(declare (nouuo t) (sstatus uuolinks nil))
(declare (*rset t) (setq errset '(lambda n (break foobar))))


;;; Table generating macro
(defun make-n-of macro (x)
       (let ((howmany (eval (cadr x)))
	   (thingum (eval (caddr x))))
	  (do ((i 0 (1+ i))
	       (l nil
		(cons (list thingum thingum) l)))
	      ((= i howmany) l))))


;;; Create a pseudo-string object
(lap e_lap_$make-dat-ol-black-magic-string subr 1)
; (make-dat-ol-black-magic-string string-ptr) (returns string)
;			    -2,-1
          (ldaq     ap|-2)		;get fixnum ptr in q
          (eppap    ap|-2)		;pop it
          (lls      18.)		; 000000 00SSSS OOOOOO 000000
          (als      18.)		; 00SSSS 000000 OOOOOO 000000
          (ora      064043,dl)	; 00SSSS 064043 OOOOOO 000000
				;ungc-able string
          (tra      ab|return,*)
()

;;; 

;;;
;;;	EMACS string manipulators
;;;	 (An EMACS string is either an atom, a string, or a file-cons)
;;;


;;; Take substr of EMACS string
(lap e_lap_$gsubstr subr 3)
; (gsubstr stuff pos-0-rel howmany) (returns string)
;          -6,-5 -4,-3     -2,-1
           (ldq     ap|-1)		;len
           (call    ab|cons-string,*)
           (staq    ap|-2)		;save
	 (epprp	ap|-2,*)
           (eppbp   ap|-6)		;gets all cases
           (tsx0    loadup)
           (lda     ap|-3)		;offset
           (a9bd    bp|0,al)
           (ldq     rp|0)		;len
           (mlr     (pr,rl),(pr,rl))
           (desc9a  bp|0,ql)
           (desc9a  rp|1,ql)
           (ldaq    ap|-2)		;string object
           (eppap   ap|-6)
           (tra     ab|return,*)


;;; Get numeric equivalent of i'th character of EMACS string
(entry e_lap_$ggcharn subr 2)
; (ggcharn stuff pos-0-rel) (returns fixnum)
;          -4,-3 -2,-1
	(eppbp	ap|-4)
	(tsx0	loadup)
	(lda	ap|-1)		;offset
	(stz	ap|-1)
	(mlr	(pr,al),(pr))
	(desc9a	bp|0,1)
	(desc9a	ap|-1(3),1)
	(ldaq	ap|-2)
	(eppap	ap|-4)
	(tra	ab|return,*)

;;; 

;;; Internal subr to get ptr and lth of EMACS string
loadup	(ldaq	bp|0)
	(eppbp	bp|0,*)
	(cana	077700,dl)	;If it's a cons, then
	(tze	loadup-fileptr)	;load it from file.
	(cana	010000,dl)	;=atsym (lisp symbol)
	(tze	2,ic)		;SKIP if string
	(eppbp	bp|4)		;move pointer up to printname
          (lda      bp|0)		;move length into a
	(eppbp	bp|1)		;move string pointer into bp
	(tra	0,x0)

loadup-fileptr
          (lda      bp|3)		;move length into a
	(lprpbp	bp|1)		;move string pointer into bp
	(tra	0,x0)


;;; Scan EMACS string for next non-printing character as defined by passed table
(entry e_lap_$tabscan_table subr 4)
; (tabscan_table tblarrayobj  stuff length pos-0-rel) (returns fixnum)
;	       -10,-7	-6,-5 -4,-3  -2,-1
	(eppbp   ap|-6)
	(tsx0    loadup)
	(ldq     ap|-3)
	(sblq    ap|-1)
	(lda     ap|-1)
          (a9bd    bp|0,al)
	(epplb   ap|-10,*)
	(epplb   lb|2,*)
	(tct	(pr,rl),mask(000))
	(desc9a  bp|0,ql)
	(arg	lb|0)
          (arg     ap|-1)
          (ldaq    ap|-2)
	(anq	(% 000777777777))
          (eppap   ap|-10)
          (tra     ab|return,*)

;;; 

;;; Compare two EMACS strings (actually substring)
(entry e_lap_$compare_strings subr 5)
; (compare_strings stuff1 pos-0-rel1 stuff2 pos-0-rel2 length) (returns t/nil)
;	         -12,-11 -10,-7    -6,-5  -4,3       -2,-1
	(eppbp	ap|-12)		;firsto
	(tsx0	loadup)
	(eppbb	bp|0)
	(ldq	ap|-7)		;len
	(a9bd	bb|0,ql)
	(eppbp	ap|-6)		;second
	(tsx0	loadup)
	(ldq	ap|-3)
	(a9bd	bp|0,ql)
	(lda	ap|-1)		;len
	(cmpc	(pr,rl),(pr,rl))
	(desc9a	bb|0,al)
	(desc9a	bp|0,al)
	(tze	eql)
	(ldaq	'nil)
	(tra	r2d2)
eql	(ldaq	't)
r2d2	(eppap	ap|-12)
	(tra	ab|return,*)

;;; 

;;; Strip leading and trailing whitespace from EMACS string
(entry e_lap_$trim subr 1)
; (trim stuff) (returns string)
;       -2,-1
	(eax7	4,x7)		;get temporaries
	(eppbp	ap|-2)
	(tsx0	loadup)		;get input string
	(spribp	us|-4)		;save ptr to source
	(sta	us|-2)		;save original length
	(tsx0	compute-rtrim)	;compute new length in us|-1
	(eppbp	us|-4,*)		;restore ptr
	(lda	us|-1)
	(tra	do-ltrim)		;now trim leading whitespace


;;; Strip leading whitepace from EMACS string
(entry e_lap_$ltrim subr 1)
; (trim stuff) (returns string)
;       -2,-1
	(eax7	4,x7)		;get temporaries
	(eppbp	ap|-2)
	(tsx0	loadup)		;get input string
	(spribp	us|-4)
do-ltrim
	(sta	us|-2)		;save original length
	(tct	(pr,rl))		;find first non-whitespace
	(desc9a	bp|0,al)
	(arg	whitespace-table)
	(arg	us|-1)		;result of scan
	(ldq	us|-1)
	(anq	(% 000777777777))
	(stq	us|-1)
	(ldq	us|-2)		;compute new length
	(sbq	us|-1)
	(tspbp	ab|cons-string,*)	;make return string
	(staq	ap|-2)
	(epprp	ap|-2,*)		;get ptr to length/string
	(lda	us|-1)		;get offset of start of string
	(ldq	rp|0)		;get length of substring
	(eppbp	us|-4,*)		;get ptr to original string
	(mlr	(pr,rl,al),(pr,rl),fill(040))
	(desc9a	bp|0,ql)
	(desc9a	rp|1,ql)
	(ldaq	ap|-2)		;get result string
	(eppap	ap|-2)
	(eax7	-4,x7)
	(tra	ab|return,*)


;;; Strip trailing whitespace from EMACS string
(entry e_lap_$rtrim subr 1)
; (rtrim stuff) (returns string)
;       -2,-1
	(eax7	4,x7)		;get temporaries
	(eppbp	ap|-2)
	(tsx0	loadup)		;get input string
	(spribp	us|-4)
	(sta	us|-2)		;save original length
	(tsx0	compute-rtrim)	;compute new length
	(ldq	us|-1)
	(tspbp	ab|cons-string,*)	;make return string
	(staq	ap|-2)
	(epprp	ap|-2,*)		;get ptr to length/string
	(lda	rp|0)
	(eppbp	us|-4,*)		;get ptr to original string
	(mlr	(pr,rl),(pr,rl),fill(040))	;move substring
	(desc9a	bp|0,al)
	(desc9a	rp|1,al)
	(ldaq	ap|-2)		;get result string
	(eppap	ap|-2)
	(eax7	-4,x7)
	(tra	ab|return,*)

compute-rtrim			;internal subr to compute rtrim length
	(tctr	(pr,rl))
	(desc9a	bp|0,al)
	(arg	whitespace-table)
	(arg	us|-1)		;result of scan
	(ldq	us|-1)
	(anq	(% 000777777777))
	(stq	us|-1)
	(ldq	us|-2)		;get original length
	(sbq	us|-1)		;compute new length
	(stq	us|-1)
	(tra	0,x0)

whitespace-table			;EIS table to scan for non-whitespace
	(make-n-of 2. -1)		;000-007
	777000777777		;010-013
	(make-n-of 5. -1)		;014-037
	000777777777		;040-043
	(make-n-of 7. -1)		;044-077
	(make-n-of 16. -1)		;100-177
	(make-n-of (- 128. 32.) -1)	;200-777
;;; 

;;; Scan EMACS string with supplied table
(entry e_lap_$tct subr 3)
; (tct pos-0-rel tblarrayobj stuff) (returns fixnum)
;      -6,-5     -4,-3       -2,-1
          (eppbp    ap|-2)
          (tsx0     loadup)
	(tsx0	tct_stringm)
	(tct	(pr,rl))
	(desc9a	bp|0,al)
	(arg	lb|0)
	(arg	ap|-5)
	(tra	0,x0)


;;; Scan EMACS string in reverse with supplied table
(entry e_lap_$tctr subr 3)
; (tctr pos-0-rel tblarrayobj stuff) (returns fixnum)
;       -6,-5     -4,-3	-2,-1
          (eppbp    ap|-2)
          (tsx0     loadup)
	(ldac	ap|-5)		;pointpos is len
	(tsx0	tct_stringm)
	(tctr	(pr,rl))
	(desc9a	bp|0,al)
	(arg	lb|0)
	(arg	ap|-5)
	(tra	0,x0)		;old coroutine cruft
tct_stringm			;xec's blew out EIS box.
jj
	(ldq	ap|-5)
	(a9bd	bp|0,ql)
	(epplb	ap|-4,*)
	(epplb	lb|2,*)
	(szn bp|0)(szn lb|0)(szn lb|76)
	(tsx0	0,x0)
	(ttf	nolose)
	(lrl	44)
	(lda	fixnum-type,dl)
	(tra	2,ic)
nolose	(ldaq	ap|-6)
	(anq	(% 000777777777))
	(eppap	ap|-6)
	(tra	ab|return,*)

;;; 

;;;	Entries to manipulate the work-string
;;;

(entry e_lap_$rplacstring-offset subr 6)
   ;like next, but last is source offset
	(eppbp	ap|-12)		;-10 for him
          (tsx0	loadup)
	(ldq	ap|-1)
	(a9bd	bp|0,ql)
	(eppap	ap|-2)
	(tra	rplacj)

(entry e_lap_$rplacstring subr 5)
   ;(allofthat magicptr newchars len offset newlen)
;	    -12,-11   -10,-7  -6,-5 -4,-3 -2,-1
	(eppbp	ap|-10)		;new
	(tsx0	loadup)
rplacj
	(eppbb	bp|0)
	(eppbp	ap|-12,*)		;-> magic
	(eppbp	bp|1)
	(ldq	ap|-3)		;offset
	(a9bd	bp|0,ql)
	(ldq	ap|-5)		;len
	(mlr	(pr,rl),(pr,rl))
	(desc9a	bb|0,ql)
	(desc9a	bp|0,ql)
	(lda	ap|-1)
	(sta	ap|-12,*)
	(eppap	ap|-12)
	(ldaq	'nil)
	(tra	ab|return,*)

(entry e_lap_$delete-chars subr 3)
  ;.. work-string curpointpos ct
 ;      -6,-5      -4,-3      -2,-1
	(eppbp	ap|-6,*)
	(eppbp	bp|1)
	(lda	ap|-3)		;point
	(a9bd	bp|0,al)
	(eppbb	bp|0)
	(lda	ap|-1)		;count
	(a9bd	bb|0,al)
	(lda	ap|-6,*)		;-orig count
	(sbla	ap|-3)
	(sbla	ap|-1)
	(mlr	(pr,rl),(pr,rl))
	(desc9a	bb|0,al)
	(desc9a	bp|0,al)
	(lcq	ap|-1)
	(asq	ap|-6,*)
	(eppap	ap|-6)
	(ldaq	'nil)
	(tra	ab|return,*)

(entry e_lap_$insert-chars subr 4)
   ; ... workstring offset stuff count
   ;     -10,-7     -6,-5  -4,-3 -2,-1
	(eppbp	ap|-4)
	(tsx0	loadup)
	(eppbb	bp|0)
	(eppbp	ap|-10,*)
	(eppbp	bp|1)
	(ldq	ap|-5)		;offset
	(a9bd	bp|0,ql)
	(epplb	bp|0)
	(ldq	ap|-1)		;count
	(asq	ap|-10,*)
	(a9bd	lb|0,ql)
	(lda	ap|-10,*)		;stringlen
	(sbla	ap|-5)
	(mrl	(pr,rl),(pr,rl))
	(desc9a	bp|0,al)
	(desc9a	lb|0,al)
	(mlr	(pr,rl),(pr,rl))
	(desc9a	bb|0,ql)
	(desc9a	bp|0,ql)
	(lda	40047,dl)
	(eppap	ap|-10)
	(tra	ab|return,*)

;;; 

;;;
;;;	Entries to move data to/from Multics files
;;;

;;; Get index of next NL in Multics file
(entry e_lap_$segnlindex subr 3)
; (segnlindex fileptr length offset) (returns fixnum)
;	    -6,-5   -4,-3  -2,-1
	(lprplb	ap|-5)		;-> segment
	(ldq	ap|-3)		;-> iolen
	(sblq	ap|-1)		;guys offset, gives length remaining
	(lda	ap|-1)		;guys offset
	(scm	(pr,rl,al),(du),mask(000))
	(desc9a	lb|0,ql)		;input string
	(arg	012000)		;000 000 NEWLINE 000
	(arg	ap|-1)		;reuse input fixnum for output
	(ldaq	ap|-2)		;get index into aq
	(eppap	ap|-6)		;pop stack and return
	(tra	ab|return,*)


;;; Get a string from Multics file
(entry e_lap_$return-string subr 3)
; (return-string fileptr offset length) (returns string)
;	       -6,-5   -4,-3  -2,-1
	(ldq	ap|-1)		;len
	(tspbp	ab|cons-string,*)	;allocate it
	(staq	ap|-2)		;save it here, dont need this
	(epprp	ap|-2,*)		;point at length ctl
	(ldq	rp|0)		;length again
	(lprpbp	ap|-5)		;fileptr
          (lda      ap|-3)		;source offset
	(mlr	(pr,rl,al)(pr,rl))
	(desc9a	bp|0,ql)
	(desc9a	lb|1,ql)
	(ldaq	ap|-2)
	(eppap	ap|-6)
	(tra	ab|return,*)


;;; Move EMACS string to a file
(entry e_lap_$write-string subr 3)
; (write-string stuff fileptr offset) (returns fixnum)
;               -6,-5 -4,-3   -2,-1
	(eppbp	ap|-6)
	(tsx0	loadup)
	(lprpbb	ap|-3)		;get pointer to file
	(ldq	ap|-1)		;and offset where to put it
	(mlr	(pr,rl),(pr,rl,ql))
	(desc9a	bp|0,al)
	(desc9a	bb|0,al)		;copy string to file
	(ada	ap|-1)		;update offset by length
	(lrl	36.)
	(lda	40047,dl)		;make a fixnum
	(eppap	ap|-6)
	(tra	ab|return,*)
;;;
;;;	Scan two substrings for obscure long-line redisplay case.
;;;	Given  fffffnnnnn  first, and
;;;	       fffffaaann  second, we want to tell that 3 chars were
;;;	inserted.  BSG 3/1/79
;;;	Modified 25 June 1982 by W. York and E. N. Kittlitz to search
;;;	both ways every time, then return the better (smaller) number.

(entry e_lap_$rdis-crossmatch subr 4)
;(rdis-crossmatch string1 string2 leftcommon stringl) ;Must be real strings
;		-8,-7  -6,-5   -4,-3     -2,-1
	(eppbb	ap|-8,*)
	(epplb	ap|-6,*)
	(lda	ap|-1)			;stringl
	(sbla	ap|-3)
	(ldq	ap|-3)			;leftcommon
	(adq	4,dl)			;varying-word
	(a9bd	bb|0,ql)
	(a9bd	lb|0,ql)
	(tsx0	crossmatch)
	(eax3	0,qu)			; save result of 1st compare
	(eppbp	bb|0)			; switch strings
	(eppbb	lb|0)
	(epplb	bp|0)
	(tsx0	crossmatch)		; try again
	(eaq	0,qu)			; set indicators
	(tmi	second_failed)
	(eax3	0,x3)			; "	"
	(tpl	both_succeeded)
return_second
	(qrl	18.)
	(tra	return_q)

both_succeeded
	(cmpx3	ap|-1)			; compare first (x3) to second (qu and ap|-1)
	(tpl	return_second)		; return the smaller
	(tra	return_first)

second_failed
	(eax3	0,x3)
	(tmi	return_nil)
return_first
	(eaq	0,x3)
	(qrl	18.)
	(eaa	0)
	(negl	0)			; negate the q (gack)
return_q
	(lda	40047,dl)			; magic constant #40047
	(eppap	ap|-8.)			; pop the args
	(tra	ab|return,*)

return_nil
	(ldaq	'nil)
	(eppap	ap|-8.)
	(tra	ab|return,*)

;;; crossmatch searches for the first occurrance of the string at lb|0
;;; in the string at bb|0, and returns the index in qu.
crossmatch
	(scd	(pr,rl),(pr,rl))
	(desc9a	bb|0,al)
	(desc9a	lb|0,al)
	(arg	ap|-1)
	(ttn	crossmatch_failed)		; no match
	(ldq	ap|-1)		; shift so we can sub from x1
	(qls	18.)
	(stq	ap|-1)
	(eax1	0,al)
	(sblx1	ap|-1)
	;; see if the remainder of the strings match
	(cmpc	(pr,rl,qu),(pr,rl))
	(desc9a	bb|0,x1)
	(desc9a	lb|0,x1)
	(tze	0,x0)
crossmatch_failed
	(ldq	-1,du)
	(tra	0,x0)

(entry  e_lap_$get-x7 subr 0)			;for error handlers
	(eaq	0,x7)
	(qrl	18.)
	(orq	-2,du)
	(lda	40047,dl)
	(tra	ab|return,*)

;;;
;;;	Replacements for PL/I searches - BSG 12/4/79
;;;

(entry e_lap_$forward-search-string subr 3)
; (forward-search-line searchee offset searchstring) => 0-rel index or -1
;		   -6,-5    -4,-3  -2,-1
; unm pdl for this and next fun:
;    searchee-len   searchstring-len forward-offset  eis-answer-dump
;    -4		-3	       -2		   -1
	(tsx4	search-string-setup)
	  (sbla	ap|-3)			;xec'd to get see len
	  (lda	ap|-3)			;xec'd to get see offset
	(tpnz	search-2-or-more)		;do it;else l = 1
	(scm	(pr,rl),(pr),mask(000))
	(desc9a	bb|0,ql)
	(desc9a	bp|0,1)
	(arg	us|-1)
	(ttn	search-fails)		;tally on = fails
search-succeeds
	(ldq	us|-1)
search-return-fixnum
	(lda	40047,dl)			;fixnum
	(eppap	ap|-6)
	(eax7	-4,x7)
	(tra	ab|return,*)
search-fails
	(lcq	1,dl)
	(tra	search-return-fixnum)
search-2-or-more
	(lda	0,dl)			;Init loop offset
	(sblq	us|-3)			;dont search last l(ss)-1
search-2-or-more-loop
	(adlq	2,dl)			;ok to match 2 more
	(scd	(pr,rl,al),(pr))
	(desc9a	bb|0,ql)
	(desc9a	bp|0)
	(arg	us|-1)
	(ttn	search-fails)		;SURELY cant find it
;;;	OK maybe this won. It wins if bp compares to bb for l(ss).
;;;	remaining-length was already truncated down, needn't check.
	(adla	us|-1)			;how far'd it find it?
	(sta	us|-1)			;in case we win
	(ldq	us|-3)			;l(ss)
	(cmpc	(pr,rl,al),(pr,rl))
	(desc9a	bb|0,ql)
	(desc9a	bp|0,ql)
	(tze	search-succeeds)		;definitely found it
					;right offset at us|-1
;;;	Lost. Increment ptrs, decrement length, see if done.

	(adla	1,dl)			;consider 1 more from here
	(ldq	us|-4)			;l(see)
	(sblq	us|-1)			;rem = l(see) - new offset
	(sblq	1,dl)
	(sblq	us|-3)			;compare to l(ss), deduct
	(tmi	search-fails)
	(tra	search-2-or-more-loop)	;try more 2-matches

;;;
;;;	Same, but reverse. Much harder.
;;;

(entry e_lap_$reverse-search-string subr 3)
; (reverse-search-line searchee offset searchstring) => 0-rel index or -1
;		   -6,-5    -4,-3  -2,-1
; unm pdl same as above

	(tsx4	search-string-setup)
	  (lda	ap|-3)			;xec'd to get see len
	  (lda	0,dl)			;xec'd to get see offset
	(tpnz	revsearch-2-or-more)
	(scmr	(pr,rl),(pr),mask(000))	;search for 1
	(desc9a	bb|0,ql)
	(desc9a	bp|0)
	(arg	us|-1)
	(ttn	search-fails)
	(tra	search-succeeds)
revsearch-2-or-more
	(sblq	us|-3)			;start len = l(see) - l(ss)
	(adlq	2,dl)			;2 more always ok
revsearch-2-or-more-loop			;a = l(ss)
	(scdr	(pr,rl,al),(pr,al))
	(desc9a	bb|-1(2),ql)		;start offset!
	(desc9a	bp|-1(2))			;last 2 chars
	(arg	us|-1)			;result
	(ttn	search-fails)		;definitely lost
;;; Same deal. May have won.
;;; Lets say we are looking for FOOBARU. Current state of world:
;;; A B C D E F O O B A R U C X Q F R U T M C
;;;|<l(ss)-2>|< contents of q       >|
;;;          |< l(ss)     >|<result >|
;;; so start of FOOBARU = l(ss) - 2 + q - result - l(ss) = q - 2 - result
	(sblq	2,dl)			;q - 2
	(sblq	us|-1)			;subtract offset he found
;;; See if string at offset is really ss. Q is cleverly real offset. A = l(ss).
	(cmpc	(pr,rl,ql),(pr,rl))
	(desc9a	bb|0,al)
	(desc9a	bp|0,al)
	(tnz	revsearch-gotta-move-on)	;br if fails
;;; Found it. Hack up result.
	(adlq	us|-3)			;add l(ss)
	(sblq	us|-4)			;l(see)
	(lda	0,dl)
	(negl	0)
	(tra	search-return-fixnum)

revsearch-gotta-move-on
;; (new q for eis) = (old-q-for-eis) - (result) -1, the 1 for moving on,
;;   = current-q + result + 2 - result - 1 = current-q + 1
	(adlq	1,dl)
	(cmpq	2,dl)			;see if anything left
	(tmi	search-fails)
	(tra	revsearch-2-or-more-loop)
;;;
;;; Common setup for searches  -- sets up unm pdl :
;;;  see-len  ss-len  offset zero-for-eis
;;;   -4        -3       -2    -1

search-string-setup				;s/r on x4, does everything
	(eax7	4,x7)
	(eppbp	ap|-6)			;searchee
	(tsx0	loadup)
	(xec	0,x4)			;subt offset or load len (rv)
	(sta	us|-4)
	(xec	1,x4)			;load offset or 0 (rv)
	(a9bd	bp|0,al)
	(eppbb	bp|0)
	(eppbp	ap|-2)
	(tsx0	loadup)			;searchstring
	(sta	us|-3)
	(cmpa	us|-4)
	(tpnz	search-fails)		;l(ss) > l(see)
	(stz	us|-1)			;result
	(ldq	us|-4)			;l(see)
	(cmpa	1,dl)			;l(ss)
	(tmi	search-succeeds)		;0 case
	(tra	2,x4)

(entry e_lap_$string_length subr 1)
;;;  (string_length "guaranteed-string") = (stringlength string)
	(lda	40047,dl)
	(ldq	ap|-2,*)
	(eppap	ap|-2)
	(tra	ab|return,*)
()




		    e_listen_interface_.lisp        11/15/84  1155.5rew 11/15/84  0849.1       64278



;;; ***********************************************************
;;; *                                                         *
;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
;;; *                                                         *
;;; * Copyright (c) 1978 by Massachusetts Institute of        *
;;; * Technology and Honeywell Information Systems, Inc.      *
;;; *                                                         *
;;; ***********************************************************
;;;
;;;
;;;	EMACS editor interface
;;;	  08/27/78 GMP
;;;	  Reorganized 3/20/79 by BSG to flush the table.
;;;	Moved argument parsing to PL/1, 21 July 1981 RMSoley
;;;       Modified: 26 November 1983 B. Margolin to not call e_pl1_ network entries.
;;;	Modified: 19 December 1983 B. Margolin to properly strip off ".ctl",
;;;		not err in ttp-validate if given a starname, complain
;;;		if -ttp/-query used in video system.
;;;

(setq errlist '((e-listen-interface)))		; set initial function

(declare (special tty-ctl-dir terminal-list next-multics-argno mode-line-herald
	        given-tty-type emacs-name null-pointer network-flag
	        args:paths args:apply-arg tasking-emacs args:force
	        args:ll args:pl args:ns tasking-arg terminal-type ttp-arg))
(declare (*expr absolute_pathname_ e_argument_parse_$get_startup_info 
	      e_argument_parse_$get_ttp_info e_lap_$rtrim
	      e_pl1_$get_real_terminal_type
	      e_pl1_$get_terminal_type e_pl1_$init e_pl1_$set_line_speed_
	      e_pl1_$set_terminal_type
	      e_pl1_$will_supdup_output e_tasking_$get_tasking_flag
	      emacs$get_my_name emacs$set_emacs_return_code error_table_
	      exists-file
	      expand_pathname_ lisp-quit-function list_emacs_ctls$find_ctl
	      list_emacs_ctls$list_emacs_ctls listener-level loadfile
	      nullstringp e_terminal_io_$check_printing))

(defun e-listen-interface ()
       (setq errlist '((lisp-quit-function)))
       (sstatus mulpi (sstatus mulquit t))
       (setq emacs-name (make_atom (e_lap_$rtrim (emacs$get_my_name))))
       (e_pl1_$init)
       (setq network-flag 0)		; no more network
       (and (setq tasking-emacs (not (zerop (e_tasking_$get_tasking_flag))))
	  (setq mode-line-herald (catenate "Tasking " mode-line-herald)))
       (let ((ttp-args (e_argument_parse_$get_ttp_info))
	   (su-args (e_argument_parse_$get_startup_info)))
	  (setq args:ns (zerop (car su-args))
	        tasking-arg (= 1 (cadr su-args))
	        args:paths (caddr su-args)
	        args:pl (cadddr su-args)
	        args:ll (car (cddddr su-args))
	        args:apply-arg (caddr (cddddr su-args)))
	  (let ((linespeed (cadr (cddddr su-args))))
	       (or (< linespeed 0)
		 (e_pl1_$set_line_speed_ (// linespeed 10.))))
	  (setq terminal-type (e_lap_$rtrim (cadr ttp-args))
	        args:force (> (car ttp-args) 99.)
	        ttp-arg (\ (car ttp-args) 100.)))
       (cond ((or (eq emacs-name 'emacs_) (zerop ttp-arg))	;no ttp arg
	    (eli:start))
	   ((= ttp-arg 1)			; -reset
	    (e_pl1_$set_terminal_type "") (e_pl1_$set_line_speed_ 0)
	    (eli:start))
	   ((and (not args:force)
	         (samepnamep (e_pl1_$get_real_terminal_type) "video_system"))
	    (princ (catenate "emacs: "
			 (cond ((= ttp-arg 2) "-query")
			       (t "-terminal_type"))
			 " not valid when using the video system."))
	    (terpri)
	    (lisp-quit-function))
	   ((= ttp-arg 2) (eli:start-internal (eli:query nil)))	; -query
	   (t (eli:start-internal terminal-type))))  ; -ttp FOO

(defun eli:start ()
       (let ((ttp (e_pl1_$get_terminal_type)))
	  (cond ((not (nullstringp ttp))
	         (eli:start-internal ttp))
	        ((and (= network-flag 1)
		    (not (zerop (e_pl1_$will_supdup_output))))
	         (eli:start-internal 'supdup_output))
	        (t (eli:start-internal (e_pl1_$get_real_terminal_type))))))

(defun eli:start-internal (ttp)
       (cond ((samepnamep ttp "ASCII") (setq ttp (eli:query nil)))
	   ((= 1 (e_terminal_io_$check_printing ttp)) (setq ttp "printing")))
       (do ((ans (make_atom (e_lap_$rtrim ttp)) (eli:query t)))
	 ((ttp-validate ans t))
	 (princ "Unknown terminal type.") (terpri)))

(defun eli:query (bothersome)
       (terpri)
       (cond (bothersome (princ "Do you want a list of known types? ")
		     (and (memq (car (explodec (readline))) '(y Y))
			(eli:produce-terminal-list))
		     (princ "Type ""quit"" to abort.")))
       (terpri)
       (princ "What type of terminal do you have? ")
       (do ((in (errset (readlist (explodec (readline))))
	      (errset (readlist (explodec (readline))))))
	 (())
	 (cond ((or (null in)
		  (numberp (setq in (car in)))
		  (nullstringp in)
		  (memq in '(? % *))
		  (not (symbolp in)))
	        (terpri)
	        (princ "Do not understand.  Try again: "))
	       ((eq (lowercase-ttp in) 'quit) (lisp-quit-function))
	       (t (return in)))))

(defun eli:produce-terminal-list ()
       (list_emacs_ctls$list_emacs_ctls "**"))

;;; This function attempts to find the given type terminal controller.
(defun ttp-known-type (type)
       (cond ((eq (get type 'ttyequiv) 'unsupported)
	    (princ
	      "This program requires a full-duplex ASCII terminal.  Sorry.")
	    (terpri) (lisp-quit-function))
	   ((or (not (zerop (index type "<")))
	        (not (zerop (index type ">"))))
	    nil)
	   (t ; Find ctl by emacs_terminal_ctls search path.
	     (let ((s (e_lap_$rtrim (list_emacs_ctls$find_ctl type))))
		(cond ((nullstringp s) nil)
		      (t s))))))

(defun ttp-validate (type set-type-flag)
       (let ((known? (ttp-known-type (lowercase-ttp type))))
	  (cond (known?
		(setq type (lowercase-ttp type))
		(setq given-tty-type (intern (make_atom type)))
		(and set-type-flag (e_pl1_$set_terminal_type type))
		(setq type (or (get type 'ttyequiv) type))
		(load known?)
		(start-emacs))		; NEVER RETURNS
	        ((exists-file type 4)
	         (and set-type-flag
		    (e_pl1_$set_terminal_type
		      (car (absolute_pathname_ type))))
	         (setq given-tty-type
		     (make_atom
		       (let ((result (cadr (expand_pathname_ type))))
			  (let ((ix (index result " ")))
			       (and (zerop ix) (setq ix 33.))
			       (cond ((= ix 1) "????")
				   ((samepnamep ".ctl"
					      (substr result
						    (- ix 4)
						    4))
				    (substr result 1 (- ix 5)))
				   ((samepnamep "ctl"
					      (substr result
						    (- ix 3)
						    3))
				    (substr result 1 (- ix 4)))
				   (t (substr result 1 (1- ix))))))))
	         (loadfile type)
	         (start-emacs))		; NEVER RETURNS
	        ((eq emacs-name 'emacs_)
	         (emacs$set_emacs_return_code
		 (error_table_ 'action_not_performed))
	         (lisp-quit-function))
	        (t nil))))

(defun lowercase-ttp (string)
       (implode (mapcar '(lambda (y)
			   (cond ((and (< y (1+ (CtoI "Z")))
				     (> y (1- (CtoI "A"))))
				(ascii (+ y 40)))
			         (t y)))
		    (exploden string))))

(defun start-emacs () (listener-level) (lisp-quit-function))

;;; Unsupportable terminals
(mapc '(lambda (x) (putprop x 'unsupported 'ttyequiv))
      '(/1050 /2741 ards corr2741 g115 g115_upper ibm2780
	    ibm2780_lower ibm3780 ibm3780_lower))









		    e_multics_files_.lisp           11/11/86  1231.1rew 11/11/86  1228.8      479754



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

;;;	Multics File Manipulation


;;; HISTORY COMMENTS:
;;;  1) change(84-01-19,Margolin), approve(), audit(),
;;;     install(86-08-20,MR12.0-1136):
;;;     pre-hcom history:
;;;      GMP, 09/23/78
;;;     Modified 28 July 1979 by GMP to add protected file query
;;;     Modified 24 September 1979 by CRD to fix find-file,
;;;      added archive primitives
;;;     Modified 28 October 1979 by BSG for starnames/archivenames.
;;;     Mod 4/29/80 BSG to finish starnames/archivenames
;;;     Modified 5/8/80 by BSG for tecoish (reasonable) newline handling.
;;;     Modifed 7 May 1981 Soley for object_info_ calls.
;;;     Modified 5 November 1981 Soley for no-newline writes.
;;;     Modified 19 November 1981 Soley to ignore dirs on "emacs **"
;;;     Modified 31 October 1983 Barmar to query in read-file if buffer
;;;              buffer modified, and convert it to defcom.
;;;     Modified 19 January 1984 Barmar to comment out register-option
;;;              forms, as they were moved to e_pathname_defaults_.
;;;  2) change(85-01-27,Margolin), approve(), audit(),
;;;     install(86-08-20,MR12.0-1136):
;;;     pre-hcom history:
;;;     Modified 23 January 1984 Barmar to fix fencepost error in read-in-file,
;;;              affecting files with no trailing newline.  Also cleaned up
;;;              the code (with-mark/save-excursion instead of explicit
;;;              set-mark/release-mark).  Changed find-file-subr-single-entry
;;;              to set fpathname if it finds the segment in an existing
;;;              buffer but fpathname is no longer valid, to not check
;;;              for object seg in this case.
;;;              Changed find-file-get-buffer-given to inform the user when
;;;              it finds such a buffer.
;;;              Changed terminate-file to use terminate_file_.
;;;     Modified 25 December 1984 B. Margolin to move e_pl1_$object_check
;;;              out to e_defpl1_.lisp, use defmacro, delete macros defined
;;;              in e-macros.incl.lisp.
;;;     Modified 6 January 1985 - Barmar - to use filecons defstruct and
;;;              emacs-internal-macros, deleted unnecessary macro defs.
;;;     Modified 27 January 1985 - Barmar - to fix buffer-ends-in-newline?
;;;              to use eline-contents, not eline-conts.
;;;  3) change(86-01-17,Margolin), approve(86-01-17,MCR7325),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Almost totally rewritten in order to support MSFs and checking of file
;;;     DTCM against the buffer before overwriting.  Removed many declarations
;;;     which were already in e-macros or which I moved to
;;;     emacs-internal-macros.
;;;  4) change(86-05-24,Margolin), approve(86-05-24,MCR7325),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Fixed find-file mode-setting function so it would turn the suffix into
;;;     a symbol before looking for the suffix-mode property.
;;;     Fixed get-filename to set the mark before inserting the pathname.
;;;     Changed read-seg-into-buffer to always insert-string the first line of
;;;     the segment, even if already at beginning of line, to prevent a
;;;     problem with marks moving.
;;;     Added allow-no-match parameter to match-star-name, to allow callers to
;;;     specify whether zero matches should cause an error (uninstalled
;;;     find-lisp-source needs this capability).
;;;     Changed open-output-file to check for a non-zero, non-noentry
;;;     msf-code, and to check for a zero init-code before checking for
;;;     archive_component_modification.
;;;     Changed open-file-reject-starname to use equal instead of =, because
;;;     entry-code-1 and comp-code-1 can be set to symbols.
;;;  5) change(86-09-20,Margolin), approve(86-10-10,MCR7553),
;;;     audit(86-10-17,Lippard), install(86-11-11,MR12.0-1209):
;;;     Changed write-out-string-line to fix a fencepost error when point is
;;;     in the middle of the line.
;;;                                                      END HISTORY COMMENTS


;;; 

(declare (genprefix /!emf_))

(%include e-macros)
(%include emacs-internal-macros)
;;; %include all the library except for format
(%include sharpsign)
(%include setf)
(%include runtime)
(sstatus feature runtime)			;bypass for bug
(%include other_other)
(%include macro_macros)
(%include loop)
(%include destructuring_let)
(%include defun)
(%include defmacro)
(%include backquote)

(declare (macros nil)
         (*expr buffer-kill check_star_name_$entry
	      e_multics_files_util_$force_msf_access e_multics_files_util_$get_dtcm
	      e_multics_files_util_$get_dtcm_file e_multics_files_util_$nth_star_match
	      e_multics_files_util_$restore_msf_access e_multics_files_util_$star_list_cleanup
	      e_multics_files_util_$star_list_init
	      e_pl1_$object_check
	      expand_pathname_$component
	      hcs_$fs_get_mode hcs_$get_max_length_seg
	      hcs_$get_uid_file hcs_$get_uid_seg hcs_$truncate_seg
	      initiate_file_$component insert-new-line
	      msf_manager_$adjust
	      msf_manager_$close msf_manager_$get_ptr msf_manager_$open
	      reinitialize-current-buffer
	      terminate_file_))

(declare
  (*lexpr absolute-pathname close-file expand-pathname))

(defvar (
;;;	 Flags to ease user transition to the "right way"  5/26/80

	 (find-file-entry-names-buffer nil)     ;flag for buffer names same as entry names
	 (std-eob-protocol t)		;flag for tecoish eob
	 ;;as of 8/14/80, e_multics_files_ ignores this
	 read-file-force			;should ^X^R overwrite mod. buffer?
	 (R_ACCESS (dpb #2r100 #o4103 0))	;"100"b
	 (RW_ACCESS (dpb #2r101 #o4103 0))	;"101"b
	 (W_ACCESS_BIN #2r00010)
	 (TERM_FILE_TERM (dpb 1 #o4101 0))	;"001"b
	 (MSFMA_TRUNC_BC (dpb #2r100 #o4103 0)) ;"100"b
	 find-file-check-dtcm		;options
	 save-same-file-check-dtcm write-file-overwrite
	 check-newline add-newline find-file-set-modes
	 ))

;;; 

(defun check-entry-name (name &aux code)
       (unless (zerop (setq code (check_star_name_$entry name)))
	     (report-error code SPACE name)))

(defun check-read-only ()
       (and read-only-flag (report-error 'read-only)))

;;; Returns the file object, unless it is an object segment, in which
;;; case it aborts with an error message.
(defun check-object (file-object)
       (when (and (not (null (fobj-contents file-object)))	;empty MSF isn't object file
	        (= 1 (e_pl1_$object_check (* 9. (fobj-length file-object))
				    (fobj-pointer file-object))))
	   (close-file file-object nil)
	   (report-file-error "File is an object segment:" file-object))
       file-object)

(defmacro lastlinep () '(null (nextline)))


;;; Option to ignore no-newline end of buffer when writing.
;;; (register-option 'check-newline nil) ; The wrong thing. ;moved to e_option_defaults_
;;; (register-option 'add-newline   't)  ; The right thing. ;moved to e_option_defaults_

;;; This predicate returns whether or not the current buffer ends in a
;;; NEWLINE.  We have to special case the silly case wherein we're on
;;; the last line AND the line is open.
(defun buffer-ends-in-newline? ()
       (samepnamep (cond ((and (lastlinep)
			 (eq curstuff work-string))
		      work-string)
		     (t (eline-contents lastline)))
	         NLCHARSTRING))

(defun check-newline-ending ()
       (and check-newline
	  (not (buffer-ends-in-newline?))
	  (not
	    (yesp "This buffer does not end in a newline.  Write anyway? "))
	  (command-quit)))

;;; Release the specified temporary files
(defun release-temp-segments (tempsegptrs)
       (cond (tempsegptrs
	     (mapc 'e$release_temporary_seg
		 tempsegptrs))))


;;; 
;;;
;;;	Lowest level primitives
;;;

;;; First some macros for readable efficiency
(eval-when (compile eval)
	 (setq *bits-per-char* 9.))

(defmacro bc-to-chars (bc)
	`(// (+ ,bc ,(1- #.*bits-per-char*))
	     #.*bits-per-char*))

(defmacro chars-to-bc (chars)
	`(* ,chars #.*bits-per-char*))

(defmacro open-file-check-code (form pathname complain)
	`(let (((value code) ,form))
	      (cond ((= 0 code) value)
		  (t (open-file-error code ,pathname ,complain)))))

(defmacro make-char-pointer (base-pointer char-offset)
	(once-only (char-offset)
		 `(alter-packed-pointer
		    ,base-pointer
		    word-offset (lsh ,char-offset -2)
		    bit-offset (* (logand ,char-offset 3)
			        #.*bits-per-char*))))

(defmacro add-char-offset (pointer chars)
	(once-only (pointer)
		 `(let ((words (pptr-word-offset ,pointer))
		        (bits (pptr-bit-offset ,pointer)))
		       (make-char-pointer
		         ,pointer
		         (+ ,chars (lsh words 2)
			  (// bits #.*bits-per-char*))))))

;;; 

;;; Subr used to open a file used by the visible primitives
;;; Name should be a pathname, access-needed should be either
;;; read -> open for input, archive component permitted
;;; write -> open for output, no archive component
;;; write-force -> open for output, force access if user says OK, still
;;;	         no archive component
;;; write/write-force will create if necessary.  Complain should be
;;; t -> abort command if any error found.
;;; nil -> silently return nil on file error.
;;; noabort -> print error and return nil.
;;; Returns a file object if successful.
(defun open-file (name access-needed &optional (complain t))
       (*catch
         'open-file-error
         (prog
	 ()
	 (let (((path expand-code) (expand-pathname name t)))
	      (cond ((= 0 expand-code) (setq name path))
		  ;;always complain about bad pathname
		  ((eq complain 'noabort)
		   (display-com-error-noabort expand-code name)
		   (return nil))		;but skip the rest of this
		  (t (display-com-error expand-code name))))
	 ;; the caller should have expanded starnames if appropriate
	 (open-file-reject-starname name complain)
	 (return
	   (selectq access-needed
		  (read (open-input-file name complain))
		  (write (open-output-file name complain nil))
		  (write-force (open-output-file name complain 'ask))
		  (t (error "Invalid open-file access-needed:"
			  access-needed 'wrng-type-arg)))))))

(defun open-input-file (pathname complain)
       (let ((dir (pn-directory pathname))
	   (ent (pn-entry pathname))
	   (comp (pn-component pathname))
	   (ptr null-pointer) bc init-code result)
	  (protect
	    (desetq (ptr bc init-code)
		  (initiate_file_$component dir ent comp R_ACCESS))
	    (setq result
		(cond ((= init-code (error_table_ 'dirseg))
		       (open-input-msf pathname dir ent complain))
		      ((= 0 init-code)
		       (open-input-segment pathname ptr bc complain))
		      (t (open-file-error init-code pathname complain))))
	    &failure
	    (terminate_file_ ptr 0 TERM_FILE_TERM))
	  result))

;;; 

(defun open-input-segment (pathname ptr bit-count complain
			      &aux file-obj)
       (setq file-obj
	   (make-file-object
	     path pathname
	     contents (list (make-filecons pointer ptr
				     length (bc-to-chars bit-count)))
	     fcb-ptr nil))
       (let ((uid (open-file-check-code (hcs_$get_uid_seg ptr)
				pathname complain))
	   (comp (pn-component pathname)))
	  (alter-file-object
	    file-obj
	    uid (cond ((nullstringp comp)
		     uid)
		    (t (cons uid comp)))	;unique to the component
	    dtcm (open-file-check-code
		 (e_multics_files_util_$get_dtcm ptr)
		 pathname complain)))
       file-obj)

(defun open-input-msf (pathname dir entry complain
			  &aux
			  file-obj (fcb-ptr null-pointer) msf-code)
       (unless (nullstringp (pn-component pathname))
	     (open-file-error 'error_table_$dirseg pathname complain))   ;good enough
       (protect
         (desetq (fcb-ptr msf-code)
	       (msf_manager_$open dir entry))
         (unless (= msf-code 0)
	       (open-file-error msf-code pathname complain))
         (setq file-obj
	     (make-file-object
	       path pathname
	       fcb-ptr fcb-ptr
	       contents (open-msf-get-components fcb-ptr pathname complain)
	       uid (open-file-check-code (hcs_$get_uid_file dir entry)
				   pathname complain)
	       dtcm (open-file-check-code
		    (e_multics_files_util_$get_dtcm_file dir entry)
		    pathname complain)))
         &failure
         (unless (= fcb-ptr null-pointer)
	       (msf_manager_$close fcb-ptr)))
       file-obj)

(defun open-msf-get-components (fcb-ptr pathname complain)
       (loop for component from 0
	   for (ptr bc code) = (msf_manager_$get_ptr fcb-ptr component 0)
	   while (= code 0)
	   collect (make-filecons pointer ptr
			      length (bc-to-chars bc))
	   finally (unless (= code (error_table_ 'noentry))    ; last component
		         (open-file-error code pathname complain))))

;;; 

;;; This does one non-obvious thing.  It tries to initiate_file_$component
;;; in order to determine whether the output file is an archive component,
;;; by checking for error_table_$archive_component_modification.  It doesn't
;;; merely check for pn-component being non-null, in case we ever implement
;;; the "implicit archive component" feature.
(defun open-output-file (pathname complain force-access
			    &aux
			    dir entry)
       (unless (nullstringp (pn-component pathname))
	     (open-file-error 'error_table_$archive_component_modification
			  pathname complain))
       (setq dir (pn-directory pathname)
	   entry (pn-entry pathname))
       (let ((ptr null-pointer)
	   init-code)
	  (protect
	    (desetq (ptr () init-code)
		  (initiate_file_$component dir entry "" RW_ACCESS))
	    &always
	    (terminate_file_ ptr 0 TERM_FILE_TERM))
	  (cond ((= init-code 0))
	        ((= init-code
		  (error_table_ 'archive_component_modification))
	         (open-file-error init-code pathname complain))))
       (let ((fcb-ptr null-pointer)
	   msf-code)
	  (protect
	    (desetq (fcb-ptr msf-code) (msf_manager_$open dir entry))
	    (cond ((= msf-code 0)
		 (open-output-msf pathname fcb-ptr
			        force-access complain))
		((= msf-code (error_table_ 'noentry))
		 (open-msf-create pathname fcb-ptr complain))
		(t (open-file-error msf-code pathname complain)))
	    &failure
	    (unless (= fcb-ptr null-pointer)
		  (msf_manager_$close fcb-ptr)))))

(defun open-msf-create (pathname fcb-ptr complain)
       (let ((contents
	     (let (((seg-ptr bc ptr-code)
		  (msf_manager_$get_ptr fcb-ptr 0 -1)))	;Create component 0
		(unless (= ptr-code 0)
		        (open-file-error ptr-code pathname complain))
		(list (make-filecons
		        pointer seg-ptr
		        length (bc-to-chars bc))))))
	  (make-file-object
	    path pathname
	    fcb-ptr fcb-ptr
	    contents contents
	    dtcm (open-file-check-code
		 (e_multics_files_util_$get_dtcm
		   (filecons-pointer (car contents)))
		 pathname complain)
	    uid (open-file-check-code
		(hcs_$get_uid_seg
		  (filecons-pointer (car contents)))
		pathname complain))))

;;; 

;;; This opens an output MSF (or SSF) that is known to exist.
(defun open-output-msf (pathname fcb-ptr force-access complain)
       (let* ((contents (open-msf-get-components fcb-ptr pathname complain))
	    (first-component (filecons-pointer (first contents)))
	    (file-obj
	      (make-file-object
	        path pathname
	        fcb-ptr fcb-ptr
	        contents contents)))
	   (protect
	     (open-output-msf-check-access
	       pathname file-obj fcb-ptr first-component force-access
	       complain)
	     (alter-file-object
	       file-obj
	       uid (open-file-check-code (hcs_$get_uid_seg first-component)
				   pathname complain)
	       dtcm (open-file-check-code 
		    (e_multics_files_util_$get_dtcm first-component)
		    pathname complain))
	     &failure
	     (restore-access file-obj))
	   file-obj))

;;; 

(defun open-output-msf-check-access (pathname file-obj fcb-ptr segptr
				      force-access complain)
       (let ((access			;check component 0 access
	     (open-file-check-code (hcs_$fs_get_mode segptr)
			       pathname complain))
	   (orig-access null-pointer))
	  (when (= (logand access W_ACCESS_BIN) 0)   ;no write access
	        (selectq
		force-access
		((t ask)
		 (when (eq force-access 'ask)
		       (ring-tty-bell)
		       (unless
		         (yesp (catenate
			       "Do you want to write to the protected file "
			       (absolute-pathname pathname) "?"))
		         (open-file-error 0 nil complain)))
		 (protect
		   (setq orig-access
		         (open-file-check-code
			 (e_multics_files_util_$force_msf_access
			   fcb-ptr)
			 pathname complain))
		   &failure
		   (unless (= orig-access null-pointer)
			 (e_multics_files_util_$restore_msf_access
			   fcb-ptr orig-access))
		   &success
		   (setf (fobj-original-access file-obj)
		         orig-access)))
		(nil (open-file-error 'error_table_$moderr pathname
				  complain))
		(t (error "Internal error: Invalid open-output-file force-access:" force-access 'wrng-type-arg))))))

(defun restore-access (file-object)
       (let ((orig (fobj-original-access file-object)))
	  (when orig
	        (unless (= null-pointer orig)
		      (e_multics_files_util_$restore_msf_access
		        (fobj-fcb-ptr file-object) orig)))))

(defun open-file-reject-starname (pathname complain)
       (let* ((entry (pn-entry pathname))
	    (comp (pn-component pathname))
	    (entry-code (check_star_name_$entry entry))
	    (comp-code (cond ((nullstringp comp) 0)
			 ((= entry-code 0)	;only bother if entry valid
			  (check_star_name_$entry comp))
			 (t 0)))
	    (entry-code-1
	      (cond ((> entry-code 2) entry-code)
		  ((> entry-code 0) 'error_table_$nostars)
		  (t 0)))
	    (comp-code-1
	      (cond ((> comp-code 2) comp-code)
		  ((> comp-code 0) 'error_table_$nostars)
		  (t 0))))
	   (cond ((not (equal 0 entry-code-1))
		(open-file-error entry-code-1 pathname complain))
	         ((not (equal 0 comp-code-1))
		(open-file-error comp-code-1 pathname complain)))))

(defun open-file-error (error-code pathname complain)
       (cond ((eq complain 'noabort)
	    (report-error-noabort error-code " "
			      (car (absolute-pathname pathname t))))
	   (complain (report-error
		     error-code " " (car (absolute-pathname pathname t)))))
       (*throw 'open-file-error nil))

;;; 

;;; Close the file, restoring access, terminating segments, and
;;; releasing storage.  If set-bc-p is non-nil then the bit count
;;; of the file should be updated from the contents list (it is ignored
;;; if the file is not an MSF/SSF (i.e. a segment/component), which are
;;; only opened for input.  We also update the UID and DTCM, in case
;;; the caller needs the latest values.
(defun close-file (file-object &optional set-bc-p)
       (when file-object
	   (let ((fcb-ptr (fobj-fcb-ptr file-object))
	         (contents (fobj-contents file-object)))
	        (alter-file-object file-object
			       fcb-ptr null-pointer
			       contents nil)
	        (cond ((and fcb-ptr (not (= fcb-ptr null-pointer)))
		     (let (((uid dtcm)
			  (close-msf fcb-ptr contents set-bc-p
				   (fobj-original-access file-object))))
			(when uid
			      (setf (fobj-uid file-object)
				  uid))
			(when dtcm
			      (setf (fobj-dtcm file-object)
				  dtcm))))
		    (t (close-segment contents))))))

;;; When processing set-bc-p, we assume that msf_manager_$adjust
;;; takes care of the non-last components.  The caller should have
;;; filled these components to their max-lengths.  Returns
(defun close-msf (fcb-ptr contents set-bc-p orig-access &aux (result nil))
       (when contents
	   (when set-bc-p
	         (msf_manager_$adjust fcb-ptr (1- (length contents))
				(chars-to-bc
				  (filecons-length
				    (car (last contents))))
				MSFMA_TRUNC_BC))
	   (when (car contents)
	         (let* ((seg (filecons-pointer
			   (car contents)))
		      ((uid uid-code)
		       (hcs_$get_uid_seg seg))
		      ((dtcm dtcm-code)
		       (e_multics_files_util_$get_dtcm seg)))
		     (setq result
			 (list (and (= uid-code 0)
				  uid)
			       (and (= dtcm-code 0)
				  dtcm))))))
       (and orig-access
	  (not (= orig-access null-pointer))
	  (e_multics_files_util_$restore_msf_access
	    fcb-ptr orig-access))
       (msf_manager_$close fcb-ptr)
       result)

;;; Terminate an input segment (output always uses msf_manager_).
(defun close-segment (contents)
       (terminate_file_ (filecons-pointer (car contents)) 0
		    TERM_FILE_TERM))

;;; 

;;;
;;;	File/buffer reading/writing primitives
;;;


;;; Reads the given file-object into the buffer at the cursor
(defun read-file-into-buffer (file-object)
       (minibuffer-remark "Reading...")
       (mapc 'read-seg-into-buffer (fobj-contents file-object))
       (minibuffer-remark ""))		;clear above remark

(defun read-seg-into-buffer (filecons &aux char-count temp-ptr temp-filecons
			        seg-ends-in-nl last-nl-index first-nl-index
			        reverse-nl-index)
       (unless
         (=  (setq char-count (filecons-length filecons))
	   0)				;skip empty segment
         (setq temp-ptr (e$get_temporary_seg)
	     temp-filecons (make-filecons
			 pointer temp-ptr
			 length char-count))
         (push temp-ptr buffer-tempsegs)	;add this one to list of
					;temporary segs
         (e_lap_$write-string filecons temp-ptr 0);copy to temp-seg
         (setq seg-ends-in-nl (= #\newline
			   (e_lap_$ggcharn temp-filecons
				         (1- char-count))))
         (cond (seg-ends-in-nl
	       (setq reverse-nl-index 0
		   last-nl-index char-count))
	     (t (setq reverse-nl-index
		    (e_lap_$reverse-search-string
		      temp-filecons char-count NLCHARSTRING)
		    last-nl-index
		    (cond ((= reverse-nl-index -1) 0) ;no newlines!
			(t (- char-count reverse-nl-index))))))
         (setq first-nl-index
	     (cond ((= last-nl-index 0) 0)	;no newlines
		 (t (1+ (e_lap_$segnlindex temp-ptr last-nl-index 0)))))
         ;; Make sure the loop starts at beginning of line.
         ;; Do it even if already (bolp), because the loop below inserts
         ;; BEFORE the line that is then current, but we want to insert AFTER
         ;; the current point, so that marks are left in the right places.
         (unless (= first-nl-index 0)
	       (insert-string
	         (e_lap_$gsubstr temp-filecons 0 first-nl-index)))
         (do ((char-index first-nl-index (+ char-index line-len))
	    (line-ptr)
	    (line-len))
	   ((>= char-index last-nl-index))	;loop over the full lines
	   (setq line-len
	         (1+ (e_lap_$segnlindex temp-ptr last-nl-index
				  char-index)))
	   (setq line-ptr (make-char-pointer temp-ptr char-index))
	   (insert-new-line (make-filecons	;make representation of line
			  pointer line-ptr
			  length line-len)))
         (unless seg-ends-in-nl
	       (insert-string
	         (e_lap_$gsubstr temp-filecons last-nl-index
			     (- char-count last-nl-index))))))

;;;
;;; Writes the specified region of the buffer to the given file-object.
;;; May move the mark.
(defun write-point-mark-to-file (file-object mark)
       (minibuffer-remark "Writing...")
       (order-mark-last mark)
       (save-excursion
         (do ((comp-number 0 (1+ comp-number)))
	   ((write-point-mark-to-comp		;returns t when done
	      file-object comp-number mark)	;updates file-object
	    (setf (cdr (nthcdr comp-number	;forget about extra components
			   (fobj-contents file-object)))
		nil))))
       (minibuffer-remark ""))		;erase above remark

;;; Writes as much of point-mark as it can to the specified
;;; component of the file.  Leaves point after the portion that was
;;; written.  Returns t if it wrote everything, nil if it filled
;;; the component before finishing.  Updates the length in the filecons
;;; for the component to the amount written.  Updates the contents
;;; list if it must allocate a new component.
;;; For efficiency, these functions know about the various representations
;;; of lines and make use of low-level buffer-management variables (cur*);
;;; the old version did alot of string and mark consing in the name of
;;; modularity.
(defun write-point-mark-to-comp (file-object comp-number mark)
       (let* ((filecons (get-output-component file-object comp-number))
	    (comp-ptr (filecons-pointer filecons))
	    max-length)
	   ;; zero segment for improved paging
	   (let ((trunc-code (hcs_$truncate_seg comp-ptr 0)))
	        (unless (= trunc-code 0)
		      (report-file-error trunc-code file-object)))
	   (let (((maxl maxl-code)
		(hcs_$get_max_length_seg comp-ptr)))
	        (cond ((= maxl-code 0) (setq max-length (* 4 maxl)))     ;word->chars
		    (t (report-file-error maxl-code file-object))))
	   (do ((next-offset 0)
	        (done-flag)
	        (file-left max-length (- max-length next-offset)))
	       (nil)
	       (cond ((stringp curstuff)
		    (desetq (next-offset done-flag)
			  (write-out-string-line
			    comp-ptr next-offset file-left mark)))
		   (t			;curstuff is in temp-seg
		     (desetq (next-offset done-flag)
			   (write-out-filecons-lines
			     comp-ptr next-offset file-left mark))))
	       (when done-flag
		   (setf (filecons-length filecons) next-offset)
		   (and (eq done-flag 'buffer)
		        add-newline (not (bolp)) ;need to add newline
		        (cond ((< next-offset max-length)
			     (setf (filecons-length filecons)
				 (e_lap_$write-string
				   NLCHARSTRING comp-ptr
				   next-offset))
			     (return t))  ;all done
			    (t (return nil))))   ;put nl in next component
		   (return (eq done-flag 'buffer))))))


;;; Write out the appropriate portion of the current line, which is
;;; stored as a string in the buffer, to the segment|offset specified.
;;; Don't write more than file-left chars, and stop at end-mark in the buffer
;;; Returns a list (new-offset done-flag), where done-flag is nil
;;; if the caller should continue writing to the segment, 'segment if
;;; the segment is full, and 'buffer if end-mark was reached.
(defun write-out-string-line (segment offset file-left end-mark
			        &aux
			        char-count (done-flag nil))
       (cond ((mark-on-current-line-p end-mark)
	    (setq done-flag 'buffer
		char-count (- (mark-position end-mark) curpointpos)))
	   (t (setq char-count (- curlinel curpointpos))))
       (when (> char-count file-left)
	   (setq char-count file-left
	         done-flag 'segment))
       (cond ((= 0 char-count))		;nothing left
	   ((and (= curpointpos 0)
	         (= char-count curlinel))	;writing whole line
	    (setq offset (e_lap_$write-string curstuff segment offset))
	    (next-line))
	   (t (setq offset
		  (e_lap_$write-string
		    (substr curstuff (1+ curpointpos) char-count)
		    segment offset))
	      (forward-n-chars char-count)))
       (list offset done-flag))

;;; The current line contents is a temp-seg filecons.  Write out this line
;;; and any following lines that are adjacent in the temp-seg in one
;;; shot (for efficiency).  Otherwise, it is like write-out-string-line.
(defun write-out-filecons-lines (segment offset file-left end-mark
				 &aux
				 beginning (done-flag nil)
				 (char-count 0)
				 (old-cpp curpointpos))
       (setq beginning (add-char-offset (filecons-pointer curstuff)
				curpointpos))
       (cond ((not (= curpointpos old-cpp))
	    (break 'bad-curpointpos)))
       (do ((line-char-count))
	 (())
	 (cond ((mark-on-current-line-p end-mark)
	        (setq line-char-count (- (mark-position end-mark)
				   curpointpos)
		    done-flag 'buffer)
	        (go-to-mark end-mark))
	       (t (setq line-char-count (- curlinel curpointpos))
		(next-line)))
	 (when (> line-char-count file-left)
	       (backward-n-chars (- line-char-count file-left))
	       (setq line-char-count file-left
		   done-flag 'segment))
	 (incf char-count line-char-count)
	 (decf file-left line-char-count)
	 ;; check if we can continue with the next line
	 (when (or done-flag		;nothing left
		 (stringp curstuff)		;not a filecons
		 (not (= (filecons-pointer curstuff)	;not adjacent in
		         (add-char-offset beginning char-count))))     ; temp-seg
	       (return nil)))
       (e_lap_$write-string (make-filecons pointer beginning
				   length char-count)
		        segment offset)
       (list (+ offset char-count) done-flag))

;;; This is the Emacs analogue to msf_manager_$get_ptr.  If it has to
;;; create the component then it will update the file-object's contents
;;; list.  It returns the filecons representing the requested component.
(defun get-output-component (file-object comp-number)
       (or (nth comp-number (fobj-contents file-object))	;existing component
	 (let* (((ptr len code)
	         (msf_manager_$get_ptr (fobj-fcb-ptr file-object)
				 comp-number -1))	;create-if-not-found
	        (filecons (make-filecons pointer ptr
				   length len))
	        (contents-count (length (fobj-contents file-object))))
	      (when (= ptr null-pointer)
		  (report-file-error code file-object))
	      (cond ((= comp-number contents-count)  ;appending next component
		   (setf (fobj-contents file-object)
		         (nconc (fobj-contents file-object)
			      (ncons filecons))))
		  ((< comp-number contents-count)  ;inserting in the middle
		   (setf (nth comp-number (fobj-contents file-object))
		         filecons))
		  (t (setf (fobj-contents file-object)
			 (nconc (fobj-contents file-object)
			        (make-list (- comp-number contents-count))
			        (ncons filecons)))))
	      filecons)))

;;; 

;;;
;;;	User-callable interfaces
;;;


;;; Returns closed file-object if named file exists with specified access
;;; Returns nil if file doesn't exist or wrong access.
;;;  (Access-needed is as for open-file.)
(defun exists-file (name &optional (access-needed 'read)
		     &aux (file-object nil))
       (when (fixp access-needed)		;backward compatibility
	   (setq access-needed
	         (cond ((zerop (logand access-needed W_ACCESS_BIN))
		      'read)
		     (t 'write))))
       (protect
         (setq file-object (open-file name access-needed nil))
         &always
         (close-file file-object))
       file-object)


;;; Returns file-object if named file exists with specified access
;;; Aborts with message if file doesn't exist of wrong access
(defun validate-file (name access-needed &aux (file-object nil))
       (when (fixp access-needed)		;backward compatibility
	   (setq access-needed
	         (cond ((zerop (logand access-needed W_ACCESS_BIN))
		      'read)
		     (t 'write))))
       (protect
         (setq file-object (open-file name access-needed t))
         &always
         (close-file file-object))
       file-object)


;;; Inserts the named file into the buffer at the cursor
(defun file-insert (file-name &aux (file-object nil))
       (check-read-only)
       (protect
         (setq file-object
	     (check-object (open-star-name-single file-name 'read)))
         (read-file-into-buffer file-object)
         &always
         (close-file file-object nil)))
	  

;;; Reads the file into the buffer, destroying previous contents.
;;; file-arg may be either a pathname string or an open file-object.
(defun read-in-file (file-arg &aux file-object)
       (check-read-only)
       (protect
         (setq file-object
	     (check-object
	       (cond ((stringp file-arg)
		    (open-star-name-single file-arg 'read))
		   (t file-arg))))
         (let ((abs-path			;save abolute pathname and UID
	       (absolute-pathname (fobj-path file-object)))
	     (uid (fobj-uid file-object))
	     (dtcm (fobj-dtcm file-object)))
	    (reinitialize-current-buffer)
	    (setq buffer-modified-flag t)	;keep quiet
	    (read-file-into-buffer file-object)
	    (setq buffer-modified-flag nil
		fpathname abs-path
		buffer-file-dtcm dtcm	;let find-file know
		buffer-uid uid)
	  (go-to-beginning-of-buffer))
         &always
         (close-file file-object nil)))

;;; Writes the current region into the named file
(defun write-out-region (file-name &aux (file-object nil))
       (unless der-wahrer-mark
	     (report-error 'mark-not-set))
       (save-excursion
         (with-mark
	 here
	 (go-to-mark der-wahrer-mark)
	 (protect
	   (setq file-object (open-file file-name 'write t))
	   (write-point-mark-to-file file-object here)
	   &success
	   (close-file file-object t)		;update if successful
	   &failure
	   (close-file file-object nil)))))

;;; Writes the entire buffer to the specified file.  A subr for the
;;; following two user-callable subrs.  Access is either write or write-force.
(defun write-buffer-to-file (file-name access &aux (file-object nil))
       (protect
         (setq file-object (open-file file-name access t))
         (save-excursion
	 (go-to-end-of-buffer)
	 (with-mark
	   end
	   (go-to-beginning-of-buffer)	;whole buffer marked
	   (write-point-mark-to-file file-object end)	;wham!
	   (close-file file-object t)))	;update only if successful
         (setq fpathname (absolute-pathname (fobj-path file-object))
	     buffer-uid (fobj-uid file-object)
	     buffer-file-dtcm (fobj-dtcm file-object)
	     buffer-modified-flag nil)	;now corresponds to file
         &failure (close-file file-object nil)))

;;; Writes the current buffer into the named file.
(defun write-out-file (file-name)
         (write-buffer-to-file file-name 'write))	;do the work

;;; Write the current buffer into the named file, forcing access if necessary
(defun write-protected-file (file-name)
       (write-buffer-to-file file-name 'write-force))

;;; 

;;;
;;;	Commands
;;;


;;; Checks for attempt to read/write in minibuffer
(defun check-minibuffer-file-command ()
       (and minibufferp
	  (display-error "No reading/writing, you are in the minibuffer.")))


;;; Should ^X^R be careful about overwriting a modified buffer?
;;; (register-option 'read-file-force nil) ;moved to e_option_defaults_


;;; Reads a file into the buffer
(defcom read-file
        &numarg (&pass)
        &prologue check-minibuffer-file-command	;abort if in minibuffer
        &args ((file-name &string &prompt "Read File: "))
        (cond ((and buffer-modified-flag	;check if overwriting modified bugffer
		(not read-file-force)	;option forces it to read
		(not numarg))		;numarg forces it to read
	     (if (not (yesp "The current buffer has not been written out; read anyway? "))
	         (command-quit))))
        (setq file-name (e_lap_$trim file-name))
        (let ((file-to-read
	      (cond ((not (nullstringp file-name)) file-name)
		  (fpathname fpathname)
		  (t (report-error "You must supply a pathname.")))))
	   (read-in-file file-to-read)))


;;; Inserts a file into the buffer at the cursor
(defcom insert-file
        &prologue check-minibuffer-file-command	;abort if in minibuffer
        &args ((file-name &string &prompt "Insert File: "))
        (setq file-name (e_lap_$trim file-name))
        (cond ((not (nullstringp file-name))
	     (with-mark before-mark
		      (file-insert file-name)
		      (set-the-mark-here before-mark)))
	    (t
	      (display-error "You must supply a pathname."))))


;;; DTCM greater-than (handles unsignedness)
(defmacro dtcm-> (time1 time2)
	(once-only
	  (time1 time2)
	  `(and (not (= ,time1 ,time2))	;check common case first
	        (or (> (lsh ,time1 -1) (lsh ,time2 -1))	;ignore low-order bit
		  (> ,time1 ,time2)))))

(defmacro dtcm-< (time1 time2)
	`(not (dtcm-> ,time1 ,time2)))

;;; Writes the buffer into the default file
(defcom save-same-file
        &numarg &pass
        (check-minibuffer-file-command)		;abort if in minibuffer
        (check-newline-ending)
        (cond (fpathname
	      (let ((output-path (expand-pathname fpathname)))
		 (and save-same-file-check-dtcm
		      (not numarg)
		      buffer-file-dtcm
		      (let ((file-obj (exists-file output-path)))
			 (and file-obj
			      (dtcm-> (fobj-dtcm file-obj)
				    buffer-file-dtcm)))
		      (not
		        (yesp
			(catenate fpathname
				" has changed since last read or written. Save anyway?")))
		      (command-quit))
		 (write-protected-file output-path)))
	    (t (display-error "No default pathname for this buffer."))))

;;; Writes the buffer into a file
(defcom write-file
        &numarg &pass
        &prologue check-minibuffer-file-command	;abort if in minibuffer
        &args ((file-name &string &prompt "Write File: "))
        (check-newline-ending)
        (setq file-name (e_lap_$trim file-name))
        (let (file-obj)
	   (cond ((nullstringp file-name) (save-same-file))    ;no name given, use default
	         ((and (not write-file-overwrite)
		     (not numarg)
		     (setq file-obj (exists-file file-name))
		     (not
		       (yesp
		         (catenate (absolute-pathname
				 (fobj-path file-obj))
			         " already exists. Overwrite it?"))))
		(command-quit))
	         (t (write-protected-file file-name)))))


;;; Insert current buffer's pathname
(defcom get-filename
        &na (&pass)       
        (cond (fpathname
	      (set-the-mark)
	      (insert-string
	        (cond (numarg (get-entryname fpathname))
		    (t fpathname))))
	    (t (display-error "No default pathname for this buffer."))))

(defun get-entryname (pathname)
       (setq pathname (expand-pathname pathname))	;canonicalize
       (let ((ename (pn-entry pathname))
	   (cname (pn-component pathname)))
	  (cond ((nullstringp cname) ename)
	        (t cname))))


;;; option to specify if find-file should set buffer modes from pathname suffix
;;; (register-option 'find-file-set-modes nil) ;moved to e_option_defaults_


;;;
;;;	find-file Command
;;;	Reads file into buffer given by its name
;;;	unless it's already in a buffer
;;;

(defcom find-file
        &prologue check-minibuffer-file-command	;abort if in minibuffer
        &args ((file-name &string &prompt "Find File: "))
        (setq file-name (e_lap_$trim file-name))
        (when (nullstringp file-name)
	    (display-error "You must supply a pathname."))
        (find-file-subr file-name)
        (select-buffer-window current-buffer 'cursize-not-empty))

(defun find-file-subr (file-name)
       (dolist (one-file-name (match-star-name file-name nil))
	     (*catch 'find-file-skip-file
		   (find-file-subr-single-entry one-file-name))))

(defun find-file-subr-single-entry (pathname &aux
				     (file nil) uid dtcm
				     abs-path default-buffer
				     buffer-given)
       (protect
         (setq file (open-file pathname 'read nil)     ;don't complain, we will create new buffer
	     uid (and file (fobj-uid file))
	     dtcm (cond (file (fobj-dtcm file))
		      (t 0))		;nonexistent file is VERY old
	     abs-path (absolute-pathname pathname)
	     default-buffer (find-file-default-buffer pathname)
	     buffer-given (find-file-choose-buffer uid dtcm default-buffer
					   pathname))
         ;; If we're going to read in a new file, make sure it isn't object seg
         (and file
	    (or (not (exists-buffer buffer-given))
	        (empty-buffer-p buffer-given))
	    (check-object file))
         ;; Now have the buffer to use in buffer-given.
         (go-to-or-create-buffer buffer-given)
         (cond ((empty-buffer-p buffer-given)
	      ;;empty buffer, read file if found
	      (cond (file (read-in-file file))
		  (t (open-file pathname 'read 'noabort)    ;to get error message.
		     (setq fpathname abs-path)))
	      (find-file-set-buffer-mode pathname))
	     ;; using existing buffer
	     (t ;;see if fpathname is invalid.
	        (let ((old-file (exists-file fpathname 'read)))
		   (and file		;old name unused now
		        (equal (fobj-uid file) (fobj-uid old-file))    ;name has moved!
		        (setq fpathname abs-path)))))	;Use the new pathname
         &failure
         (close-file file)))

(defun find-file-choose-buffer (uid dtcm default-buffer pathname)
       (let ((buffer-given nil)
	   (buffer-list nil))
	  (when uid
	        (setq buffer-list
		    (find-file-find-buffers-containing-file uid dtcm))
	        (cond ((null buffer-list))
		    ((null (cdr buffer-list)) ;only one
		     (setq buffer-given (first buffer-list)) ;use it
		     (minibuffer-remark "Buffer " buffer-given
				    " contains "
				    (absolute-pathname pathname)))
		    (t (setq buffer-given
			   (find-file-disambiguate-buffer default-buffer
						    buffer-list)))))
	  (when (null buffer-given)
	        (setq buffer-given default-buffer))
	  ;; decide if this is a reasonable buffer
	  (do ((potential-buffer buffer-given))
	      ((or (not (exists-buffer potential-buffer)) ;new buffer OK
		 (empty-buffer-p potential-buffer))	;reuse empty OK
	       potential-buffer)
	      (cond ((memq potential-buffer buffer-list)	;already in this buffer: MAYBE
		   (let ((result		;check for old version
			 (find-file-check-modified potential-buffer
					       dtcm pathname))
		         keyword)
		        (cond ((atom result)	;chose a new buffer
			     (setq potential-buffer result))
			    ((eq (setq keyword (car result))
			         'overwrite)     ;said to overwrite this one
			     (buffer-kill potential-buffer)
			     (return potential-buffer))
			    ((eq keyword 'use) (return potential-buffer))
			    ((eq (car result) 'skip)
			     (*throw 'find-file-skip-file nil)) ;said to skip this one
			    (t (error "Invalid result from find-file-check-modified." result 'fail-act)))))
		  ((and (eq potential-buffer default-buffer) ;default buffer didn't pass above
		        (let ((newbuf (find-file-alternate-buffer pathname)))
			   (and (neq newbuf potential-buffer)	;don't loop
			        (progn (setq potential-buffer newbuf)
				     t)))))    ;to skip next cond-clause
		  (t (setq potential-buffer
			 (find-file-get-new-buffer potential-buffer)))))))
;;;
;;;
;;; Friends of find-file
;;;

;;; Return buffer symbol given file name

(defun find-file-default-buffer (file-name)
       (setq file-name (get-entryname file-name))
       (make_atom
         (cond (find-file-entry-names-buffer file-name)
	     (t (first-entryname-component file-name)))))

(defun first-entryname-component (entryname)
       (let ((dot-index (index entryname ".")))
	  (cond ((< dot-index 2)		;no dot or starts with dot
	         entryname)			;so leave alone
	        (t (substr entryname 1 (1- dot-index))))))

;;; Return alternate buffer name (i.e. whole entry name) given file name

(defun find-file-alternate-buffer (file-name)
       (make_atom (get-entryname file-name)))

;;; Find all emacs buffers containing a specified file

(defun find-file-find-buffers-containing-file (uid dtcm)
       (let* ((lists (list nil nil))		;(uid-matches dtcm-matches)
	    (environment `(,uid ,dtcm .,lists)))
	   (map-over-emacs-buffers #'find-file-collect-buffer environment)
	   (or (second lists)		;if any DTCM match, then only return those
	       (first lists))))		;otherwise, return any matching files

(defun find-file-collect-buffer (buffer (uid dtcm . lists)) ;
       (when (and (not (empty-buffer-p buffer))
	        (equal (get-buffer-state buffer 'buffer-uid)
		     uid))
	   (push buffer (first lists))
	   (when (eq dtcm
		   (get-buffer-state buffer 'buffer-file-dtcm))
	         (push buffer (second lists)))))

;;; Display all the buffers containing a file, and make the user pick one

(defun find-file-disambiguate-buffer (default-buffer buffer-list)
       (init-local-displays)
       (local-display-generator-nnl "Buffers containing this file:")
       (local-display-generator-nnl "")
       (mapc 'find-file-display-one-buffer buffer-list)
       (local-display-generator-nnl "-------------------------")
       (let ((completion-list buffer-list)
	   (answer (intern-minibuffer-response "Buffer: " NL)))
	  (cond ((eq answer '||)		;null response
	         default-buffer)
	        (t answer))))

;;; Display a single buffer (subroutine of find-file-disambiguate-buffer)

(defun find-file-display-one-buffer (buffer)
       (let ((current-buffer-prefix " ")
	   (modified-prefix " ")
	   (pad (substr "                         "
		      1
		      (max (- 25. (stringlength buffer)) 1)))
	   (path (get-buffer-state buffer 'fpathname)))
	  (and (eq current-buffer buffer)
	       (setq current-buffer-prefix ">"))
	  (and (get-buffer-state buffer 'buffer-modified-flag)
	       (setq modified-prefix "*"))
	  (cond (path
		(local-display-generator-nnl
		  (catenate current-buffer-prefix
			  modified-prefix
			  buffer
			  pad
			  path)))
	        (t (local-display-generator-nnl
		   (catenate current-buffer-prefix
			   modified-prefix
			   buffer))))))

;;; Tell the user the buffer he wants is in use, and get a new one from him

(defun find-file-get-new-buffer (old-buffer)
       (let ((answer))
	  (ring-tty-bell)
	  (setq answer (intern-minibuffer-response
		       (catenate "Buffer " old-buffer
			       " is already in use.  New buffer: ")
		       NL))
	  (cond ((nullstringp answer)
	         old-buffer)
	        (t answer))))

;;; Set the major mode from the file name

(defun find-file-set-buffer-mode (file-name)
       (when find-file-set-modes
	   (let* ((entry (get-entryname file-name))
		(entry-len (stringlength entry))
		(dot-index (1- (e_lap_$reverse-search-string
			       entry entry-len ".")))
		(suffix (cond ((< dot-index 0)     ;no suffix, or null suffix
			     '(nil))	;not nil, in case of foo.nil
			    (t (substr entry
				     (- entry-len dot-index))))))
	         (when (atom suffix)
		     (setq suffix (make_atom suffix))
		     (let ((mode-fun
			   (or (get suffix 'suffix-mode)
			       (make_atom (catenate suffix "-mode")))))
			(when (getl mode-fun '(expr subr autoload))
			      (funcall mode-fun)))))))

;;; Check whether the file has been modified since the buffer was read/written
;;; and query the user if so.  Returns either a buffer (a symbol), the list
;;; (overwrite) if the caller should overwrite the specified buffer, (skip)
;;; if the caller should skip this file altogether, or (use) if the caller
;;; should just go to the specified buffer.
(defun find-file-check-modified (buffer file-dtcm pathname)
       (cond
         ((not find-file-check-dtcm) '(use))     ;user opts not to check
         ((dtcm-< (or file-dtcm 0)		;file not more recent than buffer
	        (or (get-buffer-state buffer 'buffer-file-dtcm)
		  0))
	'(use))
         (t (ring-tty-bell)
	  (let (((display help)
	         (find-file-check-mod-get-display-lists buffer pathname)))
	       (init-local-displays)
	       (mapc 'local-display-generator-nnl display)
	       (end-local-displays)
	       (let*
	         ((completion-list
		  '(Overwrite overwrite Use use New new Skip skip
			    Help help ?))
		(answer
		  (do ((ans (find-file-check-mod-query) (find-file-check-mod-query)))
		      ((memq ans completion-list)
		       ans)
		      (ring-tty-bell)
		      (init-local-displays)
		      (local-display-generator-nnl "Invalid response.  Type ""help"" or ""?"" for assistance.")
		      (end-local-displays))))
	         (selectq
		 answer
		 (overwrite '(overwrite))
		 (skip '(skip))
		 (use '(use))
		 (new
		   (let ((completion-list nil))
		        (do ((ans (intern-minibuffer-response "New buffer: ")
			        (intern-minibuffer-response "Invalid response.  New buffer: ")))
			  ((neq ans '||) ans)
			  (ring-tty-bell))))
		 ((help ?)
		  (find-file-check-mod-help help)
		  ;; recurse to try again (too bad no tail-recursion optimization)
		  (find-file-check-modified buffer file-dtcm pathname))))))))

(defun find-file-check-mod-get-display-lists (buffer pathname)
       (setq pathname (absolute-pathname pathname))
       (cond
         ((get-buffer-state buffer 'buffer-modified-flag)
	`((,(catenate "Modified buffer " buffer
		    " contains an old version of")
	    ,pathname)
	  (,(catenate "Since buffer " buffer
		    " was last saved or read, the file")
	    ,(catenate pathname " has been modified.")
	    "The buffer HAS ALSO been modified since then.")))
         (t `((,(catenate "Buffer " buffer " contains an old version of")
	      ,pathname)
	    (,(catenate "Since buffer " buffer
		      " was last saved or read, the file")
	      ,(catenate pathname " has been modified.")
	      "The buffer HAS NOT been modified since then.")))))

(defun find-file-check-mod-query ()
       (intern
         (lowercase
	 (e_lap_$rtrim
	   (minibuffer-response
	     "Select ""overwrite"", ""use"", ""skip"", ""new"" buffer, or ""help"": ")))))

(defun find-file-check-mod-help (display-list)
       (init-local-displays)
       (mapc 'local-display-generator-nnl
	   display-list)
       (mapc 'local-display-generator-nnl
	   '("" "Respond with one of:"
	        "  overwrite - to reread the file into this buffer"
	        "  use	- to use this buffer as is"
	        "  new	- to select a new buffer"
	        "  skip	- to skip the current file"))
       (end-local-displays))
;;; 

;;;
;;;	Miscellaneous functions
;;;

;;; expand-pathname takes either a pathname structure or a relative pathname
;;; character string, and returns a pathname structure.  If dont-abort is
;;; non-nil, then it returns a list of the pathname and an error code.
;;; This is the definition of "pathname" as
;;; input to all other functions in this module: a pathname is anything
;;; acceptable to expand-pathname.  They should all call expand-pathname
;;; doing anything, so that they will be generic.

(defun expand-pathname (pathname &optional dont-abort)
       (cond ((or (stringp pathname) (symbolp pathname))
	    (let (((dir entry comp code)
		 (expand_pathname_$component pathname)))
	         (cond ((= 0 code)
		      (let ((pathname
			    (make-pathname directory (e_lap_$rtrim dir)
				         entry (e_lap_$rtrim entry)
				         component (e_lap_$rtrim comp))))
			 (cond (dont-abort (list pathname 0))
			       (t pathname))))
		     (dont-abort (list (make-pathname) code))
		     (t (report-error code " " pathname)))))
	   ((atom pathname)			;dont-abort doesn't stop wrong-type-arg checking.
	    (error "The pathname is not a list or string." pathname 'wrng-type-arg))
	   (dont-abort (list pathname 0))
	   (t pathname)))

;;; absolute-pathname takes a pathname and returns a list of the character
;;; string representation of the absolute path and a standard Multics error
;;; code.  dont-abort is as in expand-pathname.

(defun absolute-pathname (orig-pathname &optional dont-abort)
       (let ((pathname (expand-pathname orig-pathname dont-abort))
	   (code 0))
	  (when dont-abort
	        (desetq (pathname code) pathname))
	  (cond ((= 0 code)
	         (let ((string (pn-abs-path pathname)))	;check cache
		    (when (null string)
			(setq string
			      (e_lap_$rtrim (pathname_$component
					  (pn-directory pathname)
					  (pn-entry pathname)
					  (pn-component pathname))))
			(setf (pn-abs-path pathname) string))
		    (cond (dont-abort (list string 0))
			(t string))))
	        (dont-abort (list "" code))
	        (t (report-error code " " orig-pathname)))))


;;; An interface to report-error for file errors.
(defun report-file-error (code file-obj)
       (report-error code SPACE
		 (car (absolute-pathname (fobj-path file-obj)
				     t))))

;;; Converts file-cons to a string
(defun filerep-to-string (file-cons)
       (e_lap_$return-string (filecons-pointer file-cons)
		         0 (filecons-length file-cons)))


;;; Loads a file of LISP using "working" directory
(defun loadfile (file-name)
       (let ((file-exists (validate-file file-name 'read)))	;need at least r, but don't need e
	  (and file-exists
	       (errset (load (fobj-abs-path file-exists))))))


;;; Loads a file from EMACS library
(defun loadlib (file-name)
       (loadfile (make-pathname directory env-dir entry file-name)))


;;; Specify that given function is autoloaded from EMACS library
(defun set-autoload-lib (function file-name)
       (putprop function (pathname_ env-dir file-name) 'autoload))

;;; 
;;; Interfaces to the starname matcher in e_multics_files_util_.

;;; This matches the starname, and opens it if it only matches one entry.
(defun open-star-name-single (starname mode)
       (let ((matches (match-star-name starname nil)))
	  (cond ((null (cdr matches))
	         (open-file (first matches) mode))
	        (t (report-error "Multiple-files not allowed here: " starname)))))

;;; This returns a list of pathnames matching the starname.  It aborts
;;; with error_table_$nomatch if there are no matches at all, so it will
;;; never return nil, unless allow-no-match is non-nil.
(defun match-star-name (starname allow-no-match)
       (let* ((path (expand-pathname starname))
	    (dir (pn-directory path))
	    (ent (pn-entry path))
	    (comp (pn-component path))
	    (data-ptr null-pointer)
	    code count)
         (protect
	 (desetq (data-ptr count code)
	         (e_multics_files_util_$star_list_init
		 dir ent comp))
	 (or (= code 0)
	     allow-no-match
	     (report-error code SPACE (absolute-pathname path)))
	 (loop for index from 1 to count
	       collecting
	       (let (((new-ent new-comp)
		    (e_multics_files_util_$nth_star_match
		      data-ptr index)))
		  (make-pathname directory (e_lap_$rtrim dir)
			       entry (e_lap_$rtrim new-ent)
			       component (e_lap_$rtrim new-comp))))
	 &always
	 (e_multics_files_util_$star_list_cleanup data-ptr))))




		    e_multics_files_util_.pl1       08/20/86  2312.3rew 08/20/86  2248.3      158688



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

/* Utility routines for manipulating Multics files from Emacs */


/****^  HISTORY COMMENTS:
  1) change(79-07-28,Palter), approve(), audit(),
     install(86-08-20,MR12.0-1136):
     Initial coding.
  2) change(86-01-17,Margolin), approve(86-01-17,MCR7325),
     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
     Added force_msf_access, restore_msf_access, star_list_init,
     nth_star_match, star_list_cleanup, get_dtcm, get_dtcm_file entrypoints.
     Upgraded code in the force_access and restore_access entrypoints, to
     establish proper cleanup handlers, use standard include file structures,
     and to use named constants.  Sorted the declarations.
                                                   END HISTORY COMMENTS */


/* format: style2,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indcomtxt,^inditerdo,idind22 */

e_multics_files_util_:
     procedure ();

	return;					/* not an entry */

	/*** Parameter ***/

	dcl     P_abs_pathname	character (*) parameter;
	dcl     P_code		fixed binary (35) parameter;
	dcl     P_component		char (*) parameter;
	dcl     P_count		fixed bin parameter;
	dcl     P_dir		char (*) parameter;
	dcl     P_dtcm		fixed bin (35) parameter;
	dcl     P_entry		char (*) parameter;
	dcl     P_fcb_ptr		ptr parameter;
	dcl     P_protect_info_ptr	pointer parameter;
	dcl     P_seg_ptr		pointer parameter;
	dcl     P_starname_info_ptr	pointer parameter;

	/*** Automatic ***/

	dcl     code		fixed bin (35);
	dcl     1 dacl		aligned like general_delete_acl_entry;
						/* entry to delete */
	dcl     dates_array		(2) bit (36);
	dcl     dirname		character (168);
	dcl     ename		character (32);
	dcl     1 new_acl		aligned like general_extended_acl_entry;
						/* entry to add/replace */
	dcl     protect_info_ptr	pointer;
	dcl     star_component	bit (1) aligned;	/* does the component name have "*" or "?" */
	dcl     star_entry		bit (1) aligned;	/* does the entryname have "*" or "?" */
	dcl     star_star_component	bit (1) aligned;	/* is the componentname "**" */
	dcl     starname_index	fixed bin;
	dcl     starname_info_max_entries
				fixed bin;
	dcl     starname_info_ptr	ptr;
	dcl     system_area_ptr	pointer;

	/*** Based ***/

	dcl     1 protect_info	aligned based (protect_info_ptr),
						/* remember how we forced access */
		2 dirname		character (168) unaligned,
		2 ename		character (32) unaligned,
		2 delete_the_acl	bit (1),		/* ON => we added ACL term */
		2 acl		like general_extended_acl_entry;
	dcl     1 protect_msf_info	aligned based (protect_info_ptr),
						/* remember how we forced access */
		2 delete_the_acl	bit (1),		/* ON => we added ACL term */
		2 acl		like general_extended_acl_entry;
	dcl     1 starname_info	aligned based (starname_info_ptr),
		2 header,
		  3 max_entries	fixed bin,	/* size of the array */
		  3 n_entries	fixed bin init (0), /* how many are used */
		2 names		(starname_info_max_entries refer (starname_info.max_entries)),
		  3 (entry, component)
				char (32) unaligned;
	dcl     system_area		area based (system_area_ptr);

	/*** Static ***/

	dcl     (
	        error_table_$argerr,
	        error_table_$nomatch,
	        error_table_$user_not_found
	        )			fixed binary (35) external static;

	/*** Builtin ***/

	dcl     (addr, binary, divide, null, unspec)
				builtin;

	/*** Condition ***/

	dcl     cleanup		condition;

	/*** External Entry ***/

	dcl     archive_$list_components
				entry (ptr, fixed bin (24), fixed bin, ptr, ptr, fixed bin, fixed bin (35));
	dcl     check_star_name_$entry
				entry (char (*), fixed bin (35));
	dcl     expand_pathname_	entry (character (*), character (*), character (*), fixed binary (35));
	dcl     get_group_id_	entry () returns (character (32));
	dcl     get_system_free_area_ entry () returns (pointer);
	dcl     hcs_$add_acl_entries	entry (character (*), character (*), pointer, fixed binary, fixed binary (35));
	dcl     hcs_$delete_acl_entries
				entry (character (*), character (*), pointer, fixed binary, fixed binary (35));
	dcl     hcs_$get_dates	entry (char (*), char (*), (*) bit (36), fixed bin (35));
	dcl     hcs_$get_dates_ptr	entry (ptr, (*) bit (36), fixed bin (35));
	dcl     hcs_$list_acl	entry (character (*), character (*), pointer, pointer, pointer, fixed binary,
				fixed binary (35));
	dcl     hcs_$star_dir_list_	entry (char (*), char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr,
				fixed bin (35));
	dcl     initiate_file_	entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
	dcl     initiate_file_$component
				entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35))
				;
	dcl     match_star_name_	entry (char (*), char (*), fixed bin (35));
	dcl     msf_manager_$acl_add	entry (ptr, ptr, fixed bin, fixed bin (35));
	dcl     msf_manager_$acl_delete
				entry (ptr, ptr, fixed bin, fixed bin (35));
	dcl     msf_manager_$acl_list entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin (35));
	dcl     terminate_file_	entry (ptr, fixed bin (24), bit (*), fixed bin (35));

%page;

/* This entry forces read/write access to the specified file */

force_access:
     entry (P_abs_pathname, P_protect_info_ptr, P_code);

	call expand_pathname_ (P_abs_pathname, dirname, ename, P_code);
	if P_code ^= 0 then return;			/* shouldn't happen */

	system_area_ptr = get_system_free_area_ ();

	protect_info_ptr = null ();
	on cleanup
	     begin;
		if protect_info_ptr ^= null () then free protect_info;
	     end;
	allocate protect_info in (system_area) set (protect_info_ptr);

	protect_info.dirname = dirname;
	protect_info.ename = ename;

	protect_info.acl.access_name = get_group_id_ ();

	call hcs_$list_acl (dirname, ename, null (), null (), addr (protect_info.acl), 1, P_code);
	if P_code ^= 0 then do;			/* couldn't list it */
	     free protect_info in (system_area);
	     return;
	end;

	if protect_info.acl.status_code = error_table_$user_not_found then
	     protect_info.delete_the_acl = "1"b;	/* must add the entry */
	else protect_info.delete_the_acl = "0"b;

	new_acl.access_name = protect_info.acl.access_name;
	new_acl.mode = RW_ACCESS;
	new_acl.extended_mode = ""b;

	on cleanup
	     begin;
		if protect_info_ptr ^= null () then do;
		     call restore_access (protect_info_ptr);
		     free protect_info;
		end;
	     end;

	call hcs_$add_acl_entries (dirname, ename, addr (new_acl), 1, P_code);

	if P_code ^= 0 then do;			/* couldn't add it */
	     free protect_info in (system_area);
	     P_protect_info_ptr = null ();
	     if P_code = error_table_$argerr then P_code = new_acl.status_code;
						/* no true info here */
	end;

	else do;					/* success */
	     P_protect_info_ptr = protect_info_ptr;
	end;

	return;

/**/

/* This entry restores the access on a segment to its original state */

restore_access:
     entry (P_protect_info_ptr);

	if P_protect_info_ptr = null () then return;

	protect_info_ptr = P_protect_info_ptr;
	P_protect_info_ptr = null ();

	if protect_info.delete_the_acl then do;
	     dacl.access_name = protect_info.acl.access_name;
	     call hcs_$delete_acl_entries (protect_info.dirname, protect_info.ename, addr (dacl), 1, (0));
	end;

	else call hcs_$add_acl_entries (protect_info.dirname, protect_info.ename, addr (protect_info.acl), 1, (0));

	system_area_ptr = get_system_free_area_ ();

	free protect_info in (system_area);

	return;
%page;

/* This entry forces read/write access to the specified MSF/SSF */

force_msf_access:
     entry (P_fcb_ptr, P_protect_info_ptr, P_code);

	system_area_ptr = get_system_free_area_ ();

	protect_info_ptr = null ();
	on cleanup
	     begin;
		if protect_info_ptr ^= null () then free protect_msf_info;
	     end;
	allocate protect_msf_info in (system_area) set (protect_info_ptr);

	protect_msf_info.acl.access_name = get_group_id_ ();

	call msf_manager_$acl_list (P_fcb_ptr, null (), null (), addr (protect_msf_info.acl), 1, P_code);
	if P_code ^= 0 then do;			/* couldn't list it */
	     free protect_msf_info in (system_area);
	     return;
	end;

	if protect_msf_info.acl.status_code = error_table_$user_not_found then
	     protect_msf_info.delete_the_acl = "1"b;	/* must add the entry */
	else protect_msf_info.delete_the_acl = "0"b;

	new_acl.access_name = protect_msf_info.acl.access_name;
	new_acl.mode = RW_ACCESS;
	new_acl.extended_mode = ""b;

	on cleanup
	     begin;
		if protect_info_ptr ^= null () then do;
		     call restore_msf_access (P_fcb_ptr, protect_info_ptr);
		     free protect_msf_info;
		end;
	     end;

	call msf_manager_$acl_add (P_fcb_ptr, addr (new_acl), 1, P_code);

	if P_code ^= 0 then do;			/* couldn't add it */
	     free protect_msf_info in (system_area);
	     P_protect_info_ptr = null ();
	     if P_code = error_table_$argerr then P_code = new_acl.status_code;
						/* no true info here */
	end;

	else do;					/* success */
	     P_protect_info_ptr = protect_info_ptr;
	end;

	return;

%page;

/* This entry restores the access on an MSF to its original state */

restore_msf_access:
     entry (P_fcb_ptr, P_protect_info_ptr);

	if P_fcb_ptr = null () then do;
	     if P_protect_info_ptr ^= null () then free P_protect_info_ptr -> protect_msf_info;
	     return;
	end;
	if P_protect_info_ptr = null () then return;

	protect_info_ptr = P_protect_info_ptr;
	P_protect_info_ptr = null ();

	if protect_msf_info.delete_the_acl then do;
	     dacl.access_name = protect_msf_info.acl.access_name;
	     call msf_manager_$acl_delete (P_fcb_ptr, addr (dacl), 1, (0));
	end;

	else call msf_manager_$acl_add (P_fcb_ptr, addr (protect_msf_info.acl), 1, (0));

	free protect_msf_info;

	return;
%page;

star_list_init:
     entry (P_dir, P_entry, P_component, P_starname_info_ptr, P_count, P_code);

	P_code = 0;
	P_count = 0;
	P_starname_info_ptr = null ();

	starname_info_ptr, star_list_branch_ptr, star_list_names_ptr = null ();
	on cleanup
	     begin;
		if starname_info_ptr ^= null then free starname_info;
		if star_list_names_ptr ^= null then free star_list_names;
		if star_list_branch_ptr ^= null then free star_dir_list_branch;
	     end;

	code = 0;
	call check_star_name_$entry (P_entry, code);
	if code = 0 then star_entry = "0"b;
	else if code > 2 then do;
	     P_code = code;
	     return;
	end;
	else star_entry = "1"b;

	if P_component = "" then
	     star_component = "0"b;
	else do;
	     call check_star_name_$entry (P_component, code);
	     if code = 0 then star_component = "0"b;
	     else if code > 2 then do;
		P_code = code;
		return;
	     end;
	     else do;
		star_component = "1"b;
		star_star_component = (code = 2);
	     end;
	end;

	system_area_ptr = get_system_free_area_ ();

	if ^star_entry & ^star_component then do;	/* simple, common case */
	     starname_info_max_entries = 1;
	     allocate starname_info in (system_area);
	     starname_info.n_entries = 1;
	     starname_info.names (1).entry = P_entry;
	     starname_info.names (1).component = P_component;
	     P_starname_info_ptr = starname_info_ptr;
	     P_count = 1;
	     return;
	end;

	star_select_sw = star_BRANCHES_ONLY;
	call hcs_$star_dir_list_ (P_dir, P_entry, star_select_sw, get_system_free_area_ (), star_branch_count,
	     star_link_count, star_list_branch_ptr, star_list_names_ptr, P_code);
	if P_code ^= 0 then return;

	if P_component = "" then
	     call star_list_files ();
	else call star_list_archives ();

	if P_code = 0 then do;
	     P_starname_info_ptr = starname_info_ptr;
	     P_count = starname_info.n_entries;
	end;
	else free starname_info;

	free star_list_names;
	free star_dir_list_branch;

	return;

star_list_files:
     proc ();

	starname_info_max_entries = star_branch_count;
	allocate starname_info in (system_area);
	do starname_index = 1 to star_branch_count;
	     if star_dir_list_branch (starname_index).type = star_SEGMENT
		| star_dir_list_branch (starname_index).bit_count > 1 /* MSF */ then do;
		starname_info.n_entries = starname_info.n_entries + 1;
		starname_info.names (starname_info.n_entries).entry =
		     star_list_names (star_dir_list_branch (starname_index).nindex);
		starname_info.names (starname_info.n_entries).component = "";
	     end;
	end;

	return;

star_list_archives:
     entry ();

	if star_component then			/* just a guess, we'll grow it if necessary */
	     if star_star_component then
		starname_info_max_entries = 15 * star_branch_count;
	     else starname_info_max_entries = 5 * star_branch_count;
	else starname_info_max_entries = star_branch_count;
						/* maximum one per archive */
	allocate starname_info in (system_area);
	do starname_index = 1 to star_branch_count;
	     if star_dir_list_branch (starname_index).type = star_SEGMENT /* no MSF archives */ then
		call star_list_components (star_list_names (star_dir_list_branch (starname_index).nindex));
	end;

	if starname_info.n_entries = 0 then P_code = error_table_$nomatch;

	return;

star_list_components:
     proc (archive_entry);

	dcl     archive_entry	char (*) parameter;

	dcl     archive_bc		fixed bin (24);
	dcl     1 archive_component_info_array
				(n_components) based (archive_component_info_array_ptr) aligned
				like archive_component_info;
	dcl     archive_component_info_array_ptr
				ptr;
	dcl     archive_ptr		ptr;
	dcl     code		fixed bin (35);
	dcl     component_index	fixed bin;
	dcl     n_components	fixed bin;


	archive_component_info_array_ptr, archive_ptr = null ();
	on cleanup
	     begin;
		if archive_component_info_array_ptr ^= null () then free archive_component_info_array;
		if archive_ptr ^= null () then call terminate_file_ (archive_ptr, 0, TERM_FILE_TERM, (0));
	     end;

	if star_component then do;			/* foo*::bar* */
	     call initiate_file_ (P_dir, archive_entry, R_ACCESS, archive_ptr, archive_bc, code);
	     if code ^= 0 then return;		/* skip this one */
	     call archive_$list_components (archive_ptr, archive_bc, ARCHIVE_COMPONENT_INFO_VERSION_1, system_area_ptr,
		archive_component_info_array_ptr, n_components, code);
	     if code ^= 0 then go to star_list_components_EXIT;

	     if star_star_component then
		do component_index = 1 to n_components;
		call star_list_comp_add (archive_entry, archive_component_info_array (component_index).name);
	     end;
	     else do component_index = 1 to n_components;
		call match_star_name_ (archive_component_info_array (component_index).name, P_component, code);
		if code = 0 then
		     call star_list_comp_add (archive_entry, archive_component_info_array (component_index).name);
		else code = 0;
	     end;

	     free archive_component_info_array;
	end;

	else do;					/* foo*::bar */
	     call initiate_file_$component (P_dir, archive_entry, P_component, R_ACCESS, archive_ptr, (0), code);
	     if code = 0 then call star_list_comp_add (archive_entry, P_component);
	end;


star_list_components_EXIT:
	call terminate_file_ (archive_ptr, 0, TERM_FILE_TERM, (0));

	return;

star_list_comp_add:
     proc (entry, component);

	dcl     (component, entry)	char (*) parameter;

	if starname_info.n_entries = starname_info.max_entries then
	     begin;
		dcl     temp_ptr		ptr init (null ());
		on cleanup
		     begin;
			if temp_ptr ^= null () then free temp_ptr -> starname_info;
		     end;
		starname_info_max_entries = starname_info.max_entries + 25;
		allocate starname_info in (system_area) set (temp_ptr);
		temp_ptr -> starname_info.header = starname_info.header;
		temp_ptr -> starname_info.names = starname_info.names;
		free starname_info;
		starname_info_ptr = temp_ptr;
	     end;

	starname_info.n_entries = starname_info.n_entries + 1;
	starname_info.names (starname_info.n_entries).entry = entry;
	starname_info.names (starname_info.n_entries).component = component;
	return;

     end star_list_comp_add;

     end star_list_components;

     end star_list_files;

nth_star_match:
     entry (P_starname_info_ptr, P_count, P_entry, P_component);

	starname_info_ptr = P_starname_info_ptr;
	if P_count > starname_info.n_entries then do;
	     P_entry = "";
	     P_component = "";
	end;
	else do;
	     P_entry = starname_info.names (P_count).entry;
	     P_component = starname_info.names (P_count).component;
	end;

	return;

star_list_cleanup:
     entry (P_starname_info_ptr);

	if P_starname_info_ptr = null () then return;

	starname_info_ptr = P_starname_info_ptr;
	P_starname_info_ptr = null ();
	free starname_info;

	return;
%page;
get_dtcm:
     entry (P_seg_ptr, P_dtcm, P_code);

	call hcs_$get_dates_ptr (P_seg_ptr, dates_array, P_code);
	go to get_dtcm_join;

get_dtcm_file:
     entry (P_dir, P_entry, P_dtcm, P_code);

	call hcs_$get_dates (P_dir, P_entry, dates_array, P_code);

get_dtcm_join:
	if P_code = 0 then
	     unspec (P_dtcm) = dates_array (2);
	else P_dtcm = 0;

	return;
%page;
%include access_mode_values;
%page;
%include acl_structures;
%page;
%include archive_component_info;
%page;
%include star_structures;
%page;
%include terminate_file;
%page;
%skip (10);
     end e_multics_files_util_;




		    e_option_defaults_.lisp         03/25/87  1030.5rew 03/25/87  1029.6       43803



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

;;; Default option setting for Multics Emacs.
;;; Culled from bound_multics_emacs_, bound_emacs_full_,
;;; bound_emacs_packages_, and bound_emacs_rmail_


;;; HISTORY COMMENTS:
;;;  1) change(84-01-19,Margolin), approve(), audit(),
;;;     install(86-08-20,MR12.0-1136):
;;;     Created.  Changed default paragraph-definition-type
;;;     to 2, remember-empty-responses to nil, find-file-set-modes to t,
;;;     in the process.
;;;  2) change(84-12-30,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     added suppress-remarks.
;;;  3) change(86-02-24,Margolin), approve(86-02-24,MCR7325),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Added find-file-check-dtcm, save-same-file-check-dtcm, and
;;;     write-file-overwrite.
;;;  4) change(87-01-30,Margolin), approve(87-01-30,MCR7607),
;;;     audit(87-02-13,RBarstad), install(87-03-25,MR12.1-1014):
;;;     Added options for emacs-compilations: compile-local-display,
;;;     compile-two-windows, and one-error-scan-buffer.
;;;                                                      END HISTORY COMMENTS


(declare (*expr register-option))

;;; e_basic_

(register-option 'paragraph-definition-type 2)
(register-option 'kill-ring-max-size 10.)
(register-option 'default-fill-column 78.)
(register-option 'default-comment-column 60.)
(register-option 'quit-on-break t)
(register-option 'no-minibuffer-<> nil)
(register-option 'underline-whitespace nil)
(register-option 'remember-empty-response nil)
(register-option 'rubout-tabs-into-spaces nil)
(register-option 'track-eol-opt nil)
(register-option 'gratuitous-marks nil)

;;; e_interact_

(register-option 'eval:eval t) ; Unfortunately
(register-option 'eval:assume-atom nil)
(register-option 'eval:correct-errors nil)
(register-option 'eval:prinlevel 3)
(register-option 'eval:prinlength 6)
(register-option 'suppress-minibuffer nil)
(register-option 'autoload-inform nil)
(register-option 'suppress-remarks nil)
(register-option 'command-bell nil)
(register-option 'command-bell-count nil)
(register-option 'meter-commands nil)
(defprop command-bell t value-ok-anything)
(defprop command-bell-count t value-ok-anything)
(defprop meter-commands t value-ok-anything)

;;; e_multics_files_

(register-option 'check-newline nil) ; The wrong thing.
(register-option 'add-newline   't)  ; The right thing.
(register-option 'read-file-force nil)
(register-option 'find-file-set-modes t)
(register-option 'find-file-check-dtcm t)
(register-option 'save-same-file-check-dtcm t)
(register-option 'write-file-overwrite nil)

;;; e_redisplay_

(register-option 'rdis-wosclr-opt nil)		;11/23/78 sorry, Olin. -b
(register-option 'display-ctlchar-with-^ nil)
(register-option 'suppress-ctlchar-display nil)
(register-option 'suppress-backspace-display nil)
(register-option 'suppress-rubout-display nil)
(register-option 'rdis-whitespace-optimize t) ;made t 9/12/80 -- BSG
(register-option 'screen-overlap 1)

;;; e_window_mgr_

(register-option 'pop-up-windows nil)

;;; emacs-compilations

(register-option 'compile-local-display nil)
(register-option 'compile-two-windows nil)
(register-option 'one-error-scan-buffer t)

;;; emacs-completions

(register-option 'cmp:allow-ambiguous 'On)

;;; emacs-console-messages

(register-option 'short-message-accept nil)	;default is long
(register-option 'fill-messages nil)		;default is to not fill
(register-option 'message-hook nil)		;default is normal acceptor

;;; emacs-lisp-debug-mode

(register-option 'ldebug-prinlevel 6.)
(register-option 'ldebug-prinlength 10.)
(register-option 'ldebug-base 8.)
(register-option 'ldebug-ibase 8.)

;;; emacs-lisp-mode

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

;;; emacs_pl1_mode_

(register-option 'pl1-indentation 5)
(register-option 'pl1-first-column 10.)
(register-option 'pl1-compile-options "")
(register-option 'pl1-inding-style 1)
(register-option 'pl1-dcl-style 1)
(register-option 'pl1-dcl-column 41.)
(register-option 'pl1-line-length 112.)
(register-option 'pl1-comment-style 1)
(register-option 'pl1-comment-column 61.)
(register-option 'pl1-comment-column-delta 10.)

;;; emacs_rmail_

(register-option 'rmail-original-yank-indent 4)
(register-option 'rmail-send-acknowledgement t)
(register-option 'rmail-request-acknowledgement nil)
(register-option 'rmail-reply-include-authors t)
(register-option 'rmail-reply-include-recipients nil)
(register-option 'rmail-reply-include-self nil)
(register-option 'rmail-header-format 'default-formatting-mode)




		    e_pl1_.pl1                      10/17/88  1110.3r w 10/17/88  1033.4      488745



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

/* format: style4,^inddcls,insnl,delnl */

e_pl1_:
     procedure;
	return;

/****^  HISTORY COMMENTS:
  1) change(84-07-31,Margolin), approve(), audit(), install():
     Pre-hcom comments:
     BSG 3/4/78
     Modified: 12/3/79 by BSG for process preservation across hangup.
     Modified: 7 May 1981 Soley for e_pl1_$check_object
     Modified: 22 June 1981 RMSoley to make get_real_terminal_type
     check for the video system.
     Modified:  2 July 1981 RMSoley to make get_char entries use the
     video system if present.
     Modified 6 July 1981 bim for correct video usage
     Modified: 9 July 1981 RMSoley to check for -login_channel in finding
     proper I/O switch.
     Modified: 23 July 1981 RMSoley to use emacs_data_ static
     Modified: August 1981 RMSoley to move static to invocation structure,
     get rid of push_pop_table_swap, calls to e_find_invocation_
     Modified: November 1981 RMSoley & BIMargulies to add get_emacs_data_ptr,
     enlarge workstring, add retry bit to window_system calls.
     Modified: 30 June 1982 B Margolin to convert hcs_$echo_negotiate_get_chars
     calls to use the new hcs_$tty_read_echoed entrypoint, and
     to process error_table_$echnego_awaiting_stop_sync instead of
     error_table_$line_status_pending.
     Modified: 1 September 1982 B. Margolin to send send_buffered_output order
     to video system in dump_obuf
     Modified: 15 September 1982 B. Margolin to call window_$sync instead of
     sending send_buffered_output order.
     Modified: 5 January 1983 B. Margolin to remove all references to the
     NCP (!!!!), as we recently switched to TCP, which use STY terminals
     Modified 31 July 1984 - K. P. Fleming - to add new messaging primitives,
     in preparation for a complete emacs-console-messages rewrite to
     support new message_facility_.
  2) change(85-01-16,Margolin), approve(), audit(), install():
     Pre-hcom comments:
     Modified 28 August 1984 - K. P. Fleming - to cover for a 'bug' in the new
     message facility. we have to be able to set the wakeup and holding states
     indepedently, and the message facility doesn't allow this yet. so, we just
     use a structure overlay and set them in there.
     Modified 22 September 1984 - B. Margolin - to fix up KPF's work, and to
     make check_for_window_status entrypoint call e_find_invocation_.
     Modified 9 October 1984 - B. Margolin - to change current_message_info
     references to last_message_info.
     Modified 2 November 1984 - B. Margolin - to translate control chars in
     messages to spaces.
     Modified 30 November 1984 - B. Margolin - to not use Iint parameter in
     the wrong entrypoint, and change some vars declared bin to fixed bin.
     Modified 16 January 1985 - B. Margolin - for compatibility with the
     change to message_facility_, changed references to last_message_info.last_message_index
     to =.last_message_id (in mf_$set_seen_switch call) and =.last_message_number
     (in ioa_$rsnnl call, which it should have been in the first place).
  3) change(86-07-08,Coren), approve(86-07-08,MCR7300),
     audit(86-07-08,Beattie), install(86-07-08,MR12.0-1089):
     Changed to use v1_echo_neg_data for compatibility.
  4) change(86-07-16,Margolin), approve(86-07-16,MCR7452),
     audit(86-07-29,Coren), install(86-11-03,MR12.0-1205):
     Changed e_pl1_$init to automatically turn on the video system if a non-MCS
     terminal is being used.
  5) change(86-11-11,LJAdams), approve(86-11-11,MCR7485),
     audit(86-12-16,Margolin), install(87-01-06,MR12.0-1255):
     Modified to support MOWSE.
  6) change(87-03-13,LJAdams), approve(87-03-13,MCR7642),
     audit(87-04-24,Gilcrease), install(87-05-14,MR12.1-1030):
     Added external variable video_data_$terminal_iocb to be able to determine
     if video has been invoked by another subsytem other than emacs.
  7) change(87-12-21,Schroth), approve(88-02-29,MCR7851),
     audit(88-06-06,RBarstad), install(88-08-01,MR12.2-1071):
     Added support for 8-bit extended ASCII I/O.
     Added set_extended_ascii and get_output_conv_table entry points,
     and grew breaktables to 256.
                                                   END HISTORY COMMENTS */

/* Those editor functions best done in PL/I, but not concerned with
   getting into or out of the editor environment.
   This includes the ring 0 TTY dim and NCP interface (removed 1/5/82!), the
   TELNET and SUPDUP-OUTPUT negotiators, the message-receiving primitives,
   etcetera. */

/* Builtin */
dcl  (byte, collate9, fixed, length, null, translate) builtin;

/* CONSTANTS for TELNET negotiations. */

dcl  (
     IAC init (255),
     WILL init (251),
     WONT init (252),
     DO init (253),
     DONT init (254),
     ECHO init (1),
     SB init (250),					/**     SE init (240), **/
     SUPDUP_OUTPUT init (22)
     ) fixed bin (8) static options (constant);

/* Static Variables */
dcl  1 bl aligned static,
       2 c fixed bin init (1),
       2 pad bit (36) aligned,
       2 event fixed bin (71);
dcl  charsgot_meter fixed bin internal static;
dcl  charsout_meter fixed bin (21) internal static;
dcl  dbosw bit (1) static init ("0"b);
dcl  1 editing_chars_v1 aligned internal static,
       2 version fixed bin init (1),
       2 escape_char character (1) aligned,
       2 erase_char character (1) aligned,
       2 kill_char character (1) aligned;
dcl  1 editing_chars_v2 aligned internal static,
       2 version fixed bin init (2),
       2 special_chars aligned,
         3 erase_char character (1) unaligned,
         3 kill_char character (1) unaligned;
dcl  ignore_lf_sw bit (1) init ("0"b) static;
dcl  locecho_meter fixed bin internal static;
dcl  my_pid bit (36) aligned static;
dcl  r0echo_meter fixed bin internal static;
dcl  sdostate bit (1) internal static initial ("0"b);
dcl  1 supdup_info aligned internal static,
       2 aobjct fixed bin (17) unaligned,
       2 pad fixed bin (17) unaligned,
       2 tctyp fixed bin (35),
       2 ttyopt bit (36),
       2 tcmxv fixed bin (35),
       2 tcmxh fixed bin (35),
       2 ttyrol fixed bin (35),
       2 smarts bit (36),
       2 ispeed fixed bin (35),
       2 ospeed fixed bin (35);
dcl  tracing_Rtyo bit (1) aligned internal static initial ("0"b);
dcl  Rtyo_trace_iocb_ptr pointer internal static initial (null ());
dcl  network_type fixed bin (4) unsigned static;

/* System Entries */
dcl  com_err_ entry options (variable);
dcl  condition_ entry (char (*), entry);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  get_process_id_ entry returns (bit (36) aligned);
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$tty_read entry (fixed bin, ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, fixed bin (35));
dcl  hcs_$tty_state entry (fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$tty_write entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  ioa_$ioa_switch entry options (variable);
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  mode_string_$get_mode entry (char (*), char (*), ptr, fixed bin (35));
dcl  object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  signal_ entry () options (variable);
dcl  sub_err_ entry () options (variable);
dcl  video_utils_$network_login_channel entry (ptr, fixed bin (4) unsigned, fixed bin (35));
dcl  video_utils_$turn_on_login_channel entry (fixed bin (35), char (*));

/* External static */
dcl  error_table_$bad_arg fixed bin (35) external static;
dcl  error_table_$echnego_awaiting_stop_sync fixed bin (35) external static;
dcl  error_table_$no_table fixed bin (35) external static;

dcl  video_data_$terminal_iocb pointer external;

/* Automatic */
dcl  1 bit_bucket aligned automatic like object_info;
dcl  break_nonvar character (1);
dcl  ch char (1) aligned;
dcl  code fixed bin (35);
dcl  code_to_check fixed bin (35);
dcl  1 delay_table aligned like delay_struc;
dcl  error_message char (128);
dcl  expdl fixed bin;
dcl  fch fixed bin (9);
dcl  gruft (10) fixed bin (71);
dcl  ignore_control bit (1) aligned;
dcl  intp pointer;
dcl  msgp pointer;
dcl  1 my_mode_value aligned like mode_value;
dcl  nargs fixed bin;
dcl  newbit bit (1);
dcl  ngo_entry bit (1);
dcl  nread fixed bin (21);
dcl  ochl fixed bin (21);
dcl  ochp pointer;
dcl  retry bit (1) aligned;
dcl  save_tty_in_emacs_p bit (1) aligned;
dcl  screenlinelen fixed bin;
dcl  sdbct fixed bin;
dcl  sddata (0:35) bit (6) unaligned;
dcl  sls_al fixed bin (21);
dcl  sls_ap pointer;
dcl  sls_t_ospeed fixed bin;
dcl  system_free_ptr pointer;
dcl  tempc fixed bin (9);
dcl  tty_mode_string character (512);
dcl  vaccum character (200) varying;
dcl  way fixed bin;
dcl  went_opblockedp bit (1);
dcl  S fixed bin;

/* Based */
dcl  based_area area based (system_free_ptr);
dcl  1 based_message_struc aligned based (msgp),
       2 msglen initial (length (P_msgtext)) fixed bin (21),
       2 sender character (64) initial (P_sender),
       2 time character (32) unal initial (P_msgtime),
       2 next pointer initial (null ()),
       2 msg character (length (P_msgtext) refer (based_message_struc.msglen)) init (P_msgtext) unal;
dcl  big_bit_string bit (256) based (addr (emacs_data.breaktable));
dcl  bytes (10000) bit (8) unal based (emacs_data.ibufptr);
dcl  chars (6000) bit (9) unal based (addr (bytes));
dcl  1 charsadded based (P_charsadded_symobj),
       2 (tinfo, ct) fixed bin (35);
dcl  1 echd like echo_neg_data aligned;
dcl  1 get_channel_info aligned,
       2 version fixed bin,
       2 devx fixed bin,
       2 channel_name char (32);
dcl  ibuf (10000) bit (8) unal based (emacs_data.ibufptr);
dcl  1 interrupt based (intp),
       2 number fixed bin,
       2 msg fixed bin,
       2 chain pointer;
dcl  obuf char (4096) unal based (emacs_data.obufptr);
dcl  och character (ochl) based (ochp);
dcl  1 rsblock aligned like tty_read_status_info;
dcl  sls_arg character (sls_al) based (sls_ap);
dcl  1 tinfo like terminal_info aligned;
dcl  workstring character (262144) varying based (P_workstringobj);

/* Parameters */
dcl  a_mxh fixed bin (35) parameter;
dcl  a_mxv fixed bin (35) parameter;
dcl  (a_r1, a_r2, a_r3, a_r4) fixed bin (35) parameter;
dcl  a_terminal_type character (*) varying parameter;
dcl  a_ttyopt bit (36) aligned;
dcl  a_terminal_type1 character (*) parameter;
dcl  in_ptr pointer parameter;
dcl  out_ptr pointer parameter;
dcl  pch character (*) parameter;
dcl  (P_1, P_2, P_3, P_4, P_5, P_6, P_7, P_8) fixed bin (32) parameter;
dcl  P_backspace_delay fixed bin parameter;
dcl  P_bc fixed bin (24) parameter;
dcl  P_bchx fixed bin parameter;
dcl  P_charsadded_symobj pointer parameter;
dcl  P_cline character (*) parameter;
dcl  1 P_cv_trans like cv_trans aligned parameter;
dcl  P_dbosw fixed bin (1) parameter;
dcl  P_erase_char character (1) parameter;
dcl  P_escape_char character (1) parameter;
dcl  P_horz_nl_delay float bin parameter;
dcl  P_intercode fixed bin parameter;
dcl  P_interrupt_msg fixed bin parameter;
dcl  P_interruptno fixed bin parameter;
dcl  P_intno_char character (*) parameter;
dcl  P_iocb_name character (*) parameter;
dcl  P_kill_char character (1) parameter;
dcl  P_line_speed fixed bin parameter;
dcl  P_linel fixed bin parameter;
dcl  P_msgno character (*) parameter;
dcl  P_msgtext character (*) parameter;
dcl  P_msgtime character (*) parameter;
dcl  P_pointer pointer parameter;
dcl  P_retmsg character (*) varying parameter;
dcl  P_retsender character (*) varying parameter;
dcl  P_rettime character (*) varying parameter;
dcl  P_screenlinelen fixed bin parameter;
dcl  P_sender character (*) parameter;
dcl  P_sw fixed bin (1) parameter;
dcl  P_tab_const_delay fixed bin parameter;
dcl  P_tab_var_delay float bin parameter;
dcl  P_tabs_avl bit (1) aligned parameter;
dcl  P_vert_nl_delay fixed bin parameter;
dcl  P_video fixed bin (1) parameter;
dcl  P_way fixed bin parameter;
dcl  P_workstringobj pointer parameter;

/* Include Files */
%include emacs_data;
%include iocb;
%include iox_dcls;
%include line_types;
%include mcs_echo_neg;
%include mode_string_info;
%include net_event_message;
%include object_info;
%include terminal_info;
%include tty_convert;
%include tty_read_status_info;
%include window_control_info;
%include window_dcls;
%include mail_format;
%include send_mail_info;
%include message_info;
%include msg_array;
%include msg_wakeup_flags;
%include last_message_info;

/* This entry reads a character, blocking if necessary */

get_char:
     entry returns (fixed bin);

	emacs_data_ptr = e_find_invocation_ ();

/* Use video system if we can. */
	if emacs_data.flags.using_video
	then begin;
dcl  break char (1) varying;

	     retry = "1"b;
	     do while (retry);

		call window_$get_one_unechoed_char (emacs_data.input_iocb, break, "1"b, code);
		call check_window_code ("get_one_unechoed_char", code, retry);
	     end;
	     break_nonvar = break;
	     return (rank (break_nonvar));
	end;

	ngo_entry = "0"b;
	expdl, screenlinelen = 0;			/* Need this to avoid fault in getc */
	call getc;
get_char_returns:
	if emacs_data.interrupts.array (0) > 0 then do;
	     if emacs_data.flags.using_r0_echnego then do;
a1r:
		call hcs_$tty_read (emacs_data.ttyx, null (), 0, 0, 0, 0, code);
		if code ^= 0
		then call revalidate_tty (a1r);
	     end;
	     if emacs_data.cgot > 0
	     then emacs_data.ctook = emacs_data.ctook - 1;/* Must be a real ch that woulda been returned. */

/* This kludge turns off ring zero echoing before emacs plays tricks on the
   display. Echoed_in_buffer had better be zero. Christ almighty, what hair. */

/* In truth, this should not be necessary for get_char entry,
   because nobody could have called regular get_char unless echo get_char
   broke echo, but this sure can't hurt, and is needed for echo call. */

	     return (-1);
	end;
	return (fixed (unspec (ch), 9));

/* This entry "prints" a character */

tyo:
     entry (fch);

	emacs_data_ptr = e_find_invocation_ ();

	unspec (ch) = bit (fixed (fch, 9), 9);
	ochp = addr (ch);
	ochl = 1;
	call output_och;
	return;

/* This entry "prints" a string */

princ:
     entry (pch);

	emacs_data_ptr = e_find_invocation_ ();

	ochp = addr (pch);
	ochl = length (pch);
	call output_och;
	return;

output_och:
     proc;

dcl  och_string character (ochl) based (ochp);

	if tracing_Rtyo then do;			/* send it to the trace iocb, as well */
	     call iox_$put_chars (Rtyo_trace_iocb_ptr, ochp, ochl, (0));
	end;

	charsout_meter = charsout_meter + ochl;
	if (ochl + emacs_data.chars_in_obuf > length (obuf))
	then call dump_obuf;
	if (ochl > length (obuf)) | dbosw then do;
	     retry = "1"b;
	     if emacs_data.flags.using_video
	     then do while (retry);
		call window_$overwrite_text (emacs_data.output_iocb, och_string, code);
		call check_window_code ("overwrite_text", code, retry);
	     end;
	     else call iox_$put_chars (emacs_data.output_iocb, ochp, ochl, code);
	end;
	else do;
	     substr (obuf, emacs_data.chars_in_obuf + 1, ochl) = och;
	     emacs_data.chars_in_obuf = emacs_data.chars_in_obuf + ochl;
	end;
	return;

     end output_och;

/* Return emacs data pointer-- 19 November 1981 RMSoley */
get_emacs_data_ptr:
     entry () returns (pointer);

	emacs_data_ptr = e_find_invocation_ ();
	return (emacs_data_ptr);


/*	Modified for DCTL Rtyo and Rprinc output tracing, 06/25/79 WOS */

set_io_trace_iocb:
     entry (P_iocb_name);

	emacs_data_ptr = e_find_invocation_ ();

	call cu_$arg_count (nargs);
	if nargs ^= 1 then do;
	     call com_err_ (0, "e_pl1_$set_io_trace_iocb", "^/Usage:^-e_pl1_$set_io_trace_iocb iocb_name");
	     return;
	end;

	if P_iocb_name = "-off" | P_iocb_name = "off" then do;
						/* shut it off */
	     tracing_Rtyo = "0"b;
	     return;
	end;

	tracing_Rtyo = "0"b;			/* turn it off until we're sure we won */

	call iox_$look_iocb (P_iocb_name, Rtyo_trace_iocb_ptr, code);
	if code ^= 0 then do;
cant_use_trace_iocb:
	     call com_err_ (code, "e_pl1_$set_io_trace_iocb", "Can't use I/O switch ""^a"".", P_iocb_name);
	     return;
	end;

	if Rtyo_trace_iocb_ptr -> iocb.open_descrip_ptr = null ()
	then goto cant_use_trace_iocb;

	tracing_Rtyo = "1"b;			/* assume we won */
	return;					/* all done with set_io_trace_iocb */

/* Lisp/PL1 echo negotiator - BSG 10/28/78 */
/* Ring 0 wired echo BSG 1/21/79 */

echo_negotiate_get_char:
     entry (P_workstringobj, P_charsadded_symobj, P_screenlinelen) returns (fixed bin);

	emacs_data_ptr = e_find_invocation_ ();

	if emacs_data.flags.using_video
	then begin;
dcl  buffer char (256);
dcl  break char (1) varying;
dcl  broke character (1);				/* Fix up break table if it needs it. */
	     if emacs_data.flags.update_breaktable
	     then begin;
dcl  1 bti aligned like break_table_info;
		bti.version = break_table_info_version;
		string (bti.breaks) = string (emacs_data.breaktable);
		call iox_$control (emacs_data.input_iocb, "set_break_table", addr (bti), code);
		if code ^= 0
		then call signal_io_error (code, "Could not set video break table.");
		emacs_data.flags.update_breaktable = "0"b;
	     end;

	     nread = 0;
	     retry = "1"b;
	     if P_screenlinelen <= 0
	     then do while (retry);

		call window_$get_one_unechoed_char (emacs_data.input_iocb, break, "1"b /* BLOCK */, code);
		call check_window_code ("get_one_unechoed", code, retry);
	     end;

	     else do while (retry);
		call window_$get_echoed_chars (emacs_data.input_iocb, (P_screenlinelen), buffer, nread, break, code);
		call check_window_code ("get_echoed_chars", code, retry);
	     end;

	     charsadded.ct = nread;
	     if nread ^= 0 then do;
		workstring = substr (workstring, 1, length (workstring) - 1);
		workstring = workstring || substr (buffer, 1, nread) || byte (10 /* NL */);
	     end;
	     broke = break;
	     if length (break) > 0
	     then return (rank (broke));
	     else return (-1);
	end;

	ngo_entry = "1"b;				/* Call right hcs_ */
	ochp = addr (ch);				/* Out what we in */
	ochl = 1;
	charsadded.ct = 0;				/* In case lisp didn't */
	expdl = 0;
	screenlinelen = P_screenlinelen;
	vaccum = "";				/* for cleanup */
enegot_loop:
	call getc;
	if emacs_data.cgot = 0
	then go to enegot_closeout;
	if fixed (unspec (ch), 9) > 127
	then if ^emacs_data.flags.extended_ascii
	     then go to enegot_closeout;		/* Meta frobs and IACs break */
	if emacs_data.breaktable (fixed (unspec (ch), 9))
	then go to enegot_closeout;
	if expdl ^< screenlinelen
	then go to enegot_closeout;
	expdl = expdl + 1;				/* Watch for end */
	vaccum = vaccum || ch;
	locecho_meter = locecho_meter + 1;
	if emacs_data.flags.using_r0_echnego then do;
	     if emacs_data.echoed <= 0
	     then call output_och;
	     else emacs_data.echoed = emacs_data.echoed - 1;
	end;
	else call output_och;
	go to enegot_loop;
enegot_closeout:
	charsadded.ct = length (vaccum);
	vaccum = vaccum || byte (10 /* NL */);
	workstring = substr (workstring, 1, length (workstring) - 1);
	workstring = workstring || vaccum;
	if emacs_data.chars_in_obuf > 0
	then call dump_obuf;
	go to get_char_returns;			/* Check echo break */

set_break_char:
     entry (P_bchx, P_way);

	emacs_data_ptr = e_find_invocation_ ();

	if P_bchx < 32 | P_bchx = 127
	then way = 1;
	else way = P_way;				/* control chars never print right */
	newbit = (way ^= 0);
	if emacs_data.breaktable (P_bchx) ^= newbit then do;
	     emacs_data.breaktable (P_bchx) = newbit;
	     emacs_data.flags.update_breaktable = "1"b;
	end;
	return;

set_break_sequence:
     entry (P_1, P_2, P_3, P_4, P_5, P_6, P_7, P_8);

	emacs_data_ptr = e_find_invocation_ ();

/* This entry sets the break table en masse, i.e., for the entire
   collating sequence.  P_(1 2 3 4) are fb32's filled from the lisp side
   to simulate a bit(128) bit string.  RMSoley 28 June 1981 */
/* Added P_5...P_8 for 8 bit ASCII breaktables. 84-11-23 EDSchroth */

	big_bit_string =
	     bit (P_1, 32) || bit (P_2, 32) || bit (P_3, 32) || bit (P_4, 32) || bit (P_5, 32) || bit (P_6, 32)
	     || bit (P_7, 32) || bit (P_8, 32);
	emacs_data.flags.update_breaktable = "1"b;
	return;

r0_echnego_on:
     entry;
	emacs_data_ptr = e_find_invocation_ ();
	emacs_data.flags.using_r0_echnego = "1"b;
	return;
r0_echnego_off:
     entry;
	emacs_data_ptr = e_find_invocation_ ();
	emacs_data.flags.using_r0_echnego = "0"b;
	return;

return_echo_meters:
     entry (a_r1, a_r2, a_r3, a_r4);

	emacs_data_ptr = e_find_invocation_ ();

	a_r1 = charsgot_meter;
	a_r2 = r0echo_meter;
	a_r3 = locecho_meter;
	a_r4 = charsout_meter;

	return;

/* This entry gets the speed of the user's terminal */

get_line_speed:
     entry returns (fixed bin);

	emacs_data_ptr = e_find_invocation_ ();

	if emacs_data.ospeed > 0
	then return (emacs_data.ospeed);
	terminal_info_ptr = addr (tinfo);
	terminal_info.version = terminal_info_version;

	call iox_$control (emacs_data.input_iocb, "terminal_info", addr (terminal_info), code);
	if code ^= 0
	then return (30);
	else return (divide (terminal_info.baud_rate, 10, 17, 0));

/* This entry allows rawmode net users to assert their true line speed */

set_line_speed:
     entry;

	emacs_data_ptr = e_find_invocation_ ();

	call cu_$arg_ptr (1, sls_ap, sls_al, code);
	if code ^= 0 then do;
sls_usage:
	     call com_err_ (code, "emacs$set_line_speed", "Usage: emacs$set_line_speed <baud> | -reset");
	     return;
	end;
	if sls_arg = "-rs" | sls_arg = "-reset" then do;
	     emacs_data.ospeed = 0;
	     return;
	end;
	sls_t_ospeed = cv_dec_check_ (sls_arg, code);
	if code ^= 0 | sls_t_ospeed ^> 0 then do;
	     code = error_table_$bad_arg;
	     go to sls_usage;
	end;
	emacs_data.ospeed = divide (sls_t_ospeed, 10, 17, 0);
	return;

set_line_speed_:
     entry (P_line_speed);

	emacs_data_ptr = e_find_invocation_ ();

	emacs_data.ospeed = P_line_speed;
	return;

/* This entry returns various information about the terminal */

get_mcs_tty_info:
     entry (P_tabs_avl, P_horz_nl_delay, P_vert_nl_delay, P_tab_var_delay, P_tab_const_delay, P_backspace_delay, P_linel);

	emacs_data_ptr = e_find_invocation_ ();

	P_linel = emacs_data.linel;

	my_mode_value.version = mode_value_version_3;
	call mode_string_$get_mode ((emacs_data.tty_modes), "tabs", addr (my_mode_value), code);
	if code ^= 0
	then P_tabs_avl = "0"b;
	else P_tabs_avl = my_mode_value.boolean_value;

	delay_table.version = 1;
	call iox_$control (emacs_data.input_iocb, "get_delay", addr (delay_table), code);
	if code ^= 0 then do;
	     unspec (delay_table) = "0"b;		/* Dont know can't hurt */
	     delay_table.horz_nl = 0.1;
	     delay_table.vert_nl = 5;
	     delay_table.var_tab = 0.250;
	end;
	else do;
	     P_horz_nl_delay = delay_table.horz_nl;
	     P_vert_nl_delay = delay_table.vert_nl;
	     P_tab_var_delay = delay_table.var_tab;
	     P_tab_const_delay = delay_table.const_tab;
	     P_backspace_delay = delay_table.backspace;
	end;
	return;


/* Dump whatever is in the output buffer. */

dump_obuf:
     proc;

dcl  (charsout, charsout_this_time) fixed bin;

dcl  video_obuf char (emacs_data.chars_in_obuf) unaligned based (emacs_data.obufptr);

	went_opblockedp = "0"b;
	if emacs_data.chars_in_obuf <= 0		/* nothing in our buffer */
	then do;
	     retry = "1"b;
	     /*** Dump what's in the video system buffer ***/
	     if emacs_data.flags.using_video
	     then do while (retry);
		call window_$sync (emacs_data.output_iocb, code);
		call check_window_code ("sync", code, retry);
	     end;
	     return;
	end;
	/*** dump our buffer now ***/
	if emacs_data.flags.using_video then do;
	     retry = "1"b;
	     do while (retry);
		call window_$overwrite_text (emacs_data.output_iocb, video_obuf, code);
		call check_window_code ("overwrite_text", code, retry);
	     end;
	     retry = "1"b;
	     do while (retry);
		call window_$sync (emacs_data.output_iocb, code);
		call check_window_code ("sync", code, retry);
	     end;
	end;
	else do;
	     charsout = 0;
	     do while (emacs_data.chars_in_obuf > charsout);
a2r:
		call hcs_$tty_write (emacs_data.ttyx, addr (obuf), charsout, emacs_data.chars_in_obuf - charsout,
		     charsout_this_time, S, code);
		if code ^= 0
		then call revalidate_tty (a2r);
		if S ^= 5 | code ^= 0
		then call signal_io_error (code, "hcs_ tty write failed, or reconnect failed.");

		charsout = charsout + charsout_this_time;
		if emacs_data.chars_in_obuf > charsout then do;
		     call ipc_$block (addr (bl), addr (gruft), code);
		     if code ^= 0
		     then call signal_io_error (code, "Block failed on tty write.");
		     went_opblockedp = "1"b;
		end;
	     end;
	end;

	emacs_data.chars_in_obuf = 0;
     end;


/* Get one unread character, actually reading if necessary. */

getc:
     proc ();					/* Fill ch */

dcl  lleft fixed bin,
     echnego_sync_flag bit (1);


	lleft = screenlinelen - expdl;
rt:
	if emacs_data.ctook >= emacs_data.cgot then do;
	     if emacs_data.chars_in_obuf > 0
	     then call dump_obuf;			/* Must dump FIRST, or echnego race loses. */
rread:
	     emacs_data.ctook, emacs_data.echoed = 0;
	     echnego_sync_flag = "0"b;		/* Start out in synch */
	     if emacs_data.flags.using_r0_echnego & ngo_entry then do;
		if emacs_data.flags.update_breaktable then do;
		     unspec (echd) = ""b;
		     echd.version = echo_neg_data_version_2;
		     string (echd.break) = string (emacs_data.breaktable);
		     call iox_$control (emacs_data.input_iocb, "set_echo_break_table", addr (echd), code);
		     if code ^= 0
		     then call signal_io_error (code, "Could not set echo break table.");

		     emacs_data.flags.update_breaktable = "0"b;
		end;
		if emacs_data.interrupts.array (0) > 0
		then lleft = 0;
		call hcs_$tty_read_echoed (emacs_data.ttyx, addr (chars), 0, dimension (chars, 1), emacs_data.cgot,
		     emacs_data.echoed, lleft, S, code);
		if emacs_data.echoed > emacs_data.cgot
		then emacs_data.echoed = emacs_data.cgot;
		r0echo_meter = r0echo_meter + emacs_data.echoed;
		if code ^= 0
		then if code = error_table_$echnego_awaiting_stop_sync then do;
						/* Echo stop waitout */
			code = 0;
			echnego_sync_flag = "1"b;
		     end;
	     end;
	     else call hcs_$tty_read (emacs_data.ttyx, addr (chars), 0, dimension (chars, 1), emacs_data.cgot, S, code);

	     if code ^= 0 then do;
		if emacs_data.flags.using_r0_echnego then do;
		     emacs_data.flags.update_breaktable = "1"b;
						/* maybe switched tties? */
		     if ngo_entry & code = error_table_$no_table
		     then go to rread;		/* Switched tties at night */
		end;
		call revalidate_tty (rread);
	     end;
	     if code ^= 0
	     then call signal_io_error (code, "hcs_ tty read failed.");
	     if emacs_data.cgot = 0 then do;
		if emacs_data.interrupts.array (0) > 0 & ^echnego_sync_flag
		then return;			/* Wait more for echnego_sync_flag */
		call ipc_$block (addr (bl), addr (gruft), code);
		if code ^= 0
		then call signal_io_error (code, "Block failed for tty read.");
		go to rread;
	     end;
	     charsgot_meter = charsgot_meter + emacs_data.cgot;
	end;
	emacs_data.ctook = emacs_data.ctook + 1;
	unspec (ch) = chars (emacs_data.ctook);

	if ignore_lf_sw & (unspec (ch) = "012"b3)
	then go to rt;				/* lf kloodgerie */

	return;
     end getc;


/* This entry dumps the output buffer */

dump_output_buffer:
     entry ();

	emacs_data_ptr = e_find_invocation_ ();
	call dump_obuf;
	return;


/* This entry does a resetwrite on the terminal */

resetwrite:
     entry;
	emacs_data_ptr = e_find_invocation_ ();
	if emacs_data.output_iocb = null
	then emacs_data.output_iocb = iox_$user_output;
	call iox_$control (emacs_data.output_iocb, "resetwrite", null, (0));
	return;


/* This entry returns if any input is available */

real_have_chars:
     entry returns (fixed bin);

	emacs_data_ptr = e_find_invocation_ ();
	if emacs_data.flags.using_video then do;
	     call iox_$control (emacs_data.input_iocb, "read_status", addr (rsblock), code);
	     if code ^= 0 | ^rsblock.input_pending
	     then return (0);
	     else return (1);
	end;

	if emacs_data.ctook < emacs_data.cgot - fixed (ignore_lf_sw, 1) - fixed (emacs_data.flags.got_cr, 1)
	then return (1);
	else return (0);


/* This entry executes a Multics command line trapping all errors */


cline_executor:
     entry (P_cline);

	emacs_data_ptr = e_find_invocation_ ();
	ignore_control = "0"b;
	call condition_ ("any_other", cline_any_other_handler);
	call cu_$cp (addr (P_cline), length (P_cline), (0));

cline_returns:
	return;

cline_any_other_handler:
     proc (mcp, cname, cop, inp, cont);

dcl  (mcp, cop, inp) ptr;
dcl  cname char (*);
dcl  cont bit (1) aligned;
	if ignore_control then do;			/* Oh my, recursing */
	     cont = "1"b;
	     return;
	end;
	if cname = "quit" | cname = "alrm" | cname = "program_interrupt" | cname = "command_error" | cname = "cput"
	     | cname = "command_question" | cname = "finish" | cname = "trm_" | cname = "sus_" then do;
	     cont = "1"b;
	     return;
	end;
	ignore_control = "1"b;			/* Let recurse thru */
	emacs_data.cgot = 0;
	save_tty_in_emacs_p = emacs_data.flags.in_emacs;
	emacs_data.flags.in_emacs = "0"b;
	call set_multics_tty_modes;
	call ioa_$ioa_switch (iox_$user_io,
	     "^/emacs: ^a raised while executing Multics command.^/Use the ^[emacs^;program_interrupt (pi)^] command to return to emacs.",
	     cname, emacs_data.in_task);
	if save_tty_in_emacs_p
	then begin options (non_quick);		/* Probably file-outputting, will never see fault msg unless we output it. */
dcl  condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*), ptr, ptr);
dcl  xarea area (500);
dcl  msg char (mlen) based (mptr),
     mlen fixed bin,
     mptr ptr;

	     call condition_interpreter_ (addr (xarea), mptr, mlen, 1, mcp, rtrim (cname), cop, inp);
	     if msg = ""
	     then return;				/* quiet_restart and friends */
	     call ioa_$ioa_switch (iox_$user_io, "^a", msg);
	end;
	call signal_ (cname, mcp, inp);
	if save_tty_in_emacs_p
	then call set_emacs_tty_modes;
	emacs_data.flags.in_emacs = save_tty_in_emacs_p;
	ignore_control = "0"b;
	return;
     end cline_any_other_handler;


/* This entry sets flag indicating whether buffering happens */

set_dbo_sw:
     entry (P_dbosw);

	emacs_data_ptr = e_find_invocation_ ();
	dbosw = bit (fixed (P_dbosw, 1), 1);
	return;


/* This entry intializes the PL/1 stuff */

init:
set_single:
     entry;

	emacs_data_ptr = e_find_invocation_ ();

	my_pid = get_process_id_ ();
	emacs_data.interrupts.array (*) = 0;
	emacs_data.flags.in_emacs = "0"b;
	if ^emacs_data.flags.debugging | (emacs_data.output_iocb = null ()) then do;

	     if emacs_data.output_iocb = null () then do; /* Check to see if the video system is on. */

		emacs_data.flags.using_video = "0"b;
		system_free_ptr = get_system_free_area_ ();
		allocate window_position_info in (based_area) set (window_position_info_ptr);
		window_position_info.version = window_position_info_version;

		call iox_$control (iox_$user_io, "get_window_info", window_position_info_ptr, code);
		free window_position_info_ptr -> window_position_info;
		if code = 0 then do;
		     emacs_data.output_iocb = iox_$user_io;
		     emacs_data.flags.using_video = "1"b;
		end;
	     end;


	     if emacs_data.output_iocb = null () then do;
		call video_utils_$network_login_channel (emacs_data.output_iocb, network_type, code);
		if code ^= 0
		then call signal_io_error (code, error_message);
	     end;

						/** See if we need to automatically invoke video **/
	     if ^emacs_data.flags.using_video
	     then if network_type ^= MCS_NETWORK_TYPE & video_data_$terminal_iocb = null then do;
		     call video_utils_$turn_on_login_channel (code, error_message);
		     if code ^= 0
		     then call signal_io_error (code, error_message);
		     emacs_data.flags.using_video = "1"b;
		     emacs_data.flags.turned_on_video = "1"b;
		end;

	     emacs_data.input_iocb = emacs_data.output_iocb;
	end;

/* Determine if iocb we got is a video iocb. */
	if ^emacs_data.flags.using_video & ^emacs_data.flags.debugging then do;
	     system_free_ptr = get_system_free_area_ ();
	     allocate window_position_info in (based_area) set (window_position_info_ptr);
	     window_position_info.version = window_position_info_version;
	     call iox_$control (emacs_data.output_iocb, "get_window_info", window_position_info_ptr, code);
	     free window_position_info_ptr -> window_position_info;
	     emacs_data.flags.using_video = (code = 0);
	end;

	call iox_$modes (emacs_data.input_iocb, "", tty_mode_string, (0));
	if emacs_data.tty_modes = ""
	then emacs_data.tty_modes = tty_mode_string;
	emacs_data.linel = get_line_length_$switch (emacs_data.output_iocb, code);
	if code ^= 0
	then emacs_data.linel = 79;
	call get_tty_channel_info;
	emacs_data.chars_in_obuf, emacs_data.ctook, emacs_data.cgot, emacs_data.echoed = 0;
	locecho_meter, charsgot_meter, charsout_meter, r0echo_meter = 0;
	call iox_$control (emacs_data.input_iocb, "get_event_channel", addr (bl.event), code);
	if code ^= 0 then do;
	     code = 0;
	     call iox_$control (emacs_data.input_iocb, "read_status", addr (rsblock), code);
	     if code = 0
	     then bl.event = rsblock.event_channel;
	end;
	if emacs_data.obufptr = null
	then allocate obuf;
	if emacs_data.ibufptr = null
	then allocate ibuf;
	return;

/* TTY channel attach/reattach hackery 12/3/79 BSG */

get_tty_channel_info:
     proc ();

dcl  gtc_code fixed bin (35);
dcl  1 ttyt aligned based,
       2 pad (14) fixed bin,
       2 tttyx fixed bin (35);

	unspec (get_channel_info) = "0"b;
	get_channel_info.version = 1;
	call iox_$control (emacs_data.output_iocb, "get_channel_info", addr (get_channel_info), gtc_code);
	if gtc_code = 0
	then emacs_data.ttyx = get_channel_info.devx;
	else emacs_data.ttyx = emacs_data.output_iocb -> iocb.attach_data_ptr -> ttyt.tttyx;
	emacs_data.flags.update_breaktable = "1"b;
     end get_tty_channel_info;

revalidate_tty:
     proc (a_label);

dcl  a_label label,
     l_code fixed bin (35);

/* This procedure is called when hcs_$tty_* returns an error.  If the
   current tty devx isn't even valid, as hcs_$tty_state indicates, we
   may have been hung up.  If this IS the case, reattach as below. If
   not, we have a real error, and let it thru. */

	call hcs_$tty_state (emacs_data.ttyx, (0), l_code);
	if l_code = 0
	then return;				/* Some other problem */

/* At this point, we have definitely hung up the line. Force the
   ring 4 TTY dim to call ring 0, and clean up his own act, figuring
   out the new devx, and waiting, if necessary,  for reattachment. */

	call iox_$control (emacs_data.input_iocb, "read_status", addr (rsblock), l_code);

	if l_code ^= 0
	then return;				/* Probly old dim */

/* The ring 4 TTY dim now knows the real devx.  Try to figure it out.
   It must be at LEAST the 8.0 TTY DIM if l_code is 0. */

	call get_tty_channel_info;

/* If we are in this situation, either get_tty_channel_info did its
   thing or we punt. */

	if get_channel_info.devx = 0
	then return;
	go to a_label;				/* Return to retry */
     end;

/* This entry is for debugging */

set_display_iocbs:
     entry (in_ptr, out_ptr);

	emacs_data_ptr = e_find_invocation_ ();

	emacs_data.input_iocb = in_ptr;
	emacs_data.output_iocb = out_ptr;
	emacs_data.flags.debugging = "1"b;
	return;

/* This entry is also for debugging, for setting emacs_data.flags.using_video. */

set_video_system:
     entry (P_video);

	emacs_data_ptr = e_find_invocation_ ();

	emacs_data.flags.using_video = bit (fixed (P_video, 1), 1);
	emacs_data.flags.debugging = "1"b;
	return;

/* This entry sets the flag controlling whether LF is ever returned */

set_ignore_lf:
     entry (P_sw);

	emacs_data_ptr = e_find_invocation_ ();
	ignore_lf_sw = bit (fixed (P_sw, 1), 1);
	return;


/* This entry sets the extended ASCII character I/O flag allowing/disallowing
   8 bit input/output. */

set_extended_ascii:
     entry (P_sw);

	emacs_data_ptr = e_find_invocation_ ();
	emacs_data.flags.extended_ascii = bit (fixed (P_sw, 1), 1);
	return;

/* This entry sets the terminal modes for EMACS */

set_emacs_tty_modes:
     entry ();

	emacs_data_ptr = e_find_invocation_ ();

	if ^emacs_data.flags.using_video then do;
	     call iox_$modes (emacs_data.input_iocb, "init,force,^prefixnl,rawi,rawo,ctl_char,fulldpx,breakall", (""),
		(0));				/* 1/5/83 to move breakall in (it had its own call!) */
						/* 1/31/81 try again */
						/* 11/8/79 to use init mode */
	     if emacs_data.flags.extended_ascii
	     then call iox_$modes (emacs_data.input_iocb, "force,8bit,no_outp", "", (0));
	     call iox_$control (emacs_data.input_iocb, "printer_off", null (), (0));
	end;
	emacs_data.flags.in_emacs = "1"b;
	return;


fix_modes_and_exit:
	call multics_tty_modes_setter;
	if code ^= 0
	then call signal_io_error (code, "Setting Multics tty modes.");
	return;

/* This entry resets the modes for Multics use */

set_multics_tty_modes:
     entry ();
	emacs_data_ptr = e_find_invocation_ ();

	call multics_tty_modes_setter;
	return;

multics_tty_modes_setter:
     procedure;

	if emacs_data.input_iocb ^= null () then do;
	     tty_mode_string = emacs_data.tty_modes;
	     call iox_$modes (emacs_data.input_iocb, tty_mode_string, "", (0));
	     call iox_$control (emacs_data.input_iocb, "printer_on", null (), (0));
	end;
	emacs_data.flags.in_emacs = "0"b;
     end multics_tty_modes_setter;

signal_io_error:
     procedure (reason, explanation);
declare  reason fixed bin (35);
declare  explanation character (*);

	call sub_err_ (reason, emacs_data.myname, "s", null (), (0),
	     "Emacs encountered an error. ^a. ^/Give the following command:^/file_output emacs_trace_;trace_stack;revert_output^/and save the results for programming staff.",
	     explanation);

     end signal_io_error;

/* This internal procedure negotiates via TELNET */

negotiate:
     procedure (option, have_it_or_not);

dcl  have_it_or_not bit (1) aligned,
     option fixed bin (8);

	call dump_obuf;
	call ncp_send (IAC);
	if have_it_or_not
	then call ncp_send (WILL);
	else call ncp_send (WONT);
	call ncp_send (option);
ne_ret:
	call dump_obuf;
	return;

ncp_send:
	proc (byte8);

dcl  byte8 fixed bin (8);


	     emacs_data.chars_in_obuf = emacs_data.chars_in_obuf + 1;
	     substr (obuf, emacs_data.chars_in_obuf, 1) = byte (byte8);
	     return;
	end ncp_send;
     end negotiate;


/* Hacks for those rare people who like messages */

/* 05/25/78 */

message_acceptor:
     entry (P_intno_char, P_msgno, P_sender, P_msgtime, P_msgtext);

	emacs_data_ptr = e_find_invocation_ ();

	if ^emacs_data.flags.in_emacs then do;
	     call ioa_$ioa_switch (iox_$user_io, "From ^a ^a:^/^a", P_sender, P_msgtime, P_msgtext);
	end;
	call set_emacs_interrupt (binary (P_intno_char, 17, 0), 0, (0));
	allocate based_message_struc set (msgp);
	if emacs_data.first_msgp = null
	then emacs_data.first_msgp = msgp;
	else emacs_data.last_msgp -> based_message_struc.next = msgp;
	emacs_data.last_msgp = msgp;
	return;

retrieve_message:
     entry (P_retsender, P_rettime, P_retmsg);

	emacs_data_ptr = e_find_invocation_ ();

	if emacs_data.last_msgp = null
	then P_retsender, P_rettime, P_retmsg = "";
	else do;
	     msgp = emacs_data.first_msgp;
	     P_retsender = rtrim (based_message_struc.sender);
	     P_rettime = rtrim (based_message_struc.time);
	     P_retmsg = rtrim (based_message_struc.msg);
	     emacs_data.first_msgp = based_message_struc.next;
	     if emacs_data.first_msgp = null
	     then emacs_data.last_msgp = null;
	     free based_message_struc;
	end;
	return;
/**** This code added 31 July 1984 - K. P. Fleming */


dcl  (PDmsgfmbx, PIint) ptr init (null ());
dcl  (P_msgfmbx_ptr, P_PIint) ptr parameter;
dcl  P_code fixed bin (35) parameter;
dcl  Iint fixed bin (17) parameter;
dcl  int_index fixed bin (17);
dcl  message_facility_$get_last_message_info entry (ptr, ptr, fixed bin (35));
dcl  1 local_last_message_info aligned like last_message_info;
dcl  date_time fixed bin (71);
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  msg_date_time char (24);
dcl  message_sender char (120);
dcl  ioa_$rsnnl entry () options (variable);
dcl  (int_index_char, Imsg_char) char (8);
dcl  message_facility_$set_seen_switch entry (ptr, bit (72) aligned, bit (*), fixed bin (35));
dcl  message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35));
dcl  message_facility_$set_wakeup_state entry (ptr, bit (*), fixed bin (35));
dcl  message_facility_$get_wakeup_state entry (ptr, bit (*), fixed bin (35));
dcl  message_facility_$set_wakeup_handler entry (ptr, entry, ptr, fixed bin (35));
dcl  message_facility_$send_message entry (char (*), char (*), char (*), ptr, fixed bin (35));
dcl  NLSPHT char (3) aligned int static options (constant) init ("
 	");
dcl  mbx_path char (*) parm;
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  mbx_dname char (168);
dcl  mbx_ename char (32);
dcl  Swakeup_state bit (5);
dcl  1 Dmail aligned like send_mail_info;
dcl  message char (*) parm;
dcl  user_info_$whoami entry (char (*));
dcl  person_id char (32);
dcl  (person, project) char (*) parameter;
dcl  message_facility_$default_wakeup_handler entry (ptr, ptr);
dcl  user_info_$homedir entry (char (*));
dcl  message_handler entry (ptr, ptr) variable;
dcl  1 Dstates_overlay defined (Swakeup_state) like wakeup_flags;
dcl  (binary, bit, dimension, divide, empty, hbound, rank, rtrim, string, wordno, addr, before, setwordno, substr, unspec)
	builtin;

set_message_handler:
     entry (mbx_path, Iint, P_code);

	P_code = 0;
/**** Note: the next line of code contains a "kludge" that saves us a little
      bit of time and storage. The message_facility_ wants an info_ptr that it
      can pass to the wakeup handler for "static" information. The only thing
      we need to save in this manner is the Emacs interrupt number for this
      mbx. Thus, instead of allocating an array in emacs_data for the
      interrupt numbers to be stored "statically", we just pass a fake pointer
      to the message_facility_ that contains the interrupt number as its word
      offset, and the rest of it is just null().

      -Kevin
*/
	PIint = setwordno (null (), Iint);
	message_handler = message_wakeup_handler;
	call expand_pathname_$add_suffix (mbx_path, "mbx", mbx_dname, mbx_ename, P_code);
	if P_code ^= 0
	then return;
SET_THE_HANDLER:
	call message_facility_$get_msgf_mbx_ptr (mbx_dname, mbx_ename, PDmsgfmbx, P_code);
	if P_code ^= 0
	then return;
	call message_facility_$get_wakeup_state (PDmsgfmbx, Swakeup_state, P_code);
	if P_code ^= 0
	then return;
	Dstates_overlay.wakeup_state = ACCEPT_MESSAGES;	/* here's our where cover for the message facility */
	call message_facility_$set_wakeup_state (PDmsgfmbx, Swakeup_state, P_code);
	if P_code ^= 0
	then return;
	call message_facility_$set_wakeup_handler (PDmsgfmbx, message_handler, PIint, P_code);
	return;

restore_message_handler:
     entry (P_code);				/* arg is only to get parm var allocated */
	P_code = 0;
	PIint = null ();
	message_handler = message_facility_$default_wakeup_handler;
	call user_info_$homedir (mbx_dname);
	call user_info_$whoami (mbx_ename);
	mbx_ename = rtrim (mbx_ename) || ".mbx";
	go to SET_THE_HANDLER;

send_message:
     entry (person, project, message, P_code);
	P_code = 0;
	mbx_dname = ">udd>" || rtrim (project) || ">" || person;
	mbx_ename = rtrim (person) || ".mbx";
	Dmail.version = send_mail_info_version_2;
	call user_info_$whoami (person_id);
	Dmail.sent_from = person_id;
	string (Dmail.switches) = ""b;
	Dmail.wakeup, Dmail.always_add = "1"b;
	call message_facility_$send_message (mbx_dname, mbx_ename, message, addr (Dmail), P_code);
	return;

message_wakeup_handler:
     entry (P_msgfmbx_ptr, P_PIint);
	int_index = wordno (P_PIint);
	code = 0;
	last_message_info_ptr = addr (local_last_message_info);
	last_message_info.version = LAST_MESSAGE_INFO_VERSION_1;
	call message_facility_$get_last_message_info (P_msgfmbx_ptr, last_message_info_ptr, code);
	if code ^= 0				/* Should probably sub_err_ or something, but I'm */
	then return;				/* not sure what. */
	message_info_ptr = last_message_info.last_message_ptr;
	mail_format_ptr = message_info.message_ptr;
	date_time = fixed (substr (last_message_info.last_message_id, 19, 54), 71);
	call date_time_ (date_time, msg_date_time);
	if mail_format.sent_from = before (message_info.sender, ".") | mail_format.sent_from = ""
	     | unspec (mail_format.sent_from) = ""b
	then message_sender = substr (message_info.sender, 1, length (rtrim (message_info.sender)) - 2);
	else message_sender =
		substr (message_info.sender, 1, length (rtrim (message_info.sender)) - 2) || " ("
		|| rtrim (mail_format.sent_from) || ")";
	call ioa_$rsnnl ("^d", int_index_char, (0), int_index);
	call ioa_$rsnnl ("^d", Imsg_char, (0), last_message_info.last_message_number);
	call message_facility_$set_seen_switch (P_msgfmbx_ptr, last_message_info.last_message_id, DELETE_UNHELD, (0));
	call message_acceptor (int_index_char, Imsg_char, message_sender, msg_date_time,
	     translate (rtrim (mail_format.text, NLSPHT), "", substr (collate9 (), 1, 32) || substr (collate9 (), 128)))
	     ;
	return;					/* End of new code */

/*

   Interrupt mechanism for Multics EMACS

   Made useful for recursive emaces November 1978

*/

get_emacs_interrupt_array:
     entry returns (ptr);

	emacs_data_ptr = e_find_invocation_ ();

	return (addr (emacs_data.interrupts.array));

free_emacs_interrupt_array:
     entry;

	return;

assign_channel:
     entry (P_interruptno) returns (fixed binary);

	return (P_interruptno);

/*	primitives to set and receive emacs interrupts */

set_emacs_interrupt:
     entry (P_interruptno, P_interrupt_msg, P_intercode);

	emacs_data_ptr = e_find_invocation_ ();

	if emacs_data.flags.using_r0_echnego & ^emacs_data.flags.using_video then do;
a3r:
	     call hcs_$tty_read_echoed (emacs_data.ttyx, null (), 0, 0, (0), (0), 0, (0), code);
	     if code ^= 0
	     then call revalidate_tty (a3r);
	end;

	call hcs_$wakeup (my_pid, bl.event, 0, (0));
	P_intercode = 0;

	emacs_data.interrupts.array (0) = 1;

	allocate interrupt;
	interrupt.number = P_interruptno;
	interrupt.msg = P_interrupt_msg;
	interrupt.chain = null ();

	if emacs_data.interrupts.head = null ()
	then emacs_data.interrupts.head, emacs_data.interrupts.tail = intp;
	else do;
	     emacs_data.interrupts.tail -> interrupt.chain = intp;
	     emacs_data.interrupts.tail = intp;
	end;

	return;

get_emacs_interrupt:
     entry (P_interruptno, P_interrupt_msg);

	emacs_data_ptr = e_find_invocation_ ();

	if emacs_data.interrupts.head = null () then do;
	     P_interruptno = -1;
	     return;
	end;
	intp = emacs_data.interrupts.head;
	emacs_data.interrupts.head = interrupt.chain;
	if emacs_data.interrupts.head = null ()
	then emacs_data.interrupts.tail = null ();
	P_interruptno = interrupt.number;
	P_interrupt_msg = interrupt.msg;
	free interrupt;
	return;

set_message_cleanup:
     entry;

	emacs_data_ptr = e_find_invocation_ ();

	emacs_data.messages_were_sent_here = "1"b;
	return;

dump_out_console_messages:
     entry;

	emacs_data_ptr = e_find_invocation_ ();

	call free_emacs_interrupt_array;
	if ^emacs_data.messages_were_sent_here
	then return;
	call restore_message_handler ((0));
	do while (emacs_data.first_msgp ^= null);
	     msgp = emacs_data.first_msgp;
	     call ioa_$ioa_switch (iox_$user_io, "From ^a ^a:^/^a", based_message_struc.sender,
		based_message_struc.time, based_message_struc.msg);
	     emacs_data.first_msgp = based_message_struc.next;
	     if emacs_data.first_msgp = null
	     then emacs_data.last_msgp = null;
	     free based_message_struc;
	end;
	return;


/* Interfaces to determine/remember terminal type and line type.
   GMP, 8/27/78 */

get_terminal_type:
     entry (a_terminal_type);				/* get static terminl type */

	emacs_data_ptr = e_find_invocation_ ();

	a_terminal_type = rtrim (emacs_data.terminal_type);

	return;

set_terminal_type:
     entry (a_terminal_type1);

	emacs_data_ptr = e_find_invocation_ ();

	emacs_data.terminal_type = a_terminal_type1;

	return;

get_real_terminal_type:
     entry (a_terminal_type);

	emacs_data_ptr = e_find_invocation_ ();

	if emacs_data.input_iocb = null ()
	then emacs_data.input_iocb = iox_$user_input;

	if emacs_data.flags.using_video then do;
	     a_terminal_type = "video_system";
	     return;
	end;

/* Not video system; find out what kind of terminal. */

	tinfo.version = terminal_info_version;

	call iox_$control (emacs_data.input_iocb, "terminal_info", addr (tinfo), code);

	if code = 0
	then a_terminal_type = rtrim (tinfo.term_type);
	else a_terminal_type = "ASCII";		/* default value */

	return;

get_iocb:
     entry () returns (pointer);

	emacs_data_ptr = e_find_invocation_ ();

	return (emacs_data.input_iocb);


get_editing_chars:
     entry (P_escape_char, P_erase_char, P_kill_char);

	emacs_data_ptr = e_find_invocation_ ();

	call iox_$control (emacs_data.input_iocb, "get_editing_chars", addr (editing_chars_v1), code);
	if code ^= 0 then do;
	     call iox_$control (emacs_data.input_iocb, "get_editing_chars", addr (editing_chars_v2), code);
	     if code = 0 then do;
		P_escape_char = "\";
		P_erase_char = editing_chars_v2.erase_char;
		P_kill_char = editing_chars_v2.kill_char;
		return;
	     end;
	end;
	if code = 0 then do;
	     P_escape_char = editing_chars_v1.escape_char;
	     P_erase_char = editing_chars_v1.erase_char;
	     P_kill_char = editing_chars_v1.kill_char;
	     return;
	end;
	P_escape_char = "\";
	P_erase_char = "#";
	P_kill_char = "@";
	return;

get_network_flag:
     entry () returns (fixed binary);			/* return 1 if a Network connection */

	return (0);				/* No more network */

/* Moby SUPDUP-OUTPUT negotiator (as per RFC 749) BSG 10/1/78 */


will_supdup_output:
     entry returns (fixed bin (1));

	emacs_data_ptr = e_find_invocation_ ();

	if sdostate
	then return (1);				/* OK as is */
						/* Must try to negotiate it */
	call negotiate (SUPDUP_OUTPUT, "1"b);		/* Send the cmd */
	do while ("1"b);				/* Let's play TELNET! */
	     do while (get_char () ^= IAC);
	     end;
	     tempc = get_char ();
	     if tempc = DO then do;
		tempc = get_char ();
		if tempc = SUPDUP_OUTPUT
		then ;
		if tempc = ECHO
		then ;
	     end;
	     if tempc = DONT then do;
		tempc = get_char ();
		if tempc = SUPDUP_OUTPUT
		then return (0);
		if tempc = ECHO
		then ;
	     end;
	     if tempc = WILL | tempc = WONT then do;
		tempc = get_char ();
	     end;
	     if tempc = SB then do;
		tempc = get_char ();
		if tempc = SUPDUP_OUTPUT then do;
		     tempc = get_char ();
		     if tempc ^= 1
		     then go to run_out_sb;
		     string (sddata) = "0"b;
		     do sdbct = 0 to (hbound (sddata, 1));
			tempc = get_char ();
			if tempc = IAC
			then go to sdd_gotten;
			sddata (sdbct) = bit (fixed (tempc, 6), 6);
		     end;
		     do while (get_char () ^= IAC);
		     end;
sdd_gotten:
		     tempc = get_char ();
		     unspec (supdup_info) = string (sddata);
		     sdostate = "1"b;
		     return (1);
		end;
run_out_sb:
		do while (get_char () ^= IAC);
		end;
		tempc = get_char ();
	     end;

	end;

return_supdup_info:
     entry (a_ttyopt, a_mxh, a_mxv);

	emacs_data_ptr = e_find_invocation_ ();

	a_ttyopt = supdup_info.ttyopt;
	a_mxh = supdup_info.tcmxh;
	a_mxv = supdup_info.tcmxv;
	return;

object_check:
     entry (P_bc, P_pointer) returns (fixed bin);

	call object_info_$brief (P_pointer, P_bc, addr (bit_bucket), code);
	if code = 0
	then return (1);
	return (0);

check_window_code:
     procedure (excuse, code, retry);

declare  excuse character (*);
declare  code fixed bin (35);
declare  retry bit (1) aligned;

declare  video_et_$window_status_pending fixed bin (35) ext static;
declare  1 wsi aligned like window_status_info;

	if code = video_et_$window_status_pending then do;
	     wsi.version = window_status_version;
	     call iox_$control (emacs_data.input_iocb, "get_window_status", addr (wsi), code);
	     if code ^= 0
	     then call signal_io_error (code, "Error from get_window_status");
	     retry = "1"b;
	     code = 0;
	     return;
	end;

	if code = 0 then do;
	     retry = "0"b;
	     return;
	end;

	call signal_io_error (code, "Error from window_$" || excuse);
	return;
     end check_window_code;

check_for_window_status:
     entry (code_to_check);

	emacs_data_ptr = e_find_invocation_ ();
	call check_window_code ("<<video system ctl>>", code_to_check, (""b));

	return;

/* This entry returns the terminal's output conversion table for use in determining
   the self-insert characters. */

get_output_conv_table:
     entry (P_cv_trans);

	emacs_data_ptr = e_find_invocation_ ();

	begin options (non_quick);
dcl  chnum fixed bin;
dcl  1 cts aligned like cv_trans_struc;
dcl  CV_TRANS_VERSION_2 fixed bin int static options (constant) init (2);
						/* tty_convert.incl.pl1 declares only CV_TRANS_VERSION */
	     cts.version = CV_TRANS_VERSION_2;
	     cts.default = 0;
	     call iox_$control (emacs_data.input_iocb, "get_output_conversion", addr (cts), code);
	     if code = 0
	     then P_cv_trans = cts.cv_trans;
	     else do;				/* fix up table */
		do chnum = 32 to 126;		/* printing */
		     P_cv_trans.value (chnum) = OUTPUT_CONVERT_ORDINARY;
		end;
		do chnum = 0 to 31, 127 to 255;	/* octal escape */
		     P_cv_trans.value (chnum) = OUTPUT_CONVERT_OCTAL;
		end;
	     end;
	end;
	return;

     end e_pl1_;




		    e_redisplay_.lisp               05/10/89  1215.8rew 05/10/89  1213.1      828405



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

;;;
;;;
;;;	Multics EMACS Redisplay


;;; HISTORY COMMENTS:
;;;  1) change(84-01-19,Margolin), approve(), audit(), install():
;;;     pre-hcom history:
;;;               Greenberg, March 1978
;;;               3/6/78 inceptus Luna meo adjutorio.
;;;               4/19/78 duas fenestras feci.
;;;               5/30/78 ^V creavi.
;;;               6/18/78 signum linearum elongatarum, ^0^L, &c
;;;               7/5/78  Cuncta lineae comparandae sunt, quicumque sint.
;;;               7/27/78 Ostendae sunt lineae quae non in textu sunt.
;;;               8/23/78 Dua fenestrae tacebant, atque mundae factae erant.
;;;               9/6/78 Indices linearum originalum per fenestris comparo.
;;;               3/1/79 Quando laboro in medio linearum elongatarum, omnes moveatur.
;;;               4/4/79 Minibuffer in multos divisus est.
;;;               4/12/79 Mille fenestrae florent.
;;;               8/24/79 ^V et ESC-V argumentes dedi.
;;;               Septembri 1979 hoc redisplicator Paltere sustenetur.
;;;               2/12/80 tty-no-cleolp impletur,
;;;                         mode-line-hook & local-display-end-string
;;;               10/23/80 Praefix minibufferis non delendum est.
;;;       1980 Decembri e manibus meis dimissi te ut sole per mundum ambules.
     
;;;               Welcome to the rosy-fingered dawn of the New Era:
;;;               Presenting, at popular demand;
;;;               A Comment In English!
     
;;;               30 June 1981 Extending local displays, Richard Mark Soley
;;;               1 July 1981 suppress-remarks and minibuffer-clear-all, Richard Soley
;;;               5 November 1981 truncate overlength modelines, Richard Soley
;;;               19 August 1982 fixed inverse-real-world-xcoord for \c lines,
;;;                              Barry Margolin
;;;               20 August 1982 added CAH's real underlining code, Barry Margolin
;;;               12 October 1982 modified underlining to use constant 400, Barmar
;;;               3 December 1983 changed redisplay-this-line to call
;;;                               randomize-redisplay first, Barmar.
;;;               19 January 1984 commented out register-option forms, as they were
;;;  2) change(84-12-25,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Changed some "'"s to ";"s, moved first reference to
;;;     realcurdispline to after wman-init is called,
;;;     slashified #'s, changed lambda's to let's.
;;;  3) change(84-12-26,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Added initializations of realcurdispline,
;;;     rdis-have-redisplayed, and last-curline, moved %include's to before
;;;     declares, replaced %include of e-define-command
;;;     with e-macros, replaced "(declare (special" with
;;;     "(defvar".
;;;  4) change(84-12-27,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Fixed redisplay to not refer out of the screen
;;;     array when a minibuffer response goes beyond the
;;;     last screen line.
;;;  5) change(84-12-30,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Moved most variable initializations from display-init
;;;     to load-time defvar.
;;;  6) change(84-12-31,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Unquoted throw/catch tag in rdis-forward-backward-screen.
;;;  7) change(85-02-03,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Moved phony-(mode path)line-edline
;;;     initializations back to display-init, because macros
;;;     are not expanded by lcp at top-level.
;;;  8) change(88-01-14,Schroth), approve(88-02-29,MCR7851),
;;;     audit(88-06-08,RBarstad), install(88-08-01,MR12.2-1071):
;;;     To implement the display of 8-bit Extended ASCII on qualified
;;;     terminals.
;;;  9) change(88-01-14,Schroth), approve(88-02-29,MCR7852),
;;;     audit(88-06-08,RBarstad), install(88-08-01,MR12.2-1071):
;;;     Implemented vertically split screen windows.
;;; 10) change(89-03-10,Flegel), approve(89-04-03,MCR8088),
;;;     audit(89-04-06,Lee), install(89-05-10,MR12.3-1042):
;;;     phx20884 - removed decrementation of line_length (args:ll)
;;;                                                      END HISTORY COMMENTS


(declare (genprefix /!rdis_))

(%include emacs-rdis-dcls)
(%include emacs-internal-macros)
(%include e-macros)
(%include other_other)

(declare (*lexpr display-error display-com-error display-error-noabort
	       display-com-error-noabort minibuffer-print
	       minibuffer-print-noclear))
(declare (*expr DCTL-assert-scpos DCTL-clear-rest-of-screen DCTL-clear-screen
	      DCTL-create-split DCTL-delete-chars DCTL-delete-lines
	      DCTL-destroy-split DCTL-display-char-string
	      DCTL-init DCTL-insert-char-string DCTL-insert-lines
	      DCTL-kill-line DCTL-nextline DCTL-position-cursor
	      DCTL-ring-tty-bell DCTL-scroll-down-region
	      DCTL-scroll-up-region DCTL-select-split DCTL-write-abort
	      Rtyo charscan-table
	      command-quit curline-as-string decimal-rep e$get_temporary_seg
	      e_lap_$compare_strings e_lap_$ggcharn e_lap_$gsubstr
	      e_lap_$insert-chars e_lap_$make-dat-ol-black-magic-string
	      e_lap_$rdis-crossmatch e_lap_$rplacstring
	      e_lap_$rplacstring-offset e_lap_$tabscan_table e_lap_$tct
	      e_pl1_$dump_output_buffer e_pl1_$get_line_speed 
	      e_pl1_$resetwrite emacs$set_lisp_rdis_meters get-char
	      go-to-end-of-buffer go-to-line-point
	      rdis-reallocate-screen-evenly rdis-upd-virtual-window-point
	      rdis-update-window-struct wman-init))
(defvar  (

;;;	DCTL args

	 X Y

;;;	PL/1 pre-parsed arguments

	 args:pl				;page length
	 args:ll				;line length

;;;	TTY parameters, Defaulted by display-init,
;;;	set by specific DCTL-init
;;;
	 idel-chars-availablep	;Insert-delete chars is available.
	 idel-lines-availablep	;Insert/delete lines is available.
	 region-scroll-availablep	;VT100-like scrolling available.
	 tty-no-cleolp		;No clear to EOL, rdis must simulate.
	 tty-no-upmotionp		;Glass or printing, can't move crsr up.
	 DCTL-prologue-availablep	;Terminal must be twiddled whenever Emacs
				;tty modes are set after initialization.
	 DCTL-epilogue-availablep	;Terminal must be twiddled whenever Multics
				;tty modes are set
	 DCTL-underline-mask	;the terminal can really underline

	 (DCTL-extended-ascii nil)	;terminal can do 8bit

	 (DCTL-hardware-windows-availablep nil)
				;does terminal support windows?
	 (DCTL-max-splits 8.)	;number of windows it supports

	 screenheight		;Number of lines of screen depth.
	 screenlinelen		;Length of line - 1.
	 overstrike-availablep	;Cant rewrite one character anew
				;by writing over it.
	 (tty-type 'ASR33)		;tty ctl name, has tintinnab..* prop
				;if cant ring own bell.
	 tty-eolch-lossp		;DD4000 screw flag meaning all
				;whitespace must be printed in full.
	 abort-availablep		;Writeabort provided.  MCS doesn't work
				;right, so nobody has or can have this.

;;;
;;;	Editor (e_) state variables defining current buffer and
;;;	position therein.

	 curline			;Editorline object for current line
	 curlinel			;# of valid characters therein, incl NL
	 curstuff			;The line-data for that line, an emacs
	 			;string, see e_lap_.
	 curpointpos		;# of chars to left of "." on curline,
				;i.e., virtual buffer cursor hpos.
	 current-buffer		;Current buffer, atomic symbol.
	 firstline		;for minibuffer hack 10/23/80

	 ;; These buffer vars are used only for mode line maintenance.

	 fpathname		;Buffer file pathname
	 current-buffer-mode	;Current buffer's major mode.
	 buffer-minor-modes		;List of minor modes in this buf.
	 buffer-modified-flag	;Non-nil if buffer has been modified
	 read-only-flag		;Non-nil if buffer can't  be modified
	 user-display-variable	;Random var for R. Lamson.


;;;
;;;	The images of these buffer state variables kept from
;;;	one redisplay to the next so the Redisplay can determine
;;;	what changed.

	 (last-curline nil)		;Image of curline
	 (last-curlinel 0)		;Image of curlinel
				;e_ knows about this, to manage
				;the damaged-flag.
	 (last-buffer (gensym))	;Image of current-buffer
	 (last-fpath nil)		;Image of fpathname
	 last-bufmode		;Image of current-buffer-mode
	 (last-minor-modes nil)	;Image of buffer-minor-modes
	 (last-modified-flag nil)	;Image of buffer-modified-flag
	 (last-read-only-flag nil)	;Image of read-only-flag
	 (last-udv nil)		;Image of user-display-variable


;;;
;;;	Other editor (e_) randomness needed by Redisplay.
;;;

	 NLCHARSTRING		;An ASCII newline as a string
	 TAB			;An ASCII TAB as a string.
	 work-seg			;Multics ptr to scratch string hack seg
	 touchy-damaged-flag	;Turned off by redisplay, turned on
				;by editor if ANY modification done.
	 damaged-flag		;Turned off by redisplay, turned on by
				;editor if any mod done except adding
				;chars to the end of last-curline.
	 minibufferp		;non-nil if user typing in minibuf.
	 minibuffer-prompt-string	;like he says
	 tab-equivalent		;Number of spaces a tab is worth.
	 numarg			;numeric argument, for commands.

	 ;; Communications to Redisplay.

	 (suppress-redisplay-flag nil) ;Editor or extension wants all
				;redisplay suppressed.
	 (rdis-suppress-redisplay nil) ;Editor wants 1 redisplay suppressed.
				;Also used by local displays.
	 (rdis-upd-locecho-flg nil)	;PL/I negotiated redisplay occurred,
				;tells redisplay to do dummy redisplay
				;updating data with no output.
	 e-quit-transparency	;In the middle of QUIT/break processing
	 (rdis-inhibit-echnego nil)	;Needed by prtty hacks 11/6/79

	 ;; And communications back from.

	 two-window-mode		;In two-window mode.
	 selected-window		; uwindowx of selected window

	 pop-up-windows		;automatic window creation if on

;;;
;;;	User hooks, mainly for the benefit of Webber Emacs Applications, Inc.

	 (mode-line-hook nil)	;fcn to call for mode line
	 (local-display-end-string	;like it says
	   "-- * * * * * * * * * * * * --")
	 mode-line-herald
	 current-minor-mode-display-string ;<fill,electric> for hookfn.

;;;
;;;	Redisplay options.
;;;

	 screen-overlap		;number of lines overlap ^V, esc-V
	 (rdis-csopt nil)		;Clear to eos when rest of window n/g.
	 (rdis-wosclr-opt nil)	;Clear to eol on rest of window first
				;when rest of window n/g.
	 display-ctlchar-with-^	;Show chars as ^L instead of \014.
	 suppress-ctlchar-display	;Don't show control chars at all.
	 suppress-backspace-display	;Don't show backspaces at all.
	 suppress-rubout-display	;Don't show rubouts (\177) at all.
	 rdis-whitespace-optimize	;Attempt to print internal whitespace
				;by cursor movement.
;;;
;;;	Meters.
;;;

	 (rdis-rdis-meter 0)	;Calls to redisplay.
	 (full-rdis-meter 0)	;Times eol-optimized rdis didnt do it.
	 (rdis-detabb-meter 0)	;Number of output conversions.
	 (rdis-detab-opt-meter 0)	;Times found old output conv ok.
	 (rdis-wgen-meter 0)	;Number of windows computed.
	 (rdis-wgen-c1-meter 0)	;Of those, cursor found in old window.
	 (rdis-wgen-c2-meter 0)	;New window chosen centered on cursor.
	 (rdis-wgen-c3-meter 0)	;Window started from cursor at top.
	 (rdis-ndf-opt-meter 0)	;c1 window with no mod/detab at all.
	 (rdis-bad-echnego-meter 0)	;had to do full rdis after echnego.

;;;
;;;	Now comes all the internal hair.
;;;

	 rdis-multiwindowed-buflist	;List of bufs in many windows
	 rdis-lru-stack		;Window stack, top is mru.
	 modelwindow		;Mode line/path line window.
	 minibufwindow		;The minibuffer/echo buffer.

	 nwindows			;Number of these to look for.
	 nuwindows		;Number of user windows
;;;
;;;	Some constants and semi-constants
;;;

	  main-window-size		;# of lines in main screen region,
				;what set-screen-size sets.
	  rwork-string		;An "old black magic" (rplacable)
				;string used to hold converted image
				;of current real screen line, extended
				;by optimized redisplays, but updated
				;by all.
	  detab-buf		;blk mgc string used for output cvsn
				;and substr-ing output strings.
	  rdis-a-lotta-blanks	;a line's worth of blanks, for
				;comparing to in redisplay-line
	  ospeed			;Chars/sec from MCS, a public var.
	  (rdis-blankscan-table nil)	;e_-style EIS table for whitespace
				;optimizer's non-blank searching.
	  rdis-splln-mark		;Mark for split-line "window"



;;;
;;;	Vars holding editorlines which comprise the phony editor
;;;	buffer which is in fact the modeline and pathline.
;;;

	  phony-modeline-edline	;The mode line, as an editorline.
	  phony-pathline-edline	;The path line, as an editorline.

;;;
;;;	Items of internal redisplay state.
;;;

	  (realcurdispline '(("" nil) "" . 0)) ;The cursor-containing displayline
				;of the last redisplay.  Its
				;printablerepresentation IS rwork-strg.
	   rdis-selected-windowx	;window index of cursor window
	   rdis-selected-wlist	;The window structure for that window.
	   rdis-selected-split	;the split for that window
	   last-foundx		;Y coord of eline having cursor
	   real-foundx		;Actual screen line where cursor left

	   last-prinl		;Printing length of curdispline,
				;used to add optimally to end of it.
	   (rdis-last-tty-upprint-x -1) ;The last Y coord on simulated
				;no-upm "tty" screen where simulated
				;cursor was left.
	   rdis-last-echolinex	;last place where minibuffers printed.
	   (rdis-mbuf-transient-linex -1) ;line that wants to die.
	   some-split-damaged	;a split (possibly) other than the current
				; one needs update, means hard redisplay
;;;
;;;	Variables used by the local display hack.
;;;

	   (rdis-locdisp-linex nil)	;Next line coord where local display
				;to go. nil = regular rdis went by.
	   rdis-locdisp-window	;Fraudulent window structure for
				;local displays.

	   (rdis-have-redisplayed nil) ;Remember if a redisplay has been
				;done since last local display.
	   (local-display:force-no-more nil)	;local display teriminion control
	   (rdis-locdisp-split nil)	;split in which the local display is placed

;;;
;;; Variables used by split management
;;;

	   (nsplits 0)		;number of splits in use
	   (nusplits 0)		;# of user addressable splits

	   (maxsplits 0)		;maximum number of splits
	   (maxusplits 0)		;maximum ... of user addressable splits

	   (current-split nil)	;the split we are currently munching
				;changes when we select-window
	   (rdis-cursor-split nil)	;split display cursor is in (not necessarily eq current-split
				; as we don't want the cursor to dance)
				;changes when we actually redisplay in a split
	   (model-split nil)	;split for the mode-line/pathline window
	   (minibuffer-split nil)	;split for the minibuffer

	   (split-mode-p nil)	;on if in split mode.

	   (full-screenlinelen 0)	;so we know how big the REAL screen is
	   (full-screenheight 0)

	   (split-ids-available nil)	;list of split-id values not in use
				;in range 0..DCTL-max-splits -1

         ))

;;; tct arrays of non-printing chars. A non-zero byte ==> non-printing.
;;;(declare (array* (fixnum (rdis-tabscan-table 128.)    ;table in use. ONE OF:
;;;		        (7bit-tabscan-table 128.)    ;7bit ASCII table
;;;		        (8bit-tabscan-table 128.)))) ;8bit ASCII
(declare (special rdis-tabscan-table		;the one in use
	        7bit-tabscan-table		;default is for 7bit ASCII
	        8bit-tabscan-table		;this one   for 8bit ASCII
	        ))

;;; 
;;; (register-option 'rdis-wosclr-opt nil)		;11/23/78 sorry, Olin. -b ;moved to e_option_defaults_
;;; (register-option 'display-ctlchar-with-^ nil) ;moved to e_option_defaults_
;;; (register-option 'suppress-ctlchar-display nil) ;moved to e_option_defaults_
;;; (register-option 'suppress-backspace-display nil) ;moved to e_option_defaults_
;;; (register-option 'suppress-rubout-display nil) ;moved to e_option_defaults_
;;; (register-option 'rdis-whitespace-optimize t) ;made t 9/12/80 -- BSG ;moved to e_option_defaults_
;;; (register-option 'screen-overlap 1) ;moved to e_option_defaults_

;;;	Screen is maintained as the array "screen", containing knowledge
;;;	and images of screen. Each element of "screen" is called a "displayline",
;;;	and looks like this:

;;;	(editorline "printablerepresentationwithnonewline" . printinglength)

;;;	The array "newscreen" is used during redisplay computation only.
;;;
;;;	The array "windows" contains "windowlists" for each extant window,
;;;	indexed from 0.  The "---" lines, the modeline/pathline, and the
;;;	minibuffer all count as windows.

;;;	The representation of a window (a window-list) is as follows:

;;;	(firstline# #of-lines pointelinemark buffersymbol)

;;;	"pointelinemark" is an editor "mark" representing the last place
;;;	that "point" was in that buffer. "buffersymbol" is the buffer symbol.
;;;
;;;	The array "uwindows" (1-originned) contains indices into
;;;	windows indexed by what the user sees as "windows", i.e.,
;;;	editing, non-overhead windows.

;;;	The array "eline-conts" parallels the window array of redisplay lines
;;;	maintaining what e_ calls "line-contents" so that an "eq" check can
;;;	be made (see redisplay-window) to avoid detabbification and resultant
;;;	consing, for eq lines with eq contents cannot detabbify differently.

;;;	Setup redisplay at start of editor invocation.

(defun display-init ()

       ;; Default DCTL flags.
       (setq DCTL-prologue-availablep nil
	   DCTL-epilogue-availablep nil
	   DCTL-underline-mask nil
	   DCTL-extended-ascii nil		;no 8-bit yet
	   DCTL-hardware-windows-availablep nil
	   overstrike-availablep nil
	   tty-eolch-lossp nil
	   abort-availablep nil
	   idel-lines-availablep nil
	   idel-chars-availablep nil
	   tty-no-cleolp nil
	   region-scroll-availablep nil
	   tty-no-upmotionp nil)

       ;; Initialize redisplay work variables and options.
       (setq rwork-string (e_lap_$make-dat-ol-black-magic-string
		        (e$get_temporary_seg))
	   detab-buf (e_lap_$make-dat-ol-black-magic-string
		     (e$get_temporary_seg))
	   ospeed (e_pl1_$get_line_speed))

       ;; Tell the terminal controller to initialize itself.
       (DCTL-init)

       ;; Force values for line/page length from command line.
       (and (> args:ll 0) (setq screenlinelen args:ll)) ;;MF phx20884
       (and (> args:pl 0) (setq screenheight args:pl))

       ;; Keep true screen size safe from split munging
       (setq full-screenlinelen screenlinelen
	   full-screenheight screenheight)

       ;; Check up behind the terminal controller, setting unset options.
       (and tty-no-upmotionp (not overstrike-availablep)
	  (setq tty-no-cleolp t))
       (and tty-no-cleolp
	  (putprop 'DCTL-kill-line 'rdis-kill-eol-writearound 'expr))
       (and (getl 'DCTL-ring-tty-bell '(subr expr))
	  (putprop tty-type t 'tintinnabulum-ipsum-meum-sono))

       ;; Initialize screen arrays.
       ;; changed to array pointers from named arrays EDS Aug/85
       ;; We use both named arrays and array pointers for these arrays to allow
       ;; existing applications (some CTLs) to use old references.
       ;; The named array and array pointer are only guarenteed EQ if not
       ;; in split-screen mode (ie. (not split-mode-p))
       (setq screen (*array 'screen t screenheight))
       (setq newscreen (*array 'newscreen t screenheight))
       (setq eline-conts (*array 'eline-conts t screenheight))
       (fillarray newscreen '(nil))
       (fillarray eline-conts '(nil))

       ;; Establish proper non-printing char tabscan table
       (setq rdis-tabscan-table
	   (cond (DCTL-extended-ascii 8bit-tabscan-table) ;8bit ASCII?
	         (t 7bit-tabscan-table)))	;normal ASCII
       
       ;; Armed with tty info, finish setting redisplay variables.
       (setq rdis-a-lotta-blanks (do ((c "         " (catenate c c)))
			       ((> (stringlength c) screenlinelen) c)))
       (randomize-redisplay)

       ;; Initialize window manager, mode line, and minibuffer.

       (setq phony-modeline-edline	;The mode line, as an editorline.
	   (make-eline contents "")
	   phony-pathline-edline	;The path line, as an editorline.
	   (make-eline contents ""
		     previous phony-modeline-edline))	;prevline is mode line
       (setf (eline-next phony-modeline-edline)
	   phony-pathline-edline)		;nextline is path line
       (wman-init)
       (setq rdis-last-echolinex (startline minibufwindow))
       (and tty-no-upmotionp (setq DCTL-hardware-windows-availablep nil))
       (init-split-management)
       (update-mode-line)
       (reset-minibuffer-size))

(defun randomize-redisplay () (setq X -777 Y -777 rdis-suppress-redisplay nil))

;;;
;;;	External utilities and interfaces.
;;;

(defun redisplay-command ()
       (cond ((null numarg)
	    (full-redisplay))
	   (t (redisplay-current-window-relative numarg))))

(defun full-redisplay ()
       (randomize-redisplay)
       (setq damaged-flag t)
       (setq last-minor-modes (ncons nil) last-fpath (ncons nil))	;force prtty update.
       (and abort-availablep (rdis-write-abort))
       (clear-the-screen)
       (redisplay))

(defcom redisplay-this-line
        &numarg (&pass)
        (setq numarg (or numarg 1))
        (and (zerop numarg) (setq numarg 1))
        (let ((old-y Y)
	    (end (min screenheight
		    (cond ((minusp numarg) (1+ Y))
			(t (+ Y numarg))))))
	   (randomize-redisplay)
	   (do ((y (cond ((minusp numarg) (max 0 (+ old-y numarg)))
		       (t old-y))
		 (1+ y)))
	       ((= y end))
	       (DCTL-position-cursor 0 y)
	       (DCTL-kill-line)
	       (redisplay-line (screen y) (hokeup-line "") y))))

(defun toggle-redisplay ()
       (setq suppress-redisplay-flag (not suppress-redisplay-flag)))	;sigh

(defun rdis-write-abort ()			;This doesnt work at all
       (and (eq abort-availablep 'resetwrite)(e_pl1_$resetwrite))
       (DCTL-write-abort))			;because MCS throws away what
					;you haven't even written yet

(defun clear-the-screen ()
       (fillarray screen '(nil))		;full screen & current split
       (fillarray eline-conts '(nil))
       (randomize-redisplay)			;for general utility.
       (rdis-wipe-screen)
       (and split-mode-p			;splits other than current
	  (do ((splitix 0 (1+ splitix)) (split))
	      ((= splitix nsplits))
	      (setq split (splits splitix))
	      (setf (split-damaged split) t)	;make redisplay see it
	      (cond ((not (eq split current-split))  ;current done above
		   (fillarray (split-screen split) '(nil))
		   (fillarray (split-eline-conts split) '(nil))
		   (rdis-select-split split)
		   (rdis-wipe-screen)))))
       (e_pl1_$dump_output_buffer))
		     
(defun rdis-wipe-screen ()
       (cond ((get 'DCTL-clear-screen 'subr)
	    (DCTL-clear-screen))
	   (t (DCTL-position-cursor 0 0)
	      (DCTL-clear-rest-of-screen))))

;;; Does printing character check using the 'correct' scan table.
;;; Added Dec 84 by EDSchroth for 8bit I/O
;;; Changed Apr 85 to use rdis-tabscan-table and macro-ize.
(defmacro rdis-tabscan (strg strgl strgx)
	`(e_lap_$tabscan_table rdis-tabscan-table ,strg ,strgl ,strgx))

(defun rdis-find-non-displayable (strg strgl strgx)
       ;; 0-index of first non-displayable char in strg or strgl-strgx if none.
       ;; strgl is length of interest, strgx is offset to start at.
       (rdis-tabscan strg strgl strgx))

;;; Fake e_lap_ entry point for compatibility with existing code
(defun e_lap_$tabscan (strg strgl strgx)
       (rdis-tabscan strg strgl strgx))

;;;
;;;
;;;	Main redisplay function, invoked to update screen however
;;;	necessary, from editor.
;;;

(defun redisplay ()
       (let ((e-quit-transparency e-quit-transparency))
	  (prog (foundsw extend extendl target-hpos hisline model-needs-update
		       curwindow curwindow-split)
	        (cond ((or suppress-redisplay-flag rdis-suppress-redisplay)	;hold the old horses?
		     (setq rdis-suppress-redisplay nil)
		     (return t))
		    ((and minibufferp
			(not (eq e-quit-transparency 'redisplaying)))
		     (setq e-quit-transparency 'redisplaying)
		     (setq rdis-have-redisplayed t)
		     (return (cond ((eq curline firstline)
				(let ((curstuff (catenate minibuffer-prompt-string curstuff))
				      (curpointpos (+ curpointpos (stringlength minibuffer-prompt-string)))
				      (curlinel (+ curlinel (stringlength minibuffer-prompt-string))))
				     (redisplay)))
			         (t (let ((realness (eline-contents firstline)))	; < (king elegance)
				       (unwind-protect
				         (progn (setf (eline-contents firstline)
						  (catenate minibuffer-prompt-string realness))
					      (redisplay))
				         (setf (eline-contents firstline) realness))))))))
	        (aos rdis-rdis-meter)		;count 'em
	        (setq e-quit-transparency 'redisplaying)	;Don't let quits
					;play with the screen!
	        (setq curwindow (cond (minibufferp minibufwindow)
				(t (rdis-update-window-struct)
				   rdis-selected-wlist))
		    curwindow-split (window-split curwindow))
	        
	        (setq rdis-have-redisplayed t)

	        (or (and (eq last-fpath fpathname) (eq last-buffer current-buffer)
		       (eq last-bufmode current-buffer-mode)
		       (eq last-minor-modes buffer-minor-modes)
		       (eq last-modified-flag buffer-modified-flag)
		       (eq last-read-only-flag read-only-flag)
		       (eq last-udv user-display-variable))
		  (prog2 (setq model-needs-update t)
		         (update-mode-line)))
;;;

;;;	Determine if simple add-to-end-of-current line hack will do.
;;;	Avoid redisplaying ANY windows if so.  This hack MUST be invoked
;;;	if the PL/I negotiated echo was used, ring 0 or otherwise.
;;;

	        (cond ((and (not (or damaged-flag    ;current split does not need update
			         some-split-damaged)) ;no inactive split needs update
			(eq last-curline curline)	;sheer insertery will do
			(not model-needs-update) ;unless mode line also changed
			(not (rdis-curline-multiwindowed)))	;or curline appears more than once
		     (setq foundsw last-foundx)
		     (cond ((> (setq extendl (- (1- curlinel) last-curlinel)) 0)
			  (cond ((= extendl 1)(setq extend (ascii (e_lap_$ggcharn (wwtcomp curline) last-curlinel))))
			        (t (setq extend (e_lap_$gsubstr (wwtcomp curline) last-curlinel extendl))))

;;; Look for any characters that require special output conversion.

			  (cond ((or (not (= extendl (rdis-tabscan extend extendl 0)))
				   (> (+ last-prinl extendl) screenlinelen))  
			         (setq damaged-flag t)
			         (return (redisplay))))
			  (or rdis-upd-locecho-flg	;the 'tty' did it.
			      (progn
			        (DCTL-position-cursor last-prinl real-foundx)
			        (DCTL-display-char-string extend)))
			  (setq last-prinl (+ last-prinl extendl))
			  (rplac-lineln realcurdispline last-prinl)
			  (e_lap_$rplacstring rwork-string extend extendl (- last-prinl extendl) last-prinl)))
		     (go set-new-state)))

;;;
;;;
;;;	Redisplay all windows.
;;;
	        (and rdis-upd-locecho-flg (aos rdis-bad-echnego-meter))

	        (aos full-rdis-meter)

	        (and model-needs-update tty-no-upmotionp (not (eq fpathname last-fpath)) fpathname
		   (redisplay-line (parameterize-line phony-pathline-edline) nil
			         (1+ (car minibufwindow))))  ;noupm path update.


	        (and split-mode-p		;leave echo-buffer
		   (eq current-split minibuffer-split)	; if in minibuffer split
		   (not minibufferp)	;           but not minibuffer response
		   (rdis-open-split curwindow-split))

	        (do ((splitix 0 (1+ splitix))	;update each split
		   (s)			;split being looked at
		   (prior-current-split current-split)) ;remember current split
		  ((= splitix nsplits))
		  (setq s (splits splitix))
		  (cond ((or (split-damaged s)     ;but only if needed
			   (eq prior-current-split s))     ;know current split needs update!
		         (and split-mode-p (rdis-open-split s))
		         (do ((windowx 0 (1+ windowx))
			    (window))
			   ((= windowx nwindows))
			   (setq window (windows windowx))
			   
			   (and model-needs-update (eq window modelwindow) (setq damaged-flag t))
			   ;inhibit opt of second type, editor didn't hit damaged flag.
			   (cond ((and window
				     (or (and (bufmark window)(not minibufferp))
				         
				         ;;during minnybuffs, dont redisplay
				         ;;any window 'xcept m.b., cause finding
				         ;;starting line is hard.
				         
				         (eq window curwindow))
				     (not (and tty-no-upmotionp (eq window modelwindow)(not model-needs-update))))
				
				(setq hisline (redisplay-window
					      window
					      (cond ((eq window curwindow)
						   curline)
						  (t (car (bufmark window))))
					      1))
				(and split-mode-p (setf (split-damaged s) nil)))	;split is consistent now
			         ((and window (null (bufmark window))
				     ;;Clear out a window just born or unbuffered.
				     (not (eq window minibufwindow))
				     (eq (eline-conts (startline window)) 'hphcs))
				(redisplay-window window nil 3)
				(and split-mode-p (setf (split-damaged s) nil)))) ;split is consistent now
			   (and (eq window curwindow)(setq foundsw hisline))))))

;;;
;;;
;;;	Compute where physical cursor is to be left.
;;;	Put it there.  Compute the new redisplay state.
;;;

set-new-state
	        (or foundsw (rbarf "Redisplay can't find the cursor"))
	        (cond (split-mode-p		;reactivate correct terminal split
		      (or (eq current-split curwindow-split)
			(rdis-open-split curwindow-split))
		      (rdis-select-split curwindow-split)))
	        (setq target-hpos (real-world-cursor-xcoord
			        (wwtcomp (eline (screen foundsw)))
			        curpointpos))
	        (setq real-foundx foundsw)
	        (do nil ((< target-hpos (1+ screenlinelen)))   ;find cursor through continuation lines
		  (setq target-hpos (- target-hpos screenlinelen))
		  (cond ((or (not (< real-foundx (1- screenheight)))
			   (not (eq (eline (screen real-foundx))
				  (eline (screen (1+ real-foundx))))))
		         (return (setq target-hpos (1- screenlinelen)))))
		  (aos real-foundx))
	        (and (eq (linedata realcurdispline) rwork-string)
		   (not (eq realcurdispline (screen real-foundx)))
		   (rplac-linedata realcurdispline (substr rwork-string 1)))
	        (setq realcurdispline (screen real-foundx))
	        (setq last-prinl (lineln realcurdispline))

;;;
;;;	On no-upmotion jobbies, print something if not done by rdis-window.
;;;

	        (and tty-no-upmotionp		;is noupm
		   (not (= rdis-last-tty-upprint-x real-foundx))
		   (progn (redisplay-line realcurdispline nil real-foundx)
			(setq rdis-last-tty-upprint-x real-foundx)))

;;;   Get the last current-line image in rwork-string so that the next
;;;   optimized redisplay can hack it.

	        (or (eq (linedata realcurdispline) rwork-string)
		  (progn (e_lap_$rplacstring rwork-string
				         (linedata realcurdispline)
				         last-prinl 0 last-prinl)
		         (rplac-linedata realcurdispline rwork-string)))

	        (setq last-fpath fpathname)
	        (setq last-buffer current-buffer)
	        (setq last-bufmode current-buffer-mode)
	        (setq last-modified-flag buffer-modified-flag)
	        (setq last-read-only-flag read-only-flag)
	        (setq last-minor-modes buffer-minor-modes)
	        (setq last-udv user-display-variable)
	        (setq last-foundx foundsw)
	        
	        (setq last-curline curline
		    damaged-flag nil
		    some-split-damaged nil
		    last-curlinel (1- curlinel)
		    touchy-damaged-flag nil
		    rdis-locdisp-linex nil
		    rdis-locdisp-split nil)
	        (and minibufferp (setq rdis-last-echolinex real-foundx))
	        (DCTL-position-cursor target-hpos real-foundx)
	        (e_pl1_$dump_output_buffer)
	        (return nil))))
;;;
;;;
;;; Look for curline occuring more once on screen
;;;

(defun rdis-curline-multiwindowed ()
       ;; determines if curline appears in more than one screen location
       (and
         (memq current-buffer rdis-multiwindowed-buflist)
         (cond ((not split-mode-p)		;simple case optimization
	      (do ((i 0 (1+ i)))		;just scan screen
		((= i screenheight) nil)
		(and (not (= i last-foundx))
		     (eq (eline (screen i)) curline)
		     (return t))))
	     (t				;split-mode is hard case
	       ;; Must examine all splits to ensure damage state accurate.
	       (< 1			;count occurances
		(do ((sn 0 (1+ sn))		;loop over all splits
		     (s)			;split being checked
		     (matches 0))		;total lines eq curline
		    ((= sn nsplits) matches)
		    (setq s (splits sn))
		    (incf matches
			(do ((i 0 (1+ i))	;loop over split lines
			     (m 0)	;# curline's in this split
			     (screen (split-screen s))     ;split image
			     (nlines (split-height s)))    ;split size
			    ;;loop over all lines; may be > 1 window in split
			    ((= i nlines) m)
			    (cond ((eq curline (eline (screen i)))   ;match?
				 (and (= 0 m)
				      (setf (split-damaged s) t))  ;update state
				 (incf m)))))))))))
;;;
;;;
;;;	Moby hair - redisplay one window
;;;	This thing is now so complex that I barely understand it.
;;;

(defun redisplay-window
       (window				;the window to redisplay
         pointeline				;editor line "point" for window
         tries)				;successive algorithms to lay out
					; new screen.
					;1 = find point on old screen
					;2 = center screen about point
					;3 = point on top line

       (prog (start				;starting line # of window
	     nlines			;# of lines in window
	     oldstart			;loc of first old line on new screen
	     oldct			;index into old screen, processed
	     newct			;index into new screen, processed
	     oldx				;look ahead index, old screen
	     newx				;look ahead index, new screen
	     foundsw			;line # on which pointeline found
					;nil if not found
	     oldfat			;when doing idel-lines, matched area
	     newfat			; on screens
	     windowlim			;bottom line # of this window
	     deletedx			;Lines idelled out'ed's index
	     opt1f			;flag for detabbification optimization
	     e-quit-transparency	;SPECIAL VAR!
	     split-selected)		;are we in the window's display split?

	   (setq e-quit-transparency 'redisplaying)
	   (aos rdis-wgen-meter)		;meter it

	   (setq start (startline window)	;determine window boundaries
	         nlines (numlines window))
	   (setq oldct start newct start)	;planned no lines, considered none.
	   (setq windowlim (+ start nlines -1))	;limit of window
	   (setq deletedx (1+ windowlim))	;For idel-lines hackery.
	   (setq split-selected (not split-mode-p))

	   ;; "tries" is passed by caller, usually 1, 3 forces pointeline home.

	   ;; Try super-optimized window redisplay for cursor motion only
	   ;; Don't use to avoid modeline update.

	   (and (not damaged-flag)(not touchy-damaged-flag)(= tries 1)
	        (do x start (1+ x)(> x windowlim)    ;nil => forget it
		  (and (eq (eline (screen x)) pointeline)
		       (not (and (eq (eline (screen windowlim)) pointeline)
			       (not (< (lineln (screen windowlim)) screenlinelen))))
		       (return (setq foundsw x))))
	        (progn (aos rdis-ndf-opt-meter)
		     (return foundsw)))


	   (do ((toldct oldct (1+ toldct)))	;find first non-deleted on screen.
	       ((> toldct windowlim)		;all deleted, full redisplay
	        (setq tries 2))
	       (and (screen toldct)		;if line has stuff,
		  (not (eq (eline-contents (eline (screen toldct))) 'deleted))   ;this is a real line
		  (return (setq oldstart toldct))))	;oldstart = 1st real line thats still there.
;;;
;;;
;;;  Try the different algorithms to fill the newscreen array to represent
;;;  the new screen.
;;;
	   (and tty-no-upmotionp (setq tries 3))     ;We know exactly for prtty.
fillup
	   (setq newx start oldx oldstart)	;oldstart is place we hope
					;to find old line conts.
	   (and (> tries 1)(setq oldx (1+ windowlim)))	;Inhibit eline-conts.

	   (do ((l (cond ((= tries 1)(eline (screen oldx))) ;could merge screens
		       ((= tries 2)(find-nice-starting-line pointeline nlines))  ; disjoint screens
		       ((= tries 3) pointeline)    ;all obscure cases, big lines
		       ((> tries 3)(rbarf "Redisplay-window can't position point.")))
		 (eline-next l))
	        (screenx start (1+ screenx)))
	       ((> screenx windowlim))

	       (and (eq l pointeline)(setq foundsw screenx))   ;we found the line, this screen ok.
	       (cond ((and tty-no-upmotionp (not (eq l pointeline)))
		    (do sx1 screenx (1+ sx1)(> sx1 windowlim)
		        (store (newscreen sx1) nil)
		        (store (eline-conts sx1) nil)
		        (store (screen sx1) nil))  ;blank out rest.
		    (return nil)))
;;;
;;;
;;;	Try to use previously output-converted image of line if
;;;	car of eline is eq to whats in eline-conts.  If not, output
;;;	convert. Re-set eline-conts at refill-new-array.
;;;	opt1f will say whether this won or not.  This is solely a CPU
;;;	time and consing optimization.

;;;	Begin by trying to find current l in old screen.

	       (do ((sx1 oldx (1+ sx1)))	;find old stuff
		 ((or (> sx1 windowlim)(null (screen sx1))))
		 (cond ((eq (eline (screen sx1)) l)
		        (setq oldx sx1)	;found it- desired effect
		        (return t))))	;is what happens to  oldx


	       (cond ((and (not (> oldx windowlim))  ;try for saving work
		         (not (eq l curline))	;don't believe anything
		         (eq (eline (screen oldx)) l)	;really there
		         (eq (eline-contents l) (eline-conts oldx)))    ;makes it.

		    (aos rdis-detab-opt-meter)

		    (do ((nx screenx (1+ nx))(ox oldx (1+ ox)))
		        ((not (eq l (eline (screen ox))))
		         (setq screenx (1- nx) oldx ox)
		         (setq opt1f t))

		        (store (newscreen nx)(screen ox))
		        (cond ((= ox windowlim)
			     (setq opt1f (or (not (screen ox))(< (lineln (screen ox)) screenlinelen)))
			     (and opt1f (setq screenx nx oldx ox))
			     (return t))
			    ((= nx windowlim)    ;ox cannot be on bottom now
			     (setq opt1f (not (eq l (eline (screen (1+ ox))))))
			     (and opt1f (setq screenx nx oldx ox))
			     (return t)))))
		   (t (setq opt1f nil)))
;;;
	       (cond ((not opt1f)		;could'nt find old detabbification
					;Output-convert it NOW.

		    (store (newscreen screenx)(parameterize-line l))
;;;
;;;
;;;	Hack in the continuation lines
;;;
		    (do ((ns (newscreen screenx)(newscreen screenx)))
		        ((or (not ns)(not (> (lineln ns) screenlinelen))))

		        (store (newscreen screenx) ;old line
			     (cons l (cons (substr (linedata ns) 1 screenlinelen)
				         screenlinelen)))
		        (cond ((not (< screenx windowlim))
			     (and (< tries 3)
				(eq l pointeline)
				(setq foundsw nil)) ; cause recomputation
			     (return nil)))

		        (store (newscreen (1+ screenx))
			     (cons l (cons (substr (linedata ns)(1+ screenlinelen))
				         (- (lineln ns) screenlinelen))))
		        (aos screenx)))))


	   (let ((lastrdisline (newscreen (+ start nlines -1))))
	        (cond (lastrdisline 		;ut SCPOS: MEANINGLESS ARGS	non habet.
		      (rplac-lineln lastrdisline
				(min screenlinelen (lineln lastrdisline))))))
;;;
;;;	See if last pass got the current line, iterate if not.
;;;	Special-case prtty stuff, set up for merge scan.

	   (cond (foundsw)			;found curline, use it as is.
	         (t (setq tries (1+ tries))	;try some other technique
		  (go fillup)))


	   (cond ((= tries 1)(aos rdis-wgen-c1-meter))	;meter window type
	         ((= tries 2)(aos rdis-wgen-c2-meter))
	         ((= tries 3)(aos rdis-wgen-c3-meter)))

	   (setq oldct start)		;init for screen scan
	   (setq oldx oldstart)		;first found line

	   (cond (tty-no-upmotionp		;check for different lines
		 (or (eq (eline (screen start))(eline (newscreen start)))
		     (progn (DCTL-nextline)
			  (DCTL-assert-scpos nil 0)	;feed up.
			  (do sx2 start (1+ sx2)(> sx2 windowlim)(store (screen sx2) nil))))
		 (go real-rdis-rest-of-window))
	         ((> tries 1)(go l0)))	;couldn't find, try random match.

;;;
;;;
;;;	Found line. Gotta insert or delete.
;;;

found-matched-line


	   ;; last-line no-share hack- bsg 10/27/79
	   (cond ((and (or (= oldx windowlim)(null (screen (1+ oldx))))
		     (= newx start)
		     (not (eq (newscreen newx)(screen oldx))))  ;detabbified differently
		(go redisplay-the-rest-of-window)))

	   (setq oldfat (- oldx oldct)	;#of lines on screen before matchee
	         newfat (- newx newct))	;# of lines that want to be displayed before
					;matchee.
	   (or (and (= 0 oldfat)(= 0 newfat))	;if no idelry, match them.
	       (and (or idel-lines-availablep region-scroll-availablep)
		  (< (1+ (abs (- oldfat newfat))) nlines))   ;dont idel for small change
	       (go redisplay-the-rest-of-window))

	   (or split-selected		;if not already in correct split, go there
	       (and (setq split-selected t)
		  (rdis-select-window-split window)))

	   (do ((ct (min oldfat newfat)(1- ct)))     ;zap-redisplay common lines
	       ((= ct 0))

	       (redisplay-line (newscreen newct)(screen oldct) newct)    ;do it
	       (aos oldct)			;ground on both screens
	       (aos newct))

	   (cond ((> newfat oldfat)		;better open up
		(let ((fatdif (- newfat oldfat)))
		     (cond ((not region-scroll-availablep)
			  (DCTL-position-cursor 0 (- (1+ windowlim) fatdif))
 
			  (DCTL-delete-lines fatdif)))
		     (do xx fatdif (1- xx)(= xx 0)
		         (setq deletedx (1- deletedx))    ;Pull up line
		         (or (> deletedx windowlim)(store (screen deletedx) nil)))
					;fixes pulling up pushed off lines.
		     (DCTL-position-cursor 0 newct)
		     (cond (region-scroll-availablep
			   (DCTL-scroll-down-region fatdif windowlim))

			 (t (DCTL-insert-lines fatdif)))
		     (do i 1 (1+ i)(> i fatdif)
		         (DCTL-position-cursor 0 newct)
		         (redisplay-line (newscreen newct) nil newct)
		         (aos newct)))))

			;next line

	   (cond ((> oldfat newfat)		;extra space on screen
		(let ((fatdif (- oldfat newfat)))
		     (DCTL-position-cursor 0 newct)
		     (cond (region-scroll-availablep
			   (DCTL-scroll-up-region fatdif windowlim))
			 (t (DCTL-delete-lines fatdif)
			    (DCTL-position-cursor 0 (- (1+ windowlim) fatdif))
			    (DCTL-insert-lines fatdif)))
		     (setq deletedx (+ deletedx fatdif)) ;offset possible wipeage index
		     (setq oldct (+ oldct fatdif)))))


	   (redisplay-line (newscreen newct)(screen oldct) newct)	;whatever technology necessary

	   (aos oldct)
	   (aos newct)

	   (and (> oldct windowlim)(go redisplay-the-rest-of-window))    ;no news in old screen, useless
	   (and (> newct windowlim)(go refill-new-array)) ;screen done
;;;
;;;
;;;	Great mergo loop. Match lines in old screen and new.
;;;

l0 	   (setq newx newct)		;Scan BUFFER..
l1 	   (and (> newx windowlim)(go redisplay-the-rest-of-window))     ;will worry about fall-thru, nils.
	   (or (newscreen newx)(go redisplay-the-rest-of-window))	;nils- could never find 'em anyhow
	   (setq oldx oldct)		;now search screen for this line

l2 	   (cond ((> oldx windowlim)		;couldnt match this line
		(aos newx)		;try the next
		(go l1))
	         ((eq (eline (newscreen newx))(eline (screen oldx)))	;found it
		(go found-matched-line))
	         (t (aos oldx)		;search on..
		  (go l2)))


redisplay-the-rest-of-window

	   (or split-selected		;if not already in correct split, go there
	       (and (setq split-selected t)
		  (rdis-select-window-split window)))

	   (and (or rdis-csopt rdis-wosclr-opt)	;try screen-clear hacks
	        (not minibufferp)
	        (< newct windowlim)		;allow 1
	        (newscreen newct)		;dont do it if happy eob window
	        (< oldct windowlim)
	        (screen oldct)
	        (or (not two-window-mode)
		  (not rdis-csopt)
		  ;;(= start (startline (windows 2))))
		  (= start (startline (windows nuwindows))))
;;; Option to clear screen to end before filling rest of screen
	        (cond (rdis-csopt (DCTL-position-cursor 0 newct)
			      (DCTL-clear-rest-of-screen)
			      (setq damaged-flag t)	;if demand redisplery, mode line zonked.
			      (do i oldct (1+ i)(= i screenheight)
				(store (screen i) nil)))
;;; Option to kill lines in rest of window prior to redisplaying it.
		    (t			;wos's hack
		      (do ((newx newct (1+ newx))
			 (oldx oldct (1+ oldx)))
			((> newx windowlim))
			(cond ((and (screen oldx)(> (lineln (screen oldx)) 0))
			       (DCTL-position-cursor 0 newx)
			       (DCTL-kill-line)
			       (store (screen oldx) nil)))))))
;;;

;;;
;;;	Set up images for next time; screen with the line structure,
;;;	eline-conts with the line strings.  Compare-update whatever is
;;;	unmerged on screen.
;;;

real-rdis-rest-of-window

	   (do ((newx newct (1+ newx))
	        (old)(new)
	        (oldx oldct (1+ oldx)))
	       ((> newx windowlim))

	       (setq old (and (not (> oldx windowlim))(screen oldx))
		   new (newscreen newx))
	       (cond ((and (null new) minibufferp)   ;dont clear minibuffer tails 10/5/79
		    (setq windowlim (1- newx));cause refill to stop
		    (return nil)))
	       (cond (tty-no-upmotionp	;Worry about prtty update
		     (cond (new		;only if new stuff
			   (cond ((or (not old)  ;If old was not there, or
				    (not (= (lineln new)(lineln old))) ;if they're different,
				    (not (e_lap_$compare_strings
					 (linedata old) 0 (linedata new) 0 (lineln old))))
				(redisplay-line new (cond ((= newx rdis-last-tty-upprint-x) old)(t nil)) newx)
				(setq rdis-last-tty-upprint-x newx))))))
		   (t (redisplay-line new old newx))))	;do it


;;;
;;;	Copy current new window into "state" of window.
;;;

refill-new-array

	   (do c start (1+ c)(> c windowlim)
	       (let ((rdl (newscreen c)))
		  (store (screen c) rdl)
		  (store (eline-conts c)(cond ((eq (eline rdl) curline) 'ahem)
					(t (eline-contents
					     (eline rdl)))))))

	   (return foundsw)))


;;;

;;;
;;;	Choose the first line of the new window
;;;	Try to go a half window back from current line, measuring lines.
;;;

(defun find-nice-starting-line (centerline nlines)
       (do ((l centerline (eline-previous l))
	  (lrl centerline)			;last known good
	  (i (// nlines 2)))
	 ((not (> i 0))(or l lrl))
	 (cond (l (setq lrl l)		;remember last real line
		(setq i (- i (rdis-/#-of-lines-in- l))))
	       (t (setq i (1- i))))))


;;;
;;;	Generate a displayline given an editorline.
;;;

(defun parameterize-line (editorline)
       (and editorline
	  (cons editorline			;car is editor's thought
	        (let ((detabif
		      (detabbify (cond ((eq editorline curline) curstuff)
				   (t (car editorline))))))
		   (cons detabif (stringlength detabif))))))
       
;;; 
;;;
;;;	El Peludo -- The hairy one
;;;

(defun redisplay-line (newl oldl sx)		;try to replace this by that.
       (prog (oldlrep newlrep oldll newll leftcommon rightcommon oldarea newarea have-slain ischct)
	   (setq oldlrep (cond (oldl (setq oldll (lineln oldl))(linedata oldl))
			   (t (setq oldll 0) "")))
	   (setq newlrep (cond (newl (setq newll (lineln newl))(linedata newl))
			   (t (setq newll 0) rdis-a-lotta-blanks)))
	   (and (= oldll 0)
	        (not tty-eolch-lossp)
	        (setq oldll newll oldlrep rdis-a-lotta-blanks))	;heh, heh.

	   (and (or (eq oldlrep newlrep)
		  (and (= newll oldll)
		       (e_lap_$compare_strings oldlrep 0 newlrep 0 oldll)))
	        (return nil))

	   (setq leftcommon 0 rightcommon 0)
	   (do i 1 (1+ i)(> i (min newll oldll))
	       (cond ((= (getcharn oldlrep i)(getcharn newlrep i))
		    (setq leftcommon (1+ leftcommon)))
		   (t (return nil))))
	   (do ((j oldll (1- j))
	        (i newll (1- i)))
	       ((or (= leftcommon i)(= leftcommon j)))

	       (cond ((= (getcharn oldlrep j)(getcharn newlrep i))
		    (setq rightcommon (1+ rightcommon)))
		   (t (return nil))))


	   (setq newarea (- newll rightcommon leftcommon)
	         oldarea (- oldll rightcommon leftcommon))

	   (and (< rightcommon 3)(go kill-eol))

;;;
;;;	Assess whether or not to try idel-chars.  Overwriting an equal-length
;;;	area is considered a special case.
;;;

	   (and (> rightcommon 0)(< rightcommon 4)(= newarea oldarea)
	        (> newarea 15.)(go kill-eol))	;3/1/79 avoid long repaint
					;cause haarenk can do better

	   (cond ((and (= oldarea newarea)	;Must be equal length.
		     (or (not overstrike-availablep)	;tty can overpaint
		         (e_lap_$compare_strings oldlrep leftcommon rdis-a-lotta-blanks 0 oldarea))) ;clean stuff
		(DCTL-position-cursor leftcommon sx)	;do it.
		(rdis-substr-display newlrep leftcommon newarea)
		(return nil)))		;All done.

	   (or idel-chars-availablep (go kill-eol))  ;Can't do it.
	   (and (> (+ (+ 4 newarea)(* 2 oldarea)) (- newll leftcommon))
	        (go kill-eol))		;not worth it.

	   (DCTL-position-cursor leftcommon sx)

	   (cond (overstrike-availablep	;All cases, can't overpaint.
		 (or (= 0 oldarea)(DCTL-delete-chars oldarea))
		 (or (= 0 newarea)(DCTL-insert-char-string (substr newlrep (1+ leftcommon) newarea))))
	         ((> oldarea newarea)
		(and (> newarea 0)(rdis-substr-display newlrep leftcommon newarea))
		(DCTL-delete-chars (- oldarea newarea)))
	         (t (or (= oldarea 0)(rdis-substr-display newlrep leftcommon oldarea))
		  (DCTL-insert-char-string (substr newlrep (+ 1 leftcommon oldarea)(- newarea oldarea)))))
	   (return nil)

kill-eol 	   (and (> newll leftcommon)		;if lotta blanks, not there.
	        (not tty-eolch-lossp)
	        (e_lap_$compare_strings newlrep leftcommon rdis-a-lotta-blanks 0 (- newll leftcommon))
	        (setq newll leftcommon))

	   (and idel-chars-availablep		;3/1/79 try idel for \c push
	        (> newll leftcommon)		;gotta be real stuff
	        (= newll oldll)		;of equal length both ends
	        (setq ischct (e_lap_$rdis-crossmatch oldlrep newlrep leftcommon oldll))
	        (> (- newll (abs ischct)) 10.)
	        (cond ((< ischct 0)
		     ;;Guy deleted characters, theres a new one at the end
		     (DCTL-position-cursor leftcommon sx)
		     (DCTL-delete-chars (setq ischct (- ischct)))
		     (DCTL-position-cursor (- newll ischct) sx)
		     (rdis-substr-display newlrep (- newll ischct) ischct)
		     (return nil))
		    ((> ischct 0) ;dont know what 0 means cant happen
		     ;;Guy inserted, the end is chopped.
		     (DCTL-position-cursor (- newll ischct) sx)
		     (DCTL-kill-line)
		     (DCTL-position-cursor leftcommon sx)
		     (DCTL-insert-char-string (substr newlrep (1+ leftcommon) ischct))
		     (return nil))))

	   (cond ((not overstrike-availablep))
	         ((= leftcommon oldll))
	         ((and (> newll leftcommon)
		     (or (not tty-no-upmotionp)    ;fixes end;end; bug.
		         (not (> oldll newll))
		         (e_lap_$compare_strings oldlrep newll rdis-a-lotta-blanks 0 (- oldll newll)))
		     (e_lap_$compare_strings oldlrep leftcommon rdis-a-lotta-blanks 0 (- newll leftcommon))))
	         ((and (= newll leftcommon)	;don't kill blanks
		     (> oldll newll)
		     (e_lap_$compare_strings oldlrep newll rdis-a-lotta-blanks 0 (- oldll newll))))
	         (t (setq have-slain t)	;flag killing
		  (DCTL-position-cursor leftcommon sx)
		  (DCTL-kill-line)))

	   (and (eq oldlrep rdis-a-lotta-blanks)(setq have-slain t))

	   (cond ((> newll leftcommon)	;Add new extension
		(or (> oldll leftcommon)(setq have-slain t)) ;nothing out there
		(cond (rdis-whitespace-optimize    ;New hair here 2/13/80
		        (cond ((and tty-no-cleolp (> oldll leftcommon)(> newll oldll))
			     (DCTL-position-cursor leftcommon sx)
			     (rdis-substr-display newlrep leftcommon (- oldll leftcommon))
			     (setq leftcommon oldll have-slain t)))
		        (cond ((rdis-whitespace-optimizer newlrep leftcommon newll have-slain sx)
			     (return nil)))))
		;;Print out the extension standardly by default.
		(DCTL-position-cursor leftcommon sx)
		(rdis-substr-display newlrep leftcommon (- newll leftcommon))))
	   ;; Now kill whats left off end.

	   (and (or have-slain (not (> oldll newll)))(return nil))	;no need

	   (cond ((not (e_lap_$compare_strings oldlrep newll rdis-a-lotta-blanks 0 (- oldll newll)))
		(DCTL-position-cursor newll sx)
		(DCTL-kill-line)))

	   (return nil)
	   ))

(defun rdis-substr-display (stuff start howmany)
       (e_lap_$rplacstring-offset detab-buf stuff howmany 0 howmany start)
       (DCTL-display-char-string detab-buf))


;;; 
;;;
;;;	Haarenkoenig: Do CRTSTY-like whitespace condensation at low speeds.
;;;

(defun rdis-whitespace-optimizer (lrep start end+ have-slain y)
       (prog (next-to-go for-blanks for-non-blanks optinc)
	   (and tty-no-cleolp (not have-slain)(return nil))
	   (and tty-eolch-lossp (return nil))
	   (setq optinc (// (- end+ start) 6))
	   (or (> optinc 1)(return nil))
	   ;;(do x start (+ x optinc)(> (+ x optinc) end+)
	   ;;(and (e_lap_$compare_strings lrep x rdis-a-lotta-blanks 0 optinc)
	   ;;(return (setq worthit t))))
	   ;;(or worthit (return nil))
	   
	   ;;
	   ;; We're gonna do it. Kill to eol first.
	   ;;
	   (or have-slain (progn (DCTL-position-cursor start y)
			     (DCTL-kill-line)))
	   (or rdis-blankscan-table (setq rdis-blankscan-table (charscan-table " ")))
	   (setq next-to-go start for-non-blanks 0)
	   (do ()((not (< next-to-go end+)))
	       (setq for-blanks (e_lap_$tct next-to-go (car rdis-blankscan-table) lrep))
	       (and (> (+ for-blanks next-to-go) end+)(setq for-blanks (- end+ next-to-go)))
	       (cond ((> for-blanks 0)	;real stuff to print
		    (cond ((< for-non-blanks 4)(DCTL-position-cursor (- next-to-go for-non-blanks) y)
					 (rdis-substr-display rdis-a-lotta-blanks 0 for-non-blanks))
			(t (DCTL-position-cursor next-to-go y)))
		    (rdis-substr-display lrep next-to-go for-blanks)
		    (setq next-to-go (+ for-blanks next-to-go))))
	       (or (< next-to-go end+)(return t))    ;ended nonblank
	       (setq for-non-blanks (e_lap_$tct next-to-go (cdr rdis-blankscan-table) lrep))
	       (setq next-to-go (+ next-to-go for-non-blanks)))
	   (return t)))

;;;
;;;	Eol-kill writearound for gran dumb tty's, BSG 2/12/80
;;;	Switched into DCTL-kill-line by display-init
;;;

(defun rdis-kill-eol-writearound ()
       (let ((l (or (lineln (screen Y)) 0)))
	  (and (> l X)(rdis-substr-display rdis-a-lotta-blanks X (- l X)))))

;;;
;;;	Minibuffer printing functions
;;;

(defun rdis-choose-echo-linex ()
       (rdis-enter-split minibuffer-split)
       (setq rdis-last-echolinex
	   (let ((mbottom (+ (numlines minibufwindow)
			 (startline minibufwindow) -1))
	         (mtop (startline minibufwindow))
	         (favor 99.)
	         (thisfavor 0)(favorite 0))
	        (do lx mtop (1+ lx)(> lx mbottom)
		  (setq thisfavor
		        (cond ((= lx rdis-mbuf-transient-linex) 10.)
			    ((or (null (screen lx))
			         (e_lap_$compare_strings
				 (linedata (screen lx)) 0
				 rdis-a-lotta-blanks 0
				 (lineln (screen lx))))
			     (cond ((= lx mtop) 30.)(t 20.)))
			    ((> lx rdis-last-echolinex) 40.)
			    ((and (< lx rdis-last-echolinex)
				(not (= lx mtop)))
			     50.)
			    ((= lx mtop) 60.)
			    ((= lx rdis-last-echolinex) 70.)
			    (t 80.)))
		  (cond ((< thisfavor favor)
		         (setq favor thisfavor favorite lx))))
	        (setq rdis-mbuf-transient-linex -1)
	        favorite)))

(defun echo-buffer-print (strg)
       (rdis-choose-echo-linex)
       (echo-buffer-overwrite strg rdis-last-echolinex))

(defun echo-buffer-utter (strg)
       (echo-buffer-print strg)
       (setq rdis-mbuf-transient-linex rdis-last-echolinex))

(defun echo-buffer-rewrite (strg)
       (echo-buffer-overwrite strg rdis-last-echolinex))

(defun echo-buffer-overwrite (strg linex)
       (rdis-enter-split minibuffer-split)
       (cond (tty-no-upmotionp (DCTL-nextline)
			 (DCTL-assert-scpos nil linex)
			 (DCTL-position-cursor 5 linex))
	   (t (redisplay-line nil (screen linex) linex)))
       (store (screen linex) nil)
       (store (newscreen linex) nil)
       (echo-buffer-print- (catenate "     " strg) linex))

(defun echo-buffer-print- (strg linex)
       (rdis-enter-split minibuffer-split)
       (let ((rdl (hokeup-line strg)))
	  (redisplay-line rdl (screen linex) linex)
	  (store (screen linex) rdl)
	  (store (newscreen linex) rdl)
	  (setq rdis-last-tty-upprint-x linex)
	  (DCTL-position-cursor (lineln rdl) linex)
	  (e_pl1_$dump_output_buffer)))

(defun hokeup-line (strg)
       (setq strg (parameterize-line
		(cons (catenate strg NLCHARSTRING) (ncons nil))))
       (rplac-lineln strg (min screenlinelen (lineln strg)))
       strg)

(defun echo-buffer-outprint (strg)
       (rdis-enter-split minibuffer-split)
       (let ((curline-there (screen rdis-last-echolinex)))
	  (cond ((null curline-there)(echo-buffer-print strg))
	        (t (echo-buffer-print-
		   (catenate (linedata curline-there) strg)
		   rdis-last-echolinex)))))

(defun echo-buffer-clear ()
       (echo-buffer-overwrite "" rdis-last-echolinex))

(defun echo-buffer-clear-all ()
       (rdis-enter-split minibuffer-split)
       (setq rdis-mbuf-transient-linex (startline minibufwindow))
       (do ((i rdis-mbuf-transient-linex (1+ i))
	  (end (+ (numlines minibufwindow) rdis-mbuf-transient-linex)))
	 ((= i end))
	 (echo-buffer-overwrite "" i)))

(defun echo-buffer-rubout (n)
       (rdis-enter-split minibuffer-split)
       (let ((rdl (screen rdis-last-echolinex)))
	  (let ((len (lineln rdl)))
	       (cond ((< len n)
		    (echo-buffer-clear))
		   (t (echo-buffer-print-
		        (substr (linedata rdl) 1 (- len n))
		        rdis-last-echolinex))))))

(defun ring-tty-bell ()
       (cond ((get tty-type 'tintinnabulum-ipsum-meum-sono) ;I ring my own bell
	    (DCTL-ring-tty-bell))
	   (t (Rtyo 007)))
       (e_pl1_$dump_output_buffer))

;;; 
;;;
;;;	Mode line maintenance
;;;

;;; This is for e_redisplay_.lisp

(defun update-mode-line ()
       (setq current-minor-mode-display-string
	   (cond ((null buffer-minor-modes) "")
	         (t (catenate
		    " <"
		    (apply 'catenate
			 (maplist
			   '(lambda (c)	;c = cons
				  (cond ((cdr c)
				         (catenate (car c) ", "))
				        (t (car c))))
			   buffer-minor-modes))
		    ">"))))
       (let ((modeline-contents "")
	   (pathline-contents ""))
	  (cond (mode-line-hook
		(let ((hook-result (funcall mode-line-hook)))
		     (setq modeline-contents (or (car hook-result) "")
			 pathline-contents (or (cadr hook-result) ""))))
	        (t (setq modeline-contents
		       (catenate
		         mode-line-herald
		         " ("
		         current-buffer-mode
		         current-minor-mode-display-string
		         ")"
		         (cond (read-only-flag " (RO)")(t ""))
		         " - "
		         current-buffer
		         (cond (user-display-variable
			       (catenate " " user-display-variable))
			     (t ""))))
		 (cond ((or buffer-modified-flag fpathname)
		        (setq pathline-contents
			    (catenate
			      (cond (buffer-modified-flag " *")
				  (t "  "))
			      (cond (fpathname (catenate " " fpathname))
				  (t ""))))))))
	  (setf (eline-contents phony-modeline-edline)
	        (catenate
		(cond ((> (stringlength modeline-contents) full-screenlinelen)
		       (substr modeline-contents 1 full-screenlinelen))
		      (t modeline-contents))
		NLCHARSTRING))
	  (setf (eline-contents phony-pathline-edline)
	        (catenate pathline-contents NLCHARSTRING)))
       (and split-mode-p
	  (setf (split-damaged model-split) t)))
;;; 
;;;
;;;	These things are called by the Fnpmeisters
;;;	    Output Conversion
;;;

(defun rdis-/#-of-\cs-in- (x)
       (let ((shrunkscreenl (- screenlinelen 2))
	   (shrunklinel (max 0 (- x 2))))
	  (1- (// (+ shrunkscreenl -1 shrunklinel) shrunkscreenl))))

(defun rdis-/#-of-\cs-to-make (x)
       (1- (// (+ screenlinelen -1 x)
	     screenlinelen)))

(defun detabbify (strg)			;MEOW!!!!!
       (aos rdis-detabb-meter)
       (e_lap_$rplacstring detab-buf "" 0 0 0)
       (do ((origstrl (1- (gstrgl strg)))
	  (strx 0)(ocol 0)(tabx))
	 ((not (< strx origstrl)) nil)

	 (setq tabx (rdis-tabscan strg origstrl strx))
	 (e_lap_$rplacstring-offset detab-buf strg tabx ocol (+ ocol tabx) strx)
	 (cond ((= (+ tabx strx) origstrl)
	        (return nil)))
	 (setq strx (+ strx tabx) ocol (+ ocol tabx))
	 (let ((ch (e_lap_$ggcharn strg strx))) ;funny char, huh!?
	      (cond ((= ch 11)		;tab
		   (let ((tl (- tab-equivalent (\ ocol tab-equivalent))))
		        (e_lap_$rplacstring detab-buf rdis-a-lotta-blanks tl ocol (+ ocol tl))
		        (setq ocol (+ tl ocol))))
		  ((and (= ch 10)		;underlining
		        (rdis-at-underline strg strx))
		   (e_lap_$rplacstring
		     detab-buf
		     (ascii (boole 7	;logior
			         400	;high-order bit
			         (rdis-underlined-char strg strx)))
		     1 (1- ocol) ocol)
		   (aos strx))
		  ((and (= ch 10)	;backspace
		        suppress-backspace-display))
		  ((and (= ch 177)	;rubout
		        suppress-rubout-display))
		  ((and (< ch 40)	;control character (including backspace)
		        suppress-ctlchar-display))
		  ((and (< ch 40) display-ctlchar-with-^)
		   (e_lap_$rplacstring detab-buf (catenate "^" (ascii (+ ch 100))) 2 ocol (+ ocol 2))
		   (setq ocol (+ 2 ocol)))
		  (t (setq ocol (+ ocol 4))
		     (e_lap_$rplacstring detab-buf (rdis-octescape ch) 4 (- ocol 4) ocol))))
	 (aos strx))			;end do- answer in detab-buf
       (cond ((not (> (stringlength detab-buf) screenlinelen))
	    (substr detab-buf 1))
	   (t (do ((n\c (rdis-/#-of-\cs-in- (stringlength detab-buf)) (1- n\c))
		 (insertx screenlinelen (+ insertx screenlinelen)))
		((= n\c 0)(substr detab-buf 1))

		(e_lap_$insert-chars detab-buf insertx "\c" 2)))))


(defun rdis-at-underline (strg strx)
       (and DCTL-underline-mask
	  (rdis-underlined-char strg strx)))


(defun rdis-underlined-char (strg strx)
       (prog (pc nc)
	   (cond
	     ((< strx 1) nil)
	     ((not (< strx (1- (gstrgl strg)))) nil)
	     (t (setq pc (e_lap_$ggcharn strg (1- strx)))
	        (setq nc (e_lap_$ggcharn strg (1+ strx)))
	        (cond ((< pc 40) nil)
		    ((< nc 40) nil)
		    ((= pc 137) (return nc))
		    ((= nc 137) (return pc))
		    (t nil))))))


(defun real-world-cursor-xcoord (strg charx)
       (prog (eolp answer)
	   (do  ((origstrl (1- (gstrgl strg)))
	         (strx 0) (ocol 0) (tabx) (lies 0))
	        ((not (< strx charx))
	         (setq eolp (= charx origstrl) answer (+ charx lies)))

	        (setq tabx (rdis-tabscan strg origstrl strx))
	        (setq strx (+ strx tabx) ocol (+ ocol tabx))
	        (cond ((not (< strx charx))
		     (return (setq eolp (= charx origstrl) answer (+ charx lies)))))
	        (let ((ch (e_lap_$ggcharn strg strx)))
		   (cond ((= ch 11)		;TAB
			(setq tabx (- tab-equivalent (\ ocol tab-equivalent))))
		         ((and (= ch 10)	;underline
			     (rdis-at-underline strg strx))
			(setq tabx -1))
		         ((and (= ch 10) suppress-backspace-display) (setq tabx 0))	;BS
		         ((and (= ch 177) suppress-rubout-display) (setq tabx 0))	;DEL to be suppressed
		         ((and (< ch 40) suppress-ctlchar-display) (setq tabx 0))	;ctl-char to be suppressed
		         ((and (< ch 40) display-ctlchar-with-^) (setq tabx 2))  ;^<char>
		         (t (setq tabx 4))))	;\nnn
	        (setq lies (+ -1 lies tabx) ocol (+ ocol tabx))	; -1 for orig tab char
	        (aos strx))			;end of do- answer in strg
	   (cond ((< answer screenlinelen))	;boundary case different here, 2l
	         ;; cant be less than 2 or 3 or so.
	         (t (setq answer (+ answer (* 2 (rdis-/#-of-\cs-in- answer))))
		  (and (not eolp)
		       (= 0 (\ answer screenlinelen))
		       (setq answer (+ 2 answer)))))
	   (return answer)))


(defun inverse-real-world-cursor-xcoord (strg schpos)
       (setq schpos (- schpos
		   (cond ((not (> schpos screenlinelen)) 0)
		         (t (* 2 (rdis-/#-of-\cs-to-make schpos))))))
       (do  ((origstrl (1- (gstrgl strg)))
	   (strx 0) (ocol 0) (tabx))
	  ((not (< ocol schpos))
	   strx)

	  (setq tabx (rdis-tabscan strg origstrl strx))
	  (cond ((not (< (+ ocol tabx) schpos))
	         (return (+ strx (- schpos ocol)))))
	  (setq strx (+ strx tabx) ocol (+ ocol tabx))
	  (let ((ch (e_lap_$ggcharn strg strx)))
	       (cond ((= ch 11)
		    (setq tabx (- tab-equivalent (\ ocol tab-equivalent))))
		   ((and (= ch 10)		;underline
		         (rdis-at-underline strg strx))
		    (setq tabx -1))
		   ((and (= ch 10) suppress-backspace-display))
		   ((and (= ch 177) suppress-rubout-display))
		   ((and (< ch 40) suppress-ctlchar-display))
		   ((and (< ch 40) display-ctlchar-with-^) (setq tabx 2))
		   (t (setq tabx 4))))
	  (setq ocol (+ ocol tabx))
	  (aos strx)))


(defun rdis-octescape (n)
       (implode (nreverse (list (prog1 (+ 60 (\ n 8.))(setq n (// n 8.)))
			  (prog1 (+ 60 (\ n 8.))(setq n (// n 8.)))
			  (+ 60 n)
			  '/\))))


(defun wwtcomp (el)				;with-what-to-compare, my dearie.
       (cond ((eq el curline) curstuff)
	   (t (car el))))


(defun gstrgl (x)				;general string length
       (cond ((stringp x)(stringlength x))
	   (t (filecons-length x))))

;;; 
;;;
;;;	Demand Redisplery.
;;;	rehacked 8/24/79 for ^v/esc-v with arguments and barfing.

(defun redisplay-window-from-eline (eline window)
       (go-to-line-point eline 0)		;convince the editor
       (rdis-upd-virtual-window-point window)
       (redisplay-window window eline 3))


(defun rdis-ensure-reasonable-window (window)
       (let ((first (startline window))
	   (stop (+ (startline window) (1- (numlines window))))
	   (ptel (car (bufmark window))))
	  (and (or (eq (eline-contents (eline (screen first))) 'deleted)
		 (do ((x first (1+ x)))
		     ((= x stop) t)
		     (and (eq (eline (screen x)) ptel) (return nil))))
	       (redisplay-window window ptel 1))))


(defun rdis-/#-of-lines-in- (eline)		;how many lines to display
       (max 1
	  (// (+  screenlinelen -1
		(real-world-cursor-xcoord (setq eline (wwtcomp eline))
				      (1- (gstrgl eline))))
	      screenlinelen)))


(defun prev-screen ()
       (rdis-forward-backward-screen (or numarg 1) 'backward))


(defun next-screen ()
       (rdis-forward-backward-screen (or numarg 1) 'forward))

(defun rdis-forward-backward-screen (howmany whichway)
       (and minibufferp (command-quit))
       (let ((window rdis-selected-wlist)
	   (step (- (numlines rdis-selected-wlist) screen-overlap)))
	  (and (< howmany 0)		;go the other way
	       (setq howmany (- howmany)
		   whichway (cond ((eq whichway 'forward) 'backward)
			        (t 'forward))))
	  (rdis-ensure-reasonable-window window)
	  (let ((catchr
		(catch
		  (progn
		    (redisplay-window-from-eline
		      (do ((el (eline (screen (startline window))))
			 (ct howmany (1- ct)))
			((= ct 0) el)
			(setq
			  el (cond
			       ((eq whichway 'forward)
			        (rdis-march-forward-screen-lines
				el step 'current))
			       (t (rdis-march-back-screen-lines
				  el step 'next))))
			(cond ((null el) (throw 'lose rdis-march))))
		      window)
		    'its-ok)
		  rdis-march)))
	       (cond ((eq catchr 'lose) (command-quit))
		   (t (rdis-find-last-foundx 
		        (startline window) (numlines window) curline))))))

;;; Place current line at given position in window (if possible)
(defun redisplay-current-window-relative (position)
       (and minibufferp (command-quit))
       (and (> position 0)(setq position (1- position)))	; 0/1 origin
       (setq rdis-have-redisplayed t)
       (cond ((< position 0)			;from bottom of window
	    (setq position (max 0 (+ (numlines rdis-selected-wlist) position))))
	   (t				;from top of window
	     (setq position (min position (1- (numlines rdis-selected-wlist))))))
       (let ((n (rdis-/#-of-lines-in- curline)))
	  (let ((actual-position		;where it should go counting long lines
		(cond ((> (+ position n) (numlines rdis-selected-wlist))
		       (cond ((> n (numlines rdis-selected-wlist)) position)
			   (t		;can push it up a little
			     (- (numlines rdis-selected-wlist) n))))
		      (t position))))	;fits nicely
	       (redisplay-window rdis-selected-wlist
			     (or 
			       (rdis-march-back-screen-lines curline actual-position 'next)
			       curline)
			     3)
	       (rdis-find-last-foundx (startline rdis-selected-wlist) (numlines rdis-selected-wlist) curline))))


;;; Command to scroll the current window up/down N lines
(defun scroll-current-window ()
       (and minibufferp (command-quit))
       (setq numarg (or numarg 1))		;default to down one line
       (and (= numarg 0) (command-quit))
       (rdis-ensure-reasonable-window rdis-selected-wlist)
       (let ((start (startline rdis-selected-wlist))
	   (numlines (numlines rdis-selected-wlist))
	   (newline curline))
	  (rdis-find-last-foundx start numlines curline)
	  (cond ((< numarg 0)		;scroll down
	         (redisplay-window rdis-selected-wlist
			       (or	;try to find new line
			         (rdis-march-back-screen-lines (eline (screen start))
						         (- numarg) 'current)
			         (command-quit)) ;couldn't
			       3)
	         (cond ((> (- last-foundx numarg)(+ start numlines -1))
		      (setq newline (eline (screen (+ start numlines -1))))
		      (let ((n (rdis-/#-of-lines-in- newline)))
			 (cond ((= n 1))	;no prob
			       ((< (prog2 (rdis-find-last-foundx start numlines newline)
				        last-foundx)
				 (+ start numlines (- n) 1)))
			       ((> n numlines)(setq newline (eline (screen start))))
			       (t (setq newline (eline-previous newline))
				(or newline (command-quit))))))))  ;??
	        (t			;scroll up
		(redisplay-window rdis-selected-wlist
			        (or	;try to find new line
				(rdis-march-forward-screen-lines (eline (screen start))
							   numarg 'next)
				(command-quit))	;couldn't
			        3)
		(cond ((< (- last-foundx numarg) start)
		       (setq newline (eline (screen start)))))))
	  (rdis-find-last-foundx start numlines newline)
	  (or (eq curline newline)	;no changes
	      (progn (go-to-line-point newline 0)
		   (rdis-upd-virtual-window-point rdis-selected-wlist))))))


(defun move-to-screen-edge ()
       (and minibufferp (command-quit))
       (rdis-ensure-reasonable-window rdis-selected-wlist)
       (and (zerop (or numarg 1)) (setq numarg 1)) ;make zero be equivalent to one
       (let ((target-line
	     (+ (startline rdis-selected-wlist) ;relative to this line on screen
	        (cond ((not numarg)		;go to middle of window
		     (quotient (numlines rdis-selected-wlist) 2))
		    ((< numarg 0)		;from bottom of window
		     (max 0 (+ numarg (numlines rdis-selected-wlist))))
		    (t			;from top of window
		      (min (1- numarg) (1- (numlines rdis-selected-wlist))))))))
	  (cond ((null (screen target-line))	;past end of buffer
	         (go-to-end-of-buffer))
	        (t			;there's a line there
		(go-to-line-point (eline (screen target-line)) 0)))))

;;; This new version by Barry Margolin.
(defun rdis-march-back-screen-lines (start count line-selector)
       (do ((n-lines 0)
	  (current (eline-previous start)	;start with previous line
		 (eline-previous current))
	  (last-current start current))
	 ((null current) last-current)	;until at start of buffer
	 (let ((n (rdis-/#-of-lines-in- current)))
	      (let ((new-n-lines (+ n-lines n)))
		 (cond ((= n-lines count)	;previous line is the one
		        (return (or (eline-next current) current)))
		       ((> new-n-lines count) ;this line does it
		        (cond ((eq line-selector 'current)
			     (return current))
			    ((eq line-selector 'next) ;wants next one
			     (return (or (eline-next current)
				       current)))
			    (t		;wants previous one
			      (return (or (eline-previous current)
				        current)))))
		       (t			;not there yet
		         (setq n-lines new-n-lines)))))))

(defun rdis-march-forward-screen-lines (start count line-selector)
       (do ((n-lines 0)
	  (current start (eline-next current)))	;from this line
	 ((null current) nil)		;ran off the edge
	 (let ((n (rdis-/#-of-lines-in- current)))
	      (let ((new-n-lines (+ n-lines n)))
		 (cond ((= n-lines count)	;this line is the one
		        (return current))
		       ((> new-n-lines count)	;this line is long and pushes us over
		        (cond ((eq line-selector 'current)
			     (return current))
			    ((eq line-selector 'next) ;wants next one
			     (return (or (eline-next current)
				       current)))
			    (t		;wants previous line
			      (return (or (eline-previous current)
				        current)))))
		       (t			;not there yet
		         (setq n-lines (+ n-lines n))))))))


(defun rdis-find-last-foundx (first num cl)
       (do ((x first (1+ x))
	  (lim (+ first num)))
	 ((not (< x lim))
	  (rbarf "rdis-find-last-foundx: can't."))
	 (cond ((eq (eline (screen x)) cl)
	        (setq last-foundx x)
	        (return nil)))))

;;;
;;;	Little interface for editor screen-hpos invocations
;;;

(defun go-to-screen-hpos (hp)
       (go-to-line-point curline (inverse-real-world-cursor-xcoord (wwtcomp curline) hp)))

(defun cur-screen-hpos ()
       (real-world-cursor-xcoord (wwtcomp curline) curpointpos))


;;; 
;;;
;;;	Reorganize screen on demand.
;;;

(defun reset-screen-size () (set-screen-size 2645.))


(defun set-screen-size (newsize)
       (rdis-assert-not-split-mode 'set-screen-size)
       (and split-mode-p
	  (display-error "You may not change screen size in split screen mode."))
       (setq newsize (min newsize (- screenheight (numlines minibufwindow)
			       (numlines modelwindow))))
       (cond ((< newsize 4)
	    (display-error "Invalid screen size: " (decimal-rep newsize)))
	   (t (cond ((= main-window-size newsize))
		  ((< main-window-size newsize)
		   (do i main-window-size (1+ i)(= i newsize)(store (screen i) nil)))
		  (t (do i newsize (1+ i)(= i main-window-size)
		         (cond ((and (screen i)(> (lineln (screen i)) 0))
			      (DCTL-position-cursor 0 i)
			      (DCTL-kill-line)))
		         (store (screen i) nil))))
	      (setq main-window-size newsize)
	      (rdis-reallocate-screen-evenly)
	      (rplac-numlines rdis-locdisp-window newsize))))


(defun rdis-cause-full-screen-recomputation ()
       (cond (split-mode-p			;only work hard if needed
	     (do ((i 0 (1+ i))
		(s))
	         ((= i nsplits))
	         (setq s (splits i))
	         (fillarray (split-eline-conts s) '(hphcs))    ;Not eq to anything
	         (setf (split-damaged s) t)))
	   (t				;non-split mode
	     (fillarray eline-conts '(hphcs)))) ;Not eq to anything
       (setq damaged-flag t
	   some-split-damaged split-mode-p))


(defun reset-minibuffer-size ()
       (rdis-assert-not-split-mode 'reset-minibuffer-size)
       (cond (tty-no-upmotionp
	    (set-minibuffer-size 1))
	   (t (set-minibuffer-size 2))))


(defun set-minibuffer-size (n)
       (rdis-assert-not-split-mode 'set-minibuffer-size)
       (prog (lucky-fellow newmlstart new-luckyfellow-size changed-top oldn)
	   (setq oldn (numlines minibufwindow))
	   (cond ((or (< n 1)(> n 6))(display-error "Invalid minibuffer size: " (decimal-rep n))))
	   (and (= n oldn)(return nil))
	   (setq lucky-fellow (windows (- nwindows 3)))
	   (setq new-luckyfellow-size
	         (- screenheight (startline lucky-fellow) n 2))
	   (cond ((< new-luckyfellow-size 3)
		(display-error "New minibuffer size would leave bottom window too small.")))
	   (setq newmlstart (- screenheight n 2))
	   (setq changed-top (cond ((< n oldn)(startline modelwindow))
			       (t newmlstart)))
	   (rplac-numlines lucky-fellow new-luckyfellow-size)
	   (rplac-startline modelwindow newmlstart)
	   (rplac-startline minibufwindow (+ 2 newmlstart))
	   (rplac-numlines minibufwindow n)
	   (setq main-window-size newmlstart)
	   (rplac-numlines rdis-locdisp-window newmlstart)
	   (setq rdis-last-echolinex (+ 2 newmlstart))
	   (do lx changed-top (1+ lx)(= lx screenheight)
	       (or (null (screen lx))(= 0 (lineln (screen lx)))
		 (progn (DCTL-position-cursor 0 lx)
		        (DCTL-kill-line)
		        (store (screen lx) nil))))
	   (rdis-cause-full-screen-recomputation)))

;;; 
;;;
;;;	Redisplay features to provide "local" displays that are
;;;	not editable and do not consume screen.
;;;
;;;	BSG 7/27/78
;;;

(defun init-local-displays ()
       (rdis-cause-full-screen-recomputation)
       (rdis-enter-local-display-split)
       (setq rdis-locdisp-linex
	   (cond (rdis-have-redisplayed (startline rdis-locdisp-window))
	         ((numberp rdis-locdisp-linex) rdis-locdisp-linex)
	         (t (startline rdis-locdisp-window))))
       (setq rdis-have-redisplayed nil)
       (cond (tty-no-upmotionp
	     (DCTL-nextline)
	     (setq rdis-last-tty-upprint-x -1)
	     (store (screen rdis-locdisp-linex) nil))))


(defun end-local-displays ()			;wait for response
       (rdis-cause-full-screen-recomputation)
       (cond (tty-no-upmotionp		;nothing to hold.
	     (e_pl1_$dump_output_buffer))
	   ((eq rdis-locdisp-linex 'abort)
	    (e_pl1_$dump_output_buffer)
	    (redisplay))
	   (t
	     (let ((local-display:force-no-more t))
		local-display:force-no-more
		(local-display-generator-nnl local-display-end-string))
	     (e_pl1_$dump_output_buffer)
	     (setq rdis-suppress-redisplay t))))


(defun local-display-generator-nnl (arg)
       (local-display-generator (catenate arg NLCHARSTRING)))


(defun local-display-current-line ()
       (local-display-generator (curline-as-string)))


(defun local-display-generator (string)
       (prog (rdis-line moregen-result nlines)
	   (or rdis-locdisp-linex (init-local-displays))
	   (and (eq rdis-locdisp-linex 'abort)(return t))
	   (setq rdis-line (parameterize-line (ncons string)))
	   (setq nlines (rdis-/#-of-lines-in- (eline rdis-line)))
	   (cond ((and tty-no-upmotionp overstrike-availablep))	;printing
	         ((= rdis-locdisp-linex (startline rdis-locdisp-window)))	;may have tried already
	         ((and (not local-display:force-no-more)
		     (> (+ nlines rdis-locdisp-linex)
		        (1- (numlines rdis-locdisp-window))))
		(setq moregen-result
		      (rdis-local-display-MORE-generator))))
	   (cond (moregen-result
		 (setq rdis-locdisp-linex 'abort)
		 (return nil)))
	   (do ((n nlines (1- n))
	        (rdl (linedata rdis-line) (substr rdl (1+ screenlinelen)))
	        (linel (lineln rdis-line)(- linel screenlinelen)))
	       ((= n 0))
	       (rdis-local-display-install-line
	         (cond ((> linel screenlinelen)(substr rdl 1 screenlinelen))
		     (t rdl))
	         (min screenlinelen linel)))
	   (setq rdis-suppress-redisplay t)
	   (return nil)))


(defun rdis-local-display-install-line (string len)
       (store (newscreen rdis-locdisp-linex)
	    (cons nil (cons string len)))
       (store (eline-conts rdis-locdisp-linex) 'random-not-found)
       (redisplay-line (newscreen rdis-locdisp-linex)
		   (screen rdis-locdisp-linex)
		   rdis-locdisp-linex)
       (cond ((screen rdis-locdisp-linex)
	    (let ((rdl (screen rdis-locdisp-linex)))
	         (rplac-linedata rdl string)
	         (rplac-lineln rdl len)))
	   (t (store (screen rdis-locdisp-linex)
		   (newscreen rdis-locdisp-linex))))
       (cond ((and tty-no-upmotionp overstrike-availablep)	;printing
	    (DCTL-nextline)
	    (store (screen 0) nil))
	   (t (aos rdis-locdisp-linex))))


(defun rdis-local-display-MORE-generator ()
       (rdis-local-display-install-line "--More?-- (space = yes, CR = no) " 33.)
       (DCTL-position-cursor 33. (1- rdis-locdisp-linex))
       (e_pl1_$dump_output_buffer)
       (prog1 (let ((char (get-char)))
	         (cond ((or (= char (CtoI "y"))(= char (CtoI " "))) nil)
		     (t t)))
	    (DCTL-position-cursor 0 (1- rdis-locdisp-linex))
	    (DCTL-kill-line)
	    (store (screen (1- rdis-locdisp-linex)) nil)
	    (setq rdis-locdisp-linex (startline rdis-locdisp-window))
	    (e_pl1_$dump_output_buffer)))

(defun set-lisp-rdis-meters ()
       (emacs$set_lisp_rdis_meters
         rdis-rdis-meter full-rdis-meter rdis-detabb-meter
         rdis-detab-opt-meter rdis-wgen-meter rdis-wgen-c1-meter
         rdis-wgen-c2-meter rdis-wgen-c3-meter rdis-ndf-opt-meter
         rdis-bad-echnego-meter))
;;;
;;;
;;; Split Management
;;;

;;;
;;;

(defun rdis-enter-split (new-split)
       ;; Opens a new split, saving the current split away. Moves cursor.
       (cond ((not (eq new-split current-split))	;only if different
	    (rdis-instate-split new-split)
	    (rdis-select-split new-split))))	;change on terminal

(defun rdis-select-window-split (window)
       ;; places the display cursor into the split that window is in
       (rdis-select-split (window-split window)))

(defun rdis-select-split (s)
       ;; activates a split on the terminal
       (cond ((not (eq rdis-cursor-split s))
	    (setq rdis-cursor-split s)
	    (setq X -777 Y -777)		;cursor location not kept for non-current splits
	    (DCTL-select-split (split-id s)))))

(defun rdis-instate-split (new-split)
       ;; saves current split data and instates new-split. Leaves cursor alone.
       (cond ((eq current-split new-split))	;don't work needlessly
	   (t (rdis-update-split-struct)	;save current state
	      (rdis-open-split new-split))))	; make it the new current split

(defun rdis-open-split (new-split)
       ;; opens a new split by unpacking it into global variables
       (setq current-split    new-split
	   screenlinelen    (split-line-length new-split)
	   screenheight	(split-height new-split)
	   main-window-size screenheight
	   damaged-flag	(split-damaged new-split)
	   screen		(split-screen new-split)
	   eline-conts	(split-eline-conts new-split)
	   windows	(split-windows new-split)
	   nwindows	(split-nwindows new-split)))

(defun rdis-update-split-struct ()
       ;; ensure split consistent after window creation/destruction
       (setf (split-damaged current-split) damaged-flag)
       (setf (split-nwindows current-split) nwindows)
       (or some-split-damaged			;keep track of damage
	 (setq some-split-damaged damaged-flag)))    ;   for redisplay

(defun rdis-enter-local-display-split ()
       (cond ((not split-mode-p))		;don't do un-needed work
	   (t (let ((new-locdisp-split (find-best-locdisp-split)))	;place it nicely
		 (cond ((not (eq new-locdisp-split rdis-locdisp-split))	;different
		        (setq rdis-locdisp-split new-locdisp-split)
		        ;;fix bogus window up
		        (setf (numlines rdis-locdisp-window) (split-height rdis-locdisp-split))
		        (setf (window-split rdis-locdisp-window) rdis-locdisp-split))))
	      (rdis-enter-split rdis-locdisp-split))))


;;; find best place to place local display
(defun find-best-locdisp-split ()
       (do ((ix 1 (1+ ix))
	  (s))
	 ((> ix nusplits) rdis-selected-split)	;use current if none found
	 (setq s (splits (usplits ix)))
	 (cond ((not (eq s rdis-selected-split))     ;use first usplit not = that of current window
	        (return s)))))

(defun rdis-create-split (sll swidth shgt shomex shomey window-to-place)
       ;; creates a split object and a terminal split
       (and (= nsplits maxsplits)
	  (display-error "Attempt to create too many splits: " (decimal-rep (1+ nsplits))))
       (let ((sid (pop split-ids-available))
	   (s))
	  (setq s (make-split id sid
			  line-length sll
			  width swidth
			  height shgt
			  home-X shomex
			  home-Y shomey
			  damaged t	;make redisplay take notice
			  screen (*array nil t shgt)
			  eline-conts (*array nil t shgt)
			  windows (*array nil t (max 1 (// (1+ shgt) 4))) ;at least 3 lines + divider in window
			  nwindows 1))
	  (setf (splits nsplits) s)
	  (setq nsplits (1+ nsplits))
	  (setf (arraycall t (split-windows s) 0) window-to-place)
	  (alter-window window-to-place
		      window-split s	;link to split
		      startline 0		;reposition at top
		      numlines shgt)	;window gets whole split
	  (DCTL-create-split sid shomex shomey swidth shgt)    ;leaves cursor there
	  s))				;return newly created split

(defun destroy-split (split-ix)
       (let ((sid (split-id (splits split-ix))))
	  (do ((i split-ix (1+ i)))		;move things down
	      ((= i (1- nsplits)))
	      (setf (splits i) (splits (1+ i))))
	  (setq nsplits (1- nsplits))
	  (setf (splits nsplits) nil)		;clear out last one
	  (DCTL-destroy-split sid)
	  (push sid split-ids-available)))	;free split id

(defun split-display-mode ()
       (prog ()
	   (if (not DCTL-hardware-windows-availablep)
	       (display-error "Split support is not available in your terminal."))
	   (if pop-up-windows		;this for JRM
	       (display-error "Turn off pop-up-windows. It is not supported with splits."))
	   (if split-mode-p
	       (display-error-noabort "Split display mode is already in effect.")
	       (return nil))
	   (setq full-screenlinelen screenlinelen    ;remember these for later reversion
	         full-screenheight screenheight)
	   (let
	     ((mbsize) (split-width) (split-ll) (split-hgt) (minisplit-width) (old-split0))
	     (setq mbsize (numlines minibufwindow)
		 split-width (// (rdis-real-ll screenlinelen) nuwindows)	;evenly apportion
					; forget about excess screen width.
					; It is almost always too much trouble (2 splits, no excess)
		 split-ll (1- split-width)	;in case terminal fumbles cursor at last char
		 split-hgt (- screenheight mbsize 2)	;screen less minibuf and mode/path
		 minisplit-width (rdis-real-ll screenlinelen))	;ensure minibuf full width

	     ;; make it look like clean slate
	     (setq old-split0 (splits 0))	;will be referencing contents but array ref is dead
	     old-split0			;reference it to stop compiler warning
	     (fillarray splits '(nil))
	     (fillarray usplits '(nil))
	     (setq nsplits 0 nusplits 0)
	     (setq split-ids-available nil)
	     (do ((i (1- DCTL-max-splits)
		   (1- i)))
	         ((< i 0))
	         (push i split-ids-available))

	     ;; create minibuffer split
	     (setq minibuffer-split		;minibuf at bottom
		 (rdis-create-split minisplit-width minisplit-width mbsize 0 (- screenheight mbsize) minibufwindow))

	     ;; create mode-line/path-line split
	     (setq model-split		;a two line split
		 (rdis-create-split minisplit-width minisplit-width 2 0 (- screenheight mbsize 2) modelwindow))

	     ;; now create user splits, one per user window
	     (do ((i 1 (1+ i))
		(s))
	         ((> i nuwindows))
	         (setq s (rdis-create-split split-ll split-width split-hgt (* (1- i) split-width) 0 (uwind i)))
	         (setf (uwindows i) (make-uwindow
				windowx 0 ;first window in split
				split s)) ;connect user window to split
	         (setf (usplits i) (1- nsplits))))   ;connect user split to split

	   (*rearray windows)		;scrap old windows stuff
	   (rdis-open-split (window-split rdis-selected-wlist))	;find current window in correct split
	   (setq rdis-selected-split current-split)
	   (rdis-select-split rdis-selected-split)

	   (setq split-mode-p t
	         nusplits nuwindows
	         suppress-redisplay-flag nil	;restart redisplay
	         rdis-suppress-redisplay nil
	         rdis-locdisp-linex nil)
	   (full-redisplay)))		;wake up redisplay

(defun rdis-real-ll (ll)
       ;; adjust a screen line-length to account for odd lengths
       ;; (which are due to terminal fumbling cursor in last column)
       (cond ((oddp ll) (1+ ll))
	   (t ll)))

(defun revert-split-mode ()
       ;; goes from split mode to standard display
       (or split-mode-p (display-error "Not in split display mode."))

       (rdis-restore-screen-to-one-split)

       ;; adjust the redisplay arrays
       (*rearray windows)
       (*rearray screen)
       (*rearray eline-conts)
       (setq windows (*array nil t 50.)
	   screen  (*array 'screen t full-screenheight)	;both named and ptr
	   eline-conts (*array 'eline-conts t full-screenheight))	;...

       ;; fix up windows
       (setf (windows 0) rdis-selected-wlist)
       (setf (windows 1) modelwindow)
       (setf (windows 2) minibufwindow)
       (setq nwindows 3
	   nuwindows 1)

       ;; fix up splits
       (fillarray usplits '(nil))
       (setf (usplits 1) 0)
       (fillarray splits '(nil))
       (setf (splits 0) (make-split id 0
			      line-length full-screenlinelen
			      width full-screenlinelen
			      height full-screenheight
			      home-X 0
			      home-Y 0
			      damaged t
			      screen screen
			      eline-conts eline-conts
			      windows windows
			      nwindows 3))
       (setq nsplits 1
	   nusplits 1
	   current-split (splits 0)
	   rdis-locdisp-split nil
	   rdis-cursor-split current-split
	   rdis-selected-split current-split
	   model-split current-split
	   minibuffer-split current-split)

       ;; make windows refer to correct split
       (setf (window-split rdis-selected-wlist) (splits 0))
       (setf (window-split modelwindow) (splits 0))
       (setf (window-split minibufwindow) (splits 0))

       ;; fix user window array
       (fillarray uwindows '(nil))
       (setf (uwindows 1) (make-uwindow windowx 0 split (splits 0)))

       ;; fix redisplay variables
       (setq rdis-lru-stack '(1)
	   rdis-multiwindowed-buflist nil
	   selected-window 1		;user window index
	   rdis-selected-windowx 0		;real window index
	   two-window-mode nil
	   screenheight full-screenheight
	   screenlinelen full-screenlinelen
	   main-window-size (- screenheight (numlines minibufwindow) (numlines modelwindow))
	   split-mode-p nil)

       ;; fix local displays
       (setf (numlines rdis-locdisp-window) main-window-size)
       (setf (window-split rdis-locdisp-window) (splits 0))
       (setq rdis-locdisp-split nil)

       ;; fix fake windows
       (setf (startline modelwindow) main-window-size)
       (setf (startline minibufwindow) (+ 2 main-window-size))

       ;; now make it take
       (full-redisplay))

(defun init-split-management ()
       ;; initializes the innards of split screen stuff
       (setq splits (*array nil t DCTL-max-splits)
	   usplits (*array nil t DCTL-max-splits))
       (fillarray splits '(nil))
       (fillarray usplits '(nil 0 nil))
       (setf (splits 0)
	   (make-split id 0
		     line-length screenlinelen
		     height screenheight
		     damaged t
		     screen screen
		     eline-conts eline-conts
		     windows windows
		     nwindows 3))		;mini, model + 1 user window
       (let ((split-0 (splits 0)))
	  (setf (window-split minibufwindow) split-0)
	  (setf (window-split modelwindow) split-0)
	  (setf (window-split (uwind 1)) split-0)    ;fix user window struct
	  (setf (uwindow-split (uwindows 1)) split-0)
	  (setq split-mode-p nil
	        nsplits 1
	        nusplits 1
	        maxsplits (cadr (arraydims splits))
	        maxusplits (1- (cadr (arraydims usplits)))     ;usplit 0 unused
	        current-split split-0
	        minibuffer-split current-split
	        model-split current-split
	        rdis-selected-split current-split
	        )))

(defun rdis-restore-screen-to-one-split ()
       (cond (split-mode-p			;protect it
	     (do ((i 1 (1+ i)))
	         ((= i nsplits))
	         (DCTL-destroy-split (split-id (splits i))))
	     (DCTL-create-split (split-id (splits 0))	;make 0 full screen
			    0 0		;home position
			    (rdis-real-ll full-screenlinelen)	;adjust for cursor wierdness
					;		  at eol fudge
			    full-screenheight)
	     (e_pl1_$dump_output_buffer)
	     (sleep 0.75))))		;MCS write-abort write-around

(defun rdis-recreate-splits-on-screen ()
       (and split-mode-p			;protect it
	  (do ((i 0 (1+ i))
	       (s))
	      ((= i nsplits) (e_pl1_$dump_output_buffer))
	      (setq s (splits i))
	      (DCTL-create-split (split-id s)
			     (split-home-X s) (split-home-Y s)
			     (split-width s) (split-height s)))))

(defun rdis-assert-not-split-mode (operation)
       (and split-mode-p			;barf if splits on
	  (display-error operation " is not supported in split display mode."))
       t)					;passed, return something nice 




		    e_self_documentor_.lisp         08/20/86  2312.3r w 08/20/86  2245.0      162144



;;; ***********************************************************
;;; *                                                         *
;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
;;; *                                                         *
;;; * Copyright (c) 1978 by Massachusetts Institute of        *
;;; * Technology and Honeywell Information Systems, Inc.      *
;;; *                                                         *
;;; ***********************************************************
;;;
;;;
;;;	Self-documentation System
;;;	 BSG 9/30/78 - 10/07/78
;;;	 Ut veritatem ipsam suam ipse dicet.

;;;	 Hacked 10/5/79 by BSG for defcom macrology.
;;;	 Hacked March 1981 by CWH to clean up describe/explain-command.

(declare (genprefix /!e_sd_))
(%include e-macros)
(declare (*expr center-line e_info_vfilesman_$get_recp e_info_vfilesman_$open
	      e_info_vfilesman_$seek e_info_vfilesman_$update
	      e_lap_$gsubstr exch-point-mark get-key-binding get-key-name
	      key-prompt mark-same-line-p runoff-fill-paragraph 
	      runoff-fill-region untabify))
(declare (special site-dir
	 doc-pack-open-mode doc-pack-curfun doc-pack-mark
	 doc-pack-rec-status fill-prefix tty-no-upmotionp))


(setq doc-pack-open-mode nil)


;;; Read documentation for given function from vfile
(defun get-doc (fun)
       (or (let ((d (get fun 'documentation)))
	       (if d
		 (setq doc-pack-rec-status nil)
		 (insert-string d))
	       d)
	 (progn
	   (or doc-pack-open-mode (doc-pack-open 'read))
	   (if (not (= 0 (e_info_vfilesman_$seek fun)))
	       (if (get fun 'editor-macro)
		 (insert-string
		   (catenate
		     "$$$ is a keyboard macro.  Type $$extended-command$ "
		     "show-macro " fun " CR to display its definition."))
		 else
		 (insert-string
		   (catenate "No documentation for " fun " found.")))
	       else
	       (let ((recp-result (e_info_vfilesman_$get_recp)))
		  (if (not (= 0 (caddr recp-result)))
		      else
		      (insert-string (e_lap_$gsubstr
				   (cons (car recp-result)
				         (cadr recp-result))
				   0 (cadr recp-result)))))))))


;;; Open the vfile for given mode
(defun doc-pack-open (mode)
       (let ((code (e_info_vfilesman_$open site-dir
				   (cond ((eq mode 'update) 1)
				         (t 0)))))
	  (if (not (= 0 code))
	      (display-com-error code "Cannot open the the info file for " mode "."))))


;;; Update documentation of current function
(defcom update-cmd-doc
        (go-to-end-of-buffer)
        (e_info_vfilesman_$update (point-mark-to-string doc-pack-mark)
			    (cond ((eq doc-pack-rec-status nil)
				 (display-error
				   "Record state inconsistent"))
				((eq doc-pack-rec-status 'new) 1)
				(t 0)))
        (minibuffer-print "Updated " doc-pack-curfun)
        (let ((code (e_info_vfilesman_$seek doc-pack-curfun)))
	   (if (not (= code 0))
	       (setq doc-pack-curfun 'Ze/ Garbage doc-pack-rec-status nil)
	       (display-com-error code "Problem updating vfile.")))
        (setq buffer-modified-flag nil
	    doc-pack-rec-status 'old))	;buffer now in file


;;; Setup to edit the documentation vfile
(defcom edit-emacs-cmd-doc
        &documentation "Enters Emacs command documentation update
         mode.  Requires write access to the info vfile."
       (or (eq doc-pack-open-mode 'update)
	 (doc-pack-open 'update))
       (go-to-or-create-buffer 'Command/ Documentation)
       (set-key '^X^S 'update-cmd-doc)
       (set-key '^X^A 'update-cmd-doc-from-old)
       (setq current-buffer-mode 'Doc/ Update)
       (without-saving (destroy-buffer-contents)))



;;; Edit documentation of a particular function
(defcom edit-cmd-doc
        &arguments ((command-name &prompt "Extended command to document: "))
        &doc "Fetches for editing the command documentation for
        an emacs extended command"
        (setq doc-pack-curfun command-name)
        (edit-emacs-cmd-doc)
        (insert-string command-name)
        (do-times 2 (new-line))
        (register-local-var 'doc-pack-mark)
        (setq doc-pack-mark (set-mark))
        (setq doc-pack-rec-status
	    (cond ((= 0 (e_info_vfilesman_$seek command-name))
		 (get-doc command-name)
		 'old)
		(t
		 (minibuffer-print "Not yet documented... Input the new doc.")
		 'new)))
       (and tty-no-upmotionp (display-buffer-as-printout)))


;;; Read documentation from old info segment
(defun get-old-style-doc (charrep)
       (save-excursion-buffer
         (go-to-or-create-buffer 'emacs-document)
         (if (empty-buffer-p 'emacs-document)
	   (read-in-file (catenate env-dir ">" "editor.info")))
         (go-to-beginning-of-buffer)
         (if (samepnamep (substr charrep 1 3) "esc")
	   (setq charrep (catenate "ESC" (substr charrep 4))))
         (do-forever
	 (if (looking-at charrep)
	     (skip-to-whitespace)
	     (skip-over-whitespace)
	     (with-mark m
		      (next-line)
		      (do-forever
		        (if (at-white-char)
			  (next-line)
			  else (stop-doing)))
		      (return (point-mark-to-string m))))    ;unwp release s mark
	 (if (lastlinep)
	     (setq charrep nil) (return ""))
	 (next-line))))


;;; Update documentation of a key's binding
(defun update-cmd-doc-from-old ()
       (let ((kp3 (key-prompt "Update Key Doc: ")))
	  (let ((symbol (get-key-name kp3))
	        (cmd (get-key-binding kp3)))
	       (edit-cmd-doc cmd)
	       (if numarg
		 (with-mark m
			  (insert-string (get-old-style-doc symbol))
			  (with-mark n
				   (go-to-mark m)
				   (do-forever
				     (if-at TAB (delete-char))
				     (if (mark-on-current-line-p n)
				         (stop-doing))
				     (next-line))))))))


;;; Replace all command names with key binding (if any)
(defun replace-substitutable-command-names (curcmd buf)
       (do-forever
         (if (not (forward-search "$$"))(stop-doing))
         (do-times 2 (rubout-char))
         (with-mark start
		(forward-search "$")
		(rubout-char)
		(let ((sym (make_atom (point-mark-to-string start))))
		     (without-saving (wipe-point-mark start))
		     (if (nullstringp sym)(insert-string curcmd)
		         else
		         (let ((val (find-key-in-buf sym buf)))
			    (if val (insert-string val)
			        else (insert-string sym))))))))


;; "description" is of the form "^S", "^X^S", or "esc-X describe".  It
;;  is substituted into the command documentation at appropriate places.
;; "symbol" is the lisp symbol the command is associated with, and is used
;;   to find the command documentation.
;; "first-line" is the first line of text to appear in the local display.

(defun describe-internal (description symbol first-line)
  (let ((original-buffer current-buffer))
    (display-as-printout
      (remprop current-buffer 'temporary-buffer)
      (setq buffer-modified-flag t)
      (insert-string first-line)
      (do-times 2 (new-line))
      (insert-command-doc symbol description original-buffer)
      (putprop current-buffer t 'temporary-buffer))))


;;; Describe an extended command
(defcom describe
        &arguments ((symbol &symbol &prompt "Extended command to describe: "))
        (let ((description (get-extcommed-name symbol current-buffer)))
	(describe-internal description symbol description)))


;;; Print documentation of a key's binding
(defun explain-command ()
  (let ((key (key-prompt "Explain Key: ")))
    (let ((symbol (get-key-binding key))
	(description (get-key-name key)))
      (describe-internal description symbol
		     (catenate description "		" symbol)))))


;;; Get "key" name of an extended command
(defun get-extcommed-name (cmd buf)
       (let ((excname (find-key-in-buf 'extended-command buf)))
	  (if (nullstringp cmd) excname
	      else (catenate excname " " cmd))))


;;; Insert documentation of a function into buffer
(defun insert-command-doc (cmd key-name origbuf)
       (with-mark
         m
         (get-doc cmd)
         (go-to-mark m)
         (replace-substitutable-command-names key-name origbuf)
         (go-to-mark m)
         (set-the-mark)
         (go-to-end-of-buffer)
         (region-fill-by-paragraphs)))


;;; Get key's binding in specified buffer
(defun get-cmd-symbol-in-buf (key buf)
       (save-excursion-buffer
         (go-to-or-create-buffer buf)
         (get-key-binding key)))


;;; Find key in buffer with given binding
(defun find-key-in-buf (cmd buf)
       (save-excursion-buffer
         (go-to-or-create-buffer buf)
         (catch
	 (progn
	   (map-over-emacs-commands
	     (function (lambda (ktps cname ss)
			   (if (eq ss cname)
			       (throw ktps find-key-))))
	     cmd)
	   nil)
	 find-key-)))


;;; Describe a key
(defun describe-key ()
       (if numarg (show-command-name)
	 else (explain-command)))


;;; Show name of binding of a key
(defun show-command-name ()
       (let ((k (key-prompt "Show Key Function: ")))
	  (let ((kn (get-key-name k))
	        (cmd (get-key-binding k)))
	       (if (memq cmd '(nil undefined-command))
		 (minibuffer-print kn " is not defined in this buffer.")
		 else
		 (cond ((getl cmd '(subr expr))
		        (minibuffer-print kn " = " cmd))
		       ((get cmd 'editor-macro)
		        (minibuffer-print kn " = " cmd " (keyboard macro)"))
		       (t (minibuffer-print kn " = " cmd " (unimplemented)")))))))


;;; Fill region a paragraph at a time

(defun region-fill-by-paragraphs ()
       (with-the-mark-last
         m				;loop in order
         (go-to-beginning-of-line)
         (if (mark-on-current-line-p m)
	   (insert-string fill-prefix)
	   else
	   (do-forever
	     (do-forever			;find beginning of para
	       (if (mark-on-current-line-p m)(stop-doing))
	       (if (at-white-char)(next-line)
		 else (stop-doing)))
	     (if (or (mark-on-current-line-p m)
		   (point>markp m))
	         (stop-doing))
	     (with-mark first-good-stuff
		      (insert-string fill-prefix)
		      (do-forever
		        (if (mark-on-current-line-p m)(stop-doing))
		        (if (line-is-blank)(stop-doing)
			  else (next-line)))
		      (if (line-is-blank)(prev-line))
		      (go-to-end-of-line)
		      (move-mark der-wahrer-mark first-good-stuff)
		      (without-saving (runoff-fill-region))
		      (if (or (point>markp m)
			    (mark-on-current-line-p m))
			(release-mark first-good-stuff)
			(stop-doing)))))))


;;; Document all keys and extended commands defined in buffer
(defcom document-buffer-commands
        &documentation "Creates a document similar to fundamental-mode.info
        describing all commands and bindings, suitable for dprinting."
        (prog (env was-mode buf)
	    (setq was-mode current-buffer-mode buf current-buffer)
	    (set (setq env (gensym)) nil)
	    (map-over-emacs-commands
	      (function (lambda (symbol suspect arg)
			    (cond ((memq suspect '(self-insert read-meta-argument)))
				(t (set arg (cons (cons symbol suspect)
					        (symeval arg)))))))
	      env)
	    (go-to-or-create-buffer
	      (make_atom (catenate  current-buffer ".doc")))
	    (setq buffer-modified-flag t)
	    (destroy-buffer-contents)
	    (insert-string "Multics Emacs Commands")
	    (insert-string " (")
	    (insert-string was-mode)
	    (insert-string " mode) ")
	    (insert-string (date))
	    (do-times 2 (new-line))
	    (insert-string TAB)
	    (insert-string "K__e_y_s _a_n_d _t_h_e_i_r _b_i_n_d_i_n_g_s")
	    (new-line)
	    (insert-string (catenate TAB TAB))
	    (insert-string
	      (catenate "(Extended (" (get-extcommed-name "" buf) ") commands are listed at the end.)" ))
	    (do-times 2 (new-line))
	    (document-emacs-functions-to-buffer
	      (symeval env) buf 1)
	    (let ((extcomsym (make_atom (catenate was-mode ".ext-commands")))
		(fill-prefix ""))
	         (if (boundp extcomsym)
		   (do-times 4 (new-line))
		   (insert-string (catenate TAB TAB TAB))
		   (insert-string "E__x_t_e_n_d_e_d C__o_m_m_a_n_d_s")
		   (do-times 2 (new-line))
		   (insert-string
		     (catenate
		       "Type " (get-extcommed-name "" buf)
		       " followed by the command name, and a carriage return"
		       " to invoke these commands."))
		   (let ((numarg 1))(runoff-fill-paragraph))
		   (do-times 2 (new-line))
		   (document-emacs-extcomms-to-buffer
		     (set extcomsym (sort (symeval extcomsym) 'alphalessp))
		     buf 1 )))))


;;; Put documentation of given extended commands into buffer
(defun document-emacs-extcomms-to-buffer (clist buf parm)
       (setq fill-prefix "   ")
       (let ((excn (get-extcommed-name "" buf)))
	  (do l clist (cdr l)(null l)
	      (let ((cmd (car l))
		  (exname (catenate excn " " (car l))))
		 (insert-string exname)
		 (do-times 2 (new-line))
		 (delete-white-sides)
		 (let ((numarg parm))
		      (insert-command-doc cmd exname buf))
		 (do-times 2 (new-line))
		 (delete-white-sides)))))
		     

;;; Put documentation of given commands into buffer
(defun document-emacs-functions-to-buffer (clist buf parm)
       (setq fill-prefix "   ")
       (do l (sortcar clist 'alphalessp)(cdr l)(null l)
	 (let ((key (caar l))
	       (cmd (cdar l)))
	      (insert-string key)
	      (format-to-col 20.)
	      (insert-string cmd)
	      (do-times 2 (new-line))
	      (delete-white-sides)
	      (let ((numarg parm))
		 (insert-command-doc cmd key buf))
	      (do-times 2 (new-line))
	      (delete-white-sides))))


;;; Apropos first written 5/24/78 by BSG and archy.
(defcom apropos
        &arguments ((string &prompt "String to match for apropos commands: "))
        (prog (env was-mode was-buf extcom-matches)
	    (setq was-mode current-buffer-mode was-buf current-buffer)
	    (setq env (ncons string))
	    (map-over-emacs-commands
	      (function (lambda (symbol suspect arg)
			    (cond ((memq suspect '(self-insert read-meta-argument)))
				((not (= 0 (index suspect (car arg))))
				 (rplacd arg (cons (cons symbol suspect)
					         (cdr arg)))))))
	      env)
	    (setq extcom-matches
		(sort (mapcan
		        (function (lambda (x)
				      (if (not (= 0 (index x string)))
					(list x))))
		        (symeval  'Fundamental/.ext-commands))
		      'alphalessp))		;TEMP KLUDGE!!!
	    (if (not (or extcom-matches (cdr env)))
	        (display-error "apropos:  No matches for " string))
	    (save-excursion-buffer
	      (go-to-or-create-buffer 'apropros)
	      (setq buffer-modified-flag t)
	      (destroy-buffer-contents)
	      (insert-string "Apropos """)
	      (insert-string string)
	      (insert-string """")
	      (insert-string " (")
	      (insert-string was-mode)
	      (insert-string " mode)")
	      (do-times 2 (new-line))
	      (list-emacs-functions-to-buffer (cdr env))
	      (if extcom-matches
		(new-line)
		(insert-string "Extended Commands:")
		(do-times 2 (new-line))
		(let ((exname (get-extcommed-name "" was-buf)))
		     (mapc '(lambda (x)
				(insert-string (catenate
					       exname " " x))
				(new-line))
			 extcom-matches)))
	      (display-buffer-as-printout)
	      (putprop current-buffer t 'temporary-buffer)))
        (end-local-displays)))


;;; Make a chart of all key bindings in this buffer
(defcom make-wall-chart
        (prog (env was-mode)
	    (setq was-mode current-buffer-mode)
	    (set (setq env (gensym)) nil)
	    (map-over-emacs-commands
	      '(lambda (symbol suspect arg)
		     (cond ((memq suspect '(self-insert read-meta-argument)))
			 (t (set arg (cons (cons symbol suspect)
				         (symeval arg))))))
	      env)
	    (go-to-or-create-buffer 'wall-chart)
	    (setq fill-column 133.)
	    (setq buffer-modified-flag t)
	    (destroy-buffer-contents)
	    (insert-string "Multics Emacs Wall Chart")
	    (insert-string " (")
	    (insert-string was-mode)
	    (insert-string " mode)  ")
	    (insert-string (date))
	    (center-line)
	    (do-times 3 (new-line))
	    (with-mark bob
		     (list-emacs-functions-to-buffer (symeval env))
		     (new-line)
		     (n-way-columnate-region 3 bob 50.))
	    (go-to-beginning-of-buffer)
	    (setq buffer-modified-flag nil)))

;;; List given keys' bindings to buffer
(defun list-emacs-functions-to-buffer (list)
       (do ((l (sortcar list 'alphalessp) (cdr l)))
	 ((null l))
	 (insert-string (printable (caar l)))
	 (format-to-col 10.)
	 (insert-string (cdar l))
	 (cond ((not (getl (cdar l) '(expr subr autoload)))
	        (format-to-col 30.)
	        (insert-string (cond ((get (cdar l) 'editor-macro)
				"(keyboard macro)")
			         (t "(unimplemented)")))))
	 (new-line)))

;;;
;;;   Columnate stuff BSG 10/31/79
;;;

(declare (special FF tab-equivalent))

(defun n-way-columnate-region (n mark pagel)
       (if (point>markp mark)(exch-point-mark mark))
       (untabify tab-equivalent)
       (let ((maxl 0)
	   (nlines 0)
	   (mlist nil))
	  (unwind-protect
	    (progn
	      (save-excursion
	        (do-forever
		(if (mark-on-current-line-p mark)(stop-doing))
		(if (= 0 (\ nlines pagel))(setq mlist (cons (set-mark) mlist)))
		(setq nlines (1+ nlines))
		(go-to-end-of-line)
		(skip-back-whitespace-in-line)
		(setq maxl (max maxl (cur-hpos)))
		(next-line)))
	      (save-excursion
	        (n-way-columnate-generate n mark pagel
				    (1+ maxl)
				    nlines
				    (reverse mlist)))
	      (without-saving (wipe-point-mark mark)))
	    (mapc 'release-mark mlist))))

(defun n-way-columnate-generate (n mark pagel maxl nlines mlist)
       (go-to-end-of-buffer)
       (do-forever
         (do lno 0 (1+ lno)(= lno pagel)
	   (new-line)
	   (do ((depth 0 (1+ depth))
	        (l mlist (cdr l)))
	       ((= depth n))
	       (if (and (car l)(not (mark-same-line-p mark (car l))))
		 (setq nlines (1- nlines))
		 (whitespace-to-hpos (* depth maxl))
		 (insert-string
		   (save-excursion
		     (go-to-mark (car l))
		     (go-to-end-of-line)
		     (skip-back-whitespace-in-line)
		     (prog2 0
			  (point-mark-to-string (car l))
			  (if (not (lastlinep))
			      (next-line)
			      (set-mark-here (car l)))))))
	       (delete-white-sides))
	   (if (< nlines 1)(stop-doing)))
         (new-line)
         (insert-string FF)
         (do i n (1- i)(= i 0)(setq mlist (cdr mlist)))
         (if (< nlines 1)(stop-doing))))





		    e_tasking_.pl1                  08/01/88  1002.5r w 08/01/88  0953.1       64980



/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1981 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

e_tasking_: procedure (P_emacs_data_ptr, P_code);

/* Procedure to do the work of maintaining a tasking Emacs.
   22 July 1981 RMSoley
   Modified: April 1982 CAHornig to update to tasking version 3.
   Modified: April 1982 RMSoley for cleanup on destroy_task.
   Modified: 25 November 1983 B. Margolin for shared_static option.
*/

/* Parameters */
dcl  P_code fixed bin (35) parameter;
dcl  P_emacs_data_ptr pointer parameter;

/* System Entries */
dcl  com_err_ entry() options(variable);
dcl  cu_$get_cl_intermediary entry (entry);
dcl  cu_$set_cl_intermediary entry (entry);
dcl  emacs_$tasking_emacs entry ();
dcl  get_system_free_area_ entry() returns(ptr);
dcl  ioa_ entry() options(variable);
dcl  task_ctl_$create entry (ptr, bit(36) aligned, fixed bin(35));
dcl  task_ctl_$destroy entry (bit(36) aligned, fixed bin(35));
dcl  task_ctl_$schedule entry() returns(bit(1) aligned);
dcl  task_ctl_$start entry (bit(36) aligned, fixed bin(35));
dcl  task_ctl_$stop entry (bit(36) aligned, fixed bin(35));

/* Static */
dcl  emacs_data_$version character (10) static external;
dcl  emacs_data_$force_tasking bit (1) aligned static external;
dcl  emacs_data_$invocation_list pointer static external;

/* Automatic */
dcl  code fixed bin (35);
dcl  ran_task bit (1);
dcl  1 TCD aligned like task_create_data;

/* Based */

/* Builtin */
dcl (addr, baseno, bin, codeptr, hbound, stackbaseptr, unspec) builtin;

/* Conditions */
dcl  program_interrupt condition;
dcl  unquiet_grave condition;

/* Include Files */
%include emacs_data;
%include task_create_data;

	emacs_data_ptr = P_emacs_data_ptr;

	if emacs_data.arguments.destroy_task then do;
	     call run_task ("1"b);
	     P_code = -1;
	     return;
	end;
	if emacs_data.arguments.no_task then do;
	     P_code = 0;
	     return;
	end;
	if emacs_data.tasking.task_flags.in_task then do;
	     call run_task ("0"b);
	     P_code = -1;
	     return;
	end;
	else if emacs_data.arguments.task
	     | emacs_data_$force_tasking then do;
	     call create_task ();
	     call run_task ("0"b);
	     P_code = -1;
	     return;
	end;
	else do;
	     P_code = 0;
	     return;
	end;

returner:
	P_code = code;
	return;

create_task: procedure ();

	emacs_data.tasking.task_flags.in_task = "1"b;
	emacs_data.tasking.task_flags.destroy = "0"b;
	TCD.version = task_create_data_version_3;
	TCD.overseer = tasking_overseer;
	TCD.vcpu_limit = -1;
	TCD.priority = 1;
	TCD.comment = "Emacs Task";
	TCD.data_ptr = null ();
	string (TCD.flags) = ""b;
	TCD.flags.shared_static = emacs_data.arguments.shared_static;
	TCD.flags.top_level = "1"b;

	call task_ctl_$create (addr (TCD), emacs_data.tasking.task_id, code);
	if code ^= 0 then do;
	     call com_err_ (code, emacs_data.myname, "Could not create task.");
	     go to returner;
	end;

	return;
     end create_task;

run_task: procedure (mark_for_death);

dcl  mark_for_death bit (1) parameter;

	if ^emacs_data.tasking.task_flags.in_task then do;
	     call com_err_ (0, emacs_data.myname, "There is no tasking Emacs to restart.");
	     go to returner;
	end;

	emacs_data.tasking.task_flags.destroy = mark_for_death;

	call task_ctl_$start (emacs_data.tasking.task_id, code);
	if code ^= 0 then do;
	     call com_err_ (code, emacs_data.myname, "Cannot start Emacs task.");
	     go to returner;
	end;

	ran_task = task_ctl_$schedule ();
	call check_death_request ();

	return;
     end run_task;

destroy_task: procedure ();

	if ^emacs_data.tasking.task_flags.in_task
	     then call com_err_ (0, emacs_data.myname, "There is no Emacs task to destroy.");
	else go to emacs_data.tasking.return_label;

/*	else call task_ctl_$destroy (emacs_data.tasking.task_id, (0));

	if emacs_data_$invocation_list = emacs_data_ptr
	     then emacs_data_$invocation_list = emacs_data.next_invocation;
	if emacs_data.next_invocation ^= null ()
	     then emacs_data.next_invocation -> emacs_data.prev_invocation = emacs_data.prev_invocation;
	if emacs_data.prev_invocation ^= null ()
	     then emacs_data.prev_invocation -> emacs_data.next_invocation = emacs_data.next_invocation;
	free emacs_data;
*/
	return;
     end destroy_task;

check_death_request: procedure ();

	if emacs_data.tasking.task_flags.destroy then call destroy_task ();

     end check_death_request;

tasking_overseer: entry (P_data_ptr);

dcl  P_data_ptr pointer parameter;

	emacs_data_ptr = e_find_invocation_ ();

	emacs_data.tasking.return_label = task_death;

	/* Remember that while the above portions of e_tasking_
	   run on the NORMAL stack, THIS portion runs on the
	   EMACS stack. */

	call cu_$get_cl_intermediary (emacs_data.tasking.saved_cl_intermediary);
	call cu_$set_cl_intermediary (resume_old_stack);

	call emacs_$tasking_emacs ();

	/* Must resume the old (NORMAL) stack. */

	call cu_$set_cl_intermediary (emacs_data.tasking.saved_cl_intermediary);
	call task_ctl_$stop (emacs_data.tasking.task_id, code);
	ran_task = task_ctl_$schedule ();

	/* Should never get to here.  Should have resumed on the
	   old stack, and never returned.
	   However, who cares.  We'll just return to Hornig and
	   let him handle it!!  -- Soley

	signal unquiet_grave;	*/

	return;

task_death:
	return; /* To tasking primitives for task destruction. */

resume_old_stack: entry ();

	emacs_data_ptr = e_find_invocation_ ();

	call cu_$set_cl_intermediary (emacs_data.tasking.saved_cl_intermediary);
	call task_ctl_$stop (emacs_data.tasking.task_id, code);
	call check_death_request ();
	ran_task = task_ctl_$schedule ();

	/* When we get to here, the NORMAL stack has resumed us.
	   We are still on the Emacs stack at this point. */

	call check_death_request ();
	call cu_$set_cl_intermediary (resume_old_stack);
	signal program_interrupt;

quit: entry () returns (fixed bin (35));

	emacs_data_ptr = e_find_invocation_ ();

	if ^emacs_data.tasking.task_flags.in_task then return (-1);
	call cu_$set_cl_intermediary (emacs_data.tasking.saved_cl_intermediary);
	call task_ctl_$stop (emacs_data.tasking.task_id, code);
	call check_death_request ();
	ran_task = task_ctl_$schedule ();

	/* When we get to here, the NORMAL stack has resumed us.
	   We are still on the Emacs stack at this point. */

	call check_death_request ();
	call cu_$set_cl_intermediary (resume_old_stack);
	signal program_interrupt;

destroy_me: entry ();

	emacs_data_ptr = e_find_invocation_ ();

	emacs_data.tasking.task_flags.destroy = "1"b;
	return;

get_death_flag: entry () returns (fixed bin);

	emacs_data_ptr = e_find_invocation_ ();

	if emacs_data.tasking.task_flags.destroy then return (1);
	else return (0);

get_tasking_flag: entry () returns (fixed bin);

	emacs_data_ptr = e_find_invocation_ ();

	if emacs_data.tasking.task_flags.in_task then return (1);
	else return (0);

     end e_tasking_;




		    e_terminal_io_.pl1              11/30/82  1504.2rew 11/30/82  1333.1       19206



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1981 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */
  

e_terminal_io_: procedure ();
	return;

/* Procedure to (eventually) contain all of the Emacs terminal IO control
   PL/I logic.

   23 November 1981, Richard Mark Soley
*/

/* Parameters */
dcl  P_terminal_type character (*) parameter;

/* System Entries */
dcl  mode_string_$get_mode entry (char(*), char(*), ptr, fixed bin(35));
dcl  ttt_info_$modes entry (char(*), char(*), fixed bin(35));

/* Builtin */
dcl (addr, translate) builtin;

/* Automatic */
dcl  code fixed bin (35);
dcl  modes character (512);
dcl  1 MV like mode_value aligned automatic;

/* Include Files */
%include mode_string_info;

/* Entry to check TTF and find out if the given terminal type is
   a printing terminal, so don't have to ask user.
   Returns 1 if DEFINITELY a printing terminal; 0 if DEFINITELY non-printing
   OR not certain. */

check_printing: entry (P_terminal_type) returns (fixed bin);

	MV.version = mode_value_version_3;

	call ttt_info_$modes (translate (P_terminal_type,
	     "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz"),
	     modes, code);
	if code ^= 0 then return (0);

	call mode_string_$get_mode (modes, "pl", addr (MV), code);
	if code ^= 0 then return (0);

	if MV.flags.boolean_valuep then do;
	     if MV.flags.boolean_value then return (0);
	     else return (1);
	end;

	if MV.flags.numeric_valuep & (MV.numeric_value = 0) then return (1);

	return (0); /* END for check_printing */

end e_terminal_io_;




		    e_window_mgr_.lisp              08/01/88  1002.5rew 08/01/88  0948.5      283014



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

;;;

;;;
;;;	Multics Emacs Window Manager


;;; HISTORY COMMENTS:
;;;  1) change(84-01-19,Margolin), approve(), audit(), install():
;;;     pre-hcom history:
;;;               27 April 1979 by BSG
;;;               To DLW, MARG, RMS, and all the others who
;;;                think/thought about this mishegoss all day long.
;;;     Modified: 19 January 1984 - Barmar - commented out register-option form,
;;;                   as it was moved to e_option_defaults_.
;;;  2) change(84-12-25,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Slashified #'s, changed lambda's to
;;;     let's, use defmacro, use the uwind macro in places where it
;;;     it is spelled out.
;;;  3) change(84-12-26,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Fixed bug in rdis-update-window-struct
;;;     that I put in last night when rewriting lambda's.
;;;  4) change(84-12-27,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     Fix the rewritten lambda in rdis-window-totenpurge.
;;;  5) change(84-12-28,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     remove buggy optimization from rdis-update-window-struct.
;;;  6) change(85-01-06,Margolin), approve(86-02-24,MCR7186),
;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
;;;     changed to use set-mark-here instead
;;;     of rplac'ing marks manually.  This may also fix some bugs, since
;;;     it now updates curline-marklist.  Changed to use make-mark
;;;     and make-eline in wman-init, rather than cons.
;;;  7) change(88-01-15,Schroth), approve(88-02-29,MCR7852),
;;;     audit(88-06-08,RBarstad), install(88-08-01,MR12.2-1071):
;;;     Implement Window Mgr portions of Split Screen Display.
;;;     Used some defstruct's suggested by Barry Margolin.
;;;                                                      END HISTORY COMMENTS


;;;	(Multics Emacs screen mgmt, vers. 3)

(%include defmacro)
(declare (macros nil))
(%include backquote)
(%include e-macros)				;for defvar
(%include emacs-internal-macros)
(%include emacs-rdis-dcls)
(%include other_other)

(declare (*expr rdis-instate-split rdis-update-split-struct rdis-assert-not-split-mode))
(declare (*expr decimal-rep del-mark-from-buffer e_lap_$gsubstr empty-buffer-p
	      get-buffer-state go-to-mark go-to-or-create-buffer gstrgl 
	      rdis-cause-full-screen-recomputation set-mark set-mark-here wwtcomp))
;;;
;;;	Declarations.  See main redisplay for meaning.
;;;
;;; (register-option 'pop-up-windows nil) ;moved to e_option_defaults_
(declare (*lexpr display-error display-error-noabort minibuffer-print
	       display-error-remark))
(declare (genprefix /!rdis_wman_))
(declare (special current-buffer minibufferp numarg damaged-flag number-of-lines-in-buffer))
(declare (special screenheight main-window-size default-new-window-size))
(declare (special pop-up-windows rdis-suppress-rupdate tty-no-upmotionp))
(declare (special known-buflist))
(declare (special two-window-mode selected-window modelwindow minibufwindow
	        nwindows nuwindows rdis-splln-mark phony-modeline-edline))

(declare (special  screenlinelen rdis-lru-stack rdis-multiwindowed-buflist
	         rdis-selected-wlist rdis-selected-windowx rdis-locdisp-window
	         current-split nsplits rdis-selected-split split-mode-p))
(declare (array* (fixnum (wman-lrux-array ?))))
;;;
;;;	Window management initialization. Called at end of rdis-init.
;;;

(defun wman-init ()
       (setq nuwindows 1 nwindows 3 selected-window 1 two-window-mode nil)
       (and tty-no-upmotionp (setq pop-up-windows nil))
       (setq rdis-suppress-rupdate nil)
       (setq windows (*array nil t 50.))	;changed to array pointer Aug/85 EDS
       (setq uwindows (*array nil t 50.))
       (*array 'wman-lrux-array 'fixnum screenheight)
       (setq main-window-size (- screenheight 3) default-new-window-size nil)
       (store (windows 0) (make-window numlines main-window-size))
       (store (windows 1) (setq modelwindow
			  (make-window startline (- screenheight 3)
				     numlines 2)))
       (store (windows 2) (setq minibufwindow
			  (make-window startline (- screenheight 1)
				     numlines 1)))
       (setq rdis-splln-mark (make-mark
			 eline (make-eline
			         contents
			         (do ((c "--------" (catenate c c)))
				   ((> (stringlength c) screenlinelen)
				    (substr c 1 (1+ screenlinelen)))))
			 position 0))
       (setq rdis-lru-stack (list 1) rdis-multiwindowed-buflist nil)
       (fillarray uwindows '((nil nil) (0 nil) (nil nil)))
       (setq rdis-selected-wlist (windows 0) rdis-selected-windowx 0)
       (setq rdis-locdisp-window
	   (make-window numlines (numlines (windows 0))))
       (rplac-bufmark (windows 1) (make-mark eline phony-modeline-edline
				     position 0))
       nil)


;;;
;;;
;;;	Window from-editor and from-redisplay updates.
;;;


;; Called at buffer-kill time from buffer-kill


(defun redisplay-purge-buffer (bufnam)
       (prog (orign u)
	   (or (boundp 'nuwindows)(return nil))
a
       (setq orign nuwindows u 1)
b
       (redisplay-purge-buffer-window bufnam u)
       (or (= orign nuwindows)(go a))
       (aos u)
       (and (> u orign)(return nil))
       (go b))))

;;; Re-initting abuffer must flush all marks, which will
;;; not be relocated, and might point to a scrapped temp-seg
;;; from the redisplay.  The next select on that window would
;;; redisplay around that garbage did we not do this.
;;; (see (cond ((bufmark... in select-window).

(defun redisplay-buffer-reinit-purge (bufnam)
       (do u 1 (1+ u)(> u nuwindows)
	 (let ((w (uwind u)))
	      (cond ((eq bufnam (bufsym w))
		   (rplac-bufmark w nil))))))

(defun lruify-current-window ()(rdis-lruify-window selected-window))
(defun lruify-window (u)(rdis-lruify-window u))

(defun find-buffer-in-window (bufnam)
       (let ((found-window (buffer-on-display-in-window bufnam)))
	  (cond (found-window
		(select-window found-window))
	        (pop-up-windows (wman-place-buffer bufnam))
	        (t (select-window (car (last rdis-lru-stack)))
		 (go-to-or-create-buffer bufnam)))
	  (rdis-update-window-struct)))

(defun buffer-on-display-in-window (bufnam)
       (do u 1 (1+ u)(> u nuwindows)
	 (and (eq bufnam (bufsym (uwind u)))
	      (return u))))

;;;
;;;
;;;	Dynamic redisplay-time window maintenance.
;;;

(defun rdis-update-window-struct ()		;Called by redisplay et al.
       (cond (rdis-suppress-rupdate)
	   ((eq current-buffer (bufsym rdis-selected-wlist))
	    (or (bufmark rdis-selected-wlist)
	        (rplac-bufmark rdis-selected-wlist (set-mark)))
	    (let ((m (bufmark rdis-selected-wlist))) ;makes marks
	         (set-mark-here m)))		;update the mark
	   (t (rdis-upd-virtual-window-point rdis-selected-wlist)))
       ;; Update LRU stack
       (setq rdis-lru-stack
	   (cons selected-window
	         (delq		;MULTICS MACLISP DEPENDENCY EQ FIXNUMS
		 selected-window rdis-lru-stack))))


(defun rdis-upd-virtual-window-point (window)
       ;; 85-09-10 EDS to look at windows through all splits
       (cond ((numberp window)(setq window (windows window))))
       (cond ((not (eq current-buffer (bufsym window)))
	    (do ((u 1 (1+ u))		;user window index
	         (testbuf)
	         (oldbuf (bufsym window))
	         (oldoccurs 0)	;Multiplicity of oldbuf
	         (newoccurs 0))	;Multiplicity of newbuf
	        ((= u nuwindows)
	         (setq oldoccurs (1- oldoccurs) newoccurs (1+ newoccurs))
	         (cond ((< oldoccurs 2)
		      (setq rdis-multiwindowed-buflist
			  (delq oldbuf rdis-multiwindowed-buflist))))
	         (cond ((> newoccurs 1)
		      (setq rdis-multiwindowed-buflist
			  (cons current-buffer (delq current-buffer rdis-multiwindowed-buflist))))))
	        (setq testbuf (bufsym (uwind-real-window u)))
	        (cond ((eq testbuf oldbuf)(aos oldoccurs))
		    ((eq testbuf current-buffer)(aos newoccurs))))))
       (del-mark-from-buffer (bufmark window)(bufsym window))
       (rplac-bufsym window current-buffer)
       (rplac-bufmark window (set-mark))))


(defun redisplay-purge-buffer-window (bufnam u)
       (let ((window (uwind-real-window u)))
	  (cond ((eq (bufsym window) bufnam)
	         (cond (pop-up-windows
		       (wman-fenestra-nata-est-virgo u)
		       (cond ((> nuwindows 1)
			    (select-other-window)
			    (delete-window u))))
		     (t (rdis-lruify-window u)
		        (rdis-fenestra-nata-est-virgo window)
		        (rplac-bufmark window nil)))))))
;; Leave bufsym around, no empty windows please.

;;; Some utility functions

(defun uwind-real-window (u)
       ;; returns true window given user window index factoring in splits
       (let ((uw (uwindows u)))
	  (arraycall t
		   (split-windows (uwindow-split uw))	;containing split's window array
		   (uwindow-windowx uw))))	;index of uwindow into same

(defun nuwindows-in-split (nrws)
       ;; computes number of uwindows given number of real windows in split
       ;; user windows in a split are followed by separator windows, hence // 2
       (cond (split-mode-p (// (1+ nrws) 2))
	   (t	       (// (1- nrws) 2))))	;don't count model or minibuf
;;;
;;;
;;;	Called by e_ when a buffer is exited.
;;;

(defun redisplay-leave-buffer ()		;current buffer implied
       (do ((u 1 (1+ u))
	  (slcbuf (bufsym rdis-selected-wlist))
	  (window))
	 ((> u nuwindows))
	 (setq window (uwind-real-window u))
	 (cond ((eq current-buffer (bufsym window))  ;Got one with guy in it
	        (cond ((or (eq window rdis-selected-wlist)     ;Update real guy
		         (not (eq current-buffer slcbuf)))
		     (rdis-bufleave-upd window)
		     (return nil)))))))  ;Dont upd many windows of same.

(defun rdis-bufleave-upd (window)
       (cond ((null (bufmark window))
	    (rplac-bufmark window (set-mark)))
	   (t (let ((m (bufmark window)))
		 (set-mark-here m)))))
;;;

;;;  Window genesis, no-pop up case.

(defun rdis-nata-est-fenestra ()		;Window is born
       (and (or (> nwindows (- (cadr (arraydims windows)) 4))
	      (> nuwindows (- (cadr (arraydims uwindows)) 2)))
	  (display-error "Too many windows, total."))
       (prog (ux wx window nnuw nnw quo)
	   (setq nnuw (1+ nuwindows)
	         nnw (+ 2 nwindows)
	         quo (// main-window-size (nuwindows-in-split nnw)))
	   (or (> quo 2)(display-error "Too many windows for this screen size."))
	   (setq wx (cond (split-mode-p (1- nnw))    ;no minibuf and model
		        (t	  (- nnw 3)))  ;only split has it all
	         ux nnuw
	         window (make-window
		        startline 0 numlines 0 bufmark nil
		        bufsym (make_atom (catenate "Window " (decimal-rep ux) " Default"))
		        window-split current-split))
	   (store (windows (- nnw 1))(windows (- nwindows 1)))
	   (store (windows (- nnw 2))(windows (- nwindows 2)))
	   (store (windows (- nnw 3)) window)
	   (store (windows (- nnw 4)) (wman-create-divider 0))
	   (store (uwindows ux) (make-uwindow windowx wx split current-split))
	   (setq nuwindows nnuw nwindows nnw)
	   (setq two-window-mode t)
	   (rdis-reallocate-screen-evenly)
	   (rdis-lruify-window ux)
	   (rdis-update-split-struct)))

(defun rdis-lruify-window (u)
       (setq rdis-lru-stack
	   (nconc (delq u rdis-lru-stack)(list u))))

(defun rdis-fenestra-nata-est-virgo (w)		;Gets done by cause-full-rc
       (do ((x (startline w)(1+ x))		;in creation case.
	  (ctr (numlines w)(1- ctr)))
	 ((= ctr 0))
	 (store (eline-conts x) 'hphcs)))	;See redisplay, rdis-wdw

(defun rdis-reallocate-screen-evenly ()
       (let ((nuws (nuwindows-in-split nwindows)))
	  (do ((w 0 (1+ w))
	       (startl 0)
	       (real-ws 0)
	       (thisw)
	       (howdeep)
	       (quo (// main-window-size nuws)) ;window + sep line size
	       (rem (\ main-window-size nuws))) ;extra lines
	      ((= real-ws nuws))
	      (setq thisw (windows w))
	      (cond ((eq (bufmark thisw) rdis-splln-mark)
		   (setq howdeep 1))
		  ((< real-ws rem)
		   (setq howdeep quo)
		   (aos real-ws))
		  (t (setq howdeep (1- quo))
		     (aos real-ws)))
	      (and (= real-ws nuwindows)(setq howdeep (1+ howdeep)))
	      (rplac-startline thisw startl)
	      (rplac-numlines thisw howdeep)
	      (setq startl (+ startl howdeep)))
	  (rdis-cause-full-screen-recomputation)))

;;;

;;; Window destruction

(defun remove-window ()			;command
       (rdis-assert-not-split-mode 'remove-window)
       (delete-window (or numarg selected-window)))
	    
;;; Enter one window mode
(defun expand-window-to-whole-screen ()
       (rdis-assert-not-split-mode 'expand-window-to-whole-screen)
       (do ((u 1 (1+ u))
	  (windows-to-go))
	 ((> u nuwindows)
	  (mapc 'rdis-delete-uwindow windows-to-go))
	 (or (= u selected-window)
	     (setq windows-to-go (cons u windows-to-go)))))

(defun delete-window (u)
       (rdis-assert-not-split-mode 'delete-window)
       (cond ((or (< u 1)(> u nuwindows))
	    (display-error "Invalid window number: " (decimal-rep u)))
	   ((not two-window-mode)
	    (display-error "Not in multi-window mode"))
	   ((= u selected-window)
	    (select-other-window)))
       (rdis-delete-uwindow u)
       (rdis-update-split-struct))

(defun rdis-delete-uwindow (u)
       ;; delete user window given index
       (let ((uw (uwindows u))		;link to real window
	   (ocs current-split)		;saved current-split
	   (uws))				;split containing uwindow
	  (setq uws (uwindow-split uw))
	  (and (eq (uwind u) rdis-selected-wlist)
	       (display-error "Attempt to destroy selected window"))
	  (and (= 1 (split-nwindows uws))	;only 1 window in split?
	       (display-error "Attempt to destroy only window in split"))
	  (do uu 0 (1+ uu)(> uu nuwindows)
	      (cond ((> uu u)(store (uwindows (1- uu))(uwindows uu)))))
	  (sos nuwindows)
	  (rdis-instate-split uws)		;switch splits if needed
	  (rdis-delete-rwindow (uwindow-windowx uw))
	  (rdis-instate-split ocs)		;restore real current split
	  (setq rdis-lru-stack (delq u rdis-lru-stack))
	  (and (> selected-window u)(sos selected-window))
	  (setq two-window-mode (> nuwindows 1))
	  (map '(lambda (x)(and (> (car x) u)(rplaca x (1- (car x)))))
	       rdis-lru-stack)))

(defun rdis-delete-rwindow (r)
       (prog (upper lower nlines window scbottom upstairsadd downstairsadd)
	   (setq window (windows r) scbottom (1- main-window-size))
	   (setq upper (startline window) nlines (numlines window)
	         lower (+ upper (1- nlines)) nlines (1+ nlines))
	   (cond ((and (= upper 0)(= lower scbottom))
		(rbarf "rdis-delete-rwindow: deleting all that's left")))
	   (rdis-window-totenpurge window)
	   (cond ((= upper 0)		;This is the top window
		(rdis-remove-divider (1+ r))
		(rdis-adjust-window (1+ r)(- nlines) nlines))
	         ((= lower scbottom)
		(rdis-remove-divider (1- r))
		(sos r)
		(rdis-adjust-window (1- r) 0 nlines))
	         (t (rdis-remove-divider (1+ r))
		  (setq upstairsadd (// nlines 2) downstairsadd (- nlines upstairsadd))
		  (rdis-adjust-window (- r 2) 0 upstairsadd)
		  (rdis-adjust-window (- r 1) upstairsadd 0) ;divider
		  (rdis-adjust-window (+ r 1) (- downstairsadd) downstairsadd)))
	   (rdis-condense-out-window r)
	   (rdis-cause-full-screen-recomputation)))

(defun rdis-remove-divider (w/#)
       (or (eq (bufmark (windows w/#)) rdis-splln-mark)(rbarf "rdis-remove-divider: not a divider: " w/#))
       (rdis-condense-out-window w/#))

(defun rdis-condense-out-window (w/#)
       (do w 0 (1+ w)(= w nwindows)
	 (and (> w w/#)(store (windows (1- w))(windows w))))
       (and (= w/# rdis-selected-windowx)
	  (rbarf "rdis-condense-out-window: called on current: " w/#))
       (and (> rdis-selected-windowx w/#)(sos rdis-selected-windowx))
       (sos nwindows)
       (do ((u 1 (1+ u))
	  (uw))
	 ((> u nuwindows))
	 (setq uw (uwindows u))
	 (and (> (uwindow-windowx uw) w/#)
	      (decf (uwindow-windowx uw)))))

(defun rdis-adjust-window (w addstart addnl)
       (setq w (windows w))
       (rplac-startline w (+ addstart (startline w)))
       (rplac-numlines w (+ addnl (numlines w))))

(defun rdis-window-totenpurge (window)
;;; This thoroughly ingenious hack totally cleans out all traces of the
;;; buffer that was in here and updates the multiwindowed list.
       (let ((ocb current-buffer)
	   (current-buffer (gensym)))
	  (rdis-upd-virtual-window-point window)
	  (del-mark-from-buffer (bufmark window) ocb)))
;;;
;;;
;;;	Demand Window Selection.
;;;

(defun select-window (utag)
       (prog (window)
	   (and minibufferp (display-error "No window selection from minibuffer."))
	   (and (or (< utag 1)
		  (> utag nuwindows))
	        (display-error "Non-existant window number: " (decimal-rep utag)))
;;; This next line is a source of infinite grief and the root of all hair
;;; and bugs.  When not in pop-up mode, it ensures that ^XB/^XO done
;;; "real fast" (redisplayless) indeed updates the new buffer into the
;;; old window, if not the old buffer would not show up in the wlist.
;;; Now in pop-up mode, it is completely wrong, because people
;;; have to find-buffer-in-window current-buffer's, which would tend to update
;;; that buffer into old and new windows.  "What is truth?" -Pilate.

	   (and (or (not pop-up-windows)
		  (eq current-buffer (bufsym rdis-selected-wlist)))
	        (rdis-update-window-struct))
	   (setq selected-window utag)
	   (rdis-instate-split (uwind-split utag))   ;switch splits
	   (setq window (uwind utag))
	   (setq rdis-selected-wlist window
	         rdis-selected-windowx (uwindow-windowx (uwindows utag))
	         rdis-selected-split (window-split window))
	   (go-to-or-create-buffer (bufsym window))
	   (cond ((bufmark window)(go-to-mark (bufmark window))))
	   (rdis-update-window-struct)
	   (setq damaged-flag t)))

(defun create-new-window-and-stay-here ()
       (rdis-assert-not-split-mode 'create-new-window-and-stay-here)
       (rdis-nata-est-fenestra))

(defun create-new-window-and-go-there ()
       (rdis-assert-not-split-mode 'create-new-window-and-go-there)
       (rdis-nata-est-fenestra)
       (rdis-select-lru-window))

(defun select-another-window ()
       (and (not two-window-mode)
	  (display-error "Not in two window mode."))
       (cond ((not numarg)(rdis-select-lru-window))
	   ((or (< numarg 1)(> numarg nuwindows))
	    (display-error "Invalid window number: " (decimal-rep numarg)))
	   (t (select-window numarg))))

(defun rdis-select-lru-window ()
       (or (cdr rdis-lru-stack)(display-error "No alternate window to select."))
       ;; The above error should not happen.
       (select-window (car (last rdis-lru-stack))))


(defun select-other-window ()
       (cond ((> nuwindows 1)
	    (and (cdr rdis-lru-stack)(select-window (cadr rdis-lru-stack))))
	   (t (display-error "Not in 2-window mode"))))


;;;
;;;
;;;	Externally available utilities needed by window editor.
;;;


(defun window-info (u)
       (and (or (< u 1)(> u nuwindows))
	  (display-error "window-info: no such window: " (decimal-rep u)))
       (let ((w (uwind-real-window u)))
	  (list (cons (startline w)(numlines w))     ;bounds
	        (uwindow-windowx (uwindows u))	;internal window index
	        (bufsym w)			;buffer
	        (cond ((null (bufmark w)) nil)	;char string on line
		    (t (let ((s (wwtcomp (car (bufmark w)))))
			  (e_lap_$gsubstr s 0 (gstrgl s)))))
					;split number of the window
	        (cond ((not split-mode-p) 0)
		    (t (do ((s (window-split w))
			  (split-num 0 (1+ split-num)))
			 ((= split-num nsplits)  ;should not get here!!!
			  (display-error "Could not find window split."))
			 (cond ((eq s (splits split-num))
			        (return split-num)))))))))

(defun window-adjust-upper (u deltaf)
       (rdis-assert-not-split-mode 'window-adjust-upper)
       (and (or (< u 2)(> u nuwindows))
	  (display-error "window-adjust-upper: bad window #: " (decimal-rep u)))
       (let ((w (uwindow-windowx (uwindows u))))
	  (rdis-adjust-window (- w 2) 0 deltaf)
	  (rdis-adjust-window (- w 1) deltaf 0)
	  (rdis-adjust-window w deltaf  (- deltaf))
	  (rdis-cause-full-screen-recomputation)
	  (assign-current-wsize w)))

(defun window-adjust-lower (u deltaf)
       (rdis-assert-not-split-mode 'window-adjust-lower)
       (and (or (< u 1)(> u (1- nuwindows)))
	  (display-error "window-adjust-lower: bad window #: " (decimal-rep u)))
       (let ((w (uwindow-windowx (uwindows u))))
	  (rdis-adjust-window w 0 deltaf)
	  (rdis-adjust-window (+ w 1) deltaf 0)
	  (rdis-adjust-window (+ w 2) deltaf (- deltaf))
	  (rdis-cause-full-screen-recomputation)
	  (assign-current-wsize w)))

(defun assign-current-wsize (w)
       (setq w (windows w))
       (and (bufmark w)(putprop (bufsym w)(numlines w) 'window-size)))


;;;
;;;
;;;	Dynamic (pop-up) window policy and implementation department.
;;;

;;; Put buffer buf someplace appropriate on the screen.
;;; This is an esoteric form of select-window.  It is critical to note
;;; that find-buffer-in-window does a rdis-update-window-strct after calling
;;; this.

(defun wman-place-buffer (buf)
       (let ((u (wman-allocate-window (wman-buf-wsize buf))))
	  (and (eq buf (bufsym (uwind u)))
	       (rdis-update-window-struct))	;moby hair.
	  ;;see select-window, same thing.
	  (setq selected-window u
	        rdis-selected-windowx (uwindow-windowx (uwindows u))
	        rdis-selected-wlist (windows rdis-selected-windowx)
	        rdis-selected-split (window-split rdis-selected-wlist))
	  (setq damaged-flag t)
	  (go-to-or-create-buffer buf)))
	  
;;; Find a good place of size size to put a window.

(defun wman-allocate-window (size)
       (cond ((wman-find-unused-window size))	;set.
	   (t (wman-fill-lrux-array)
	      (let ((start (wman-find-rottenest-space (1+ size))))
		 (or (= start 0)
		     (= (+ start size) main-window-size)
		     (setq start (1+ start)))
		 (wman-metamorphose start size)))))

;;; Find out a buffer's wanted window size.

(defun wman-buf-wsize (buf)
       (let ((prop (get buf 'window-size)))
	  (cond ((fixp prop) prop)
	        ((eq prop 'share)
	         (min (// main-window-size 2)
		    (do ((u 1 (1+ u))
		         (m 0))
		        ((> u nuwindows) m)
		        (setq m (max m (numlines (uwind u)))))))
	        ((= nuwindows 1) main-window-size)
	        (default-new-window-size)
	        (t (// main-window-size 2)))))


;;; Find a totally useless window for first choice.

(defun wman-find-unused-window (size)		;Find unused space that fits
       (do ((u 1 (1+ u))			;best.
	  (m main-window-size)
	  (mu nil))
	  ((> u nuwindows) mu)
	 (and (get (bufsym (uwind u)) 'nulls-windows-buffer)
	      (not (< (numlines (uwind u)) size))
	      (< (numlines (uwind u)) m)
	      (setq m (numlines (uwind u)) mu u))))


;;; not used.

(defun wman-find-lruness (u)
       (do ((l rdis-lru-stack (cdr l))
	  (d 1 (1+ d)))
	 ((null l) d)
	 (and (= (car l) u)(return d))))


;;; Set up the array with the LRU depth of each screen line.

(defun wman-fill-lrux-array ()
       (let ((ld (1+ (length rdis-lru-stack))))
	  (fillarray 'wman-lrux-array (list (1+ ld)))
	  (do ((l rdis-lru-stack (cdr l))
	       (d 1 (1+ d)))
	      ((null l) d)
	      (do ((c (numlines (uwind (car l)))(1- c))
		 (lx (startline (uwind (car l)))(1+ lx)))
		((= c 0))
		(store (wman-lrux-array lx) d)))))

(defun wman-find-rottenest-space (height)
       (setq height (min main-window-size height))
       (do ((rotsx 0 (1+ rotsx))		;index of.
	  (best-try-index)
	  (just-how-rotten-was-it 0)
	  (stopx (- main-window-size height)))
	 ((> rotsx stopx) best-try-index)
	 (do ((c height (1- c))
	      (lx rotsx (1+ lx))
	      (total 0))
	     ((= c 0)(cond ((> total just-how-rotten-was-it)
			(setq just-how-rotten-was-it total
			      best-try-index rotsx))))
	     (and (or (null (screen lx))
		    (= 0 (lineln (screen lx))))
		(aos total))		;Counts points!
	     (setq total (+ total (wman-lrux-array lx))))))

;;;
;;;
;;;	wman-metamorphose returns an index (uwindow) for a window
;;;	at line start for size (not including dividers).  He will
;;;	destroy all current windows contained therein, take one over,
;;;	and chop into others to make it so.   He will not leave 0-line
;;;	windows, nor rend an extant window in twain.

(defun wman-metamorphose (start size)
   (rdis-assert-not-split-mode 'pop-up/ windows)
   (prog2 
       (rdis-cause-full-screen-recomputation)
       (prog (mytop mybot histop hisbot ux w try-here dchop w/#)
					;Terminology is geographic
	   (setq mytop (1- start) mybot (+ size start))	;not numeric
	   (setq ux 1)			;loop uwindows
loop
	   (and (> ux nuwindows)(go pass2))
	   (setq w (uwind ux))
	   (setq histop (1- (startline w)) hisbot (+ histop (numlines w) 1))
	   (cond ((not (< histop mybot))(go pass2))  ;clear below us
	         ((not (> hisbot mytop))	;clear above us
		(aos ux))
	         ((and (= hisbot mybot)(= histop mytop))	;'xact match!
		(return ux))		;WOW!
	         ((and (< histop mytop)	;eat up oneliner on top
		     (not (< histop (- mytop 2))))
		(setq mytop histop))
	         ((and (not (< histop mytop))	;completely contained within
		     (not (> hisbot mybot)))	;flush it
		(wman-delete-window ux)
		(or (= ux 1)(sos ux)))
	         ((and (> hisbot mybot)	;Bottom short.
		     (not (> hisbot (+ 2 mybot))))
		(setq mybot hisbot))
	         ((> histop mybot)(rbarf "wman-metamorphose: err 3 "
				   (list ux mytop mybot histop hisbot)))
	         ((and (< histop mytop)(> hisbot mybot))	;dont split window
		(setq mytop (+ mytop (- hisbot mybot)) mybot hisbot))
	         ((and (= (abs (- histop mybot)) 1)  ;dont move 1 up down
		     (> (- mybot mytop) 4))
		(setq mybot histop))
	         ((and (= (abs (- mytop hisbot)) 1)
		     (> (- mybot mytop) 4))
		(setq mytop hisbot))
	         (t (or try-here (setq try-here ux))
		  (aos ux)))
	   (go loop)
;;;
pass2
;;;  Two cases wrt try-here:
;;;    1. We cut out of his bottom and maybe the next guy's top.
;;;    2. We cut out of his top alone.
;;;  There is no case of upper guy's top, or we'd be case 1 on him.

	   (setq ux try-here)		;for typing ease!
	   (setq w/# (uwindow-windowx (uwindows ux)))
	   (setq w (windows w/#))
	   (setq histop (1- (startline w)) hisbot (+ histop (numlines w) 1))
	   (setq size (- mybot mytop 1) start (1+ mytop))
	   (cond ((< histop mytop)		;Case 1
		(setq dchop (- mybot hisbot))
		(and (or (> hisbot mybot)
		         (not (> hisbot mytop)))
		     (rbarf "wman-metamorphose.pass2: err case 1 "
			  (list ux mytop mybot histop hisbot)))
		(wman-push-down-uwnums (1+ ux))
		(rdis-adjust-window w/# 0 (- mytop hisbot))
		(wman-push-down-rwnums (1+ w/#) 2)
		(store (windows (+ 1 w/#))(wman-create-divider mytop))
		(store (windows (+ 2 w/#))
		       (wman-fenestrarum-genetrix start size (1+ ux)))
		(cond ((and (not (= ux (1- nuwindows)))
			  (> dchop 0))
		       (rdis-adjust-window (+ 3 w/#) dchop 0)
		       (rdis-adjust-window (+ 4 w/#) dchop (- dchop))))
		(store (uwindows (1+ ux))
		       (make-uwindow windowx (+ 2 w/#)
				 split (window-split w)))
		(return (1+ ux)))
	         (t			;case 2.
		 (and (or (not (> hisbot mybot))
			(> histop mytop))
		      (rbarf "wman-metamorphose.pass2: err case 2 "
			   (list ux mytop mybot histop hisbot)))
		 (wman-push-down-uwnums ux)
		 (wman-push-down-rwnums w/# 2)
		 (rdis-adjust-window (+ 2 w/#) (1+ size)(- (1+ size)))
		 (store (windows w/#)
		        (wman-fenestrarum-genetrix start size ux))
		 (store (windows (1+ w/#))(wman-create-divider mybot))
		 (store (uwindows ux)
		        (make-uwindow windowx w/# split (window-split w)))
		 (return ux))))
       (setq two-window-mode t)))

;;;
;;;
;;;	Friends and utilities of wman-metamorphose.
;;;

(defun wman-fenestrarum-genetrix (sl nl u/#)
       (let ((sym (maknam (append '(n u l l i t y /. )(explodec u/#)))))
	  (putprop sym t 'nulls-windows-buffer)
	  (make-window startline sl numlines nl bufmark nil bufsym sym window-split current-split)))

(defun wman-create-divider (lx)
       (make-window startline lx numlines 1 bufmark rdis-splln-mark bufsym nil window-split current-split))

(defun wman-delete-window (u)
       (and (= selected-window u)
	  (select-other-window))
       (rdis-delete-uwindow u))

(defun wman-push-down-uwnums (u)
       (map '(lambda (x)(or (< (car x) u)(rplaca x (1+ (car x)))))
	  rdis-lru-stack)
       (or (< selected-window u)(aos selected-window))
       (aos nuwindows)
       (do x nuwindows (1- x)(= x u)
	 (store (uwindows x)(uwindows (1- x))))
       (store (uwindows u) (make-uwindow windowx -1 split nil)))

(defun wman-push-down-rwnums (w/# d)
       (or (< rdis-selected-windowx w/#)
	 (setq rdis-selected-windowx (+ rdis-selected-windowx d)))
       (setq nwindows (+ d nwindows))
       (do x (1- nwindows)(1- x)(= (- x d)(1- w/#))
	 (store (windows x)(windows (- x d))))
       (do u 1 (1+ u)(> u nuwindows)
	 (or (< (uwindow-windowx (uwindows u)) w/#)
	     (incf (uwindow-windowx (uwindows u)) d))))


(defun wman-fenestra-nata-est-virgo (u)
       (setq rdis-lru-stack (delq u rdis-lru-stack))
       (rdis-fenestra-nata-est-virgo (uwind u))
       (store (uwind u)
	    (wman-fenestrarum-genetrix (startline (uwind u))
				 (numlines (uwind u))
				 u))
       (and (= u selected-window)
	  (setq rdis-selected-wlist (uwind u)
	        rdis-selected-split (window-split rdis-selected-wlist))))

(defun assign-buffer-window-size ()
       (putprop current-buffer (numlines rdis-selected-wlist) 'window-size))
;;;
;;;
;;;	Buffer window size hacking primitives.
;;;


;;; Callable interface from editor.

(defun select-buffer-window (buf key)
       (cond (pop-up-windows
	     (putprop buf (select-buffer-window-size-interpreter buf key)
		    'window-size)
	     (find-buffer-in-window buf))
	   (t (go-to-or-create-buffer buf))))

(defun select-buffer-find-window (buf key)
       (cond (pop-up-windows (select-buffer-window buf key))
	   ((eq buf current-buffer)(find-current-buffer-in-window))
	   (t (find-buffer-in-window buf))))

(defun select-buffer-window-size-interpreter (buf size)
       (cond ((and (eq size 'default-cursize)(get buf 'window-size))
	    (setq size (get buf 'window-size)))
	   ((and (eq size 'cursize-not-empty)(empty-buffer-p buf))
	    (setq size nil)))
       (or (fixp size)(memq size '(float nil))
	 (setq size
	       (cond ((memq buf known-buflist)
		    (get-buffer-state buf 'number-of-lines-in-buffer))
		   (t nil))))
       (cond ((fixp size)
	    (and (< size 1)(setq size 1))
	    (and (> size (// (*  main-window-size 3) 5))
	         (setq size nil))))
       (and (not (eq size 'float)) size))

(defun find-current-buffer-in-window ()
       (find-buffer-in-window-noupdate current-buffer))

(defun find-buffer-in-window-noupdate (buf)
       (let ((rdis-suppress-rupdate t))
	  (find-buffer-in-window buf))
       (rdis-update-window-struct))




		    emacs.pl1                       08/01/88  1002.5r w 08/01/88  0952.7      203715



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

/* format: style2,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indcomtxt,^inditerdo,idind22 */
multics_emacs:
emacs:
     procedure () options (variable);

	go to emacs_start;

/* Command interface to Multics EMACS editor. */


/****^  HISTORY COMMENTS:
  1) change(82-04-12,Margolin), approve(), audit(),
     install(86-11-03,MR12.0-1205):
     Pre-hcom comments:
     03/22/78 by BSG
     Last modified:      03/23/78 by GMP for temporary segment manager
     Last modified:      03/26/78 by GMP for debugging entries and to differentiate
     FNP and Network usage.
     Last modified:      21 April 1978 by RSL to restore modes after usage
     Last modified:27 August 1978 by GMP to remove FNP/Network differentiation,
     and put save/restore modes into push/pop level
     Last modified:      24 November 1978 by BSG to
     implement e_pl1_$push_pop_tbl_swap)
     Last Modified:      3 May 1979 by BIM for logging
     Last Modified:   7 May 1979 by BSG for lisp_linkage_error
     Last Modified:   9 May 1979 by BSG for integration with new_emacs,
     better logging
     Last Modified 28 Feb 1980 by BSG for >sc1>emacs_dir
     Last Modified 17 June 1981 by RMSoley for emacs$get_my_name and friends.
     Last Modified 7 July 1981 RMSoley for emacs$get_version and to use
     emacs_data_$version for saved environment name.
     Last Modified 10 July 1981 RMSoley for logging changes
     Last Modified 14 July 1981 RMSoley for info_ptr in emacs_ and
     emacs$get_info_ptr
     Last Modified 22 July 1981 RMSoley to move parsing to PL/1,
     fully use emacs_data_ static, add tasking, and clean up.
     Last Modified: August 1981 RMSoley: fix tasking, get rid
     of push_pop_tbl_swap technology, fix invocation workings.
     Modified: 3 April 1982 Richard Soley to fix lisp_save_ message
                  received during installation window.
     Modified: 12 April 1982 Richard Soley to remove site-dir dependence.
  2) change(86-07-17,Margolin), approve(86-07-17,MCR7452),
     audit(86-07-29,Coren), install(86-11-03,MR12.0-1205):
     Changed pop_level to turn off video if Emacs turned it on automatically.
                                                   END HISTORY COMMENTS */


/* System Entries */
	dcl     cu_$arg_ptr_rel	entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
	dcl     cu_$cl		entry ();
	dcl     com_err_$suppress_name
				entry options (variable);
	dcl     cu_$arg_list_ptr	entry () returns (pointer);
	dcl     ioa_$ioa_switch	entry options (variable);
	dcl     e_argument_parse_	entry (ptr, char (*), fixed bin (35));
	dcl     e_argument_parse_$subroutine
				entry (ptr, char (*), char (*), ptr);
	dcl     e_pl1_$dump_out_console_messages
				entry ();
	dcl     e_pl1_$return_echo_meters
				entry (fixed bin, fixed bin, fixed bin, fixed bin);
	dcl     e_pl1_$set_multics_tty_modes
				entry ();
	dcl     e_pl1_$get_terminal_type
				entry (char (*) varying);
	dcl     e_tasking_		entry (pointer, fixed bin (35));
	dcl     expand_pathname_	entry (char (*), char (*), char (*), fixed bin (35));
	dcl     find_condition_info_	entry (ptr, ptr, fixed bin (35));
	dcl     forward_command_	entry (pointer, entry, character (*));
	dcl     get_group_id_	entry () returns (char (32));
	dcl     get_system_free_area_ entry () returns (pointer);
	dcl     get_temp_segment_	entry (character (*), pointer, fixed binary (35));
	dcl     hcs_$fs_get_path_name entry (entry, character (*), fixed binary, character (*), fixed binary (35));
	dcl     hcs_$initiate	entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
				fixed bin (35));
	dcl     hcs_$get_process_usage
				entry (ptr, fixed bin (35));
	dcl     hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin (3), fixed bin (5), fixed bin (35))
				;
	dcl     hcs_$status_minf	entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				fixed bin (35));
	dcl     ioa_$rsnnl		entry options (variable);
	dcl     iox_$modes		entry (pointer, character (*), character (*), fixed binary (35));
	dcl     lisp$lisp		entry () options (variable);
	dcl     user_info_$terminal_data
				entry (char (*), char (*), char (*), fixed bin, char (*));
	dcl     video_utils_$turn_off_login_channel
				entry (fixed bin (35));
	dcl     write_log_$write_log_test
				entry (char (*));
	dcl     write_log_$write_log_file
				entry (fixed bin (71), fixed bin, char (*), char (*), ptr);
	dcl     release_temp_segments_
				entry (character (*), (*) pointer, fixed binary (35));
	dcl     release_temp_segment_ entry (character (*), pointer, fixed binary (35));

/* Automatic */
	dcl     cgmeter		fixed bin;
	dcl     1 cinfo		like condition_info aligned automatic;
	dcl     code		fixed bin (35);
	dcl     edirl		fixed bin;
	dcl     env_name		char (32);
	dcl     groupid		character (32);
	dcl     idx		fixed bin;
	dcl     line_type		fixed bin;
	dcl     locemeter		fixed bin;
	dcl     log_name		char (32);
	dcl     log_ptr		pointer;
	dcl     loser		character (256) varying;
	dcl     lstring		char (116);
	dcl     mode		fixed bin (5);
	dcl     myname		char (32);
	dcl     n_to_allocate	fixed bin;
	dcl     netsw		bit (1);
	dcl     1 new_usage_info	automatic aligned like process_usage;
	dcl     outmeter		fixed bin;
	dcl     p			pointer;
	dcl     r0emeter		fixed bin;
	dcl     temp_ptr		pointer;
	dcl     temp_string		character (168);
	dcl     termid		char (4);
	dcl     time_in		fixed bin (71);
	dcl     ttychan		character (32);
	dcl     ttytype		character (32);
	dcl     1 usage_info	automatic aligned like process_usage;
	dcl     vtyp		character (100) varying;

/* External Static */
	dcl     emacs_data_$invocation_list
				pointer static external;
	dcl     emacs_data_$log_dir	character (168) static external;
	dcl     emacs_data_$status_code
				fixed bin (35) static external;
	dcl     emacs_data_$version	character (10) static external;
	dcl     iox_$user_io	pointer external;

/* Internal Static */
	dcl     isw		bit (1) static initial ("0"b);
	dcl     log_subdir		char (32) static options (constant) init ("log_dir");
	dcl     names		(2) character (32) static options (constant)
				initial ("lisp", "lisp_static_vars_");
	dcl     system_area_ptr	pointer static internal initial (null ());

/* Builtin */
	dcl     (addr, clock, divide, hbound, index, length, null, rtrim, stackframeptr, substr)
				builtin;

/* Conditions */
	dcl     cleanup		condition;
	dcl     lisp_linkage_error	condition;
	dcl     record_quota_overflow condition;

/* Based */
	dcl     based_code		fixed bin (35) based;
	dcl     1 cond_info		aligned based,
		2 lth		fixed bin,
		2 version		fixed bin,
		2 action_flags	aligned,
		  3 cant_restart	bit (1) unal,
		  3 default_restart bit (1) unal,
		  3 pad		bit (34) unal,
		2 info_string	char (256) varying,
		2 status_code	fixed bin (35);
	dcl     system_area		area based (system_area_ptr);

/* Parameters */
	dcl     segment_ptr		pointer parameter;
	dcl     P_code		fixed bin (35);
	dcl     P_environment	char (*) parameter;
	dcl     P_info_ptr		pointer;
	dcl     P_iocb_ptr		pointer;
	dcl     P_pathname		char (*) parameter;

/* Include Files */
%include condition_info;
%include emacs_data;
%include line_types;
%include process_usage;

emacs_start:
	myname = "emacs";
	env_name = "emacs";
	log_name = "emacs_log";
	goto e_ne_common;

emacs_:
     entry (P_iocb_ptr, P_pathname, P_environment, P_info_ptr, P_code);

	myname = "emacs_";
	env_name = "emacs_";
	log_name = "emacs_log";
	go to e_ne_common;

ne:
new_emacs:
     entry options (variable);

	myname = "new_emacs";
	env_name = "new-emacs";
	log_name = "ne_log";

e_ne_common:
	emacs_data_$status_code = 0;

/* Push this invocation (it may be popped later.) */
	system_area_ptr = get_system_free_area_ ();
	allocate emacs_data in (system_area) set (emacs_data_ptr);
	emacs_data.prev_invocation = null ();
	emacs_data.next_invocation = emacs_data_$invocation_list;
	if emacs_data_$invocation_list ^= null () then
	     emacs_data_$invocation_list -> emacs_data.prev_invocation = emacs_data_ptr;
	emacs_data_$invocation_list = emacs_data_ptr;
	emacs_data.frame_ptr = stackframeptr ();

/* Parse argument list. */
	emacs_data.arg_list_ptr = cu_$arg_list_ptr ();
	code = 0;
	if myname ^= "emacs_" then
	     call e_argument_parse_ (emacs_data.arg_list_ptr, myname, code);
	else call e_argument_parse_$subroutine (P_iocb_ptr, P_pathname, P_environment, P_info_ptr);
	if code ^= 0 then return;

/* Now, if we are going to be tasking AND THERE IS A TASK AROUND,
   pop invocation list (saving arguments). */
	if emacs_data.arguments.no_task then go to escape_loop;

	do temp_ptr = emacs_data_$invocation_list repeat (temp_ptr -> emacs_data.next_invocation)
	     while (temp_ptr ^= null ());
	     if temp_ptr -> emacs_data.tasking.task_flags.in_task then do;
		temp_ptr -> emacs_data.arguments = emacs_data.arguments;
		emacs_data_ptr = temp_ptr;
		temp_ptr = emacs_data_$invocation_list -> emacs_data.next_invocation;
		free emacs_data_$invocation_list -> emacs_data in (system_area);
		emacs_data_$invocation_list = temp_ptr;
		emacs_data_$invocation_list -> emacs_data.prev_invocation = null ();
		go to escape_loop;
	     end;
	end;
escape_loop:
	if myname = "emacs_" then do;
	     emacs_data.info_ptr = P_info_ptr;
	     emacs_data.output_iocb, emacs_data.input_iocb = P_iocb_ptr;
	end;

	emacs_data.flags.new_arguments = "1"b;
	emacs_data.arg_list_ptr = cu_$arg_list_ptr ();
	emacs_data.myname = myname;
	emacs_data.env_name = rtrim (env_name) || "." || emacs_data_$version;
	emacs_data.log_name = log_name;

	call hcs_$fs_get_path_name (emacs, temp_string, edirl, (""), (0));
	emacs_data.edir = temp_string;
	if edirl < 168 then substr (emacs_data.edir, edirl + 1) = "";
	if ^isw then do;
	     do idx = 1 to hbound (names, 1);
		call hcs_$initiate ((emacs_data.edir), names (idx), names (idx), (0), (0), p, (0));
	     end;
	end;
	isw = "1"b;
	if emacs_data.myname = "emacs_" | emacs_data.myname = "emacs" then
	     emacs_data.ledir = emacs_data_$log_dir;
	else emacs_data.ledir = emacs_data.edir;

/* Check existence of lisp environment. */
	call hcs_$status_minf ((emacs_data.edir), rtrim (emacs_data.env_name) || ".sv.lisp", 1, 1 /* seg */, (0), code);
	if code ^= 0 then do;
	     call com_err_$suppress_name (0, emacs_data.myname,
		"A new version of emacs, version ^a, is being installed.", rtrim (emacs_data_$version));
	     call com_err_$suppress_name (0, emacs_data.myname, "Please wait 5 minutes and try again.");
	     return;
	end;

	mode = 0;
	call hcs_$get_user_effmode ((emacs_data.ledir), "metering.acs", "", 4, mode, code);
	if mode > 01000b then do;
	     usage_info.number_wanted = 5;
	     log_ptr = null ();
	     call hcs_$get_process_usage (addr (usage_info), (0));
	     call write_log_$write_log_test (rtrim (emacs_data.ledir) || ">" || log_subdir);
	     call user_info_$terminal_data (termid, ttytype, ttychan, line_type, (""));
	     netsw = (line_type = LINE_TELNET);
	     call ioa_$rsnnl ("^a: Entering ^a (^a) on ^a ^a ^a", lstring, length (lstring), get_group_id_ (),
		emacs_data.myname, rtrim (emacs_data_$version), ttytype, termid, ttychan);
	     time_in = clock ();
	     call write_log_$write_log_file (time_in, 0, lstring, (emacs_data.log_name), log_ptr);
	end;

	call push_level ();

	code = 0;					/* If this returns a non-zero code, then got error or already
						   ran an Emacs, punt. */
	call e_tasking_ (emacs_data_ptr, code);
	if code ^= 0 then return;
	go to not_tasking;

tasking_emacs:
     entry ();

	emacs_data_ptr = emacs_data_$invocation_list;
	emacs_data.frame_ptr = stackframeptr ();

not_tasking:
	on cleanup
	     begin;
		emacs_data_ptr = e_find_invocation_ ();
		call pop_level ();
		call unthread_invocation ();
	     end;

	on lisp_linkage_error call llerror ();

	on record_quota_overflow call rqoerror ();

/* Now forward to Lisp. */
	call forward_command_ (emacs_data.arg_list_ptr, lisp$lisp,
	     rtrim (emacs_data.edir) || ">" || rtrim (emacs_data.env_name));
	call pop_level ();

	if emacs_data.myname = "emacs_" then P_code = emacs_data.status_code;
	call unthread_invocation ();
returner:
	return;

llerror:
     procedure ();

	emacs_data_ptr = e_find_invocation_ ();
	call pop_level;

/* Figure out exactly what part of emacs failed. */
	call find_condition_info_ (null (), addr (cinfo), code);
	if code ^= 0 then
	     loser = rtrim (emacs_data.myname);
	else do;
	     loser = cinfo.info_ptr -> cond_info.info_string;
	     if substr (loser, 1, 4) ^= "The " then
		loser = rtrim (emacs_data.myname);
	     else do;
		loser = substr (loser, 5);
		idx = index (loser, " ");
		loser = substr (loser, 1, idx - 1);
	     end;
	end;

	call com_err_$suppress_name (0, emacs_data.myname, "A new version of ^a, a part of ^a, has been installed.",
	     loser, emacs_data.myname);
	call com_err_$suppress_name (0, emacs_data.myname,
	     "Please issue the ""tmr ^a"" command in order to be able to use it.", loser);
	call unthread_invocation ();
	go to returner;
     end;

rqoerror:
     procedure ();
	emacs_data_ptr = e_find_invocation_ ();
	call e_pl1_$set_multics_tty_modes ();
	call ioa_$ioa_switch (iox_$user_io,
	     "^/^a: There has been a record quota overflow.  Delete unnecessary segments", emacs_data.myname);
	call ioa_$ioa_switch (iox_$user_io, "and issue the ""^[^a^;pi^s^]"" command to re-enter ^a.",
	     emacs_data.tasking.task_flags.in_task, emacs_data.myname, emacs_data.myname);

	revert record_quota_overflow;
	call cu_$cl ();
	on record_quota_overflow call rqoerror ();
	return;
     end rqoerror;

unthread_invocation:
     procedure ();

/* Don't unthread if this is a tasking invocation, or
   e_tasking_ won't be able to destroy.
   16 April 1982 RMSoley: new way is to just release through
   the entire stack, so DO unthread tasking invocations.
   if emacs_data.tasking.task_flags.in_task then return; */

	if emacs_data_$invocation_list = emacs_data_ptr then emacs_data_$invocation_list = emacs_data.next_invocation;
	if emacs_data.next_invocation ^= null () then
	     emacs_data.next_invocation -> emacs_data.prev_invocation = emacs_data.prev_invocation;
	if emacs_data.prev_invocation ^= null () then
	     emacs_data.prev_invocation -> emacs_data.next_invocation = emacs_data.next_invocation;
	free emacs_data;
	return;
     end unthread_invocation;

/* This entry allows the lisp side of emacs find out what name we were
   called with, emacs/emacs_/new_emacs.    RMSoley 17 June 1981 */

get_my_name:
     entry () returns (char (32));

	emacs_data_ptr = e_find_invocation_ ();

	return (emacs_data.myname);

/* This entry allows the lisp side to set a return code for emacs_ */

set_emacs_return_code:
     entry (P_return_code);
	dcl     P_return_code	fixed bin (35);

	emacs_data_ptr = e_find_invocation_ ();

	emacs_data.status_code = P_return_code;
	emacs_data_$status_code = P_return_code;

	if emacs_data.myname ^= "emacs_" then return;

/* Now patch it into the argument list.
   Have to go through this hair since the argument list
   might be on another stack ! */

	call cu_$arg_ptr_rel (5, temp_ptr, (0), (0), emacs_data.arg_list_ptr);
	temp_ptr -> based_code = P_return_code;

	return;

/* This entry returns the current emacs version string. */

get_version:
     entry () returns (character (10));

	return (emacs_data_$version);

/* This entry is called by the lisp side to set redisplay meters. */

set_lisp_rdis_meters:
     entry (P_1, P_2, P_3, P_4, P_5, P_6, P_7, P_8, P_9, P_10);

	declare (P_1, P_2, P_3, P_4, P_5, P_6, P_7, P_8, P_9, P_10)
				fixed bin;
	declare (static_rdis_1, static_rdis_2, static_rdis_3, static_rdis_4, static_rdis_5, static_rdis_6,
	        static_rdis_7, static_rdis_8, static_rdis_9, static_rdis_10)
				static internal fixed bin init (0);

	static_rdis_1 = P_1;
	static_rdis_2 = P_2;
	static_rdis_3 = P_3;
	static_rdis_4 = P_4;
	static_rdis_5 = P_5;
	static_rdis_6 = P_6;
	static_rdis_7 = P_7;
	static_rdis_8 = P_8;
	static_rdis_9 = P_9;
	static_rdis_10 = P_10;
	return;

/* emacs$get_info_ptr -> get information pointer provided in emacs_
   call.  14 July 1981 RMSoley */

get_info_ptr:
     entry () returns (pointer);

	emacs_data_ptr = e_find_invocation_ ();

	return (emacs_data.info_ptr);

/* This entry allocates a temporary segment for the editor.
   It remembers all such segments allocated so that it can free them when done.
*/


get_temporary_seg:
     entry () returns (pointer);

	emacs_data_ptr = e_find_invocation_ ();

	if emacs_data.level_ptr -> level_info.n_used = emacs_data.level_ptr -> level_info.n_allocated then do;
						/* need more room in table */

	     n_to_allocate = emacs_data.level_ptr -> level_info.n_allocated + 16;
	     allocate level_info in (system_area) set (p);

	     p -> level_info.prev_level = emacs_data.level_ptr -> level_info.prev_level;

	     p -> level_info.n_used = emacs_data.level_ptr -> level_info.n_used;
	     do idx = 1 to p -> level_info.n_used;
		p -> level_info.segment_ptrs (idx) = emacs_data.level_ptr -> level_info.segment_ptrs (idx);
	     end;

	     do idx = p -> level_info.n_used + 1 to p -> level_info.n_allocated;
						/* and new ones */
		p -> level_info.segment_ptrs (idx) = null ();
	     end;

	     free emacs_data.level_ptr -> level_info in (system_area);
						/* release old table */

	     emacs_data.level_ptr = p;		/* remember new table */
	end;


	idx, emacs_data.level_ptr -> level_info.n_used = emacs_data.level_ptr -> level_info.n_used + 1;

	call get_temp_segment_ ("emacs", emacs_data.level_ptr -> level_info.segment_ptrs (idx), (0));

	return (emacs_data.level_ptr -> level_info.segment_ptrs (idx));


/* This entry releases a temporary segment previously allocated by this level
   of the editor. */

release_temporary_seg:
     entry (segment_ptr);

	emacs_data_ptr = e_find_invocation_ ();

	do idx = 1 to emacs_data.level_ptr -> level_info.n_used;
						/* find it */
	     if emacs_data.level_ptr -> level_info.segment_ptrs (idx) = segment_ptr then go to found_release;
	end;

	return;					/* not from this level, forget it */


found_release:
	do idx = idx + 1 to emacs_data.level_ptr -> level_info.n_used;
	     emacs_data.level_ptr -> level_info.segment_ptrs (idx - 1) =
		emacs_data.level_ptr -> level_info.segment_ptrs (idx);
	end;					/* remove from list */

	emacs_data.level_ptr -> level_info.n_used = emacs_data.level_ptr -> level_info.n_used - 1;

	call release_temp_segment_ ("emacs", segment_ptr, (0));

	return;


/* These commands are for use when debugging EMACS.  They push and pop
   editor levels to permit use of the editor fom free-standing LISP.
*/

debug_on:
     entry () options (variable);

	emacs_data_ptr = e_find_invocation_ ();

	call push_level ();

	return;



debug_off:
     entry () options (variable);

	emacs_data_ptr = e_find_invocation_ ();

	mode = 0b;
	call pop_level ();

	return;


/* This internal procedure pushes a new editor level.
*/

push_level:
     procedure ();

	if system_area_ptr = null () then system_area_ptr = get_system_free_area_ ();

	n_to_allocate = 16;				/* good size for start */

	allocate level_info in (system_area) set (p);

	p -> level_info.prev_level = emacs_data.level_ptr;/* chain previous level */

	p -> level_info.n_used = 0;
	p -> level_info.segment_ptrs (*) = null ();

	call iox_$modes (iox_$user_io, (""), p -> level_info.tty_modes, (0));

	emacs_data.level_ptr = p;			/* push */

     end push_level;

/* This internal procedure pops an editor level. */

pop_level:
     procedure ();
	if mode > 01000b then do;

	     new_usage_info.number_wanted = 5;
	     call hcs_$get_process_usage (addr (new_usage_info), (0));
	     time_in = divide (clock () - time_in, 6000000, 35, 0);
	     call e_pl1_$return_echo_meters (cgmeter, r0emeter, locemeter, outmeter);
	     groupid = get_group_id_ ();
	     call e_pl1_$get_terminal_type (vtyp);
	     if vtyp = "" then
		if netsw then
		     ttytype = "supdup output";
		else ;
	     else call expand_pathname_ ((vtyp), (168)" ", ttytype, 0);
	     if (substr (ttytype, length (rtrim (ttytype)) - 2, 3) = "ctl") then
		substr (ttytype, length (rtrim (ttytype)) - 2) = "";
	     call ioa_$rsnnl ("^a: (^a) in ^d, r0/r4 echo ^d/^d, out ^d.", lstring, length (lstring), groupid, ttytype,
		cgmeter, r0emeter, locemeter - r0emeter, outmeter);
	     call write_log_$write_log_test (rtrim (emacs_data.ledir) || ">" || log_subdir);
	     call write_log_$write_log_file (clock (), 0, lstring, (emacs_data.log_name), log_ptr);
	     call ioa_$rsnnl ("^a: lisp rdis: ^d ^d ^d ^d ^d ^d ^d ^d ^d ^d", lstring, length (lstring), groupid,
		static_rdis_1, static_rdis_2, static_rdis_3, static_rdis_4, static_rdis_5, static_rdis_6,
		static_rdis_7, static_rdis_8, static_rdis_9, static_rdis_10);
	     call write_log_$write_log_file (clock (), 0, lstring, (emacs_data.log_name), log_ptr);

	     call ioa_$rsnnl ("^a: ^.1f min, v/cpu ^d/^d mem ^d paging ^d/^d", lstring, length (lstring), groupid,
		time_in / 10e0, (new_usage_info.virtual_cpu_time - usage_info.virtual_cpu_time) * 1e-6,
		(new_usage_info.cpu_time - usage_info.cpu_time) * 1e-6,
		divide (new_usage_info.paging_measure - usage_info.paging_measure, 1000, 35, 0),
		new_usage_info.pd_faults - usage_info.pd_faults, new_usage_info.page_faults - usage_info.page_faults);
	     call write_log_$write_log_file (clock (), 0, lstring, (emacs_data.log_name), log_ptr);
	end;

	if emacs_data.level_ptr = null () then return;	/* nothing to do */

	call release_temp_segments_ ("emacs", emacs_data.level_ptr -> level_info.segment_ptrs (*), (0));
						/* release all temporary segments of this level */

	call e_pl1_$set_multics_tty_modes ();		/* renegotiate echoing */

	if emacs_data.flags.turned_on_video then call video_utils_$turn_off_login_channel ((0));
						/* we turned it on, we should turn it off */

	call iox_$modes (iox_$user_io, emacs_data.level_ptr -> level_info.tty_modes, (""), (0));

	call e_pl1_$dump_out_console_messages ();

	p = emacs_data.level_ptr -> level_info.prev_level;

	free emacs_data.level_ptr -> level_info in (system_area);

	emacs_data.level_ptr = p;			/* pop */

     end pop_level;

     end emacs;




		    emacs_data_.cds                 08/01/88  1002.5rew 08/01/88  0949.0       27279



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Bull Inc., 1988                *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1981 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */
/* format: style3 */

/* emacs_data_: Emacs static data. */


/* HISTORY COMMENTS:
  1) change(81-07-07,Soley), approve(), audit(), install():
     Written.
  2) change(81-07-22,Soley), approve(), audit(), install():
     add argument flags.
  3) change(82-04-12,Soley), approve(), audit(), install():
     help punt site-dir.
  4) change(86-02-24,Margolin), approve(86-02-24,MCR7325),
     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
     Changed version to 12.6.
  5) change(86-09-20,Margolin), approve(86-10-10,MCR7553),
     audit(86-10-17,Lippard), install(86-11-11,MR12.0-1209):
     Changed version to 12.6e.
  6) change(87-01-30,Margolin), approve(87-01-30,MCR7607),
     audit(87-02-13,RBarstad), install(87-03-25,MR12.1-1014):
     Changed version to 12.7.
  7) change(88-01-19,Schroth), approve(88-02-29,MCR7852),
     audit(88-06-06,RBarstad), install(88-08-01,MR12.2-1071):
     Changed version to 12.9.
                                                   END HISTORY COMMENTS */


emacs_data_:
     procedure ();

/* Automatic */
declare	code		fixed binary (35);
declare	me		character (32) initial ("emacs_data_");
declare	1 cdsa		aligned like cds_args;

/* Builtin */
declare	(addr, null, size, unspec)
			builtin;

/* Entries */
declare	com_err_		entry options (variable);
declare	create_data_segment_
			entry (pointer, fixed binary (35));

/* Include Files */
%include cds_args;

/* Automatic to become the emacs_data_ variables. */

declare	1 text_data	aligned,
	  2 version	character (10) initial ("12.9"),
	  2 log_dir	character (168) initial ("");
declare	1 static_data	aligned,
	  2 force_tasking	bit (1) aligned initial ("0"b),
	  2 invocation_list pointer initial (null ()),
	  2 status_code	fixed bin (35) initial (0);

/* Fill in CDS data. */
	unspec (cdsa) = ""b;
	cdsa.sections (1).p = addr (text_data);
	cdsa.sections (1).len = size (text_data);
	cdsa.sections (1).struct_name = "text_data";
	cdsa.sections (2).p = addr (static_data);
	cdsa.sections (2).len = size (static_data);
	cdsa.sections (2).struct_name = "static_data";
	cdsa.seg_name = "emacs_data_";
	cdsa.exclude_array_ptr = null ();
	cdsa.switches.have_text = "1"b;
	cdsa.switches.separate_static = "1"b;
	cdsa.switches.have_static = "1"b;

	call create_data_segment_ (addr (cdsa), code);
	if code ^= 0
	then do;
		call com_err_ (code, me);
		return;
	     end;

	return;
     end emacs_data_;




		    emacs_search_file_caller_.pl1   11/30/82  1504.2rew 11/30/82  1332.7       20952



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


emacs_search_file_caller_:
	proc (regexp, pointpos, filelinep, filelinel, stringline, answer);

/*  Bernard Greenberg 6/23/78 */

dcl regexp char (*);				/* regular exp */
dcl pointpos fixed bin;				/* rel offset */
dcl filelinep ptr;					/* null if string passed */
dcl filelinel fixed bin;				/* 21 not interesting */
dcl stringline char (*);				/* line as string */
dcl answer bit (36) aligned;				/* encode this loser better, see below. */

dcl code fixed bin (35), (amitemp, ametemp) fixed bin (17) aligned;
dcl linep ptr, linel fixed bin, line char (linel) based (linep); /* real params */
dcl null builtin;
dcl search_file_ entry (ptr, fixed bin, fixed bin,
		/*   atp     ati       atl  */
		    ptr, fixed bin, fixed bin,
		/*   afp     afi       afe  */
		    fixed bin, fixed bin, fixed bin (35));
	
		/*  ami	   ame	   code */
dcl 1 packed_return_val aligned,
    2 zero_rel_index fixed bin (17) unaligned,
    2 length fixed bin (17) unaligned;

dcl length builtin;

	if filelinep ^= null then do;			/* in file */
	     linep = filelinep;
	     linel = filelinel;
	end;
	else do;					/* string passed */
	     linep = addr (stringline);
	     linel = length (stringline);
	end;

	call search_file_ (addr (regexp), 1, length (regexp), linep, pointpos + 1, linel, amitemp, ametemp, code);
	if code ^= 0 then do;
	     packed_return_val.zero_rel_index = -1;
	     packed_return_val.length = 0;
	end;

/* Got good answer, pack it up and go. */

	else do;
	     packed_return_val.zero_rel_index = amitemp - 1;
	     packed_return_val.length = ametemp - amitemp + 1;
	end;
	
	answer = unspec (packed_return_val);
     end;




		    forward_command_.alm            11/30/82  1504.2rew 11/30/82  1333.8       13194



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1978 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************
"
	name	forward_command_
	segdef	forward_command_
forward_command_:
	eppab	ap|2,*
	eppab	ab|0,*
	ldx7	pushinst
	eax7	2,7
	adx7	ab|0
	adx7	ab|1
	lxl6	ab|0
	cmpx6	8,du
	tnz	*+2
	eax7	2,7
	eax7	4,7
	adx7	15,du
	anx7	-16,du
	tra	pushinst+1
pushinst:	push
	ldx7	pushinst
	eppbp	sp|0,7
	ldaq	ab|0
	ada	2,du
	adq	2,du
	staq	bp|0
	eppbb	ap|6,*
	spribb	bp|2
	eppbp	bp|4
	ldx6	ab|0
lp1:	eax6	-2,6
	tmi	l1done
	ldaq	ab|2,6
	staq	bp|0,x6
	tra	lp1
l1done:	lxl0	ab|0
	ldx6	ab|0
	eppbp	bp|0,x6
	ldx5	ab|0
	cmpx0	8,du
	tnz	nosp
	eax5	2,5
	ldx6	ab|0
	ldaq	ab|2,6
	staq	bp|0
	eppbp	bp|2
nosp:
	eppbb	ap|12,*
	spribb	bp|0
	eppbp	bp|2
	ldx6	ab|1
	eppbb	ab|2,5
lp2:	eax6	-2,6
	tmi	l2done
	ldaq	bb|0,6
	staq	bp|0,6
	tra	lp2
l2done:
	eppab	ap|4,*
	eppab	ab|0,*
	eppap	sp|0,x7
	short_call	ab|0
	return
	end





		    list_emacs_ctls.pl1             11/15/84  1155.5rew 11/15/84  0849.9       72216



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1981 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */

/* format: style2 */
list_emacs_ctls:
     procedure ();

/* Procedure to list all of the terminal controllers in the
   emacs_terminal_ctls search paths.
   Originally coded: 1 July 1981 by Richard Mark Soley.
   Modified: 6 July 1981 RMSoley for find_ctl and ".ctl" names.
   Switched to object segment search rules BIM August 1981.
   Removed support for old style names ending in "ctl" WMY 08/21/81
   Duplicate dir detection, restoration of support for old names
   only for find, not for list, BIM, shortly thereafter.
   Modified: 20 December 1983 B. Margolin to fix cleanup handler to
	   not do non-local exit.
*/

/* Parameters */
	dcl     P_type		 character (*) parameter;

/* System Entries */
	dcl     absolute_pathname_	 entry (char (*), char (*), fixed bin (35));
	dcl     com_err_		 entry () options (variable);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     get_wdir_		 entry () returns (char (168));
	dcl     hcs_$make_ptr	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	dcl     hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
				 fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$nnl		 entry () options (variable);
	dcl     hcs_$get_search_rules	 entry (ptr);
	dcl     sort_items_$char	 entry (ptr, fixed bin (24));
	dcl     user_info_$homedir	 entry (char (*));
	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	declare hcs_$status_long	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
						/* Conditions */
	dcl     cleanup		 condition;

/* Static */
	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
	dcl     error_table_$nomatch	 fixed bin (35) ext static;

/* Based */
	dcl     ap		 pointer,
	        al		 fixed bin (21),
	        arg		 char (al) based (ap);
	dcl     char32		 character (32) based;

/* Automatic */
	dcl     area_ptr		 pointer;
	dcl     code		 fixed bin (35);
	dcl     count		 fixed bin (35);
	dcl     dirname		 char (168);
	dcl     have_printed_header	 bit (1) aligned initial ("0"b);
	dcl     idx		 fixed bin;
	dcl     jdx		 fixed bin;

	dcl     me		 char (32) initial ("list_emacs_ctls");
	dcl     starname		 char (32) initial ("*");
	dcl     temp_ptr		 pointer;
	dcl     terminal		 char (32) varying;
	dcl     type		 character (32);

	dcl     1 search_rules	 aligned,
		2 n_directories	 fixed bin,
		2 dir_names	 (22) character (168);

/* Builtin */
	dcl     (addr, codeptr, hbound, length, max, min, null, rtrim, substr, translate)
				 builtin;

/* Include Files */
%include star_structures;
%include status_structures;
	declare 1 SB		 aligned like status_branch;

	area_ptr = get_system_free_area_ ();
	on cleanup call clean_up ();

/* See if there's an argument to pick up.
	   Set up starname for use by hcs_$star_ */
	call cu_$arg_ptr (1, ap, al, code);
	if code = 0
	then starname = substr (arg, 1, min (al, 29));
	if substr (starname, max (length (rtrim (starname)) - 1, 1), 2) = "**"
	then starname = substr (starname, 1, length (rtrim (starname)) - 1);
	starname = translate (starname, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");


	search_rules.n_directories = 0;
	call hcs_$get_search_rules (addr (search_rules));
	if search_rules.n_directories = 0
	then
no_ctls:
	     do;
		call com_err_ (0, me, "No emacs ctls can be found via the search rules.");
		return;
	     end;

dir_list:
	begin;
	     declare dirx		      fixed bin;
	     declare dir_uids	      (search_rules.n_directories) bit (36);
	     declare dir_dir	      character (168);
	     declare dir_entryname	      character (32);

	     dir_uids (*) = (36)"0"b;

	     do idx = 1 to search_rules.n_directories;

		star_entry_ptr = null;
		star_names_ptr = null;

		dirname = search_rules.dir_names (idx);

		if dirname = "working_dir"
		then dirname = get_wdir_ ();

		else if dirname = "referencing_dir"
		then call hcs_$fs_get_path_name (codeptr (list_emacs_ctls), dirname, (0), "", (0));

		else if dirname = "initiated_segments"
		then go to give_up;			/* we cant look at all the refnames */

		call expand_pathname_ (dirname, dir_dir, dir_entryname, (0));
						/* we trust hcs_$get... */
		call hcs_$status_long (dir_dir, dir_entryname, 1, addr (SB), null, code);
		if code = 0
		then do;
			dir_uids (idx) = SB.uid;
			do dirx = 1 to idx - 1;	/* perhaps 0 trip */
			     if dir_uids (dirx) = dir_uids (idx)
			     then go to give_up;	/* been here before */
			end;
		     end;

/* Now have directory to look in.  Look in it! */

		call hcs_$star_ (dirname, rtrim (starname) || ".ctl", star_ALL_ENTRIES, area_ptr, star_entry_count,
		     star_entry_ptr, star_names_ptr, code);

		if code = error_table_$nomatch
		then go to end_loop;

		if code ^= 0
		then do;
			call com_err_ (code, me, "Can't get listing of ctls in ^a.", dirname);
			go to end_loop;
		     end;

		count = hbound (star_names, 1);
		if count = 0
		then go to end_loop;

		begin;
		     dcl sorted_names (count) char (28) varying;
		     dcl	   1 v		      aligned,
			     2 n		      fixed bin (24),
			     2 vector	      (count) pointer unaligned;

		     do jdx = 1 to count;
			v.vector (jdx) = addr (star_names (jdx));
		     end;

/* Sort the entries alphabetically. */
		     v.n = count;
		     call sort_items_$char (addr (v), 32);

/* Now have listing of some entries.  Print them (and
		header if haven't yet. */
		     if ^have_printed_header
		     then do;
			     have_printed_header = "1"b;
			     call ioa_ ("Listing of Emacs terminal controllers:^/");
			end;

		     call ioa_ ("   in ^a", dirname);
		     do jdx = 1 to count;
			terminal =
			     /* translate (*/ rtrim (v.vector (jdx) -> char32)/*, "abcdefghijklmnopqrstuvwxyz",
			     "ABCDEFGHIJKLMNOPQRSTUVWXYZ")*/;
			sorted_names (jdx) = substr (terminal, 1, length (terminal) - length (".ctl"));
		     end;
		     call ioa_$nnl ("^(^8x^3(^20a^5x^)^/^)", sorted_names);
		end;
end_loop:
		if star_names_ptr ^= null ()
		then free star_names;
		if star_entry_ptr ^= null ()
		then free star_entries;

give_up:
	     end;
	end dir_list;

	if ^have_printed_header
	then call ioa_ ("No Emacs terminal controllers found.");

	call ioa_ ("");
	call clean_up ();

	return;

clean_up: proc ();

	if star_names_ptr ^= null ()
	then free star_names;
	if star_entry_ptr ^= null ()
	then free star_entries;

	return;

     end clean_up;
     

find_ctl:
     entry (P_type) returns (character (168));

/* This entry returns the full pathname of a ctl if found,
	   or null string if not. */

	declare tried_both		 bit (1) aligned;

	if length (P_type) > 168
	then return ("");				/* its just impossible... */

	type = rtrim (P_type) || ".ctl";
	tried_both = "0"b;

	do while ("1"b);

	     call hcs_$make_ptr (codeptr (list_emacs_ctls), type, "symbol_table", temp_ptr, code);

	     if temp_ptr ^= null
	     then do;
		     call hcs_$fs_get_path_name (temp_ptr, dirname, (0), "", code);
		     if code = 0
		     then return (rtrim (dirname) || ">" || type);
		end;

	     if tried_both
	     then return ("");			/* No can do */
	     tried_both = "1"b;
	     type = rtrim (P_type) || "ctl";
	end;
     end list_emacs_ctls;




		    task_alm_.alm                   11/05/86  1617.8r w 11/04/86  1038.4       16416



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

	name	task_alm_
"
"	That part of the tasking system that cannot be
"	written in PL/1.
"
"	Written by C. Hornig, April 1980
"
	segdef	switch_stacks
"
	tempd	task_proc(2)
"
	even
null_arglist:
	zero	0,4
	zero	0,0
"
" This macro defines an entrypoint which may be "pseudo-called"
" by task_ctl_. It is entered with its stack frame already set up.
"
	macro	task_tv
	segdef	&1_tv
	entry	&1
&1_tv:
&1:
	getlp
	sprilp	sp|stack_frame.lp_ptr
	eppbp	&1-*,ic
	spribp	sp|stack_frame.entry_ptr
	spbpsb	sp|0
	&end
"
" " " " " " " " " " " " " " " " " " " " " "
"
" This routine is entered when a task is first run.
" It is responsible for calling the task overseer
" on the new stack.
"
	task_tv	task_overseer
	eppap	null_arglist	" call task_overseer_ ();
	short_call task_overseer_$task_overseer_
	tra	task_ctl_$death	" call task_ctl_$death ();
"
" " " " " " " " " " " " " " " " " " " " " "
"
" This routine calls signal_ in a task.
"
	task_tv	task_signal_caller
	eppap	sp|stack_frame.arg_ptr,*
	short_call task_signaller_$task_signaller_
	return
"
" " " " " " " " " " " " " " " " " " " " "
"
" This routine switches from one task to another.
"
switch_stacks:
	epbpsb	sp|0
	sprisp	sb|stack_header.bar_mode_sp
	eppbb	ap|2,*
	epbpsb	bb|0,*
	eppsp	sb|stack_header.bar_mode_sp,*
	short_return
"
	include	stack_header
	include	stack_frame
"
	end




		    task_cl_intermediary_.pl1       11/30/82  1504.2rew 11/30/82  1254.0       11853



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


task_cl_intermediary_:
     procedure;

declare  iox_$error_output pointer external;

dcl  ioa_$ioa_switch entry options (variable),
     task_ctl_$current_task entry returns (fixed bin (35)),
     task_ctl_$schedule entry returns (bit aligned),
     task_ctl_$stop entry (fixed bin (35), fixed bin (35)),
     task_ctl_$die entry,
     ipc_$run entry;

declare  code fixed bin (35);
declare  task fixed bin (35);

declare  (addr, null) builtin;

declare  any_other condition;

/* * * * * * * * * * * * * * * * * * * */

	on any_other call task_ctl_$die;

	task = task_ctl_$current_task ();
	call ioa_$ioa_switch (iox_$error_output, "task_cl_intermediary_: task ^w suspended.", task);
	call task_ctl_$stop (task, (0));
	if ^task_ctl_$schedule () then call ipc_$run;
	return;

     end task_cl_intermediary_;




		    task_create_.pl1                11/05/86  1617.8r w 11/04/86  1034.1       52641



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


/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
task_create_:
     procedure (Task_create_data_ptr, Task_data_ptr, Code);

dcl  Task_create_data_ptr ptr parameter;
dcl  Task_data_ptr ptr parameter;
dcl  Code fixed bin (35) parameter;

dcl  1 abort_label_overlay aligned based (addr (task_data.abort)),
       2 code_ptr ptr,
       2 env_ptr ptr;
dcl  1 defptr_overlay aligned based,			/* overlays defptr in active linkage section */
       2 pad1 bit (29) unaligned,
       2 pps_sw bit (1) unaligned,
       2 pad2 bit (6) unaligned;
dcl  based_ptr ptr based;
dcl  based_words (stack_header.cur_lot_size) fixed bin (35) based;
dcl  task_area area based (task_data.task_area_ptr);

dcl  active_all_rings_data$hcscnt fixed bin (15) external;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  sys_info$max_seg_size fixed bin (19) ext static;

dcl  define_area_ entry (ptr, fixed bin (35));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  ioa_$rsnnl entry () options (variable);
dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  task_alm_$task_overseer_tv entry;
dcl  task_cl_intermediary_ entry;
dcl  task_ctl_$death entry;

dcl  task_name char (13);
dcl  segno fixed bin (15);
dcl  1 ai aligned like area_info;

dcl  size builtin;
%page;
	Task_data_ptr = null ();
	Code = 0;

	call get_temp_segment_ ("task_ctl_", sb, Code);	/* get a stack segment */
	if Code ^= 0 then return;
	task_data_ptr = pointer (sb, size (stack_header));
	sp = addrel16 (task_data_ptr, size (task_data));
	task_data.create_data = Task_create_data_ptr -> task_create_data;

	if task_data.create_data.version = 2 then do;	/* upgrade from 2 to 3 */
	     task_data.create_data.version = 3;
	     string (task_data.create_data.flags) = ""b;
	     task_data.create_data.top_level, task_data.create_data.shared_static = "1"b;
	     end;

	if task_data.create_data.version ^= task_create_data_version_3 then do;
	     Code = error_table_$unimplemented_version;
	     return;
	     end;

	if task_data.create_data.flags.top_level
	then task_data.mother = addr (tasking_data.root_task_data);
	else task_data.mother = pointer (stackbaseptr (), TASK_DP) -> based_ptr;

	stack_header = task_data.mother -> task_data.sb -> stack_header;
	stack_header.stack_begin_ptr, stack_header.bar_mode_sp = sp;
	stack_header.stack_end_ptr = addrel16 (sp, (stack_frame_min_length));

	if task_data.create_data.flags.shared_static	/* create new linkage area if necessary */
	then task_data.task_area_ptr = null ();
	else do;
	     ai.version = area_info_version_1;
	     string (ai.control) = ""b;
	     ai.control.extend, ai.control.zero_on_alloc = "1"b;
	     ai.owner = "task_create_";
	     ai.size = sys_info$max_seg_size;
	     ai.areap = null ();
	     call define_area_ (addr (ai), Code);
	     if Code ^= 0 then return;

	     stack_header.combined_stat_ptr, stack_header.clr_ptr, stack_header.user_free_ptr, task_data.task_area_ptr =
		ai.areap;

	     allocate based_words in (task_area) set (lotp);
	     allocate based_words in (task_area) set (isotp);
	     lotp -> based_words = stack_header.lot_ptr -> based_words;
	     isotp -> based_words = stack_header.isot_ptr -> based_words;
	     do segno = active_all_rings_data$hcscnt + 1 to stack_header.cur_lot_size - 1;
		if unspec (lot.lp (segno)) = ""b then unspec (lot.lp (segno)) = lot_fault;
		if unspec (lot.lp (segno)) ^= lot_fault
		then if ^lot.lp (segno) -> defptr_overlay.pps_sw then unspec (lot.lp (segno)) = lot_fault;
	     end;
	     stack_header.lot_ptr = lotp;
	     stack_header.isot_ptr = isotp;
	     end;

	stack_frame.prev_sp = null ();
	stack_frame.next_sp = stack_header.stack_end_ptr;
	stack_frame.return_ptr = codeptr (task_alm_$task_overseer_tv);
	stack_frame.operator_and_lp_ptr, stack_frame.arg_ptr = null ();
	stack_frame.translator_id = "000001"b3;

	pointer (sb, TASK_DP) -> based_ptr = task_data_ptr;

	task_data.state = STOPPED;
	task_data.sb = sb;
	task_data.task_id = baseno (sb) || substr (bit (clock (), 72), 55, 18);
	abort_label_overlay.code_ptr = codeptr (task_ctl_$death);
	abort_label_overlay.env_ptr = stack_header.stack_begin_ptr;

	task_data.youngest_daughter, task_data.elder_sister, task_data.younger_sister, task_data.ready_next,
	     task_data.ready_last = null ();

	call ioa_$rsnnl ("^w.", task_name, (0), task_data.task_id);
	call iox_$attach_name (task_name || "user_input", task_data.ui_iocb, "syn_ user_i/o -inh close put_chars",
	     null (), Code);
	call iox_$attach_name (task_name || "user_output", task_data.uo_iocb,
	     "syn_ user_i/o -inh close get_chars get_line", null (), Code);
	call iox_$attach_name (task_name || "error_output", task_data.eo_iocb,
	     "syn_ user_i/o -inh close get_chars get_line", null (), Code);

	task_data.cl_intermediary = task_cl_intermediary_;
	task_data.ips_mask = "777777777777"b3;

	Task_data_ptr = task_data_ptr;
	return;



addrel16:
     procedure (Ptr, Offset) returns (ptr);
dcl  Ptr ptr parameter;
dcl  Offset fixed bin parameter;
dcl  offset uns fixed bin (18);

	offset = binary (rel (Ptr), 18) + Offset + 15;
	return (pointer (Ptr, offset - mod (offset, 16)));

     end addrel16;
%page;
%include tasking_data;
%include area_info;
%include linkdcl;
%include lot;
%include stack_header;
%include stack_frame;

     end task_create_;




		    task_ctl_.pl1                   11/05/86  1617.8r w 11/04/86  1034.1      139788



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


/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
task_ctl_:
     procedure;

/* Task control primitives */
/* written by C. Hornig, Decmeber 1978 */

dcl  (
     Task bit (36) aligned,
     Create_data pointer,
     Condition character (*),
     Info_ptr pointer,
     Code fixed (35)
     ) parameter;

dcl  based_ptr pointer based;
dcl  based_fb fixed bin based;

dcl  (
     C32_DESC init ("524000000040"b3),
     PTR_DESC init ("464000000000"b3),
     MASK_ALL init ("000000000000"b3),
     UNMASK_ALL init ("777777777776"b3)
     ) bit (36) aligned static options (constant);

dcl  (
     iox_$user_input,
     iox_$user_output,
     iox_$error_output
     ) external ptr;
dcl  sys_info$max_seg_size fixed bin (19) external;

dcl  error_table_$bad_arg fixed (35) external;

dcl  cu_$get_cl_intermediary entry (entry);
dcl  cu_$set_cl_intermediary entry (entry);
dcl  get_ring_ entry returns (fixed bin (3));
dcl  get_temp_segment_ entry (char (*), pointer, fixed (35));
dcl  hcs_$get_process_usage entry (pointer, fixed bin (35));
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  ioa_$rsnnl entry () options (variable);
dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$find_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$move_attach entry (ptr, ptr, fixed bin (35));
dcl  ipc_$run entry;
dcl  release_area_ entry (ptr);
dcl  release_temp_segment_ entry (char (*), pointer, fixed (35));
dcl  signal_ entry options (variable);
dcl  task_alm_$task_signal_caller_tv entry;
dcl  task_alm_$switch_stacks entry (pointer);
dcl  task_create_ entry (ptr, ptr, fixed bin (35));
dcl  task_init_ entry;
dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  xhcs_$set_stack_ptr entry (pointer);

dcl  1 task_signal_frame aligned based (sp),
       2 f aligned like stack_frame,
       2 arg_list_header,
         3 arg_count uns fixed bin (17) unal,
         3 code uns fixed bin (19) unal,
         3 desc_count uns fixed bin (17) unal,
         3 pad bit (19) unal,
       2 ap (3) ptr,				/* argument pointers */
       2 dp (3) ptr,				/* descriptor pointers */
       2 infop ptr,					/* ptr to info */
       2 cname char (32),				/* condition name */
       2 info (info_length) bit (36) aligned;

dcl  based_info (info_length) bit (36) aligned based;

dcl  1 my_task_data aligned like task_data based (my_task_ptr);

dcl  info_length fixed bin;
dcl  my_task_ptr pointer;
dcl  saved_mask bit (36) aligned;
dcl  scheduledp bit (1) aligned;
dcl  code fixed bin (35);

dcl  (addr, addrel, baseno, baseptr, binary, bit, clock, codeptr, length, mod, null, pointer, rel, size, stackbaseptr,
     stackframeptr, string, substr, unspec) builtin;

dcl  any_other condition;
%page;
/* * * * * * * * * * CREATE * * * * * * * * * */

create:
     entry (Create_data, Task, Code);

	Code = 0;
	Task = ""b;
	if tasking_data_ptr_ = null () then call task_init_;

	call task_create_ (Create_data, task_data_ptr, Code);
	if Code ^= 0 then return;

	call hcs_$set_ips_mask (MASK_ALL, saved_mask);	/* mask down for rethreading */

	task_data.elder_sister = task_data.mother -> task_data.youngest_daughter;

	if task_data.mother -> task_data.youngest_daughter ^= null ()
	then task_data.mother -> task_data.youngest_daughter -> task_data.younger_sister = task_data_ptr;
	task_data.mother -> task_data.youngest_daughter = task_data_ptr;

	tasking_data.valid_tasks (binary (baseno (task_data.sb))) = "1"b;

	call hcs_$reset_ips_mask (saved_mask, saved_mask);

	Task = task_data.task_id;

return_to_caller:
	return;

/* * * * * * * * * * DESTROY * * * * * * * * * */

destroy:
     entry (Task, Code);

	Code = 0;
	call find_task;
	call find_my_task;
	goto mark_as_dead;

/* * * * * * * * * * DIE * * * * * * * * * */

die:
     entry;

	if tasking_data_ptr_ = null () then call task_init_;
	call find_my_task;
	goto my_task_data.abort;

death:
     entry;

	call find_my_task;
	task_data_ptr = my_task_ptr;

mark_as_dead:
	call hcs_$set_ips_mask (MASK_ALL, saved_mask);
	call update_state (DEAD);
	tasking_data.valid_tasks (binary (baseno (task_data.sb))) = "0"b;
	tasking_data.dead_tasks = "1"b;

	if my_task_data.state = DEAD
	then
find_something_to_do:
	     if ^sked () then do;
		call hcs_$set_ips_mask (UNMASK_ALL, (""b));
		call ipc_$run;
		end;

	call hcs_$reset_ips_mask (saved_mask, saved_mask);
	return;

/* * * * * * * * * * CURRENT_TASK * * * * * * * * * */

current_task:
     entry returns (bit (36) aligned);

	if tasking_data_ptr_ = null () then call task_init_;
	call find_my_task;
	return (my_task_data.task_id);

/* * * * * * * * * * GET_TASK_USAGE * * * * * * * * * */

get_task_usage:
     entry (Task, Info_ptr, Code);

	if tasking_data_ptr_ = null ()
	then call hcs_$get_process_usage (Info_ptr, Code);
	else do;
	     Code = 0;
	     call find_task;
	     call find_my_task;
	     if task_data_ptr = my_task_ptr then call meter (task_data.meters);
	     process_usage_pointer = Info_ptr;
	     process_usage.number_can_return = 5;
	     if process_usage.number_wanted > 0 then process_usage.cpu_time = task_data.tcpu;
	     if process_usage.number_wanted > 1 then process_usage.paging_measure = task_data.mem;
	     if process_usage.number_wanted > 2 then process_usage.page_faults = task_data.pf;
	     if process_usage.number_wanted > 4 then process_usage.virtual_cpu_time = task_data.vcpu;
	     call hcs_$reset_ips_mask (saved_mask, saved_mask);
	     end;
	return;

/* * * * * * * * * * START * * * * * * * * * */

start:
     entry (Task, Code);

	Code = 0;
	call find_task;
	call update_state (READY);
	call hcs_$reset_ips_mask (saved_mask, saved_mask);
	return;

/* * * * * * * * * * STOP * * * * * * * * * */

stop:
     entry (Task, Code);

	Code = 0;
	call find_task;
	call update_state (STOPPED);
	call hcs_$reset_ips_mask (saved_mask, saved_mask);
	return;

/* * * * * * * * * * SIGNAL * * * * * * * * * */

signal:
     entry (Task, Condition, Info_ptr, Code);

	Code = 0;
	call find_task;
	call find_my_task;
	if task_data_ptr = my_task_ptr then do;		/* easy way */
	     call signal_ (Condition, null (), Info_ptr, null ());
	     return;
	     end;

	sb = task_data.sb;
	sp = stack_header.stack_end_ptr;

	if Info_ptr = null ()
	then info_length = 0;
	else info_length = Info_ptr -> based_fb;

	stack_frame.next_sp,			/* push a stack frame */
	     stack_header.stack_end_ptr = addrel16 (sp, size (task_signal_frame));
	stack_frame.prev_sp = stack_header.bar_mode_sp;
	stack_frame.return_ptr = codeptr (task_alm_$task_signal_caller_tv);
	stack_frame.arg_ptr = addr (task_signal_frame.arg_list_header);
	stack_frame.translator_id = "000001"b3;

	task_signal_frame.arg_count, task_signal_frame.desc_count = 3;
	task_signal_frame.code = 4;
	task_signal_frame.ap (1) = addr (task_signal_frame.cname);
	task_signal_frame.ap (2) = addr (stack_header.null_ptr);
	task_signal_frame.ap (3) = addr (task_signal_frame.infop);
	task_signal_frame.dp (1) = addr (C32_DESC);
	task_signal_frame.dp (2), task_signal_frame.dp (3) = addr (PTR_DESC);
	task_signal_frame.infop = addr (task_signal_frame.info);
	task_signal_frame.cname = Condition;
	if Info_ptr ^= null () then task_signal_frame.info = Info_ptr -> based_info;

	stack_header.bar_mode_sp = sp;
	goto wake;

/* * * * * * * * BLOCK * * * * * * * * * */

block:
     entry;

	if tasking_data_ptr_ = null () then call task_init_;
	call find_my_task;
	task_data_ptr = my_task_ptr;
	call hcs_$set_ips_mask (MASK_ALL, saved_mask);
	if task_data.state = READY then do;
	     call update_state (BLOCKED);
	     end;					/*
						   call hcs_$reset_ips_mask (saved_mask, saved_mask);
						   return;
						*/
	goto find_something_to_do;

/* * * * * * * * * * WAKEUP * * * * * * * * * */

wakeup:
     entry (Task, Code);

	Code = 0;
	call find_task;
wake:
	if task_data.state = BLOCKED then do;
	     call update_state (READY);
	     end;
	call hcs_$reset_ips_mask (saved_mask, saved_mask);
	return;

/* * * * * * * * * * SCHEDULE * * * * * * * * * */

schedule:
     entry returns (bit (1) aligned);

	if tasking_data_ptr_ = null () then call task_init_;
	call find_my_task;
	call hcs_$set_ips_mask (MASK_ALL, saved_mask);
	scheduledp = sked ();
	call hcs_$reset_ips_mask (saved_mask, saved_mask);
	return (scheduledp);

sked:
     procedure returns (bit (1) aligned);
dcl  best_task pointer;
dcl  best_value fixed bin (35);

	call meter (my_task_data.meters);
	if (my_task_data.vcpu_limit > 0) & (my_task_data.meters.vcpu > my_task_data.vcpu_limit)
	     & (my_task_data.state ^= DEAD)
	then goto my_task_data.abort;			/* over CPU limit */

	best_task = null ();
	best_value = -34359738367;
	do task_data_ptr = tasking_data.ready_head repeat (task_data.ready_next) while (task_data_ptr ^= null ());

	     if task_data.priority > best_value then do;
		best_value = task_data.priority;
		best_task = task_data_ptr;
		end;
	end;

	if best_task = null () then return ("0"b);

	task_data_ptr = best_task;
	if task_data.ready_next ^= null () then do;	/* rethread at end */
	     call thread_out;
	     call thread_in;
	     end;

	if my_task_ptr ^= task_data_ptr
	then begin;

/* ***** SWITCH TASKS ***** */

	     my_task_data.ips_mask = saved_mask;
	     call iox_$move_attach (iox_$user_input, my_task_data.ui_iocb, code);
	     call iox_$move_attach (iox_$user_output, my_task_data.uo_iocb, code);
	     call iox_$move_attach (iox_$error_output, my_task_data.eo_iocb, code);
	     call cu_$get_cl_intermediary (my_task_data.cl_intermediary);
	     call xhcs_$set_stack_ptr (task_data.sb);
	     call task_alm_$switch_stacks (task_data.sb);
	     call cu_$set_cl_intermediary (my_task_data.cl_intermediary);
	     call iox_$move_attach (my_task_data.ui_iocb, iox_$user_input, code);
	     call iox_$move_attach (my_task_data.uo_iocb, iox_$user_output, code);
	     call iox_$move_attach (my_task_data.eo_iocb, iox_$error_output, code);
	     saved_mask = my_task_data.ips_mask;

/* ***** DONE STACK SWITCHING * ****/

	end;

	if tasking_data.dead_tasks then do;
	     tasking_data.dead_tasks = "0"b;
	     call gc_dead_tasks (addr (tasking_data.root_task_data));
	     end;
	call meter (overhead_meters);
	return ("1"b);
     end sked;

/* * * * * * * * * * * * * * * * * * * */

find_task:
     procedure;
dcl  segno unsigned fixed bin (18);
dcl  task bit (36) aligned;

	task = Task;				/* copy arguments */
	call hcs_$set_ips_mask (MASK_ALL, saved_mask);

	task_data_ptr = get_tdp (task);
	if task_data_ptr ^= null () then return;

	call hcs_$reset_ips_mask (saved_mask, saved_mask);
	Code = error_table_$bad_arg;
	goto return_to_caller;

     end find_task;

/* * * * * * * * * */

get_tdp:
     procedure (Task) returns (ptr);
dcl  Task bit (36) aligned parameter;
dcl  tdp ptr;
dcl  segno fixed bin (15);

	segno = binary (substr (Task, 1, 18), 15);
	if tasking_data.valid_tasks (segno) then do;
	     tdp = pointer (baseptr (segno), TASK_DP) -> based_ptr;
	     if tdp -> task_data.task_id = Task then return (tdp);
	     end;
	return (null ());
     end get_tdp;

/* * * * * * * * * */

find_my_task:
     procedure;
	my_task_ptr = pointer (stackbaseptr (), TASK_DP) -> based_ptr;
     end find_my_task;

/* * * * * * * * * */

gc_dead_tasks:
     procedure (Tdp) recursive;
dcl  Tdp ptr parameter;
dcl  (tdp, next_tdp) ptr;

	do tdp = Tdp -> task_data.youngest_daughter repeat (next_tdp) while (tdp ^= null ());
	     next_tdp = tdp -> task_data.elder_sister;
	     call gc_dead_tasks (tdp);
	end;
	if (Tdp -> task_data.state = DEAD) & (Tdp -> task_data.youngest_daughter = null ()) then call kill (Tdp);
	return;

     end gc_dead_tasks;

/* * * * * * * * * */

kill:
     procedure (Tdp);
dcl  Tdp pointer parameter;
dcl  code fixed bin (35);

	call iox_$detach_iocb (Tdp -> task_data.ui_iocb, code);
	call iox_$detach_iocb (Tdp -> task_data.uo_iocb, code);
	call iox_$detach_iocb (Tdp -> task_data.eo_iocb, code);
	call iox_$destroy_iocb (Tdp -> task_data.ui_iocb, code);
	call iox_$destroy_iocb (Tdp -> task_data.uo_iocb, code);
	call iox_$destroy_iocb (Tdp -> task_data.eo_iocb, code);

	if Tdp -> task_data.task_area_ptr ^= null () then call release_area_ (Tdp -> task_data.task_area_ptr);

	if Tdp -> task_data.younger_sister = null ()
	then Tdp -> task_data.mother -> task_data.youngest_daughter = Tdp -> task_data.elder_sister;
	else Tdp -> task_data.younger_sister -> task_data.elder_sister = Tdp -> task_data.elder_sister;
	if Tdp -> task_data.elder_sister ^= null ()
	then Tdp -> task_data.elder_sister -> task_data.younger_sister = Tdp -> task_data.younger_sister;
	call release_temp_segment_ ("task_ctl_", Tdp -> task_data.sb, (0));
	return;

     end kill;

/* * * * * * * * * */

meter:
     procedure (Meters);
dcl  1 Meters aligned like task_data.meters parameter;
dcl  1 pu aligned like process_usage;

	pu.number_wanted = 5;
	call hcs_$get_process_usage (addr (pu), (0));
	Meters.tcpu = Meters.tcpu + pu.cpu_time - old_pu.tcpu;
	old_pu.tcpu = pu.cpu_time;
	Meters.vcpu = Meters.vcpu + pu.virtual_cpu_time - old_pu.vcpu;
	old_pu.vcpu = pu.virtual_cpu_time;
	Meters.mem = Meters.mem + pu.paging_measure - old_pu.mem;
	old_pu.mem = pu.paging_measure;
	Meters.pf = Meters.pf + pu.page_faults - old_pu.pf;
	old_pu.pf = pu.page_faults;
     end meter;

/* * * * * * * * * * UPDATE_STATE * * * * * * * * * */

update_state:
     procedure (State);
dcl  State fixed bin;

	if task_data.state = State then return;
	if task_data.state = READY then do;		/* must unthread the task */
	     call thread_out;
	     end;
	if State = READY then do;			/* must thread the task */
	     call thread_in;
	     end;
	task_data.state = State;
     end update_state;

/* * * * * * * * * */

addrel16:
     procedure (Ptr, Offset) returns (ptr);
dcl  Ptr ptr parameter;
dcl  Offset fixed bin parameter;
dcl  offset uns fixed bin (18);

	offset = binary (rel (Ptr), 18) + Offset + 15;
	return (pointer (Ptr, offset - mod (offset, 16)));
     end addrel16;

/* * * * * * * * * */

thread_in:
     procedure;

	task_data.ready_last = tasking_data.ready_tail;
	task_data.ready_next = null ();
	if tasking_data.ready_tail ^= null ()
	then tasking_data.ready_tail -> task_data.ready_next = task_data_ptr;
	else tasking_data.ready_head = task_data_ptr;
	tasking_data.ready_tail = task_data_ptr;
	return;

     end thread_in;

/* * * * * * * * * */

thread_out:
     procedure;

	if task_data.ready_last = null ()
	then tasking_data.ready_head = task_data.ready_next;
	else task_data.ready_last -> task_data.ready_next = task_data.ready_next;
	if task_data.ready_next = null ()
	then tasking_data.ready_tail = task_data.ready_last;
	else task_data.ready_next -> task_data.ready_last = task_data.ready_last;
	task_data.ready_next, task_data.ready_last = null ();
	return;

     end thread_out;
%page;
%include tasking_data;
%include stack_header;
%include stack_frame;
%include process_usage;

     end task_ctl_;




		    task_init_.pl1                  11/05/86  1617.8r w 11/04/86  1034.1       41706



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


/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
task_init_:
     procedure options (separate_static);

dcl  sys_info$max_seg_size fixed bin (19) external;

dcl  define_area_ entry (ptr, fixed bin (35));
dcl  get_ring_ entry () returns (fixed bin (3));
dcl  hcs_$grow_lot entry (fixed bin (3));
dcl  ioa_$rsnnl entry () options (variable);
dcl  iox_$find_iocb entry (char (*), ptr, fixed bin (35));
dcl  task_ctl_$death entry;

dcl  foo static;
dcl  1 static_tasking_data aligned like tasking_data static;

dcl  i fixed bin;
dcl  code fixed bin (35);
dcl  task_name char (13);
dcl  old_rnt_areap ptr;
dcl  1 ai aligned like area_info;

dcl  1 abort_label_overlay aligned based (addr (task_data.abort)),
       2 code_ptr ptr,
       2 env_ptr ptr;

dcl  based_ptr ptr based;

dcl  rnt_areap ptr;
dcl  rnt_area area (sys_info$max_seg_size) based (rnt_areap);

dcl  (addr, addrel, pointer, size, stackbaseptr) builtin;

dcl  task_error_ condition;
%page;
	foo = 0;
	sb = stackbaseptr ();

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Make sure that the LOT has been extended to its maximum size.  This is because	*/
/* grow_lot doesn't know about multiple stacks and would get confused.		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if stack_header.lot_ptr = sb then call hcs_$grow_lot (get_ring_ ());

	lotp = stack_header.lot_ptr;
	do i = 0 to stack_header.max_lot_size;		/* fault all the LOT pointers */
	     if unspec (lot.lp (i)) = ""b then unspec (lot.lp (i)) = lot_fault;
	end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Now do the same for the RNT.						*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if stack_header.rnt_ptr -> rnt.rnt_area_size < sys_info$max_seg_size then do;
	     ai.version = area_info_version_1;
	     string (ai.control) = ""b;
	     ai.zero_on_free, ai.system = "1"b;
	     ai.owner = "RNT";
	     ai.size = sys_info$max_seg_size;
	     ai.areap = null ();
	     call define_area_ (addr (ai), code);
	     if code ^= 0 then signal task_error_;
	     rnt_areap = ai.areap;

	     old_rnt_areap = stack_header.rnt_ptr -> rnt.areap;
	     rnt_area = old_rnt_areap -> based_rnt_area;
	     rntp = addrel (rnt_areap, binary (rel (stack_header.rnt_ptr), 18) - binary (rel (old_rnt_areap), 18));
	     rnt.srulep = addrel (rnt_areap, binary (rel (rnt.srulep), 18) - binary (rel (old_rnt_areap), 18));
	     rnt.areap = rnt_areap;
	     rnt.rnt_area_size = size (rnt_area);
	     stack_header.rnt_ptr = rntp;
	     free old_rnt_areap -> based_rnt_area;
	     end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Now fill in the task data for the root task.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	tasking_data_ptr_ = addr (static_tasking_data);

	pointer (sb, TASK_DP) -> based_ptr, task_data_ptr = addr (tasking_data.root_task_data);

	task_data.sb = sb;
	task_data.state = READY;
	task_data.comment = "Initial Task";
	task_data.mother, task_data.youngest_daughter, task_data.elder_sister, task_data.younger_sister,
	     task_data.ready_last, task_data.ready_next = null ();
	task_data.task_id = baseno (sb);
	abort_label_overlay.code_ptr = codeptr (task_ctl_$death);
	abort_label_overlay.env_ptr = stack_header.stack_begin_ptr;

	call ioa_$rsnnl ("^w.", task_name, (0), task_data.task_id);
	call iox_$find_iocb (task_name || "user_input", task_data.ui_iocb, code);
	call iox_$find_iocb (task_name || "user_output", task_data.uo_iocb, code);
	call iox_$find_iocb (task_name || "error_output", task_data.eo_iocb, code);

	tasking_data.ready_head, tasking_data.ready_tail = task_data_ptr;
	tasking_data.valid_tasks (binary (baseno (sb), 15)) = "1"b;
	return;
%page;
%include tasking_data;
%include area_info;
%include lot;
%include rnt;
%include stack_header;

     end task_init_;




		    task_overseer_.pl1              11/30/82  1504.2rew 11/30/82  1254.0       25722



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


task_overseer_:
     procedure;

dcl  iox_$user_input ptr ext static;
dcl  iox_$user_output ptr ext static;
dcl  iox_$error_output ptr ext static;

dcl  continue_to_signal_ entry (fixed bin (35));
dcl  cu_$arg_list_ptr entry returns (ptr);
dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
dcl  cu_$generate_call entry (entry, ptr);
dcl  cu_$set_cl_intermediary entry (entry);
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  iox_$move_attach entry (ptr, ptr, fixed bin (35));
dcl  signal_ entry;

dcl  based_ptr ptr based;

dcl  code fixed bin (35);
dcl  overseer bit (1) aligned;

dcl  (length, pointer, stackbaseptr) builtin;

dcl  (any_other, finish, task_debug_) condition;
%page;
	overseer = "1"b;

	on condition (any_other) system;
	on condition (finish), condition (task_debug_)
	     begin;
dcl  code fixed bin (35);
dcl  1 ci aligned like condition_info;
dcl  command char (256) aligned;

		call find_condition_info_ (null (), addr (ci), code);
		if code = 0 then do;
		     if ci.info_ptr ^= null () then do;
			if /* case */ ci.condition_name = "finish" then do;
			     if ci.info_ptr -> finish_info.type = "task" then goto abort_task;
			     end;
			else if ci.condition_name = "task_debug_" then do;
			     command = ci.info_ptr -> task_debug_info.info_string;
			     call cu_$cp (addr (command), length (ci.info_ptr -> task_debug_info.info_string), code)
				;
			     goto done_cond;
			     end;
			end;
		     end;
		call continue_to_signal_ (code);
done_cond:
	     end;

	goto common;
%page;
task_signaller_:
     entry options (variable);

	overseer = "0"b;

common:
	task_data_ptr = pointer (stackbaseptr (), TASK_DP) -> based_ptr;

	call cu_$set_cl_intermediary (task_data.cl_intermediary);
	call iox_$move_attach (task_data.ui_iocb, iox_$user_input, code);
	call iox_$move_attach (task_data.uo_iocb, iox_$user_output, code);
	call iox_$move_attach (task_data.eo_iocb, iox_$error_output, code);
	call hcs_$set_ips_mask (task_data.ips_mask, (""b));

	if overseer
	then call task_data.overseer (task_data.data_ptr);
	else call cu_$generate_call (signal_, cu_$arg_list_ptr ());

abort_task:
	return;
%page;
%include task_data;
%include task_create_data;
%include task_condition_info;
%include condition_info;

     end task_overseer_;





		    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
