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 '||) (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 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- 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- (display-error "esc- 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 '||) (go-to-or-create-buffer 'main) (setq previous-buffer 'main)) ((eq previous-buffer '||) (setq previous-buffer current-buffer))) (setq known-buflist (delq '|| 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 ;;;||< contents of q >| ;;; |< l(ss) >|| ;;; 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 | -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 ("<