LISTING FOR >spec>install>1014>e_macops_ COMPILED BY Multics LISP Compiler, Version 2.13c, July 11, 1983 ON 03/25/87 1029.5 mst Wed IN BEHALF OF GJohnson.SysMaint.a ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; EMACS extended functions ;;; BSG, archy, GMP, RSL, RMSoley, etc ;;; ;;; How about some journalization: ;;; HISTORY COMMENTS: ;;; 1) change(84-01-30,Margolin), approve(), audit(), ;;; install(86-08-20,MR12.0-1136): ;;; pre-hcom history: ;;; Modified: June 1982 by Barmar - to install JSL's new string-search ;;; and global-print commands, using all his new hairy ;;; defcom features. ;;; Modified: 31 August 1982 by Barmar - to move query-replace here from ;;; emacs-extended-searches. ;;; Modified: 1 November 1983 by Barmar - to fix replace to not fill up the ;;; kill-ring with the old string, and fix replace and query-replace ;;; to use backward-char instead of reverse-search. ;;; Modified: 25 November 1983 by Barmar - to fix the read-only bug in ;;; word-operator, also converting macros to defmacro. ;;; Modified: ?? January 1984 by Barmar - to rewrite underlining code. ;;; 2) change(84-12-25,Margolin), approve(86-02-24,MCR7186), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; to move iox_$control out to e_defpl1_.lisp, changed lambda into let. ;;; 3) change(84-12-30,Margolin), approve(86-02-24,MCR7186), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; to move fillon, fill-mode-off, and ;;; filloff to e_basic_, with fill-mode; changed speedtype to ;;; interact with previous key bindings better. ;;; 4) change(84-12-31,Margolin), approve(86-02-24,MCR7186), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; change comout-get-output to check ;;; read-only-flag, add unwind-protect to comout, comout-get-output, ;;; and eval-multics-command-line; move reset_more ;;; from comout-command to eval-multics-command-line; changed ;;; comout-get-output to use "file_output -truncate" rather than ;;; calling hcs_$set_bc. ;;; 5) change(85-01-27,Margolin), approve(86-02-24,MCR7186), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; add some *expr declarations. ;;; 6) change(85-02-03,Margolin), approve(86-02-24,MCR7186), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; changed speedtype to special-case ;;; CR, rather than expecting it to be in fill-mode-delimiters. ;;; 7) change(85-02-24,Margolin), approve(87-01-27,MCR7607), ;;; audit(87-02-13,RBarstad), install(87-03-25,MR12.1-1014): ;;; added comout-to-buffer, changed comout to use it. Added ;;; (%include defun), and changed comout to use &rest. Changed ;;; comout-command to turn off read-only-flag (with a warning in the ;;; prompt), added comout-command-to-buffer. ;;; 8) change(86-11-22,Margolin), approve(87-01-27,MCR7607), ;;; audit(87-02-13,RBarstad), install(87-03-25,MR12.1-1014): ;;; Changed comout-command and comout-command-to-buffer to check whether ;;; the output buffer contains an unwritten nonempty buffer, and to use ;;; local displays for the warnings. Changed comout-to-buffer to support ;;; the comout-local-display option. ;;; END HISTORY COMMENTS (%include e-macros) (%include defmacro) (declare (macros nil)) (%include defun) (%include other_other) (defmacro defkill (name type) `(defprop ,name ,type kills)) (declare (genprefix /!e_macops_)) (declare (*lexpr ncline comout minibuffer-remark gratuitous-mark-setter report-error report-error-noabort)) (declare (*expr autofill-self-insert buffer-kill close-line iox_$control e_pl1_$set_emacs_tty_modes e_pl1_$set_multics_tty_modes ed-cv-fixnum-check extended-command forward-regexp-search get-buffer-state go-to-hpos hcs_$set_bc hcs_$truncate_file e_pl1_$get_iocb intern-minibuf-response mark-at-current-point-p mark-tag-fun local-display-buffer-info delete-word search-charset-forward minibuffer-response push-mark-ring search-charset-backwards self-insert skip-to-whitespace-in-line exists-buffer search:numeric-prompt set-the-mark-here backward-n-chars check-read-only get-key-binding parse-key-description)) (declare (special curpointpos good-word-charactertbl whitespace-charactertbl iocb_ptr null-pointer non-speedtype-bindings CRET last-input-char current-buffer-mode buffer-minor-modes pdir-temp-ename suppress-redisplay-flag two-window-mode number-of-lines-in-buffer known-buflist fpathname buffer-modified-flag read-only-flag fill-prefix NLCHARSTRING tab-equivalent comment-column comment-prefix firstline lastline curline pdir-temp-pathname hard-enforce-fill-column varlist fill-column fill-mode-delimiters minibufferp OPEN-PAREN CLOSE-PAREN SEMI SINGLEQUOTE DOUBLEQUOTE SLASH sexp-searcher-mark-list MCS-editing-characters mark-ring MCS-escape-character process-dir named-mark-list macro-execution-in-progress tty-no-upmotionp damaged-flag last-minibuf-response previous-command e-lisp-error-mode completion-list)) (defvar ((comout-local-display nil) (*comout-command-default-buffer* 'file_output) *comout-buffer-force* *comout-command-buffer*)) ;;; ;;; Named mark management ;;; (defun get-named-mark (name) (let ((m (let ((tag (mark-tag-fun current-buffer))) (get name tag)))) (and (null m) (report-error 'no-named-mark " " name)) m)) (defun set-named-mark- (markname) (let ((tag (mark-tag-fun current-buffer))) (let ((current (get markname tag))) (cond (current (set-mark-here current)) (t (setq current (set-mark)) (putprop markname current tag) (setq named-mark-list (cons markname named-mark-list)))) current))) (defcom delete-named-mark &arguments ((markname &symbol &prompt "Delete named mark: " &default &eval (report-error 'need-mark-name))) (let ((m (get-named-mark markname))) (setq named-mark-list (delq markname named-mark-list)) (release-mark m) (remprop markname (mark-tag-fun current-buffer)))) (defun produce-named-mark-list () (let ((tag (mark-tag-fun current-buffer))) (mapcar '(lambda (x)(list x (get x tag))) named-mark-list))) ;;; Character-oriented commands. (defcom twiddle-chars &undo-function twiddle-chars (backward-char) (backward-char) (insert-char (prog2 0 (curchar) (delete-char) (forward-char)))) ;;; Word-oriented commands. (defcom replace &arguments ((original &default &eval (get-search-string "Replace old string")) (new &prompt "Replace new string: " NL)) (if (not (forward-search original)) (search-failure-annunciator)) (let ((old-length (stringlength original))) (do-forever (with-mark m ;have already searched, flush it (backward-n-chars old-length) (without-saving (wipe-point-mark m))) (insert-string new) (if (not (forward-search original)) ;look again (stop-doing))))) ;not found, done (defcom twiddle-words &undo-function twiddle-words (save-excursion (and (charset-member (curchar) good-word-charactertbl) (forward-word)) (search-charset-backwards good-word-charactertbl) (with-mark bow (backward-word) (let ((second (point-mark-to-string bow))) (without-saving (wipe-point-mark bow)) (search-charset-backwards good-word-charactertbl) (cond ((at-beginning-of-buffer) (insert-string second) (command-quit))) (let ((in-between (point-mark-to-string bow))) (without-saving (wipe-point-mark bow)) (backward-word) (insert-string second) (insert-string in-between) (forward-word)))))) (defcom underline-word &undo-function remove-underlining-from-word (or (bolp)(backward-char)) (forward-word) (with-mark m (backward-word) (underline-point-mark m))) (declare (special underline-whitespace)) (defcom underline-region &numeric-function de-underline-region &undo-function de-underline-region (let ((point-at-end)) (with-the-mark-last done (setq point-at-end (mark-at-current-point-p der-wahrer-mark)) (underline-point-mark done)) (or point-at-end (exchange-point-and-mark)) (cond ((and (looking-at BACKSPACE) (alphalessp (lefthand-char) "_")) (forward-char) (forward-char))) (or point-at-end (exchange-point-and-mark)))) (defun underline-point-mark (mark) (do ((this (curchar) (curchar))) ((mark-reached mark)) (cond ((and (samepnamep this TAB) underline-whitespace) (insert-string (gen-repetitive (- tab-equivalent (\ (cur-hpos) tab-equivalent)) "_")) (delete-char)) ((and (samepnamep this SPACE) underline-whitespace) (delete-char) (insert-string "_")) ((or (samepnamep this "_") ;don't underline underscore (samepnamep this "ÿ") ;skip control chars (alphalessp this SPACE)) ; "" "" "" (forward-char)) ((and (charset-member this whitespace-charactertbl) (not underline-whitespace)) (forward-char)) ((alphalessp this "_") (forward-char) (cond ((samepnamep (curchar) BACKSPACE) ;already overstruck (forward-char) (forward-char)) (t (insert-string BACKSPACE) (insert-string "_")))) ((samepnamep (lefthand-char) BACKSPACE) ;already overstruck (forward-char)) (t (insert-string "_") (insert-string BACKSPACE) (forward-char))))) (defcom de-underline-region &undo-function underline-region (with-the-mark-last done (de-underline-point-mark done))) ;;; Removes underlining from the point to a given mark. ;;; Caller must ensure that mark is beyond point. (defun de-underline-point-mark (mark) (do-forever (if (mark-reached mark) (stop-doing)) (cond ((or (looking-at "_") (looking-at "_")) (delete-char) (delete-char)) ((and underline-whitespace (looking-at "_")) (delete-char) (insert-string SPACE)) ('else (forward-char))))) (defcom remove-underlining-from-word (or (bolp) (backward-char)) (forward-word) (with-mark m (backward-word) (de-underline-point-mark m))) ;;; Line-oriented commands. (defcom open-space &numeric-argument (&repeat &lower-bound 0) (insert-char NL) (backward-char)) (defcom set-fill-prefix &arguments ((new-prefix &default &eval (with-mark m (go-to-beginning-of-line) (prog2 nil (point-mark-to-string m) (go-to-mark m))))) (setq fill-prefix new-prefix)) (defcom center-line (save-excursion (go-to-beginning-of-line) (delete-white-sides) (go-to-end-of-line) (delete-white-sides) (let ((hp (cur-hpos))) (go-to-beginning-of-line) (and (< hp fill-column) (whitespace-to-hpos (// (- fill-column hp) 2)))))) (defcom split-line (let ((hpos (cur-hpos))) (save-excursion (insert-char NL) (whitespace-to-hpos hpos)))) (defcom delete-line-indentation &numeric-argument (&pass) (if numarg (next-line)) (go-to-beginning-of-line) (delete-white-sides) (rubout-char)) (defcom mark-whole-buffer (go-to-end-of-buffer) (set-the-mark) (go-to-beginning-of-buffer)) ;;; Speedtype (defcom speedtype-expander &numeric-argument (&repeat &lower-bound 0) (prog (the-word) (backward-char) (cond ((not (charset-member (curchar) good-word-charactertbl)) (forward-char)) (t (forward-char) (with-mark m (backward-word) (setq the-word (internedp (point-mark-to-string m))) (if (symbolp the-word) (setq the-word (get the-word 'speedtype)) else (setq the-word nil)) (if the-word (wipe-point-mark m) (insert-string the-word) else (go-to-mark m))))) (let ((old-binding (or (cdr (assq last-input-char non-speedtype-bindings)) 'self-insert))) (funcall old-binding)))) ;;; Hack to check obarray for a "word" without interning it (defun internedp (string) (cond ((= (stringlength string) 1) (ascii (getcharn string 1))) (t (do ((l (obarray (\ (sxhash string) 509.)) (cdr l))) ((null l) string) (and (samepnamep (car l) string) (return (car l))))))) (defun setab n ;reverted to old-command (do ((arg-list (listify n)(cddr arg-list))) ((null arg-list)) (let ((name (intern (make_atom (e_lap_$trim (car arg-list))))) (value (cadr arg-list))) (if (nullstringp value) (display-error "No expansion supplied for " name ".")) (putprop name value 'speedtype)))) (defcom speedtype (assert-minor-mode 'speedtype) (register-local-var 'non-speedtype-bindings) (setq non-speedtype-bindings nil) (mapc '(lambda (x) (push (cons x (get-key-binding (parse-key-description x))) non-speedtype-bindings) (set-key x 'speedtype-expander)) (cons CRET fill-mode-delimiters))) (defcom speedtypeoff (negate-minor-mode 'speedtype) (mapc '(lambda (x) (set-key (car x) (cdr x))) non-speedtype-bindings)) ;;; Uncle-and-aunt indenter, BSG 12/10/78 (defcom indent-relative &numeric-argument (&pass) (go-to-beginning-of-line) (tab-to-previous-columns)) (defcom tab-to-previous-columns &numeric-argument (&pass) (skip-over-whitespace-in-line) (and (bolp) (eolp) (setq numarg nil)) (let ((orighpos (cur-hpos))) (with-mark m (delete-white-sides) (do-forever (if (firstlinep) (stop-doing) else (prev-line)) (if (line-is-blank) else (if numarg (skip-over-indentation) (if (< (cur-hpos) orighpos) (stop-doing)) else (stop-doing)))) (if (not numarg) (go-to-hpos orighpos) (if (at-white-char) (skip-over-whitespace-in-line) (if (eolp) (go-to-beginning-of-line)) else (if (not (> (cur-hpos) orighpos)) (skip-to-whitespace-in-line) (skip-over-whitespace-in-line)))) (setq orighpos (cur-hpos)) (go-to-mark m) (whitespace-to-hpos orighpos)))) (defcom cret-and-indent-relative &numeric-argument (&pass) (cond (minibufferp (insert-string NLCHARSTRING)) (t (new-line) (indent-relative)))) ;;; ;;; Adapted from Killian, BSG 10/15/80 ;;; (defcom indent-rigidly &numeric-argument (&pass) (setq numarg (or numarg 0)) (save-excursion (with-the-mark-last m (do-forever (if (mark-at-current-point-p m)(stop-doing)) (if (not (line-is-blank)) (skip-over-indentation) (let ((hpos (cur-hpos))) (delete-white-sides) (whitespace-to-hpos (max 0 (+ hpos numarg))))) (if (mark-on-current-line-p m)(stop-doing)) (next-line))))) ;;; ;;; Variable managers ;;; (setq varlist nil) (defcom put-variable &prologue &eval (if der-wahrer-mark else (report-error 'mark-not-set)) &arguments ((x &symbol &prompt "Set variable: " &default &eval (display-error-noabort "You must supply a variable name."))) (or (memq x varlist) (setq varlist (cons x varlist))) (wipe-region) (putprop x (kill-pop) 'editvalue)) (defcom get-variable &arguments ((x &symbol &prompt "Get variable: " &default &eval (display-error-noabort "You must supply a variable name."))) (let ((stuff (get x 'editvalue))) (if stuff (set-the-mark) (insert-string stuff) else (display-error x " has no value.")))) (defcom list-variables (prog () (if (not varlist) (display-error "No variables to list.")) (save-excursion-buffer (go-to-or-create-buffer (maknam (explodec "Variable list"))) (putprop current-buffer t 'temporary-buffer) (insert-string "Current string variables") (new-line)(new-line) (insert-string "Name") (format-to-col 10.) (insert-string "#Chars") (new-line)(new-line) (do l varlist (cdr l)(null l) (let ((v (car l)) (s (get (car l) 'editvalue))) (insert-string v) (format-to-col 10.) (insert-string (decimal-rep (stringlength s)))) (new-line)) (display-buffer-as-printout)) (end-local-displays))) (defcom-synonym lvars list-variables) ;;; ;;; Buffer lister ;;; (declare (special previous-buffer)) ;;; Got rid of old horrible crock, replaced using local-display-buffer-info ;;; Richard Mark Soley, 5 August 1981 (defcom list-buffers (init-local-displays) (local-display-generator-nnl "Listing of Current Buffers") (local-display-generator-nnl "") (do ((buffer known-buflist (cdr buffer))) ((null buffer)) (local-display-buffer-info (car buffer))) (end-local-displays)) (defun format-to-col (x) (cond ((not (< curpointpos x))(insert-char SPACE)) (t (whitespace-to-hpos x)))) ;;; Case changing commands and primitives. (defmacro word-operator (count &body forms) `(progn (cond ((or (null ,count) (and (charset-member (curchar) good-word-charactertbl) (plusp ,count))) (or (and (not (charset-member (lefthand-char) good-word-charactertbl)) (charset-member (curchar) good-word-charactertbl)) (backward-word))) ((minusp ,count) (do-times (abs ,count) (backward-word))) (t (search-charset-forward good-word-charactertbl))) (do ((n (abs (or ,count 1)) (1- n)) (word) (quit)) ((or quit (zerop n)) (and quit (ring-tty-bell))) (setq word (with-mark here (forward-word) (prog1 (point-mark-to-string here) (go-to-mark here)))) (protect ,@forms &success (without-saving (delete-word))) (or (= n 1) (search-charset-forward good-word-charactertbl) (setq quit t))) (cond ((and (fixp ,count) (minusp ,count)) (do-times (abs ,count) (backward-word)) (or (at-beginning-of-buffer) (backward-char)))))) (defcom capitalize-initial-word &numeric-argument (&pass) (word-operator numarg (insert-char (uppercase (substr word 1 1))) (insert-string (lowercase (substr word 2))))) (defcom upper-case-word &numeric-argument (&pass) (word-operator numarg (insert-string (uppercase word)))) (defcom lower-case-word &numeric-argument (&pass) (word-operator numarg (insert-string (lowercase word)))) (defun uppercase (string) (maknam (mapcar '(lambda (x) (cond ((and (> x (1- (CtoI "a"))) (< x (1+ (CtoI "z")))) (- x 40)) (t x))) (exploden string)))) (defun lowercase (string) (maknam (mapcar '(lambda (x) (cond ((and (> x (1- (CtoI "A"))) (< x (1+ (CtoI "Z")))) (+ x 40)) (t x))) (exploden string)))) (defun upper-case-char (c) (let ((cn (getcharn c 1))) (cond ((and (< cn (1+ (CtoI "z"))) (> cn (1- (CtoI "a")))) (ascii (- cn 40))) (t c)))) (defun lower-case-char (c) (let ((cn (getcharn c 1))) (cond ((and (< cn (1+ (CtoI "Z"))) (> cn (1- (CtoI "A")))) (ascii (+ cn 40))) (t c)))) (defcom lower-case-region (with-the-mark-last m (do-forever (if (mark-reached m)(stop-doing)) (insert-char (lower-case-char (curchar))) (delete-char)))) (defcom upper-case-region (with-the-mark-last m (do-forever (if (mark-reached m)(stop-doing)) (insert-char (upper-case-char (curchar))) (delete-char)))) ;;; ;;; Auto-documenting features ;;; BSG and archy 5/24/78 ;;; BSG moved 'em all to e_self_documentor_ 10/7/78, leaving ;;; only the following pieces that sort of gotta stay around. ;;; (defcom find-key &arguments ((fun &symbol &prompt "Function name: " &default &eval (display-error-noabort "You must supply a function name."))) (prog (env) (setq env (ncons fun)) (map-over-emacs-commands '(lambda (symbol suspect arg) (cond ((eq suspect (car arg)) (rplacd arg symbol)))) env) (cond ((cdr env) (minibuffer-print fun " is on " (printable (cdr env)))) (t (minibuffer-print fun " is not on any key."))))) (defun display-buffer-as-printout () (save-excursion (init-local-displays) (go-to-beginning-of-buffer) (do-forever (local-display-generator (curline-as-string)) (if (lastlinep) (stop-doing)) (next-line)))) (defcom skip-over-indentation (go-to-beginning-of-line) (do-forever (if (eolp)(stop-doing)) (if (not (at-white-char))(stop-doing)) (forward-char))) ;;; ;;; Hirsute blank line deleter, 6/12/78 ;;; (defcom delete-blank-lines (prog (orig-was-blank eobp) (setq orig-was-blank (line-is-blank)) (if (not orig-was-blank)(go-to-end-of-line) (delete-white-sides) (insert-char NL) else (skip-back-whitespace) (go-to-end-of-line) (if (not (bolp))(forward-char))) ;bolp => bobp (with-mark m (skip-over-whitespace) (setq eobp (at-end-of-buffer)) (or eobp (go-to-beginning-of-line)) (without-saving (wipe-point-mark m))) (if (and eobp (not orig-was-blank))(rubout-char)) (if (and (not eobp) orig-was-blank)(insert-char NL)))) ;;; ;;; Sentence hackery, 5/78, converted by bsg & archy ;;; from a noble attempt by Margulies. ;;; (defun at-end-of-sentence () (prog () (if (at-white-char) (dispatch-on-lefthand-char ("." (return t)) ("?" (return t)) ("!" (return t)))) (if (or (at-end-of-buffer)(at-beginning-of-buffer)) (return t)) (if (and (eolp)(save-excursion (next-line)(line-is-blank))) (return t)))) (defcom forward-sentence &numeric-argument (&repeat) &negative-function backward-sentence (skip-over-whitespace) (if (at-end-of-buffer)(command-quit)) (do-forever (skip-over-whitespace) (skip-to-whitespace) (if (at-end-of-sentence) (stop-doing)))) (defcom backward-sentence &numeric-argument (&repeat) &negative-function forward-sentence (skip-back-whitespace) (if (at-beginning-of-buffer)(command-quit)) (skip-back-to-whitespace) ;in case we ARE are end-of-sentence (do-forever (if (at-end-of-sentence) (skip-over-whitespace) (stop-doing)) (skip-back-to-whitespace) (skip-back-whitespace))) (defprop kill-to-end-of-sentence forward kills) (defcom kill-to-end-of-sentence &numeric-argument (&repeat) &negative-function kill-backward-sentence (with-mark m (forward-sentence) (kill-backwards-to-mark m) (merge-kills-forward))) (defprop kill-backward-sentence reverse kills) (defcom kill-backward-sentence &numeric-argument (&repeat) &negative-function kill-to-end-of-sentence (with-mark m (backward-sentence) (kill-forward-to-mark m) (merge-kills-reverse))) ;;; ;;; Comments, anyone? ;;; BSG 6/25/78 ;;; (defcom set-comment-column &arguments ((column &integer &default &eval (if numarg numarg else (1+ (cur-hpos))))) &numeric-argument (&pass) (setq comment-column (1- column)) (minibuffer-print "Comment column = " (decimal-rep (1+ comment-column)))) (defcom set-comment-prefix &arguments ((prefix &prompt "Comment prefix: ")) (setq comment-prefix prefix)) (defcom prev-comment-line (cond ((firstlinep)) (t (prev-line) (indent-for-comment)))) (defcom down-comment-line (cond ((lastlinep)) (t (next-line) (indent-for-comment)))) (defun indent-to-fill-prefix () (go-to-beginning-of-line) (delete-white-sides) (insert-string fill-prefix)) (defcom indent-for-comment (go-to-beginning-of-line) (if (nullstringp comment-prefix)(indent-for-nondelimited-comment) else (if (forward-search-in-line comment-prefix) ;already got one) (do-times (stringlength comment-prefix)(backward-char)) (if (= (cur-hpos) comment-column) nil else (delete-white-sides) (do ((column comment-column (+ column 5))) ((> column (cur-hpos)) (whitespace-to-hpos column)))) (do-times (stringlength comment-prefix)(forward-char)) else (go-to-end-of-line) (delete-white-sides) (insert-string comment-prefix) (indent-for-comment)))) (defun indent-for-nondelimited-comment () ;;at bol from above. (if (go-to-hpos comment-column) ;line at least that long. (if (get (lefthand-char) 'whiteness) ;last was whitespace (if (> (cur-hpos) comment-column) ;tab or such (rubout-char) (insert-string " ") (indent-for-nondelimited-comment) else ;we are right at it. (do-forever (if (eolp)(stop-doing)) (if (at-white-char)(delete-char) else (stop-doing)))) else ; foo|__com (skip-to-whitespace-in-line) (if (not (eolp))(delete-white-sides)) (insert-char " ")) else ;line not that long (whitespace-to-hpos comment-column))) (defprop kill-comment forward kills) (defcom kill-comment (go-to-beginning-of-line) (if (nullstringp comment-prefix) (if (go-to-hpos comment-column) (if (not (get (lefthand-char) 'whiteness)) (skip-to-whitespace))) (skip-back-whitespace-in-line) (with-mark m (go-to-end-of-line)(wipe-point-mark m)) else (if (forward-search-in-line comment-prefix) (reverse-search-in-line comment-prefix) (skip-back-whitespace-in-line) (with-mark m (go-to-end-of-line)(wipe-point-mark m)) else (killsave-string "")))) ;;; ;;; Stuff grabbed from old start_up ;;; (defun ncline n ;lexprish cline (e_cline_ (apply 'catenate (mapcan '(lambda (x)(append '(" ") (explodec x))) (listify n))))) (defcom dp (ncline 'dp fpathname)) (defcom loadit (let ((fpathname nil)) (write-out-file pdir-temp-pathname) (loadfile pdir-temp-pathname) (hcs_$truncate_file process-dir pdir-temp-ename 0))) (defun comout-get-output n (check-read-only) (unwind-protect (progn (ncline "file_output" pdir-temp-pathname "-ssw user_output -ssw error_output -truncate") (apply 'ncline (listify n))) (e_cline_ "revert_output -ssw user_output -ssw error_output")) (let ((fpathname nil)) (read-in-file pdir-temp-pathname)) (hcs_$truncate_file process-dir pdir-temp-ename 0)) (defun comout (&rest command) (apply 'comout-to-buffer (cons 'file_output command))) (defun comout-to-buffer (buffer &rest command) (unwind-protect (progn (go-to-or-create-buffer buffer) (apply 'comout-get-output command)) (cond (comout-local-display (display-buffer-as-printout) (go-to-buffer previous-buffer)) (t (select-buffer-find-window current-buffer 'cursize))))) (defcom comout-command &numeric-function comout-command-to-buffer &arguments ((command-line &prompt &eval (progn (setq *comout-buffer-force* (comout-buffer-warning *comout-command-default-buffer*)) "Multics command: "))) (comout-command-internal *comout-command-default-buffer* *comout-buffer-force* command-line)) (defun comout-command-internal (buffer force-flag command) (setq command (e_lap_$trim command)) (unless (nullstringp command) (when force-flag (save-excursion-buffer (go-to-buffer buffer) (setq fpathname nil) (setq read-only-flag nil))) (comout-to-buffer buffer command))) (defcom comout-command-to-buffer &numarg &ignore &arguments ((buffer &symbol &default &eval (let ((completion-list known-buflist)) (setq *comout-command-buffer* (make_atom (minibuffer-response "Buffer: "))))) (command-line &prompt &eval (progn (setq *comout-buffer-force* (comout-buffer-warning *comout-command-buffer*)) "Multics command: "))) (comout-command-internal buffer *comout-buffer-force* command-line)) (defun comout-buffer-warning (buffer) (and (exists-buffer buffer) (let ((ro (get-buffer-state buffer 'read-only-flag)) (not-empty (not (empty-buffer-p buffer))) (path (get-buffer-state buffer 'fpathname)) (force)) (setq force (or ro path)) (setq path (and not-empty path)) (when (or ro path) (ring-tty-bell) (init-local-displays) (when ro (local-display-generator-nnl (catenate "Output buffer '" buffer "' is READ ONLY."))) (when path (local-display-generator-nnl (catenate "Output buffer '" buffer "' contains unwritten changes to ")) (local-display-generator-nnl (catenate " " path "."))) (local-display-generator-nnl "It will be overwritten if you continue (type ^G to abort).") (end-local-displays)) force))) (defcom linecounter (let ((lineno 1) (curlineno 0) (nnlp (save-excursion (go-to-end-of-buffer) (not (and (eolp)(bolp)))))) (save-excursion (with-mark m (go-to-beginning-of-buffer) (do-forever (if (mark-on-current-line-p m) (setq curlineno lineno) (stop-doing)) (if (lastlinep) (stop-doing)) ;just in case (setq lineno (1+ lineno)) (next-line)))) (setq lineno (if nnlp number-of-lines-in-buffer else (1- number-of-lines-in-buffer))) (minibuffer-remark (decimal-rep lineno) (if (= lineno 1) " line" else " lines") (if nnlp " (NO NEWLINE)" else "") ", current = " (decimal-rep curlineno) ", column = " (decimal-rep (1+ (cur-hpos)))))) ;;; ;;; Global Print command. ;;; New version by JSL - June 1982 (defcom global-print &numeric-function global-regexp-print &arguments ((string &string &default &eval (get-search-string "Global print"))) (let ((foundflag) (line-count 0)) (save-excursion (go-to-beginning-of-buffer) (do-forever (if (not (forward-search string)) (stop-doing)) (if (not foundflag) (setq foundflag t) (with-mark m (reverse-search string) (do-forever (if (mark-on-current-line-p m) (stop-doing)) (setq line-count (1+ line-count)) (next-line))) (init-local-displays)) (do-times line-count (prev-line)) (do-times line-count (local-display-current-line) (next-line)) (local-display-current-line) (if (lastlinep) (stop-doing)) (next-line))) (if foundflag (end-local-displays) else (search-failure-annunciator)))) ;;; ;;; Option manager ;;; BSG 7/29/78 ;;; (defprop option opt expr) (declare (special list-of-known-options)) (defun opt n ;lexpr (cond ((= n 0) ;noargs (display-error "Usage: opt list/opt status XXX/opt XXX ")) ((= n 1) (if (eq (arg 1) 'list) (save-excursion-buffer (go-to-or-create-buffer (intern (make_atom "Opt List"))) (putprop current-buffer t 'temporary-buffer) (insert-string "Options in effect")(new-line) (new-line) (mapc '(lambda (x) (insert-string x)(format-to-col 33.) (insert-string (option-value-string x))(new-line)) list-of-known-options) (display-buffer-as-printout)) (end-local-displays) else (opt))) ;barfo ((= n 2) (if (eq (arg 1) 'status) (if (memq (arg 2) list-of-known-options) (minibuffer-print "Option " (arg 2) ": " (option-value-string (arg 2))) else (display-error "Unknown option: " (arg 2))) else (if (memq (arg 1) list-of-known-options) (option-set-value (arg 1)(arg 2)) else (opt 'status (arg 1))))) ((= n 3) ; opt register foo bar (cond ((eq (arg 1) 'register) (register-option (arg 2)(arg 3))) (t (opt)))) (t (opt)))) (defun option-value-string (x) (cond ((not (boundp x)) 'Off) ((numberp (setq x (symeval x)))(decimal-rep x)) ((eq x 'nil) 'Off) ((eq x 't) 'On) ((stringp x) x) ((symbolp x) x) (t "-- ???? ---"))) (defun option-set-value (sym val) (if (stringp val) (setq val (intern (make_atom val)))) (cond ((or (and (boundp sym) (numberp(symeval sym))) (get sym 'value-must-be-numeric)) (if (numberp val) (set sym val) else (display-error "Value for " sym " must be numeric."))) ((or (and (boundp sym)(memq (symeval sym) '(t nil))) (get sym 'value-ok-true-false)) (cond ((memq val '(t T True true ok Ok On ON on y yes Yes)) (set sym t)) ((memq val '(nil no No Off OFF off false)) ;; I thank Bawden for this randomness (set sym nil)) ((get sym 'value-ok-anything) (set sym val)) (t (display-error "The value for " sym " must be either ""on"" or ""off"".")))) (t (set sym val)))) ;;; ;;; The printing-tty-man's friend, ;;; BSG 08/06/76 ;;; (defcom view-lines &numeric-argument (&pass) (if numarg (if (= numarg 0) (view-region-as-lines) else (init-local-displays) (if (< numarg 0) (setq numarg (- numarg)) (do y numarg (1- y)(= y 0) (if (firstlinep) (setq numarg (1- numarg)) else (prev-line)))) (do x numarg (1- x) (< x 1) ;lisp do (local-display-current-line) (if (or (lastlinep) (= numarg 1)) (stop-doing) else (next-line))) (end-local-displays)) else (setq numarg 1) (view-lines))) (defcom view-region-as-lines (with-the-mark-last m (init-local-displays) (do-forever (local-display-current-line) (if (mark-on-current-line-p m) (stop-doing)) (next-line)) (end-local-displays))) ;;; ;;; Word Searches. ;;; BSG 8/26/78 ;;; (defun compare-word-to-list-rep-word (list) (prog (text-char) a (cond ((null list) ;no more source (do-forever (if-at (ascii 10)(forward-char) ;run out trailing _ BS else (if-at "_" (forward-char) else (stop-doing)))) (cond ((charset-member (curchar) good-word-charactertbl) (search-for-first-not-charset-line good-word-charactertbl) (return nil)) ;lost (t (return t)))) ((= (car list) 52) ;star (search-for-first-not-charset-line good-word-charactertbl) (return t))) (if (eolp) ;lost (return nil)) (setq text-char (getcharn (curchar) 1)) ;; Quick check for good case. (if (and (< text-char (1+ (CtoI "Z")))(> text-char (1- (CtoI "A")))) (setq text-char (+ 40 text-char))) ;lower case it. (if (= text-char (car list)) ;local winnage (setq list (cdr list)) (forward-char) (go a)) (if (or (= text-char 10)(= text-char 137)) ;BS or US (forward-char) (go a)) ;; Wholesale mismatch. (search-for-first-not-charset-line good-word-charactertbl) (return nil))) (defun word-search (word) (setq word (listify-word word)) (with-mark m (if (do-forever (if (not (search-charset-forward-nosavepos good-word-charactertbl)) (return nil)) (if (compare-word-to-list-rep-word word) (return t)) (if (at-end-of-buffer) (return nil))) else (go-to-mark m) nil))) (defun listify-word (w) (mapcar '(lambda (x) (cond ((and (< x (1+ (CtoI "Z"))) (> x (1- (CtoI "A")))) (+ x 40)) (t x))) (exploden w))) (defcom multi-word-search &arguments ((wordlist &default &eval (string-to-list-of-strings (get-search-string "Word Search")))) &numeric-argument (&pass) (let ((bjflag numarg)) (setq wordlist (mapcar 'listify-word wordlist)) (with-mark m (if bjflag (go-to-beginning-of-buffer)) (if (prog (trials temp-list) (return (do-forever (if (not (search-charset-forward-nosavepos good-word-charactertbl)) (go-to-mark m) (search-failure-annunciator)) (setq trials 0 temp-list wordlist) a (cond ((null temp-list) (return t))) (cond ((compare-word-to-list-rep-word (car temp-list)) (setq temp-list (cdr temp-list)) (cond ((null temp-list)(return t))) (setq trials (1+ trials)) (if (search-charset-forward-nosavepos good-word-charactertbl) else (go-to-mark m) (search-failure-annunciator)) (go a))) ;; Has failed. Found 2 good words, 1 bad one. trials = 2. ;; Back up 2 words. (do-times trials (backward-word))))) else (go-to-mark m) (search-failure-annunciator))))) (defun string-to-list-of-strings (instr) (prog (answer locanswer ch1) (setq instr (exploden instr)) a (do-forever (if (null instr)(stop-doing)) (setq ch1 (car instr)) (if (or (= ch1 40)(= ch1 11)(= ch1 12)) ;blank, tab newline (setq instr (cdr instr)) else (stop-doing))) (if (null instr) ;all done (return (nreverse answer))) ;; collect one string (setq locanswer nil) (do-forever (if (null instr)(stop-doing)) (setq ch1 (car instr) instr (cdr instr)) (if (or (= ch1 40)(= ch1 11)(= ch1 12)) (stop-doing) else (setq locanswer (cons ch1 locanswer)))) (setq answer (cons (maknam (nreverse locanswer)) answer)) (go a))) (defun search-charset-forward-nosavepos (charset) (do-forever (cond ((search-for-first-charset-line charset) (return (curchar))) ((lastlinep) (return nil)) (t (next-line))))) ;;; Not L I S P mode. ;;; Things dealing with parenthese balancing to placate those ;;; who miss native Lisp mode. ;;; BSG 9/11/78 (defun unwind-sexp-searchers-marks-and-nlgoto () (mapc 'release-mark sexp-searcher-mark-list) (setq numarg nil) (setq sexp-searcher-mark-list nil) (command-quit)) (defcom balance-parens-forward &numeric-argument (&repeat) &negative-function balance-parens-backward (let ((count nil)) (save-excursion-on-error (do-forever (dispatch-on-current-char ("(" (if (not count)(setq count 1) else (setq count (+ 1 count)))) (")" (if count (setq count (- count 1))) (if (and count (= count 0)) (forward-char) (stop-doing)))) (if (at-end-of-buffer) (display-error "Unbalanced Parentheses")) (forward-char))))) (defcom balance-parens-backward &numeric-argument (&repeat) &negative-function balance-parens-forward (let ((count nil)) (save-excursion-on-error (do-forever (dispatch-on-lefthand-char (")" (if (not count)(setq count 1) else (setq count (+ 1 count)))) ("(" (if count (setq count (- count 1))) (if (and count (= 0 count)) (backward-char) (stop-doing)))) (if (at-beginning-of-buffer) (display-error "Unbalanced Parentheses")) (backward-char))))) ;;; ;;; Page-other-window copped from Larry Johnson ;;; BSG 12/11/78 .. ditto go-to-line-number ;;; (declare (special selected-window)) (defcom page-other-window &numeric-argument (&pass) (if (not two-window-mode) (display-error "Not in 2 window mode") else (let ((origwindow selected-window)) (unwind-protect (progn (select-other-window) (if (null numarg)(next-screen) else (if (> numarg 0)(next-screen) else (setq numarg (- numarg)) (prev-screen)))) (select-window origwindow))))) ;;; New non-losing go-to-line-number 22 April 1981 RMSoley ;;; Prompt for line number if wasn't given. (defcom go-to-line-number &numeric-argument (&pass) (let ((count numarg)) (cond ((null count) (setq count (1- (integer-minibuf-response "Go to line number: " NL)))) ('else (setq count (1- count)))) (and (< count 0) (setq count 0)) (go-to-beginning-of-buffer) (do-times count (and (lastlinep) (command-quit)) (next-line)))) (defun integer-minibuf-response (Question Char) (let ((ans (minibuf-response Question Char))) (or (ed-cv-fixnum-check ans) (display-error "Non-numeric answer: " ans ".")))) ;;; ;;; Untabifiers, moved from Rmail 1/18/79 ;;; (defcom untabify &arguments ((x &default &eval (if numarg numarg else tab-equivalent))) &numeric-argument (&pass) (let ((tab-equivalent x)) tab-equivalent (save-excursion (go-to-beginning-of-buffer) (do-forever (if (forward-search TAB) (let ((hp (cur-hpos))) (rubout-char) (let ((nhp (cur-hpos))) (do ((x nhp (1+ x)))((= x hp)) (insert-char " ")))) else (stop-doing)))))) (defcom-synonym mmuntabify untabify) ;;; ;;; Mark commands. ;;; (defkill wipe-region ambiguous) (defcom wipe-region (cond ((not der-wahrer-mark) (report-error 'mark-not-set) (setq previous-command nil)) ;be sure not accidently repeated (t (wipe-point-mark der-wahrer-mark)))) (defcom copy-region (cond (der-wahrer-mark (killsave-string (point-mark-to-string der-wahrer-mark))) (t (report-error 'mark-not-set)))) ;;; ;;; Named mark routines -- BSG 8/19/79 ;;; (defcom set-named-mark &arguments ((markname &symbol &prompt "Set named mark: " &default &eval (display-error "You must supply a mark name."))) (set-named-mark- markname) (minibuffer-print "Set " markname)) (defcom go-to-named-mark &arguments ((mn &symbol &prompt "Go to named mark: " &default &eval (display-error "You must supply a mark name."))) (let ((m (get-named-mark mn))) (set-the-mark) (go-to-mark m))) (defcom list-named-marks () (let ((ml (produce-named-mark-list))) (if (null ml)(display-error "No named marks in this buffer.")) (init-local-displays) (local-display-generator-nnl "Line # Mark name") (local-display-generator-nnl "") (save-excursion (let ((lnno 1)) (go-to-beginning-of-buffer) (do-forever (mapc '(lambda (x) (if (mark-on-current-line-p (cadr x)) (local-display-generator-nnl (catenate (decimal-rep lnno) TAB (car x))))) ml) (if (lastlinep)(stop-doing)) (setq lnno (1+ lnno)) (next-line)))) (end-local-displays))) (defun date () ;general utility BSG 10/31/79 (let ((statdate (mapcar 'decimal-rep (status date)))) (catenate (cadr statdate) "/" (caddr statdate) "/" (car statdate)))) ;;; Buffer commands. ;;; Command to switch buffers ;;; Fixed 17 April 1981 RMSoley to prompt with default. ;;; Added &completions 6 August 1981 RMSoley (defcom select-buffer &prologue insure-intelligent-previous-buffer &arguments ((buffer &symbol &prompt &eval (catenate "Select buffer (" previous-buffer "): ") &completions known-buflist)) (select-buffer-window buffer 'default-cursize)) ;;; Make sure that previous-buffer isn't nil or same as current ;;; buffer for select-buffer and kill-buffer. ;;; 6 Aprill 1982 Richard Soley (defun insure-intelligent-previous-buffer () (or (exists-buffer previous-buffer) (setq previous-buffer (cond ((eq (car known-buflist) current-buffer) (cadr known-buflist)) ('else (car known-buflist))))) (and (eq previous-buffer current-buffer) (setq previous-buffer 'main)) (or previous-buffer (setq previous-buffer 'main))) ;;; Command to delete a buffer ;;; Fixed 17 April 1981 RMSoley to prompt with default. ;;; Fixed 6 August 1981 RMSoley for &completions (defcom kill-buffer &arguments ((buffer &symbol &prompt "Kill buffer: " &completions known-buflist &default &eval current-buffer)) (cond ((not (memq buffer known-buflist)) (display-error "Buffer does not exist: " buffer)) ((eq buffer current-buffer) (insure-intelligent-previous-buffer) (do nil (nil) (ring-tty-bell) (let ((newbuf (let ((completion-list known-buflist)) (intern-minibuf-response (catenate "Killing current buffer. " "Select new buffer (" previous-buffer "): ") NL)))) (and (nullstringp newbuf) (progn (setq newbuf previous-buffer) (minibuffer-print-noclear newbuf))) (cond ((eq buffer newbuf) (display-error-noabort "Killing buffer " buffer ". Can't go there.")) (t (select-buffer-window newbuf 'default-cursize) (buffer-kill buffer) (return nil))))) (setq previous-buffer (cond ((eq (car known-buflist) current-buffer) (cadr known-buflist)) (t (car known-buflist)))) (or previous-buffer (setq previous-buffer current-buffer))) (t (buffer-kill buffer)))) ;;; Command to mark the current buffer unmodified (defcom unmodify-buffer (setq buffer-modified-flag nil damaged-flag t) ;makes redisplay happy (close-line) ;lest this, nobody'd check (minibuffer-remark "Not modified.")) ;;; Yank and search commands and esc-esc. (defkill merge-last-kills-with-next ambiguous) (defcom merge-last-kills-with-next nil) (defcom yank-minibuf (set-the-mark) (insert-string last-minibuf-response)) ;;; JSL's new searching commands - June 1982 ;;; These are changed to lowercase the noninitial words in the prompt, ;;; and to only set gratuitous marks when the search succeeds. ;;; If the search succeeds partially, the mark is always set. (defcom string-search &cleanup search:command-cleanup &prologue search:command-prologue &epilogue search:command-epilogue &inverse reverse-string-search &negative-function reverse-string-search &numeric-argument &repeat &arguments ((search-string &string &default &eval (get-search-string (search:numeric-prompt "String search")))) (forward-search search-string)) (defcom reverse-string-search &cleanup search:command-cleanup &prologue search:command-prologue &epilogue search:command-epilogue &inverse string-search &negative-function string-search &numeric-argument &repeat &arguments ((search-string &string &default &eval (get-search-string (search:numeric-prompt "Reverse string search")))) (reverse-search search-string)) (defun search:command-prologue () (cons 0 (set-mark))) (defun search:command-cleanup (prologue-info) (if prologue-info (if (cdr prologue-info) (go-to-mark (cdr prologue-info)) (release-mark (cdr prologue-info))))) (defun search:command-epilogue (prologue-info result last-time) (cond (result (rplaca prologue-info (1+ (car prologue-info))) (and last-time (or (gratuitous-mark-setter (cdr prologue-info)) (release-mark (cdr prologue-info))) (rplacd prologue-info nil))) ; For cleanup. ((zerop (car prologue-info)) (search-failure-annunciator)) (t (set-the-mark-here (cdr prologue-info)) (rplacd prologue-info nil))) ; For cleanup. (or result (search:announce-partial-failure (car prologue-info)))) (defun search:announce-partial-failure (count) (display-error "Search failed after " (decimal-rep count) " successful search" (cond ((= count 1) "") (t "es")) ". Mark set at start.") (and macro-execution-in-progress (command-quit))) (defun search-failure-annunciator () (display-error "Search fails.") (and macro-execution-in-progress (command-quit))) (defcom regexp-search-command &arguments ((search-string &default &eval (get-search-string "Regexp Search"))) (setq search-string (forward-regexp-search search-string)) (cond ((null search-string) (search-failure-annunciator)) (t ;found it set mark around it (let ((y (set-mark))) ;save-excursion (go-to-mark search-string) (set-the-mark) (go-to-mark y) (release-mark search-string) (release-mark y))))) ;;; ;;; Query replace by Carl Hoffman ;;; ;;; read macro 12/3/78 by BSG (eval-when (compile eval) (setsyntax '/# 'macro '(lambda () (cond ((= (tyipeek) 57) (tyi) (tyi)) ((= (tyipeek) 136) (tyi) (- (boole 1 137 (tyi)) 100))))) );;;end of eval-when (defcom query-replace &arguments ((old &default &eval (get-search-string "Query replace old string")) (new &prompt "Query replace new string: " NL)) (assert-minor-mode '|query replace|) (if (not (forward-search old)) (minibuffer-print "No occurrences of old string found.") else (query-replace-execute old new) (minibuffer-print "Done.")) (negate-minor-mode '|query replace|)) ; This function does all of the work. When it is invoked, the point ; is to the right of the first occurrence of the old string. (defun query-replace-execute (old new) (catch (do-forever (redisplay) (query-replace-dispatch old new (get-char)) (if (not (forward-search old)) (stop-doing))) done)) (defun query-replace-dispatch (old new response) (do-forever (cond ((= response #/,) (query-replace-swap-strings old new) (redisplay) (stop-doing)) ((= response #/ ) (query-replace-swap-strings old new) (stop-doing)) ;don't redisplay 10/15/80 ((or (= response #^M) ;return = 15 (= response 177)) ;rubout = 177 (stop-doing)) ((= response #/!) ;! is replace to end (query-replace-swap-strings old new) (do-forever (if (forward-search old) (query-replace-swap-strings old new) else (throw t done)))) ((= response #/.) (query-replace-swap-strings old new) (throw t done)) ((or (= response #^G) (= response 33)) ;altmode (throw t done)) ((= response #^J)) ;newline = 12 ((= response #^L) (redisplay)) ((or (= response #/?) (= response #^_)) (query-replace-documentation)) (t (display-error-noabort "Unknown query replace response.") (redisplay))) (setq response (get-char)))) (defun query-replace-swap-strings (old new) (with-mark m (backward-n-chars (stringlength old)) (without-saving (wipe-point-mark m)) (insert-string new))) (defun query-replace-documentation () (init-local-displays) (mapc 'local-display-generator-nnl '("Query replace options:" "" "SPACE Replace this occurrence and go on" "CR, DEL Skip this occurrence and go on" ". (period) Replace this occurrence and stop" "^G, ESC Stop now" ", (comma) Replace this occurrence, redisplay, and go on" "! Replace all following occurrences without querying" "LF Nothing" "^L Redisplay" "?, ^_ Print this description" "" "Type any character to remove this display.")) (end-local-displays) (redisplay) (get-char)) (defcom eval-multics-command-line &arguments ((command-line &prompt "Multics: ")) (let ((e-quit-transparency 'transparent)) e-quit-transparency (unwind-protect (progn (e_pl1_$set_multics_tty_modes) (e_cline_ command-line)) (iox_$control (e_pl1_$get_iocb) "reset_more" null-pointer) (e_pl1_$set_emacs_tty_modes)))) (declare (special eval:eval eval:assume-atom eval:correct-errors eval:prinlevel eval:prinlength + - *)) (defcom eval-lisp-line &numeric-argument (&pass) (cond ((not eval:eval) (extended-command (minibuffer-response "Command: "))) (t (eval:internal (minibuffer-response "Eval: "))))) (defun eval:internal (lisp-form) (let ((prinlevel eval:prinlevel) (prinlength eval:prinlength)) (eval:evaluate (let ((e-lisp-error-mode 'read-lisp-fun-lossage-handler)) e-lisp-error-mode (read-from-string (evl-parenify lisp-form)))))) (defun eval:evaluate (form) (setq - form) (setq * (let ((e-lisp-error-mode 'eval-lisp-line-lossage-handler)) (eval form))) (setq + form) (minibuffer-print "Value: " (maknam (explode *)))) (defun paren-counter (string) (let ((left 0) (right 0) (balanced nil) (quote-open nil) (bar-open nil) (spacep nil) (skip-this-char nil) (in (explodec string)) (len (stringlength string))) (do ((sofar in (cdr sofar)) (a 1 (1+ a))) ((> a len)) (let ((this (car sofar)) (open (or bar-open quote-open))) (cond (skip-this-char (setq skip-this-char nil)) ((eq this '/" ) (or bar-open (setq quote-open (null quote-open))) (or open (setq spacep t))) ((eq this '/| ) (or quote-open (setq bar-open (null bar-open))) (or open (setq spacep t))) ((eq this '/ ) (or open (setq spacep t))) ((eq this '// ) (or open (setq skip-this-char t))) ((eq this '/; ) (or open (setq a len))) ((eq this '/' ) (or open (setq spacep t))) ((eq this '/( ) (or open (setq left (1+ left)))) ((eq this '/) ) (or open (setq right (1+ right)))))) (cond ((not (or (= a 1) (= a len))) (setq balanced (or balanced (= left right)))))) (cons left (cons right (cons balanced (cond (quote-open (list 'error "unbalanced quotes.")) (bar-open (list 'error "unbalanced vertical bars.")) (skip-this-char (list 'error "too much slashification.")) (t spacep))))))) (defun evl-parenify (string) (let ((parens (paren-counter string))) (let ((l>r (> (car parens) (cadr parens))) (dif (abs (- (car parens) (cadr parens)))) (symbol (and (not (cadddr parens)) (= (car parens) 0) (= (cadr parens) 0) eval:assume-atom)) (balanced (caddr parens))) (cond ((not (or eval:correct-errors (zerop dif))) (display-error "Error in syntax of Lisp form - " "unbalanced parentheses.")) ((eq (cadddr parens) 'error) (or eval:correct-errors (display-error "Error in syntax of Lisp form - " (car (cddddr parens)))) (evl-parenify ;fix user's error (catenate string (let ((kludge (substr (car (cddddr parens)) 12. 1))) (cond ((samepnamep kludge "q") """") ((samepnamep kludge "v") "|") (t " ")))))) (t (let ((intermediate (cond ((= dif 0) string) (l>r (catenate string (gen-repetitive dif ")"))) (t (catenate (gen-repetitive dif "(") string))))) (cond (symbol string) (balanced (catenate "(" intermediate ")")) (t intermediate)))))))) (defun gen-repetitive (number string) (and (nullstringp string) (setq string SPACE)) (and (minusp number) (setq number 0)) (do ((string string (catenate string string))) ((not (< (stringlength string) number)) (substr string 1 number)))) (defun eval-lisp-line-lossage-handler x x (command-quit)) (defun read-lisp-fun-lossage-handler (arg) arg (display-error "Syntax error in Lisp form.")) INCLUDE FILE >ldd>include>e-macros.incl.lisp ;;; BEGIN INCLUDE FILE e-macros.incl.lisp ;;; Declares for use by Emacs programs and extenstions. Also loads ;;; in e_macros_, which contains macro definitions. ;;; HISTORY COMMENTS: ;;; 1) change(85-01-01,Margolin), approve(86-02-24,MCR7186), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Written: New Year's Day 1985, by excerpting the old e-macros.incl.lisp ;;; and leaving out all the definitions and qwerty junk (don't ask). ;;; 2) change(86-02-24,Margolin), approve(86-02-24,MCR7325), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Alphabetized declarations, and added more declarations for documented ;;; functions, and also for some undocumented functions. ;;; END HISTORY COMMENTS (%include backquote) (declare ;basic editor stuff (*expr apply-catenate assert-minor-mode backward-char backward-n-chars charlisten charset-member command-abort command-quit copy-region cur-hpos curline-as-string curbuf-as-string curchar curline-as-string delete-char delete-word destroy-buffer-contents dont-notice-modified-buffer e_cline_ e_lap_$reverse-search-string e_lap_$trim empty-buffer-p error_table_ establish-local-var exchange-point-and-mark firstlinep forward-char forward-n-chars forward-regexp-search-in-line forward-search forward-search-in-line get-char get-search-string go-to-beginning-of-buffer go-to-beginning-of-line go-to-buffer go-to-end-of-buffer go-to-end-of-line go-to-hpos go-to-mark go-to-or-create-buffer insert-char insert-string kill-backwards-to-mark kill-forward-to-mark kill-pop kill-to-end-of-line killsave-string lastlinep loadfile looking-at lowercase map-over-emacs-commands mark-on-current-line-p mark-reached merge-kills-forward merge-kills-reverse move-mark minibuf-response minibuffer-clear negate-minor-mode new-line next-line nullstringp pathname_ pathname_$component point-mark-to-string point>markp prev-line printable process-char produce-named-mark-list read-in-file release-mark reverse-search register-local-var reverse-search-in-line search-back-first-charset-line search-back-first-not-charset-line search-failure-annunciator search-for-first-charset-line search-for-first-not-charset-line set-emacs-epilogue-handler set-buffer-self-destruct set-key set-mark-here set-mark set-perm-key set-the-mark set-the-mark-here skip-to-whitespace skip-to-whitespace-in-line wipe-point-mark wipe-region write-out-file trim-minibuf-response yesp yank) (*fexpr define-autoload-lib)) (declare ;redisplay stuff (*expr end-local-displays init-local-displays ring-tty-bell local-display-generator local-display-generator-nnl next-screen prev-screen local-display-current-line find-buffer-in-window select-buffer-window window-info select-buffer-find-window select-other-window select-window buffer-on-display-in-window redisplay full-redisplay)) (declare ;extended stuff (*expr forward-word backward-word skip-over-whitespace skip-back-whitespace skip-over-whitespace-in-line skip-back-whitespace-in-line skip-back-to-whitespace skip-to-whitespace rubout-char date display-buffer-as-printout delete-white-sides lefthand-char format-to-col whitespace-to-hpos line-is-blank decimal-rep register-option minibuffer-clear)) (declare (*lexpr display-error display-com-error display-error-noabort display-error-remark comout-get-output display-com-error-noabort minibuffer-print minibuffer-response trim-minibuffer-response intern-minibuffer-response minibuffer-remark minibuffer-print-noclear report-error report-error-noabort)) (declare (special TAB NL SPACE ESC curpointpos current-buffer dont-stash numarg der-wahrer-mark fpathname fill-column completion-list curlinel BACKSPACE read-only-flag buffer-modified-flag previous-buffer current-buffer-mode env-dir process-dir minibuffer-end-string NLCHARSTRING undo null-pointer)) ;;; Load in macro packages (eval-when (eval compile) (or (status feature e-defcom) (progn (load (catenate (car (namelist (truename infile))) ">e_define_command_")) (sstatus feature e-defcom))) (or (status feature e-macros) (load (catenate (car (namelist (truename infile))) ">e_macros_")))) ;;; END INCLUDE FILE e-macros.incl.lisp INCLUDE FILE >ldd>include>backquote.incl.lisp ;;; ;;; backquote.incl.lisp - BSG 10/9/79 ;;; Loads lisp_backquote_ into either the compiler or interpreter ;;; environment. ;;; ;;; Modified 10/30/82 by Richard Lamson to use eval-when and ;;; (status feature backquote) ;;; (eval-when (eval compile) (or (status feature backquote) (load (catenate (car (namelist (truename infile))) ">lisp_backquote_")))) INCLUDE FILE >ldd>include>defmacro.incl.lisp ;; -*- Mode: Lisp; Lowercase: True -*- ;; defmacro.incl.lisp - Loads lisp_backquote_, lisp_destructuring_let_, ;; and lisp_defmacro_ into either the compiler or interpreter environment. ;; Written: October 1982 by Carl Hoffman ;; Defmacro needs destructuring_let to run. ;; It can run without backquote, but would be useless. (eval-when (eval compile) (or (status feature backquote) (load (catenate (car (namelist (truename infile))) ">lisp_backquote_"))) (or (status feature destructuring_let) (load (catenate (car (namelist (truename infile))) ">lisp_destructuring_let_"))) (or (status feature defmacro) (load (catenate (car (namelist (truename infile))) ">lisp_defmacro_")))) ;; This is necessary for (defprop a b macro) forms and defuns produced ;; by defmacro to appear in the object segment. Let the default be ;; the right thing for naive users. (declare (macros t)) INCLUDE FILE >ldd>include>defun.incl.lisp ;; -*- Mode: Lisp; Lowercase: True -*- ;; defun.incl.lisp - Loads lisp_destructuring_let_, lisp_defmacro_, ;; and lisp_defun_ into either the compiler or interpreter environment. ;; Written: October 1982 by Carl Hoffman ;; defun needs destructuring_let and defmacro to run. The code produced contains ;; let forms, and an internal routine in defmacro is called. (eval-when (eval compile) (or (status feature destructuring_let) (load (catenate (car (namelist (truename infile))) ">lisp_destructuring_let_"))) (or (status feature defmacro) (load (catenate (car (namelist (truename infile))) ">lisp_defmacro_"))) (or (status feature defun) (load (catenate (car (namelist (truename infile))) ">lisp_defun_")))) INCLUDE FILE >ldd>include>other_other.incl.lisp ;; -*- Mode: Lisp; Lowercase: True -*- ;; other_other.incl.lisp - Loads lisp_setf_ and lisp_other_other_ into either ;; the compiler or interpreter environment. ;; Written: October 1982 by Carl Hoffman (eval-when (eval compile) (or (status feature setf) (load (catenate (car (namelist (truename infile))) ">lisp_setf_"))) (or (status feature other_other) (load (catenate (car (namelist (truename infile))) ">lisp_other_other_")))) Functions Defined Name Offset Offset Name at-end-of-sentence 5152 0 get-named-mark backward-sentence 5312 32 set-named-mark- balance-parens-backward 11334 76 delete-named-mark balance-parens-forward 11212 132 delete-named-mark-$-1-$-&default capitalize-initial-word 3131 140 produce-named-mark-list center-line 1431 220 twiddle-chars comout 6266 235 replace comout-buffer-warning 6614 321 replace-$-1-$-&default comout-command 6454 326 twiddle-words comout-command-$-1-$-&prompt 6466 503 underline-word comout-command-internal 6475 541 underline-region comout-command-to-buffer 6557 711 underline-point-mark comout-command-to-buffer-$-1-$-&default 6571 1137 de-underline-region comout-command-to-buffer-$-2-$-&prompt 6605 1252 de-underline-point-mark comout-get-output 6170 1324 remove-underlining-from-word comout-to-buffer 6325 1362 open-space compare-word-to-list-rep-word 10342 1370 set-fill-prefix copy-region 11741 1374 set-fill-prefix-$-1-$-&default cret-and-indent-relative 2350 1431 center-line date 12156 1512 split-line de-underline-point-mark 1252 1561 delete-line-indentation de-underline-region 1137 1571 mark-whole-buffer delete-blank-lines 5035 1575 speedtype-expander delete-line-indentation 1561 1723 internedp delete-named-mark 76 2001 setab delete-named-mark-$-1-$-&default 132 2100 speedtype display-buffer-as-printout 4741 2162 speedtypeoff down-comment-line 5457 2215 indent-relative dp 6131 2220 tab-to-previous-columns eval-lisp-line 13372 2350 cret-and-indent-relative eval-lisp-line-lossage-handler 14356 2363 indent-rigidly eval-multics-command-line 13340 2600 put-variable eval:evaluate 13437 2634 put-variable-$-0-$-&prologue eval:internal 13413 2645 put-variable-$-1-$-&default evl-parenify 14000 2653 get-variable find-key 4666 2704 get-variable-$-1-$-&default find-key-$-1-$-&default 4733 2712 list-variables format-to-col 3112 3060 list-buffers forward-sentence 5271 3112 format-to-col gen-repetitive 14300 3131 capitalize-initial-word get-named-mark 0 3440 upper-case-word get-variable 2653 3724 lower-case-word get-variable-$-1-$-&default 2704 4210 uppercase global-print 7202 4262 lowercase global-print-$-1-$-&default 7352 4334 upper-case-char go-to-line-number 11525 4362 lower-case-char go-to-named-mark 12003 4410 lower-case-region go-to-named-mark-$-1-$-&default 12020 4537 upper-case-region indent-for-comment 5474 4666 find-key indent-for-nondelimited-comment 5601 4733 find-key-$-1-$-&default indent-relative 2215 4741 display-buffer-as-printout indent-rigidly 2363 5013 skip-over-indentation indent-to-fill-prefix 5465 5035 delete-blank-lines insure-intelligent-previous-buffer 12265 5152 at-end-of-sentence integer-minibuf-response 11576 5271 forward-sentence internedp 1723 5312 backward-sentence kill-backward-sentence 5366 5334 kill-to-end-of-sentence kill-buffer 12321 5366 kill-backward-sentence kill-buffer-$-1-$-&default 12466 5420 set-comment-column kill-comment 5674 5437 set-comment-column-$-1-$-&default kill-to-end-of-sentence 5334 5445 set-comment-prefix linecounter 6756 5451 prev-comment-line list-buffers 3060 5457 down-comment-line list-named-marks 12026 5465 indent-to-fill-prefix list-variables 2712 5474 indent-for-comment listify-word 10561 5601 indent-for-nondelimited-comment loadit 6141 5674 kill-comment lower-case-char 4362 6023 ncline lower-case-region 4410 6131 dp lower-case-word 3724 6141 loadit lowercase 4262 6170 comout-get-output mark-whole-buffer 1571 6266 comout merge-last-kills-with-next 12503 6325 comout-to-buffer multi-word-search 10631 6454 comout-command multi-word-search-$-1-$-&default 11030 6466 comout-command-$-1-$-&prompt ncline 6023 6475 comout-command-internal open-space 1362 6557 comout-command-to-buffer opt 7357 6571 comout-command-to-buffer-$-1-$-&default option-set-value 7751 6605 comout-command-to-buffer-$-2-$-&prompt option-value-string 7716 6614 comout-buffer-warning page-other-window 11454 6756 linecounter paren-counter 13472 7202 global-print prev-comment-line 5451 7352 global-print-$-1-$-&default produce-named-mark-list 140 7357 opt put-variable 2600 7716 option-value-string put-variable-$-0-$-&prologue 2634 7751 option-set-value put-variable-$-1-$-&default 2645 10126 view-lines query-replace 13006 10220 view-region-as-lines query-replace-$-1-$-&default 13047 10342 compare-word-to-list-rep-word query-replace-dispatch 13103 10472 word-search query-replace-documentation 13314 10561 listify-word query-replace-execute 13054 10631 multi-word-search query-replace-swap-strings 13246 11030 multi-word-search-$-1-$-&default read-lisp-fun-lossage-handler 14377 11037 string-to-list-of-strings regexp-search-command 12742 11144 search-charset-forward-nosavepos regexp-search-command-$-1-$-&default 13001 11165 unwind-sexp-searchers-marks-and-nlgoto remove-underlining-from-word 1324 11212 balance-parens-forward replace 235 11334 balance-parens-backward replace-$-1-$-&default 321 11454 page-other-window reverse-string-search 12530 11525 go-to-line-number reverse-string-search-$-1-$-&default 12536 11576 integer-minibuf-response search-charset-forward-nosavepos 11144 11625 untabify search-failure-annunciator 12730 11715 untabify-$-1-$-&default search:announce-partial-failure 12676 11722 wipe-region search:command-cleanup 12562 11741 copy-region search:command-epilogue 12605 11760 set-named-mark search:command-prologue 12545 11775 set-named-mark-$-1-$-&default select-buffer 12243 12003 go-to-named-mark select-buffer-$-1-$-&prompt 12253 12020 go-to-named-mark-$-1-$-&default set-comment-column 5420 12026 list-named-marks set-comment-column-$-1-$-&default 5437 12156 date set-comment-prefix 5445 12243 select-buffer set-fill-prefix 1370 12253 select-buffer-$-1-$-&prompt set-fill-prefix-$-1-$-&default 1374 12265 insure-intelligent-previous-buffer set-named-mark 11760 12321 kill-buffer set-named-mark- 32 12466 kill-buffer-$-1-$-&default set-named-mark-$-1-$-&default 11775 12470 unmodify-buffer setab 2001 12503 merge-last-kills-with-next skip-over-indentation 5013 12505 yank-minibuf speedtype 2100 12513 string-search speedtype-expander 1575 12521 string-search-$-1-$-&default speedtypeoff 2162 12530 reverse-string-search split-line 1512 12536 reverse-string-search-$-1-$-&default string-search 12513 12545 search:command-prologue string-search-$-1-$-&default 12521 12562 search:command-cleanup string-to-list-of-strings 11037 12605 search:command-epilogue tab-to-previous-columns 2220 12676 search:announce-partial-failure twiddle-chars 220 12730 search-failure-annunciator twiddle-words 326 12742 regexp-search-command underline-point-mark 711 13001 regexp-search-command-$-1-$-&default underline-region 541 13006 query-replace underline-word 503 13047 query-replace-$-1-$-&default unmodify-buffer 12470 13054 query-replace-execute untabify 11625 13103 query-replace-dispatch untabify-$-1-$-&default 11715 13246 query-replace-swap-strings unwind-sexp-searchers-marks-and-nlgoto 11165 13314 query-replace-documentation upper-case-char 4334 13340 eval-multics-command-line upper-case-region 4537 13372 eval-lisp-line upper-case-word 3440 13413 eval:internal uppercase 4210 13437 eval:evaluate view-lines 10126 13472 paren-counter view-region-as-lines 10220 14000 evl-parenify wipe-region 11722 14300 gen-repetitive word-search 10472 14356 eval-lisp-line-lossage-handler yank-minibuf 12505 14377 read-lisp-fun-lossage-handler Functions Referenced abs get-key-binding opt alphalessp get-named-mark opt append get-search-string option-set-value apply getcharn option-value-string arg go-to-beginning-of-buffer paren-counter ascii go-to-beginning-of-line parse-key-description assert-minor-mode go-to-buffer point-mark-to-string assq go-to-end-of-buffer point>markp at-end-of-sentence go-to-end-of-line prev-line backward-char go-to-hpos prev-screen backward-n-chars go-to-mark printable backward-sentence go-to-or-create-buffer produce-named-mark-list backward-word gratuitous-mark-setter putprop buffer-kill hcs_$truncate_file query-replace-dispatch catenate indent-for-comment query-replace-documentation catenate indent-for-nondelimited-comment query-replace-execute catenate indent-relative query-replace-swap-strings catenate init-local-displays read-from-string charset-member insert-char read-in-file check-read-only insert-string redisplay close-line insure-intelligent-previous-buffer register-local-var command-quit integer-minibuf-response register-option comout-buffer-warning intern release-mark comout-command-internal intern-minibuf-response remprop comout-to-buffer internedp report-error compare-word-to-list-rep-word iox_$control report-error cur-hpos kill-backwards-to-mark reverse-search curchar kill-forward-to-mark reverse-search-in-line curline-as-string kill-pop ring-tty-bell de-underline-point-mark killsave-string rubout-char decimal-rep last samepnamep delete-char lastlinep search-charset-backwards delete-white-sides lefthand-char search-charset-forward delete-word line-is-blank search-charset-forward-nosavepos delq listify search-failure-annunciator display-buffer-as-printout listify-word search-for-first-charset-line display-error loadfile search-for-first-not-charset-line display-error local-display-buffer-info search:announce-partial-failure display-error local-display-current-line search:numeric-prompt display-error local-display-generator select-buffer-find-window display-error-noabort local-display-generator-nnl select-buffer-window display-error-noabort looking-at select-other-window e_cline_ lower-case-char select-window e_lap_$trim lowercase set-key e_pl1_$get_iocb make_atom set-mark e_pl1_$set_emacs_tty_modes maknam set-mark-here e_pl1_$set_multics_tty_modes map-over-emacs-commands set-named-mark- ed-cv-fixnum-check mark-at-current-point-p set-the-mark empty-buffer-p mark-on-current-line-p set-the-mark-here end-local-displays mark-reached skip-back-to-whitespace error mark-tag-fun skip-back-whitespace eval max skip-back-whitespace-in-line eval:evaluate merge-kills-forward skip-over-indentation eval:internal merge-kills-reverse skip-over-whitespace evl-parenify minibuf-response skip-over-whitespace-in-line exchange-point-and-mark minibuffer-print skip-to-whitespace exists-buffer minibuffer-print skip-to-whitespace-in-line explode minibuffer-print status explodec minibuffer-print string-to-list-of-strings exploden minibuffer-print-noclear stringlength extended-command minibuffer-remark substr firstlinep minibuffer-remark substr format-to-col minibuffer-response sxhash forward-char move-mark tab-to-previous-columns forward-regexp-search ncline underline-point-mark forward-search ncline upper-case-char forward-search-in-line negate-minor-mode uppercase forward-sentence new-line view-lines forward-word next-line view-region-as-lines funcall next-screen whitespace-to-hpos gen-repetitive nreverse wipe-point-mark get nullstringp wipe-region get-buffer-state obarray write-out-file get-char ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL and BULL HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by BULL HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved