LISTING FOR >spec>online>the_last_emacs_for_9.0_i_hope>source>pool>emacs-ITS-searches COMPILED BY Multics LISP Compiler, Version hc9.2, June 5, 1981 ON 08/25/81 0945.4 mst Tue IN BEHALF OF Martinson.SysMaint.a ;;; ****************************************************** ;;; * * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; * * ;;; ****************************************************** ;;; ;;; ;;; Various Hairy Search Commands ;;; GMP ;;; CR/NL handling 5/23/80 by BSG ;;; ;;; read macro 12/3/78 by BSG (declare (eval (read))) (setsyntax '/# 'macro '(lambda () (cond ((= (tyipeek) 57) (tyi) (tyi)) ((= (tyipeek) 136) (tyi) (- (boole 1 137 (tyi)) 100))))) (%include e-macros) (declare (special search-forward last-search-string search-string search-ring search-from-end tty-no-upmotionp must-announce-search last-char-was-^S isearch-stack macro-execution-in-progress)) ;;; Command intended for use in start_up.emacs. It sets permanent definitions ;;; of ^S and ^R to specified type of search. (defun set-search-mode (search-type) (let ((forward-search-command nil) (reverse-search-command nil)) (cond ((memq search-type '(string default)) (setq forward-search-command 'string-search reverse-search-command 'reverse-string-search)) ((eq search-type 'character) (setq forward-search-command 'character-search reverse-search-command 'reverse-character-search)) ((memq search-type '(ITS-string its-string)) (setq forward-search-command 'ITS-string-search reverse-search-command 'reverse-ITS-string-search)) ((memq search-type '(regular-expression regexp)) (setq forward-search-command 'regexp-search-command) (display-error-noabort "Warning: No reverse regular expression search. ^R not rebound.")) ((eq search-type 'incremental) (setq forward-search-command 'incremental-search reverse-search-command 'reverse-incremental-search)) (t (display-error "Unknown search mode: " search-type))) ;can't risk throw done by command-quit ; since we might be in start_up.emacs (cond (forward-search-command (set-permanent-key '^S forward-search-command))) (cond (reverse-search-command (set-permanent-key '^R reverse-search-command))))) ;;; ;;; ;;; Character search commands (from ITS) ;;; GMP, 08/31/78 ;;; ;;; Character search command (defun character-search () (let ((search-forward t)) (character-search-))) ;;; Reverse character search command (defun reverse-character-search () (let ((search-forward nil)) (character-search-))) ;;; Subr that actually does character search (defun character-search- () (let ((quoted nil)) (do-forever (let ((ch (get-char))) (cond ((and (= ch #^A) (not quoted)) ; string search (ITS-string-search-) (stop-doing)) ((and (= ch #^G) (not quoted)) ; punt (command-quit)) ((or (= ch #^J) ; find line break (and (= ch #^M) (not quoted))) ; ^M (unquoted), same as ^J (search-maybe-push-default NL) (if search-forward (if (lastlinep) (display-error "Search fails.")) (next-line) else (if (firstlinep) (display-error "Search fails.")) (prev-line) (go-to-end-of-line)) (stop-doing)) ((and (= ch #^Q) (not quoted)) ; quote char (setq quoted t)) ((and (= ch #^R) (not quoted)) ; reverse direction (if search-forward (setq search-forward (not search-forward)) else (search-for-default-string) (stop-doing))) ((and (= ch #^S) (not quoted)) ; look for default (search-for-default-string) (stop-doing)) (t ; look for this (let ((result nil)) (if search-forward (setq result (forward-search (ascii ch))) else (setq result (reverse-search (ascii ch)))) (search-maybe-push-default (ascii ch)) (if result (stop-doing) else (display-error "Search fails."))))))))) ;;; Search for current default string (defun search-for-default-string () (if (nullstringp last-search-string) (display-error "No default search string.") else (let ((result nil)) (if (> (stringlength last-search-string) 1) (minibuffer-clear) (minibuffer-print (cond (search-forward "") (t "Reverse ")) "Search: " last-search-string)) (if search-forward (setq result (forward-search last-search-string)) else (setq result (reverse-search last-search-string))) (if (not result) (display-error "Search fails."))))) ;;; ;;; ;;; ITS String search commands ;;; GMP, 08/31/78 ;;; Cleaned up and bugs fixed 1 July 1981 Barry Margolin ;;; Merged and installed 1 July 1981 RMSoley ;;; ;;; ITS string search command (defun ITS-string-search () (let ((search-forward t)) (ITS-string-search-))) ;;; Reverse ITS string search command (defun reverse-ITS-string-search () (let ((search-forward nil)) (ITS-string-search-))) ;;; Subr to perform ITS string search (defun ITS-string-search- () (setq last-char-was-^S nil search-string "" search-from-end nil) (ITS-string-search-announce) (do-forever (if (eq (ITS-string-search-process-char (get-char)) 'done) (stop-doing))) (if (not tty-no-upmotionp) (minibuffer-clear))) ;;; Announce direction, type, and search string (defun ITS-string-search-announce () (minibuffer-clear) (if search-forward (if search-from-end (minibuffer-print "BJ ITS String Search: ") else (minibuffer-print "ITS String Search: ")) else (if search-from-end (minibuffer-print "ZJ Reverse ITS String Search: ") else (minibuffer-print "Reverse ITS String Search: "))) (minibuffer-print-noclear search-string) (setq must-announce-search nil)) ;;; Handle single character of ITS string search (defun ITS-string-search-process-char (ch) (prog2 0 (cond ((or (= ch 177) (= ch #/#)) (if (nullstringp search-string) (ITS-string-search-quit) else (isearch-chop-string-and-minibuffer) ; need better for printing 'continue)) ((= ch #^J) 'continue) ;LF ((= ch #^G) (ITS-string-search-quit)) ; punt ((= ch #^B) ; complement search from beginning (if search-forward (setq search-from-end (not search-from-end)) (ITS-string-search-announce) else (ITS-string-search-error "Can not search from beginning in reverse search." nil)) 'continue) ((= ch #^E) ; complement search from end (if search-forward (ITS-string-search-error "Can not search from end in forward search." nil) else (setq search-from-end (not search-from-end)) (ITS-string-search-announce)) 'continue) ((= ch #^L)(minibuffer-clear) (redisplay) ; redisplay (ITS-string-search-announce) 'continue) ((= ch #^Y) ; append default string (if (nullstringp last-search-string) (ITS-string-search-error "No default search string." nil) else (setq search-string (catenate search-string last-search-string)) (ITS-string-search-out last-search-string)) 'continue) ((= ch #^D) ; yank default and rotate (if (nullstringp last-search-string) (ITS-string-search-error "No default search string." nil) else (setq search-string (search-ring-top-and-rotate)) (setq last-search-string (search-ring-top)) ; copy of top (ITS-string-search-announce)) 'continue) ((= ch #^Q) ; quote next chararacter (let ((ch1 (ascii (get-char)))) (setq search-string (catenate search-string ch1)) (ITS-string-search-out ch1)) 'continue) ((= ch #^R) ; reverse direction of search (setq search-forward (not search-forward)) (ITS-string-search-announce) 'continue) ((or (= ch #^S) (= ch #^[)) ; ^S or ESC, search and maybe quit (if (and (= ch #^[) last-char-was-^S) ; ESC after ^S, just exit 'done else (if (nullstringp search-string) (setq search-string last-search-string) (ITS-string-search-out search-string)) (if (nullstringp search-string) (ITS-string-search-error "No search string." (= ch #^[)) else (with-mark start-pos (let ((result nil)) (if search-from-end (if search-forward (go-to-beginning-of-buffer) else (go-to-end-of-buffer))) (if search-forward (setq result (forward-search search-string)) else (setq result (reverse-search search-string))) (if result (redisplay) (if tty-no-upmotionp (setq must-announce-search t)) else (ITS-string-search-error "Search fails." (= ch #^[)) (go-to-mark start-pos))))) (search-maybe-push-default search-string) (if (= ch #^S) 'continue ; keep looking else 'done))) ; ESC, search terminates ((and (or (< ch 40) (> ch 177)) ; unknown control (not (or (= ch #^M)(= ch #^L)(= ch #^I)(= ch #^K)))) (ring-tty-bell) 'continue) (t ; normal character (if (= ch #^M)(setq ch #^J));cr => nl 5/23/80 (setq search-string (catenate search-string (ascii ch))) (ITS-string-search-out (ascii ch)))) (setq last-char-was-^S (= ch #^S)))) ;;; Add string to minibuffer unless must redisplay minibuffer (defun ITS-string-search-out (string) (if must-announce-search (ITS-string-search-announce) else (minibuffer-print-noclear string))) ;;; Print error for ITS string search (defun ITS-string-search-error (message use-minibuffer) (if (or tty-no-upmotionp use-minibuffer) (minibuffer-print message) ; not display-error since not fatal (setq must-announce-search t) else ; for display, print it (init-local-displays) (local-display-generator-nnl message) (minibuffer-print-noclear "")) ; reposition cursor (if macro-execution-in-progress (command-quit) else (ring-tty-bell))) ;;; Exit ITS string search (defun ITS-string-search-quit () (if (not tty-no-upmotionp) (minibuffer-clear)) ; if display, clear minibuffer (command-quit)) ;;; ;;; ;;; Incremental Search ;;; ;;; Incremental search command (defun incremental-search () (let ((search-forward t)) (incremental-search-))) ;;; Reverse Incremental search command (defun reverse-incremental-search () (let ((search-forward nil)) (incremental-search-))) ;;;Subr to do all the work (defun incremental-search- () (setq isearch-stack (list (cons nil (set-mark)))) (setq search-string "") (incremental-search-announce) (do-forever (or macro-execution-in-progress (redisplay)) (if (eq (isearch-process-char (get-char)) 'done) (stop-doing))) (if (not (nullstringp search-string)) ;if didn't abort search (search-maybe-push-default search-string)) (mapc '(lambda (x) (release-mark (cdr x))) isearch-stack) (if (not tty-no-upmotionp) (minibuffer-clear))) ;;; Process a single character (defun isearch-process-char (ch) (cond ((or (= ch 177)(= ch #/#)) ;rubout last char (isearch-rubout)) ((= ch #^G) ; abort search (ring-tty-bell) (setq search-string "") (go-to-mark (cdar (last isearch-stack))) 'done) ((= ch #^L) ; redisplay (redisplay) (incremental-search-announce) 'continue) ((= ch #^Q) ; quote next char (isearch-search-single (ascii (get-char)))) ((or (= ch #^S)(= ch #^R)) ; search again or use default (let ((new-dir (= ch #^S))) (if (not (eq new-dir search-forward)) (setq search-forward new-dir) (minibuffer-clear) (incremental-search-announce))) (if (not (nullstringp search-string)) (search-maybe-push-default search-string) (setq search-string "") else (minibuffer-print-noclear last-search-string)) (setq isearch-stack (cons (cons nil (set-mark)) ;non-inserting isearch-stack)) (let ((nss (catenate search-string last-search-string))) (if search-forward ;Movin' right... (if (looking-at last-search-string) ;already in front of it, OK (forward-search last-search-string) (setq search-string nss) 'continue else (if (forward-search nss) (setq search-string nss) 'continue else ;not found again (minibuffer-clear) (incremental-search-failure) (incremental-search-announce))) else ;Movin' left... (if (reverse-search nss) (setq search-string nss) 'continue else (minibuffer-clear) (incremental-search-failure) (incremental-search-announce))))) ((= ch #^[) ; all done 'done) ((= ch #^J) 'continue) ((= ch #^M)(isearch-search-single NL)) ((and (or (< ch 40) (> ch 177)) ;random control char, not allowed (not (or (= ch #^L)(= ch #^K)(= ch #^I)))) (ring-tty-bell) 'continue) (t ;normal char, search for it (isearch-search-single (ascii ch))))) ;;; Delete a character from search string (defun isearch-rubout () (cond ((= 1 (length isearch-stack)) ;nothing to rubout, abort (ring-tty-bell) 'done) (t (go-to-mark (cdar isearch-stack)) (release-mark (cdar isearch-stack)) (cond ((caar isearch-stack) ;rubbing out self-insert (isearch-chop-string-and-minibuffer))) (setq isearch-stack (cdr isearch-stack)) 'continue))) (declare (special display-ctlchar-with-^)) (defun isearch-chop-string-and-minibuffer () (let ((sl (stringlength search-string))) (let ((lastch (substr search-string sl 1))) (setq search-string (substr search-string 1 (1- sl))) (if (not tty-no-upmotionp) (minibuffer-rubout (cond ((not (samepnamep lastch NL)) 1) (display-ctlchar-with-^ 2) (t 4))))))) ;pretty kludgey, eh? ;;; Search for a single character incrementally (defun isearch-search-single (ch) (if (not tty-no-upmotionp) ;put in buffer if needed (minibuffer-print-noclear ch)) (setq search-string (catenate search-string ch)) (setq isearch-stack (cons (cons 'insert (set-mark)) isearch-stack)) (if search-forward (if-at ch ;char is here, continue along (forward-char) 'continue else ;not here, search again (if (forward-search search-string) 'continue ;found it else ;not found, flush char typed (incremental-search-failure) (isearch-rubout))) else ;Reverse Isearch (if (looking-at search-string) 'continue else (do-times (1- (stringlength search-string))(forward-char)) (if (reverse-search search-string) 'continue else (do-times (1- (stringlength search-string))(backward-char)) (incremental-search-failure) (isearch-rubout))))) (defun incremental-search-announce () (if search-forward (minibuffer-print "Incremental Search: ") else (minibuffer-print "Reverse Incremental Search: ")) (minibuffer-print-noclear search-string) 'continue) (defun incremental-search-failure () (if macro-execution-in-progress (go-to-mark (cdar (last isearch-stack))) (mapc '(lambda (x) (release-mark (cdr x))) isearch-stack) (setq search-string "") (search-failure-annunciator) else (ring-tty-bell))) ;;; ;;; Query replace by Carl Hoffman ;;; (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 (t (display-error-noabort "Unknown query replace response.") (redisplay))) (setq response (get-char)))) (defun query-replace-swap-strings (old new) (with-mark m (reverse-search old) (without-saving (wipe-point-mark m)) (insert-string new))) INCLUDE FILE >spec>online>the_last_emacs_for_9.0_i_hope>include>e-macros.incl.lisp ;;; ****************************************************** ;;; * * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; * * ;;; ****************************************************** ;;; ;;; ;;; Macros for Programming in EMACS Environment ;;; ;;; Written by BSG. ;;; Added without-line-control, cleaned up a bit. 25 June 1981 RMSoley ;;; ;;; Added by BSG 5/8/80. ;;; This attempts to punt loading the interpreted version of e-macros ;;; (what you are reading) and load in the pre-compiled, if such ;;; exists. (eval-when (compile eval) (let ((objnamelist (reverse (cdr (reverse (namelist (truename infile))))))) (cond ((and (equal (cdr objnamelist) '(e-macros incl)) (or instack (status feature Emacs)) (allfiles objnamelist)) ;; Load in pre-compiled e-macros.lisp (load objnamelist) ;; Force lisp to stop reading this file (simulate EOF). (filepos infile 'eof))))) ;;; Added by BSG 4/28/80: Include backquote in compilation. (%include backquote) ;;; The hair of a thousand self-shaving barbers 5/10/80 ;;; If conditions are ripe, compile this file into an object segment. (defun e-macros-self-compile-qwerty macro (x) (cond ((and (equal (cdr (namelist infile)) '(e-macros incl lisp)) (null instack)) ;yes (do x (read)(read)(equal x ''end-self-compile)(eval x)) (do x (read) (read) nil (e-macros-self-compile-1 x) (tyipeek t) (and (= (tyipeek) 3)(return nil))) `(progn `compile . ,(nreverse e-macros-self-compile-list))) (t (do x (read)(read)(equal x ''end-self-compile)) nil))) (e-macros-self-compile-qwerty) (setq e-macros-self-compile-list '((load (catenate (car (namelist (truename infile))) ">lisp_backquote_")))) (defun e-macros-self-compile-output (x) (setq e-macros-self-compile-list (cons x e-macros-self-compile-list))) (defun e-macros-self-compile-1 (x) (cond ((atom x) nil) ((eq (car x) 'declare) (e-macros-self-compile-output `(and (status feature compiler) (progn . ,(cdr x))))) ((eq (car x) 'eval-when) (cond ((memq 'compile (cadr x)) (e-macros-self-compile-1 (cons (cond ((memq 'eval (cadr x)) 'progn) ;10/22/80 (t 'declare)) (cddr x)))))) ((eq (car x) 'defun) (cond ((eq (caddr x) 'macro) (let ((mname (cadr x)) (var (car (cadddr x))) (body (cddddr x))) (let ((xmname (make_atom (catenate mname " MACRO")))) (e-macros-self-compile-output `(defun ,xmname (,var) (setq ,var ,var) .,body)) (e-macros-self-compile-output `(putprop ',mname ',xmname 'macro))))) (t (error "Don't know how to compile fcn def: " x 'fail-act)))) (t (e-macros-self-compile-output x)))) 'end-self-compile (declare ;basic editor stuff (*expr apply-catenate charlisten assert-minor-mode backward-char charset-member command-quit copy-region cur-hpos curline-as-string curbuf-as-string curchar curline-as-string delete-char e_lap_$trim establish-local-var dont-notice-modified-buffer destroy-buffer-contents empty-buffer-p e_cline_ exchange-point-and-mark firstlinep forward-char forward-regexp-search-in-line forward-search forward-search-in-line get-char get-search-string go-to-beginning-of-buffer go-to-beginning-of-line go-to-buffer go-to-end-of-buffer go-to-end-of-line go-to-mark go-to-or-create-buffer insert-char insert-string kill-backwards-to-mark kill-forward-to-mark kill-pop kill-to-end-of-line killsave-string lastlinep loadfile looking-at map-over-emacs-commands mark-on-current-line-p mark-reached merge-kills-forward merge-kills-reverse move-mark minibuf-response minibuffer-clear negate-minor-mode new-line next-line nullstringp point-mark-to-string point>markp prev-line printable process-char produce-named-mark-list read-in-file register-option release-mark reverse-search register-local-var set-emacs-epilogue-handler reverse-search-in-line search-back-first-charset-line search-back-first-not-charset-line search-failure-annunciator search-for-first-charset-line search-for-first-not-charset-line set-mark-here set-buffer-self-destruct set-key set-perm-key set-mark set-the-mark wipe-point-mark wipe-region trim-minibuf-response yesp write-out-file yank) (*fexpr define-autoload-lib)) (declare ;redisplay stuff (*expr end-local-displays init-local-displays ring-tty-bell local-display-generator local-display-generator-nnl next-screen prev-screen local-display-current-line find-buffer-in-window select-buffer-window window-info select-buffer-find-window select-other-window select-window buffer-on-display-in-window redisplay full-redisplay)) (declare ;extended stuff (*expr forward-word backward-word skip-over-whitespace skip-back-whitespace skip-over-whitespace-in-line skip-back-whitespace-in-line skip-back-to-whitespace skip-to-whitespace rubout-char date display-buffer-as-printout delete-white-sides lefthand-char format-to-col whitespace-to-hpos line-is-blank decimal-rep)) (declare (*lexpr display-error display-com-error display-error-noabort display-error-remark comout-get-output display-com-error-noabort minibuffer-print minibuffer-print-noclear report-error report-error-noabort)) (declare (or (and (get 'unwind-protect 'fsubr)(get 'eval-when 'fsubr)) (error "This version of the Lisp Compiler does not support this version of e-macros.incl.lisp"))) (declare (special TAB NL SPACE ESC curpointpos current-buffer dont-stash numarg der-wahrer-mark fpathname fill-column completion-list curlinel BACKSPACE read-only-flag buffer-modified-flag previous-buffer current-buffer-mode env-dir process-dir)) (eval-when (eval compile) (load (catenate (car (namelist (truename infile))) ">e_define_command_"))) (defun bolp macro (x) '(= curpointpos 0)) (defun eolp macro (x) '(= curpointpos (1- curlinel))) (defun at-white-char macro (x) '(get (curchar) 'whiteness)) (defun with-mark macro (x) (let ((forms (cddr x)) (mark (cadr x))) `((lambda (,mark) (unwind-protect (progn (setq ,mark (set-mark)) . ,forms) (release-mark ,mark))) nil)))) (defun save-excursion macro (x) (let ((forms (cdr x)) (mark (gensym))) `((lambda (,mark) (unwind-protect (progn (setq ,mark (set-mark)) . ,forms) (go-to-mark ,mark) (release-mark ,mark))) nil)))) (defun save-excursion-buffer macro (x) (let ((forms (cdr x)) (buffer (gensym)) (prevbuf (gensym))) `((lambda (,buffer ,prevbuf) (unwind-protect (progn . ,forms) (go-to-or-create-buffer ,buffer) (setq previous-buffer ,prevbuf))) current-buffer previous-buffer))) (defun protect-excursion macro (x) (let ((forms (cdr x)) (buffer (gensym)) (done (gensym)) (mark (gensym))) `(let ((,buffer current-buffer) (,mark) (,done)) (unwind-protect (prog2 (setq ,mark (set-mark)) (progn . ,forms) (setq ,done t)) (or ,done (progn (go-to-or-create-buffer ,buffer) (and ,mark (go-to-mark ,mark)))) (release-mark ,mark))))) (defun do-forever macro (x) `(do nil (nil) . ,(cdr x))) (defun with-the-mark-last macro (x) (let ((forms (cddr x)) (mark (cadr x))) `(and (or der-wahrer-mark (display-error "There is no true mark.")) (save-excursion (with-mark ,mark (cond ((point>markp der-wahrer-mark) (go-to-mark der-wahrer-mark)) (t (move-mark ,mark der-wahrer-mark))) (progn . ,forms)))))))))) (defun if-at macro (x) (let ((forms (cddr x)) (char (cond ((stringp (cadr x)) (list 'quote (getchar (cadr x) 1))) (t (cadr x))))) `(Multics-Emacs-if (eq (curchar) ,char) . ,forms))) (defun at-white macro (x) '(get (curchar) 'whiteness)) (defun stop-doing macro (x) '(return nil)) (defun dispatch-on-current-char macro (x) (do ((gs (gensym)) (clauses (cdr x) (cdr clauses)) (outs nil (cons s outs)) (s)) ((null clauses) `((lambda (,gs)(cond . ,(nreverse outs))) (curchar))) (setq s (cons (cond ((eq (caar clauses) 'else) 't) ((stringp (caar clauses)) `(eq ,gs ',(getchar (caar clauses) 1))) (t (list 'eq gs (caar clauses)))) (cdar clauses))))) (defun Multics-Emacs-if macro (x) (do ((ifs) (elses) (l (cddr x) (cdr l))) ((null l) (cond (elses (list 'cond (cons (cadr x) (nreverse ifs)) (cons 't (cdr (nreverse elses))))) (t (list 'cond (cons (cadr x) (nreverse ifs)))))) (cond ((eq (car l) 'else)(setq elses (list nil))) (elses (setq elses (cons (car l) elses))) (t (setq ifs (cons (car l) ifs)))))) ;;; See Bawden "if" treaty of 5/9/80 -BSG (or (getl 'if '(macro expr subr)) (putprop 'if (or (get 'Multics-Emacs-if 'macro) (get 'Multics-Emacs-if/ MACRO 'expr) 'Multics-Emacs-if/ MACRO) 'macro)) (defun at-end-of-buffer macro (x) '(and (eolp)(lastlinep))) (defun at-beginning-of-buffer macro (x) '(and (bolp)(firstlinep))) (defun walk-through-region macro (x) (let ((forms (cdr x)) (mark (gensym))) `(with-the-mark-last ,mark (do-forever (and (mark-reached ,mark)(return nil)) . ,forms)))) (defun without-saving macro (x) `(let ((dont-stash t)) .,(cdr x))) (defun do-times macro (x) (let ((forms (cddr x)) (howmany (cadr x)) (dovar (gensym))) `(do ,dovar ,howmany (1- ,dovar)(= 0 ,dovar) . ,forms))) (defun if-back-at macro (x) (let ((forms (cddr x)) (thing (cond ((stringp (cadr x)) (list 'quote (getchar (cadr x) 1))) (t (cadr x))))) `(Multics-Emacs-if (eq (lefthand-char) ,thing) . ,forms))) (defun at macro (x) (let ((thing (cond ((stringp (cadr x)) (list 'quote (getchar (cadr x) 1))) (t (cadr x))))) `(eq (curchar) ,thing))) (defun back-at macro (x) (let ((thing (cond ((stringp (cadr x)) (list 'quote (getchar (cadr x) 1))) (t (cadr x))))) `(eq (lefthand-char) ,thing))) (defun dispatch-on-lefthand-char macro (x) (do ((gs (gensym)) (clauses (cdr x) (cdr clauses)) (outs nil (cons s outs)) (s)) ((null clauses) `(let ((,gs (lefthand-char))) (cond . ,(nreverse outs)))) (setq s (cons (cond ((eq (caar clauses) 'else) 't) ((stringp (caar clauses)) `(eq ,gs ',(getchar (caar clauses) 1))) (t (list 'eq gs (caar clauses)))) (cdar clauses))))) (defun without-modifying macro (x) `((lambda (read-only-flag buffer-modified-flag) . ,(cdr x)) nil t))) (defun display-as-printout macro (x) `(progn (save-excursion-buffer (go-to-or-create-buffer (gensym)) (putprop current-buffer t 'temporary-buffer) (init-local-displays) (progn . ,(cdr x)) (display-buffer-as-printout)) (end-local-displays))) (defun defvar macro (f) (let ((specials nil) (inits nil) (nothing (ncons nil))) (cond ((atom (cadr f)) (setq f `(defvar ((,(cadr f) ,(cond ((null (cddr f)) nothing) (t (caddr f))))))))) (mapc '(lambda (x) (let ((v)(init nothing)) (cond ((atom x)(setq v x)) ((null (cdr x)) (setq v (car x) init nil)) (t (setq v (car x) init (cadr x)))) (setq specials (cons v specials)) (or (eq init nothing) (setq inits (cons `(or (boundp ',v)(setq ,v ,init)) inits))))) (cadr f)) (setq specials (reverse specials)) (cond ((null inits) `(declare (special . ,specials))) (t `(progn 'compile (declare (special .,specials)) . ,(reverse inits)))))) ;;; Macro to invisibly (and temporarily) turn off line control ;;; 25 June 1981 Richard Mark Soley (defun without-line-control macro (x) `(let ((read-only-flag nil) (line-control:buffer 0)) . ,(cdr x))) Functions Defined Name Offset Offset Name ITS-string-search 430 0 set-search-mode ITS-string-search- 444 111 character-search ITS-string-search-announce 470 117 reverse-character-search ITS-string-search-error 1256 125 character-search- ITS-string-search-out 1242 333 search-for-default-string ITS-string-search-process-char 541 430 ITS-string-search ITS-string-search-quit 1316 436 reverse-ITS-string-search character-search 111 444 ITS-string-search- character-search- 125 470 ITS-string-search-announce incremental-search 1324 541 ITS-string-search-process-char incremental-search- 1340 1242 ITS-string-search-out incremental-search-announce 2202 1256 ITS-string-search-error incremental-search-failure 2227 1316 ITS-string-search-quit isearch-chop-string-and-minibuffer 1751 1324 incremental-search isearch-process-char 1431 1332 reverse-incremental-search isearch-rubout 1706 1340 incremental-search- isearch-search-single 2044 1431 isearch-process-char query-replace 2274 1706 isearch-rubout query-replace-$-1-$-&default 2335 1751 isearch-chop-string-and-minibuffer query-replace-dispatch 2371 2044 isearch-search-single query-replace-execute 2342 2202 incremental-search-announce query-replace-swap-strings 2522 2227 incremental-search-failure reverse-ITS-string-search 436 2274 query-replace reverse-character-search 117 2335 query-replace-$-1-$-&default reverse-incremental-search 1332 2342 query-replace-execute search-for-default-string 333 2371 query-replace-dispatch set-search-mode 0 2522 query-replace-swap-strings Functions Referenced ITS-string-search- go-to-end-of-buffer negate-minor-mode ITS-string-search-announce go-to-end-of-line next-line ITS-string-search-error go-to-mark nullstringp ITS-string-search-out incremental-search- prev-line ITS-string-search-process-char incremental-search-announce query-replace-dispatch ITS-string-search-quit incremental-search-failure query-replace-execute ascii init-local-displays query-replace-swap-strings assert-minor-mode insert-string redisplay backward-char isearch-chop-string-and-minibuffer release-mark catenate isearch-process-char reverse-search character-search- isearch-rubout ring-tty-bell command-quit isearch-search-single samepnamep curchar last search-failure-annunciator display-error lastlinep search-for-default-string display-error length search-maybe-push-default display-error-noabort local-display-generator-nnl search-ring-top firstlinep looking-at search-ring-top-and-rotate forward-char minibuffer-clear set-mark forward-search minibuffer-print set-permanent-key get-char minibuffer-print stringlength get-search-string minibuffer-print-noclear substr go-to-beginning-of-buffer minibuffer-rubout wipe-point-mark ----------------------------------------------------------- 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