emacs-alm-mode.lisp 08/20/86 2313.5rew 08/20/86 2242.8 20070 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; HISTORY COMMENTS: ;;; 1) change(81-07-31,Hornig), approve(), audit(), ;;; install(86-08-20,MR12.0-1136): ;;; to separate electric-alm mode. ;;; 2) change(84-12-27,Margolin), approve(86-02-24,MCR7186), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; to register and set mode-identification ;;; in alm-mode, as it is required by compile-buffer. ;;; 3) change(85-01-27,Margolin), approve(86-02-24,MCR7186), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; to declare mode-identification special. ;;; END HISTORY COMMENTS (%include e-macros) (declare (special fill-column comment-column comment-prefix fill-prefix compiler compile-options mode-identification)) (defvar alm-mode-hook nil) (defun alm-mode () (register-local-var 'compiler) (register-local-var 'compile-options) (register-local-var 'mode-identification) (setq current-buffer-mode 'ALM compiler 'alm compile-options "" mode-identification -3) (setq comment-column 40. comment-prefix "") (negate-minor-mode 'electric) (set-key 'ESC-^C 'compile-buffer) (if alm-mode-hook (errset (funcall alm-mode-hook)))) (defun electric-alm-mode () (alm-mode) (setq fill-prefix TAB) (set-key ': 'alm-label-hacker) (set-key '^M 'nl-nb-line) (assert-minor-mode 'electric)) (defun nl-nb-line () (and (eolp)(delete-white-sides)) (new-line)) (defun alm-label-hacker () (save-excursion (go-to-beginning-of-line) (if (at-white-char)(delete-white-sides))) (insert-string ":") (format-to-col 10.))  emacs-buffer-edit.lisp 08/20/86 2313.5r w 08/20/86 2245.0 102447 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; Bufed pro bufonibus. ;;; BSG 4/14/79 ;;; Modified: 4 December 1983 - B. Margolin - fix misspelling in ;;; message printed by bufed-examine. ;;; (%include e-macros) (declare (special bufed-goback-buf bufed-wopt bufed-kill-list known-buflist two-window-mode)) (declare (*expr buffer-kill create-new-window-and-stay-here delete-window get-buffer-state go-to-hpos lruify-current-window lruify-window save-same-file window-adjust-lower window-adjust-upper)) (defun edit-buffers ()(bufed)) (defun bufed () (prog (tbufnam origbuf origmark) (setq origbuf current-buffer) (setq tbufnam 'BUFEDIT) (if numarg (find-buffer-in-window tbufnam) else (go-to-or-create-buffer tbufnam)) (register-local-var 'bufed-goback-buf) (setq bufed-goback-buf origbuf) (register-local-var 'bufed-wopt) (setq bufed-wopt numarg numarg nil) (register-local-var 'bufed-kill-list) (setq bufed-kill-list nil) (bufedit-mode) (go-to-beginning-of-buffer) (setq read-only-flag nil) (do ((bufl (delq tbufnam (subst nil nil known-buflist)) (cdr bufl)) (buf)) ((null bufl)) (setq buf (car bufl)) (or (line-is-blank)(without-saving (kill-to-end-of-line))) (and (eq buf previous-buffer) (setq origmark (set-mark))) (cond ((eq buf bufed-goback-buf)(insert-char ">")) (t (insert-char SPACE))) (cond ((get-buffer-state buf 'buffer-modified-flag) (insert-char "*")) (t (insert-char SPACE))) (do-times 2 (insert-char SPACE)) (insert-string buf) (cond ((get-buffer-state buf 'fpathname) (format-to-col 25.) (insert-string (get-buffer-state buf 'fpathname)))) (if (lastlinep)(new-line) else (next-line))) (backward-char) (without-saving (with-mark m (go-to-end-of-buffer)(wipe-point-mark m))) (go-to-mark origmark) (release-mark origmark) (setq read-only-flag t buffer-modified-flag nil) (select-buffer-window current-buffer 'cursize))) (defun bufedit-mode () (if (empty-buffer-p current-buffer) (setq current-buffer-mode 'Buffer/ Edit) (mapc '(lambda (x)(set-key (car x)(cadr x))) '( (w edit-windows) (W edit-windows) (q bufed-quit) (Q bufed-quit) (e bufed-examine) (E bufed-examine) (d bufed-kill) (D bufed-kill) (k bufed-kill) (K bufed-kill) (g bufed-go) (G bufed-go) (u bufed-undelete) (U bufed-undelete) (p bufed-prev) (P bufed-prev) (n bufed-next) (N bufed-next) (f bufed-find) (F bufed-find) (s bufed-save) (S bufed-save) (^X^Q bufed-quit))))) (defun bufed-prev () (if (firstlinep)(go-to-end-of-buffer) (go-to-beginning-of-line) else (prev-line))) (defun bufed-next () (if (lastlinep)(go-to-beginning-of-buffer) else (next-line))) (defun bufed-validate-target (targ) (if (memq targ bufed-kill-list) (display-error "Buffer " targ " to be deleted. Can't go there.")) (if (not (memq targ known-buflist)) (display-error "Buffer " targ " no longer exists. Choose another."))) (defun bufed-go () (let ((targ (bufed-get-bufnam)) (goback bufed-goback-buf)) ;gonna get switched w bufs (bufed-validate-target targ) (bufed-check-deletions) (set-buffer-self-destruct 'BUFEDIT) (select-buffer-window targ nil) (setq previous-buffer goback))) (defun bufed-find () (let ((buf (bufed-get-bufnam)) (goback bufed-goback-buf)) (bufed-validate-target buf) (bufed-check-deletions) (set-buffer-self-destruct 'BUFEDIT) (find-buffer-in-window buf) (setq previous-buffer goback))) (defun bufed-quit () (bufed-validate-target bufed-goback-buf) (bufed-check-deletions) (set-buffer-self-destruct 'BUFEDIT) (if bufed-wopt (lruify-current-window) (find-buffer-in-window bufed-goback-buf) else (select-buffer-window bufed-goback-buf nil))) (defun bufed-examine () (if two-window-mode (let ((bub current-buffer) (targ (bufed-get-bufnam))) (let ((wf (buffer-on-display-in-window targ))) (if wf (display-error-remark "Buffer " targ " on display in window " (decimal-rep wf)) else (find-buffer-in-window targ) (setq wf (buffer-on-display-in-window targ)) (display-error-remark "Buffer " targ " on display in window " (decimal-rep wf)) (find-buffer-in-window bub) (lruify-window wf)))) else (go-to-buffer (bufed-get-bufnam)) (display-error-noabort "^XB CR to get back to Buffer Edit."))) (defun bufed-kill () (go-to-hpos 2) (if-at 'X (go-to-beginning-of-line) else (without-modifying (delete-char) (insert-char 'X)) (setq bufed-kill-list (cons (bufed-get-bufnam) bufed-kill-list)) (if (lastlinep)(go-to-beginning-of-line) else (next-line)))) (defun bufed-check-deletions () (if bufed-kill-list (init-local-displays) (mapc 'local-display-generator-nnl '("Buffers to Kill:" "----------------" "")) (mapc 'local-display-generator-nnl bufed-kill-list) (end-local-displays) (if (yesp "Go ahead and kill these buffers? ") (mapc 'buffer-kill bufed-kill-list)) (setq bufed-kill-list nil))) (defun bufed-undelete () (go-to-hpos 2) (if-at 'X (without-modifying (delete-char) (insert-string " ")) (setq bufed-kill-list (delq (bufed-get-bufnam) bufed-kill-list)) (if (lastlinep)(go-to-beginning-of-line) else (next-line)))) (defun bufed-get-bufnam () (go-to-hpos 4.) (prog2 0 (make_atom (with-mark b (if (go-to-hpos 25.) (if (forward-search-in-line ">") (backward-char) else (go-to-end-of-line)) (skip-back-whitespace)) (point-mark-to-string b))) (go-to-beginning-of-line))) (defun bufed-save () (save-excursion-buffer (go-to-buffer (bufed-get-bufnam)) (save-same-file)) (go-to-hpos 1) (if-at '* (without-modifying (delete-char) (insert-char SPACE))) (if (lastlinep) (go-to-beginning-of-line) else (next-line))) ;;; ;;; ;;; Window editor BSG 4/14/79 ;;; (declare (special selected-window nuwindows)) (defun edit-windows () (let ((ona numarg)(numarg nil)) (if ona (find-buffer-in-window 'WINDOWSTAT)) (wstat-edit)) (select-buffer-window current-buffer 'cursize)) (defun wstat-edit () (go-to-or-create-buffer 'WINDOWSTAT) (wstat-mode) (select-buffer-window current-buffer (if (buffer-on-display-in-window current-buffer) nuwindows else (1+ nuwindows))) (wstat-create-display) ; (redisplay) (lruify-current-window)) (defun wstat-create-display () (setq read-only-flag nil buffer-modified-flag t) ;suppr modified msg (go-to-beginning-of-buffer) (do i 1 (1+ i)(> i nuwindows) (without-saving (kill-to-end-of-line)) (insert-string (decimal-rep i)) (if (= i selected-window)(insert-string "*")) (format-to-col 4) (let ((info (window-info i))) (insert-string (decimal-rep (cadr info))) ;internal # (format-to-col 10.) (insert-string (decimal-rep (caar info))) ;startline (format-to-col 15.) (insert-string (decimal-rep (cdar info))) ;nlines (format-to-col 20.) (insert-string (caddr info)) ;buffer (format-to-col 40.) (if (null (cadddr info)) (insert-string "<>") else (insert-string (substr (cadddr info) 1 (min 10. (1- (stringlength (cadddr info)))))))) (if (lastlinep)(new-line) else (next-line))) (rubout-char) (without-saving (with-mark m (go-to-end-of-buffer)(wipe-point-mark m))) (setq buffer-modified-flag nil read-only-flag t) (go-to-beginning-of-buffer)) (defun wstat-mode () (if (empty-buffer-p current-buffer) (mapc '(lambda (x)(set-key (car x)(cadr x))) '((b edit-buffers) (c wstat-create-window) (/3 wstat-create-window) (g wstat-go-window) (f wstat-go-window) (^ wstat-push-up-top) (v wstat-push-down-bottom) (u wstat-pull-up-bottom) (a wstat-pull-down-top) (k wstat-kill-window) (d wstat-kill-window) (n wstat-next) (p wstat-prev))) (setq current-buffer-mode 'Window/ Edit))) (defun wstat-create-window () (create-new-window-and-stay-here) (wstat-create-display) (go-to-end-of-buffer) (go-to-beginning-of-line)) (defprop wstat-next t argwants)(defprop wstat-prev t argwants) (defun wstat-next ()(if (lastlinep)(go-to-beginning-of-buffer)else (next-line))) (defun wstat-prev ()(if (firstlinep)(go-to-end-of-buffer)(go-to-beginning-of-line) else (prev-line))) (defun wstat-go-window () (set-buffer-self-destruct 'WINDOWSTAT) (select-window (wstat-collect-wnum))) (defun wstat-kill-window () (delete-window (wstat-collect-wnum)) (save-excursion (wstat-create-display))) (defun wstat-collect-wnum () (prog2 (go-to-beginning-of-line) (let ((ibase 10.)) (readlist (explodec (with-mark m (forward-word) (point-mark-to-string m))))) (go-to-beginning-of-line))) (defun wstat-push-up-top () (let ((howmuch (or numarg 1)) (u (wstat-collect-wnum))) (if (= u 1)(display-error "The top window has no topline!")) (if (< (- (cdar (window-info (1- u))) howmuch) 3) (display-error "Attempt to make upstairs window too small.")) (window-adjust-upper u (- howmuch))) (save-excursion (wstat-create-display))) (defun wstat-push-down-bottom () (let ((howmuch (or numarg 1)) (u (wstat-collect-wnum))) (if (= u nuwindows) (display-error "The bottom window has no bottomline!")) (if (< (- (cdar (window-info (1+ u))) howmuch) 3) (display-error "Attempt to make downstairs window too small.")) (window-adjust-lower u howmuch)) (save-excursion (wstat-create-display))) (defun wstat-pull-down-top () (let ((howmuch (or numarg 1)) (u (wstat-collect-wnum))) (if (= u 1)(display-error "The top window has no topline!")) (if (< (- (cdar (window-info u)) howmuch) 3) (display-error "Attempt to make this window too small.")) (window-adjust-upper u howmuch)) (save-excursion (wstat-create-display))) (defun wstat-pull-up-bottom () (let ((howmuch (or numarg 1)) (u (wstat-collect-wnum))) (if (= u nuwindows) (display-error "The bottom window has no bottomline!")) (if (< (- (cdar (window-info u)) howmuch) 3) (display-error "Attempt to make this window too small.")) (window-adjust-lower u (- howmuch))) (save-excursion (wstat-create-display)))  emacs-compilations.lisp 03/25/87 1031.4rew 03/25/87 1028.8 68409 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; HISTORY COMMENTS: ;;; 1) change(86-04-23,Margolin), approve(86-04-23,MCR7325), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Added *expr declarations so that it would compile without warnings. ;;; 2) change(86-11-24,Margolin), approve(87-01-27,MCR7607), ;;; audit(87-02-13,RBarstad), install(87-03-25,MR12.1-1014): ;;; To not use "file_output" buffer, and to add one-error-scan-buffer, ;;; compile-two-windows, and compile-local-display options. ;;; 3) change(87-01-28,Margolin), approve(87-01-28,MCR7607), ;;; audit(87-02-13,RBarstad), install(87-03-25,MR12.1-1014): ;;; Added display-compilation-result. ;;; END HISTORY COMMENTS ;;; (%include e-macros) (%include other_other) ;;; Common part of error list processor. ;;; Paul Schauble, DVCP, Phoenix. (declare (special error-list-builder e-list error-scan-buffer mode-identification fill-prefix buffer-minor-modes current-buffer buffer-uid compiler fpathname compile-options two-window-mode number-of-lines-in-buffer)) (declare (*expr comout-to-buffer create-new-window-and-stay-here redisplay-current-window-relative save-same-file)) (defvar ((compile-local-display nil) (compile-two-windows nil) (error-list '()) error-source-buffer nuwindows (one-error-scan-buffer t))) (defun locate-next-error () (if (not (memq 'Error/ scan buffer-minor-modes)) (build-new-error-list)) (if e-list ; Advance to next error (let ((error-entry (car e-list))) (save-excursion-buffer (find-buffer-in-window error-scan-buffer) (without-modifying (if-at '/= (delete-char) (delete-char) (insert-string " ")) (go-to-mark (car error-entry)) (delete-char) (delete-char) (insert-string "=>")) (go-to-beginning-of-line) (redisplay-current-window-relative 0) (find-buffer-in-window previous-buffer)) (let ((z (cdr error-entry))) (if z (go-to-mark z)))) (setq e-list (cdr e-list)) else (exit-error-scan-mode) (display-error "No more errors."))) (defun build-new-error-list () (if error-list ; Wipe old mark list (save-excursion-buffer (go-to-buffer error-scan-buffer) (exit-error-scan-mode))) (let ((crufty-error-list-builder error-list-builder) ;; Ack! Not bound correctly in file_output!!! (temp-error-list nil) (other-buffer current-buffer) (buffer-modified-flag t)) (save-excursion-buffer (go-to-buffer error-scan-buffer) (unless (eq error-source-buffer other-buffer) (display-error "This buffer was not the last one compiled.")) (without-modifying (go-to-end-of-buffer) (setq temp-error-list (funcall crufty-error-list-builder))) (if (not (symbolp temp-error-list)) (setq buffer-uid -143 read-only-flag t) else (setq buffer-uid 0))) (setq error-list temp-error-list)) ;get into this buffer's variable (cond ((null error-list) (display-error "No errors found.")) ((eq error-list 'not-compile) (setq error-list nil) (display-error "Last comout was not a compilation.")) ; That error returned so that error-list-builder does ; not command-quit while in file_output ;; The mark list is a list of ( . ) ;; convert the line num to a mark in the source buffer. (t (go-to-beginning-of-buffer) (let ((line 1) (target) (move)) (dolist (error-entry error-list) (setq target (cdr error-entry)) (if target (setq move (- target line)) (cond ((= move 0)) ; on that line now ((> move 0) ; must advance (do-times move (next-line))) (t ; else move back (do-times (- move)(prev-line)))) (setq line target) (rplacd error-entry (set-mark))))) ; error-list is now list of ( . ) (setq e-list error-list) (assert-minor-mode 'Error/ scan)))) (defun exit-error-scan-mode () ; Must be in source buffer when called (dolist (error-entry error-list) (and (cdr error-entry) (release-mark (cdr error-entry)))) (save-excursion-buffer (go-to-buffer error-scan-buffer) (setq read-only-flag nil buffer-uid 0 buffer-modified-flag t) (if-at '/= (delete-char) (delete-char) (insert-string " ")) (dolist (error-entry error-list) (release-mark (car error-entry))) (setq buffer-modified-flag nil)) (negate-minor-mode 'Error/ scan) (setq error-list nil e-list nil)) ;;; ;;; Conditional new line, does new line and insert special prefix ;;; if the current line has significant contents, it will be used. ;;; Note that the new prefix must be an arg, since this needs both ;;; the old and new values. (defun conditional-new-line (pfx) (go-to-beginning-of-line) (if (or (line-is-blank) (and (looking-at fill-prefix) (= curlinel (1+ (stringlength fill-prefix))))) (without-saving (kill-to-end-of-line)) else (go-to-end-of-line) (let ((fill-prefix "")) (new-line))) (if pfx (insert-string pfx))) ;;; ;;; Fortran compilatons, January 29, 1979, by Paul Schauble ;;; (defun compile-buffer () (if buffer-modified-flag (save-same-file)) (mapc 'register-local-var '(error-scan-buffer error-list e-list)) (if error-list (exit-error-scan-mode)) (let ((compile-command (catenate compiler " " fpathname " " compile-options)) (curbuf current-buffer) (type-buffer-expected mode-identification)) (setq error-scan-buffer (cond (one-error-scan-buffer '|Compilation Errors|) (t (make_atom (catenate current-buffer " Errors"))))) (minibuffer-print compile-command "<>") (and compile-two-windows (< nuwindows 2) (create-new-window-and-stay-here)) (comout-to-buffer error-scan-buffer compile-command) (register-local-var 'error-source-buffer) (setq error-source-buffer curbuf) (setq buffer-uid type-buffer-expected) (cond ((> nuwindows 1)) ;display in other window (compile-local-display ;local display the errors (display-buffer-as-printout) (end-local-displays)) (t (display-compilation-result))) ;local display success/failure (find-buffer-in-window curbuf))) (defun display-compilation-result () (init-local-displays) (local-display-generator (cond ((> number-of-lines-in-buffer 2) (catenate (decimal-rep number-of-lines-in-buffer) " lines of compilation errors were generated.")) (t "No compilation errors were generated."))) (end-local-displays)) (defun set-compiler (comp) (setq compiler (catenate comp " "))) (defun set-compile-options n (setq compile-options "") (do i 1 (1+ i) (> i n) (setq compile-options (catenate compile-options " " (arg i)))))  emacs-completions.lisp 08/20/86 2313.5r w 08/20/86 2245.0 37962 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1981 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; Emacs completion command and underpinnings. ;;; ;;; Richard Mark Soley and Barry Margolin, August 1981 ;;; Modified 19 November 1981 RMSoley for trying other completions on ;;; successive ESC-SPACE's, disallow minibuffer, get rid of table. ;;; Modified 3 October 1982 B. Margolin for not depending upon being ;;; bound to ESC-SPACE. ;;; Modified 19 January 1984 B. Margolin to comment out register-option form, ;;; as it was moved to e_option_defaults_. ;;; (declare (special completion-list cmp:worked cmp:mark cmp:last-completion cmp:allow-ambiguous X Y minibufferp previous-command current-command) (*lexpr cmp:get-completion) (*expr DCTL-position-cursor)) (%include e-macros) (eval-when (eval compile) (defun abort-completion macro (form) '(prog2 (ring-tty-bell) (throw 0 nocomplete))) (defun catch-abort macro (form) `(catch ,@(cdr form) nocomplete))) (or (boundp 'completion-list) (setq completion-list nil)) (setq cmp:worked nil cmp:mark nil cmp:last-completion nil) ;;; (register-option 'cmp:allow-ambiguous 'On) ;moved to e_option_defaults_ (defcom complete-command &numeric-argument (&pass) (cond ((not minibufferp) (command-quit)) (numarg (or (eq previous-command current-command) (setq cmp:worked nil)) (cmp:display-completions)) ((cmp:undo-completion?) (without-saving (wipe-point-mark cmp:mark)) (release-mark cmp:mark) (catch-abort (let ((completion-info (cmp:get-completion (cmp:get-word) cmp:last-completion))) (cond (completion-info (setq cmp:worked t cmp:last-completion (car completion-info)) (insert-string (substr (car completion-info) (cdr completion-info))) (insert-string SPACE)) (t (setq cmp:worked nil cmp:mark nil)))))) (t (catch-abort (let ((completion-info (cmp:get-completion (cmp:get-word)))) (cond (completion-info (setq cmp:worked t cmp:last-completion (car completion-info)) (insert-string (substr (car completion-info) (cdr completion-info))) (insert-char SPACE)))))))) (defun cmp:undo-completion? () (and cmp:worked cmp:mark (eq previous-command 'complete-command))) (defun cmp:set-mark () (and cmp:mark (release-mark cmp:mark)) (setq cmp:mark (set-mark))) (defun cmp:get-word () (cmp:set-mark) (with-mark here (go-to-beginning-of-line) (prog1 (point-mark-to-string here) (go-to-mark here)))) (defun cmp:get-completion lexpr (let ((word (arg 1)) (ignore-until (and (> lexpr 1) (arg 2))) (found nil)) (do ((words (cond (ignore-until (cdr (member ignore-until completion-list))) (t completion-list)) (cdr words))) ((null words) (cond (found found) (t (setq cmp:last-completion nil) (abort-completion)))) (let ((cur-word (car words))) (and (= (index cur-word word) 1) (cond (cmp:allow-ambiguous (return (cons cur-word (1+ (stringlength word))))) (found (abort-completion)) (t (setq found (cons cur-word (1+ (stringlength word))))))))))) (defun cmp:display-completions () (or completion-list (display-error "There are no completions in effect.")) (let ((littleX X) (littleY Y)) (init-local-displays) (local-display-generator-nnl "Current Completions in Effect") (local-display-generator-nnl "") (do ((words completion-list (cdr words))) ((null words)) (local-display-generator-nnl (car words))) (end-local-displays) (DCTL-position-cursor littleX littleY)))  emacs-console-messages.lisp 08/20/86 2313.5r w 08/20/86 2245.0 237006 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; Interactive Message Handling for Multics EMACS ;;; ;;; Coded in a peek of phit 1978.08.07-11 ;;; by Richard S. Lamson ;;; Patterned after similar code by bsg. ;;; Qsends by bsg, 4/15/79, to enable better communications ;;; with persons at MIT-AI. ;;; ;;; Extensively re-written 10-23 January 1980 by Richard Mark Soley ;;; to allow multiple mailboxes, automatic checking for qsend-ok-flag, ;;; really use emacs interrupt system, and clean up this nasty code. ;;; ;;; Modified 7 February 1980 by Richard Mark Soley to create ;;; 'fill-messages option; i.e., whether or not to fill messages. ;;; ;;; Modified 1 March 1980 by R. M. Soley to add hook, take away ;;; auto check on qsend-ok (sniffle - it doesn't really work), fix ;;; bug in filling messages, add short-message-accept option. ;;; ;;; Modified 15 March 1980 for repeat-last-message and send-a-message. ;;; repeat-last-message: locally display last message sent to you. ;;; send-a-message: prompts for name/message, sends to any random, ;;; creating message buffer etc. (by Soley) ;;; ;;; All of Soley's improvements integrated/installed 10/4/80 by BSG ;;; ;;; Modified 19 January 1984 - Barmar - to comment out register-option ;;; forms, as they were moved to e_option_defaults_. ;;; ;;; Modified 31 July 1984 - K. P. Fleming - quick fix to use new message ;;; facility (will be rewritten later). ;;; Modified 5 October 1984 - B. Margolin - quick fixes to KPF's fixes. (%include e-macros) (declare (special known-buflist accept-messages-environment-initp) (*lexpr expand-pathname-relative)) (declare (*expr absolute_pathname_ e_lap_$rtrim display-com-error exch-point-mark expand_pathname_ runoff-fill-region set-emacs-interrupt-handler user_info_$homedir trim-minibuffer-response e_pl1_$retrieve_olc_message)) (defvar message-mode-hook nil) (remprop 'accept-messages 'autoload) (declare (defpl1 e_pl1_$set_message_cleanup "") (defpl1 user_info_$whoami "" (return char (32.)) (return char (32.))) (defpl1 e_pl1_$set_message_handler "" (char (*)) (fixed bin(17.)) (return fixed bin(35.))) (defpl1 e_pl1_$retrieve_message "" (return char (64.) varying) (return char (32.) varying) (return char (2000.) varying)) (defpl1 e_pl1_$send_message "" (char (*)) (char (*)) (char (*)) (return fixed binary (35.))) (defpl1 host_id_$check_id "" (char (*)) (bit (36.)) (bit (36.)) (return fixed bin (32.)) (return fixed bin (35.))) (defpl1 host_id_$symbol "" (fixed bin (32.)) (return char (32.)) (return fixed bin (35.))) (defpl1 qsend$qsend "" (char (*)) (char (*)) (char (*))) (defpl1 absolute_pathname_$add_suffix "" (char (*)) (char (*)) (return char (168.)) (return fixed bin (35.))) (special current-buffer current-buffer-mode conversations last-message-sender-display-variable tty-no-upmotionp last-message-sender last-message-time last-message-mark last-message-error-code fill-prefix short-message-accept message-hook last-message qsend-ok-flag daemon-mbx-dir fill-messages)) ;;; (setq qsend-ok-flag nil ;the default daemon-mbx-dir ">user_dir_dir>Daemon>mailboxes" conversations nil last-message "No last message." last-message-sender nil) ;;; What do these options MEAN??? Well... ;;; ;;; If short-message-accept is t, messages will not be put on the ;;; screen in local display; a message of the form "Messages recieved from ;;; Foo.BAR" will appear under the mode line instead. The default is nil. ;;; ;;; If fill-messages is nil, messages will NOT be filled with ;;; runoff-fill-region. The default is nil (NOT to fill). ;;; ;;; If message-hook is non-null, it will be funcalled with the following ;;; arguments: sender, time, message, mailbox message was received in. ;;; (The last item will be nil if the message was received in the ;;; default mbx). There is more to it, though, so be careful. If the ;;; called function returns nil, NO OTHER ACTION WILL BE PERFORMED ON THE ;;; MESSAGE. So, if you want it in the buffer or somesuch, do it yourself ;;; of call the routine below that does it. ;;; (register-option 'short-message-accept nil) ;default is long ;moved to e_option_defaults_ ;;; (register-option 'fill-messages nil) ;default is to not fill ;moved to e_option_defaults_ ;;; (register-option 'message-hook nil) ;default is normal acceptor ;moved to e_option_defaults_ (defun accept-messages-make-sense-of-mbxname (mbx) (let ((dots (am-find-chars mbx ".")) (greaters (am-find-chars mbx ">"))) (let ((inter (cond ((memq 1 greaters) mbx) ((or (> 0 (length greaters)) (not (= 0 (index mbx "<")))) (expand-pathname-relative mbx "working_dir")) ((= 0 (length dots)) (catenate daemon-mbx-dir ">" mbx)) ((samepnamep (substr mbx (- (stringlength mbx) 3)) ".mbx") (expand-pathname-relative mbx "home_dir")) ((> (length dots) 0) (let ((Name (substr mbx 1 (1- (car dots)))) (Project (substr mbx (1+ (car dots))))) (catenate ">user_dir_dir>" Project ">" Name ">" Name))) (t nil)))) (cond ((null inter) nil) (t (let ((answer (e_lap_$trim (car (absolute_pathname_$add_suffix inter "mbx"))))) (substr answer 1 (- (stringlength answer) 4)))))))) (defun am-find-chars (string char) (am-find-chars_guts string char 0)) (defun am-find-chars_guts (string char before) (let ((where (index string char))) (cond ((= 0 where) nil) (t (cons (+ before where) (am-find-chars_guts (substr string (1+ where)) char where)))))) (defun accept-messages-environment () (cond ((or (not (boundp 'accept-messages-environment-initp)) (not accept-messages-environment-initp)) (e_pl1_$set_message_cleanup) (set-perm-key '^X: 'message-response-command) (set-perm-key '^X/' 'go-to-new-message-buffer) (set-perm-key '^X/` 'send-a-message) (set-perm-key '^X/~ 'repeat-last-message) (setq accept-messages-environment-initp t)))) (defun accept-messages n (cond ((= n 0) (accept-messages-default-mbx)) (t (mapc 'accept-messages-path (listify n))))) (defprop accept-msgs accept-messages expr) ;;; Accept messages on a certain path. (defun accept-messages-path (message-pathname) (let ((pathname-of-mbx (accept-messages-make-sense-of-mbxname message-pathname))) (and (null pathname-of-mbx) (display-error (catenate "Invalid mailbox pathname: " message-pathname))) (accept-messages-environment) (let ((error-code (e_pl1_$set_message_handler pathname-of-mbx (set-emacs-interrupt-handler 'console-messages-interrupt-handler pathname-of-mbx)))) (or (= 0 error-code) (display-com-error error-code (catenate "While accepting messages on " pathname-of-mbx)))))) ;;; Accept messages on default mbx. (defun accept-messages-default-mbx () (accept-messages-environment) (let ((pathname-of-mbx (let ((id (user_info_$whoami))) (let ((proj (e_lap_$rtrim (second id))) (pers (e_lap_$rtrim (first id)))) (catenate ">udd>" proj ">" pers ">" pers))))) (let ((error-code (e_pl1_$set_message_handler pathname-of-mbx (set-emacs-interrupt-handler 'console-message-interrupt-handler nil)))) (or (= 0 error-code) (display-com-error error-code "While accepting messages." ))))) ;;; Lisp side of OLC stuff -- see e_pl1_ olc stuff. ;;; RMSoley 10 April 1980 (declare (defpl1 olcn$olcn2 "" (char (*)) (char (*))) (special olc-messages)) ;;;(register-option 'olc-messages nil) (defvar olc-messages nil) ;made invis. option BSG 10/11/80 (defvar keep-unresponded-buffers-modified nil) (defun console-message-interrupt-handler (intno mbx arg) intno ; compiler gets bummed ; out otherwise (do-forever (setq arg (e_pl1_$retrieve_message)) (and (= 0 (stringlength (car arg))) (return nil)) (console-message-processor (car arg) (cadr arg) (caddr arg) mbx)) (and olc-messages (do-forever (setq arg (e_pl1_$retrieve_olc_message)) (and (= 0 (stringlength (car arg))) (return nil)) (console-message-processor (car arg) (cadr arg) (caddr arg) 'OLC)))) (defun console-message-processor (sender time message mbx) (let ((msender (massage-message-sender sender))) (setq last-message-sender-display-variable (get-message-sender-display sender)) (cond ((or (null message-hook) (and message-hook (funcall message-hook msender time message mbx))) (or (cnsmsg-make-qsend-sense msender time message mbx) (cnsmsg-make-mail-sense msender time message mbx) (process-the-message msender time message mbx)))))) (defun process-the-message (msender time message mbx) (ring-tty-bell) (setq last-message message) (let ((buffer-in-progress current-buffer)) (save-excursion-buffer (go-to-or-create-message-buffer msender) (let ((display-time (massage-message-time time last-message-time))) (insert-message-into-message-buffer display-time time message mbx) (cond ((or tty-no-upmotionp (buffer-on-display-in-window current-buffer) (eq buffer-in-progress current-buffer))) (short-message-accept (minibuffer-print "Message received from " msender ".")) (t (local-display-message display-time message mbx))))))) (defun local-display-message (time message mbx) (init-local-displays) (setq last-message-sender-display-variable (get-message-sender-display last-message-sender)) (let ((display-time (cond ((< (stringlength time) 4) ":") (t (catenate " (" time "):"))))) (local-display-generator-nnl (catenate "Message from " last-message-sender-display-variable display-time)) (cond ((null mbx)) (t (local-display-generator-nnl (catenate "(Received in mailbox " mbx ")")))) (local-display-generator-nnl message)) (end-local-displays)) (defun insert-message-into-message-buffer (display-time time message mbx) (without-modifying (go-to-mark last-message-mark) (set-the-mark) (insert-string display-time) (insert-string ": ") (insert-string message) (if fill-messages (let ((fill-prefix " ")) (without-saving (runoff-fill-region))) (without-saving (runoff-fill-region))) (new-line) (if (not (null mbx)) (insert-string "(Rec'd. in mbx. ") (insert-string mbx) (insert-string ")") (new-line))) (putprop current-buffer "<=" 'message-direction) ;reply necessary (if keep-unresponded-buffers-modified (setq buffer-modified-flag t)) (set-mark-here last-message-mark) (go-to-end-of-buffer) (setq last-message-time time)) (defun cnsmsg-make-mail-sense (msender time message mbx) time ;; goddam lcp (cond ((samepnamep (substr message 1 (stringlength "You have mail")) "You have mail") (ring-tty-bell) (minibuffer-print "You have mail from " msender (cond (mbx (catenate " in mailbox " mbx)) (t "")) ".") t) (t nil))) ;;; ;;; ;;; Character munching functions for message beastie. ;;; (defun massage-message-sender (sender) ; remove "(from) at system_high" (setq sender (massage-message-sender1 sender " (")) (setq sender (massage-message-sender1 sender " at"))) (defun massage-message-sender1 (sender string-to-look-for) ; aux function (prog (position) (or (= 0 (setq position (index sender string-to-look-for))) (setq sender (substr sender 1 (1- position)))) (return sender))) (defun massage-message-time (new-time old-time) ; make shortest unambiguous ; time string (prog (date-string) (cond ((samepnamep (substr new-time 1 14.) (substr old-time 1 14.)) (return "=")) (t (cond ((samepnamep (substr new-time 1 8.) (substr old-time 1 8.)) (setq date-string "")) (t (setq date-string (substr new-time 1 9.)))))) (return (catenate date-string (substr new-time 11. 4))))) (defun get-message-sender-display (sender) (let ((lparen-pos (index sender "("))) (let ((rparen-pos (index (substr sender lparen-pos) ")"))) (if (zerop (* lparen-pos rparen-pos)) (massage-message-sender1 sender ".") else (catenate (substr sender (1+ lparen-pos) (- rparen-pos 2)) " (" (massage-message-sender1 sender ".") ")"))))) ;;; ;;; Create message buffer, based on the name of the sender of the message. ;;; (defun go-to-or-create-message-buffer (sender) (prog (person project qspr) (and (setq qspr (cnsmsg-qsend-parse-to sender)) (let ((hidr (host_id_$check_id (cadr qspr) 0 0))) (cond ((= 0 (cadr hidr)) (putprop (setq sender (car qspr)) (e_lap_$trim (car (host_id_$symbol (car hidr)))) 'net-site)) (t (display-com-error (cadr hidr) (cadr qspr)))))) (cond ((setq project (get (setq person (make_atom sender)) 'net-site)) (setq project (cons 'net-host project))) (t (setq person (massage-message-sender1 sender ".")) (or (= (stringlength person) (stringlength sender)) (setq project (substr sender (+ 2 (stringlength person))))))) (go-to-or-create-buffer (implode (append (explodec "Messages from ") (explodec person)))) (setq last-message-sender person) (go-to-end-of-buffer) (cond ((empty-buffer-p current-buffer) ;S.O.B. may have killed ; the buffer, eh!? (cond ((not project) (display-error-noabort "User name must include project. " sender) (return nil))) (putprop current-buffer person 'message-person) (putprop current-buffer project 'message-project) (putprop current-buffer "" 'message-direction) (register-local-var 'last-message-time) (register-local-var 'last-message-error-code) (register-local-var 'last-message-mark) (setq last-message-time "01/01/01 0000.0 GMT Tue" last-message-error-code 0) (setq conversations (cons last-message-sender conversations)) (setq current-buffer-mode 'Message) (set-key 'CR 'respond-from-buffer) (without-modifying (insert-string current-buffer) (insert-string ":") (new-line) (new-line)) (setq last-message-mark (set-mark)) (and message-mode-hook (funcall message-mode-hook)))) (return t))) (defun message-buffer-prompter () (let ((completion-list conversations)) (let ((ans (trim-minibuffer-response (cond (last-message-sender (catenate "Messages to/from (" last-message-sender "): ")) ('else "Messages to/from: ")) NL))) (cond ((not (nullstringp ans)) ans) (last-message-sender last-message-sender) ('else (display-error "No message buffers.")))))) ;;; ^X-' -- prompt for message buffer name. (defun go-to-new-message-buffer () (cond (numarg (list-message-buffers)) (t (let ((message-name (message-buffer-prompter)) (prev current-buffer)) (go-to-or-create-message-buffer message-name) (select-buffer-window current-buffer 4) (setq previous-buffer prev))))) (defun list-message-buffers () (let ((msg-buffers-info nil) (original-buffer current-buffer) (previous-buffer previous-buffer)) (mapc (function (lambda (bufname) (go-to-buffer bufname) (cond ((eq current-buffer-mode 'Message) (setq msg-buffers-info (cons (list (get bufname 'message-person) (get bufname 'message-direction) (get bufname 'message-project)) msg-buffers-info)))))) known-buflist) (go-to-or-create-buffer original-buffer) (and (null msg-buffers-info) (display-error "No message buffers.")) (init-local-displays) (mapc 'local-display-generator-nnl '("Listing of Current Message Buffers" "" "Direction Person" "")) (mapc '(lambda (info) (local-display-generator-nnl (catenate " " (cadr info) TAB TAB (car info) (cond ((atom (caddr info)) (catenate "." (caddr info))) (t "")) (cond ((let ((site (get (make_atom (car info)) 'net-site))) (and site (catenate " @ " site)))) (t ""))))) msg-buffers-info) (local-display-generator-nnl "") (end-local-displays))) ;;; ;;; ;;; Message sending commands. ;;; Send line in message buffer to other end of conversation. ;;; (defun respond-from-buffer () ; ^M in Message mode. (prog (error-code) (cond ((not (atom (get current-buffer 'message-project))) (cnsmsg-qsend (cdr (get current-buffer 'message-project)) (get current-buffer 'message-person) (curline-as-string-nnl)) (go send-done))) (cond ((= last-message-error-code (setq error-code (e_pl1_$send_message (get current-buffer 'message-person) (get current-buffer 'message-project) (curline-as-string-nnl))))) (t (setq last-message-error-code error-code) (cond ((= 0 error-code) (display-error-noabort "Message sent successfully to " (get current-buffer 'message-person) "." (get current-buffer 'message-project))) (t (display-com-error-noabort error-code (get current-buffer 'message-person) "." (get current-buffer 'message-project)))))) send-done) (without-modifying (set-the-mark) (go-to-beginning-of-line) (insert-string "Reply: ") (exch-point-mark der-wahrer-mark) (and fill-messages ((lambda (fill-prefix) (setq fill-prefix fill-prefix) (without-saving (runoff-fill-region))) "-> "))) (new-line) (putprop current-buffer "=>" 'message-direction) (set-mark-here last-message-mark) (setq buffer-modified-flag nil)) ; rather than fighting it. (defun message-response-command () ; ^X: strikes again. (cond (numarg (cond (last-message-sender (go-to-or-create-message-buffer last-message-sender)) (t (display-error "No message buffers.")))) (t (cond (last-message-sender ((lambda (message) (save-excursion-buffer (cond ((not (= 0 (stringlength message))) (go-to-or-create-message-buffer last-message-sender) (go-to-mark last-message-mark) (without-modifying (insert-string message) (new-line) (backward-char)) (respond-from-buffer))))) (minibuf-response (catenate "To " last-message-sender ": ") NL))) (t (display-error "No one to respond to.")))))) (defun curline-as-string-nnl () ; remove extra newline 'cause ((lambda (str) ; send_message won't. (substr str 1 (1- (stringlength str)))) (curline-as-string))) ;;; ;;; ;;; Qsend cruft 4/15/79 ;;; (defun cnsmsg-make-qsend-sense (sender time msg mbx) (prog (tox hdr) (or (samepnamep (substr sender 1 (stringlength "Network_Server")) "Network_Server") (return nil)) (cond ((samepnamep (substr msg 1 (stringlength "You have mail")) "You have mail") (ring-tty-bell) (display-error-noabort "You have network mail.") (return t))) ;Don't process any further. (setq tox (index msg "To:")) (cond ((= tox 0) (setq tox (index msg "to:")) (cond ((= tox 0) (setq tox (index msg "TO:")) (and (= tox 0) (return nil)))))) ;no sense made. (setq hdr (e_lap_$trim (substr msg 1 (1- tox))) msg (substr msg tox)) (and (member (substr hdr 1 5) '("From:" "FROM:" "from:")) (setq hdr (e_lap_$trim (substr hdr 6)))) (setq hdr (cnsmsg-qsend-parse-to hdr)) (or hdr (return nil)) (console-message-processor (car hdr) time msg mbx) (return t))) (defun qsend-ok () (setq qsend-ok-flag t)) (defun cnsmsg-qsend (host person msg) (if (not qsend-ok-flag) (display-error "You have not the right to send interactive net mail.")) (minibuffer-print "Qsending to " person " at " host ".") (qsend$qsend host person msg) (minibuffer-clear)) (defun cnsmsg-qsend-parse-to (x) (prog (sender site tox) (or (= 0 (index x TAB)) (setq x (maknam (mapcar '(lambda (y)(cond ((= y 11) 40)(t y))) x)))) (setq tox (index x "@")) (cond ((> tox 0) (setq sender (e_lap_$trim (substr x 1 (1- tox))) x (e_lap_$trim (substr x (1+ tox))))) (t (setq tox (index x " at ")) (and (= tox 0)(setq tox (index x " AT "))) (and (= tox 0)(setq tox (index x " At "))) (and (= tox 0)(setq tox (index x " -at"))) (and (= tox 0)(return nil)) (setq sender (e_lap_$trim (substr x 1 (1- tox))) x (e_lap_$trim (substr x (+ tox 4)))))) (setq tox (index x " ")) (and (= tox 0)(setq tox (1+ (stringlength x)))) (setq site (substr x 1 (1- tox))) (setq site (make_atom site) sender (make_atom sender)) (putprop sender site 'net-site) (return (list sender site)))) ;;; ;;; More additions!!! ;;; (defcom repeat-last-message &doc "Repeats via local display the last message received." (and (null last-message-sender) (display-error "No last message.")) (local-display-message last-message-time last-message nil)) (defcom send-a-message &doc "Prompts for a name and message, and sets up a message buffer for that recipient and sends the message without leaving the current buffer." (save-excursion-buffer (and (eq (go-to-new-message-buffer) 'couldnt-get-it) (command-quit)) (insert-string (minibuf-response (catenate "To " (get current-buffer 'message-person) ": ") NL)) (respond-from-buffer))) (defun message-sender-internal (to message) (save-excursion-buffer (cond ((not (= 0 (stringlength message))) (go-to-or-create-message-buffer to) (go-to-mark last-message-mark) (without-modifying (insert-string message) (new-line) (backward-char)) (respond-from-buffer))))) ;;; ;;; Soley's pathname hack .. at sometime, may make standard, but ;;; for now, leave in console-messages.... -BSG ;;; ;;; Pathname expander for start up emacs ;;; RMSoley 10 January 1980 ;;; 5 March 1980 to lexprize epr, add default_working_dir key ;;; 13 March 1980 for zero arguments to epr (path = ""), ;;; remove non-working dwdir (since dwd doesn't ;;; return right thing) ;;; ;;; expand-pathname-relative is a way to expand a path relative to anywhere ;;; A bit better than e_pl1_$pathname_util, since it accepts ", relative is ignored (path taken to be absolute) ;;; If relative is missing, assumes working directory ;;; If path & relative are both missing, returns wdir. ;;; If path = "" and relative is non-null, returns the directory without ;;; a trailing ">" (defun expand-pathname-relative lexpr (and (> lexpr 2) (display-error "expand-pathname-relative: " "Wrong number of arguments supplied.")) (let ((path (cond ((< lexpr 1) "") (t (arg 1)))) (relative (cond ((< lexpr 2) nil) (t (arg 2))))) (and (not (= 0 (caddr (expand_pathname_ relative)))) (display-error "expand-pathname-relative: Error in syntax of relative.")) (and (not (= 0 (caddr (expand_pathname_ path)))) (display-error "expand-pathname-relative: Error in syntax of pathname.")) (let ((rel (e_lap_$rtrim (cond ((null relative) (absolute_pathname_ "")) ((nullstringp relative) (absolute_pathname_ "")) ((samepnamep relative "working_dir") (absolute_pathname_ "")) ((samepnamep relative "home_dir") (user_info_$homedir)) ;used user_info BSG 10/4/80 ((samepnamep relative "process_dir") process-dir) ;used vbl BSG 10/4/80 (t (expand-pathname-relative relative "working_dir")))))) (cond ((samepnamep (substr path 1 1) ">") path) ;absolute ((= lexpr 0) rel) ;return wdir ((null path) rel) ((nullstringp path) rel) (t (expand-pathname-fix-ups (catenate rel ;really expand ">" path))))))) ;;; The guts. Takes care of those nasty less thans. ;;; ">udd>fooudd>foo> ">udd>bar" (defun expand-pathname-fix-ups (path) (let ((where-up (index path "<"))) (cond ((zerop where-up) path) (t (expand-pathname-fix-ups (catenate (substr path 1 (- where-up (index (implode (reverse (explodec (substr path 1 (- where-up 2))))) ">") 1)) (substr path (1+ where-up))))))))  emacs-dir-edit.lisp 08/20/86 2313.5r w 08/20/86 2245.0 70326 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; Directory editor ;;; Archy, '78, extracted from e_macops_ 8/16/79 by BSG ;;; Modified: 12/8/83 - B. Margolin - don't allow d/u when on ;;; blank line at the end. Also modernized some code ;;; (defun->defcom, lambda->let, comout-get-output). ;;; (%include e-macros) (declare (special dired-segs-to-delete dired-buffer-to-go-back-to dired-dir) (*expr absolute_pathname_ convert_status_code_ error_table_ expand_pathname_ go-to-hpos minibuffer-remark)) (declare (defpl1 cu_$level_get "" (return fixed bin))) (defprop trim e_lap_$trim expr) (declare (defpl1 hcs_$get_user_effmode "" (char (*))(char (*))(char (*))(fixed bin)(return fixed bin)(return fixed bin (35.)))) (defcom edit-dir &numeric-argument (&pass) &arguments ((dir &default &eval (if numarg (minibuf-response "Directory: " NL) else ""))) (setq dir (absolute_pathname_ dir)) (if (not (zerop (cadr dir))) (display-com-error (cadr dir) "") else (setq dir (trim (car dir)))) (let ((access-ok (dired-access-check dir))) (if (not access-ok) (display-error-noabort "Warning: Modify access on " dir " lacking."))) (go-to-or-create-buffer 'Dir/ Edit) (setq buffer-modified-flag t) (comout-get-output "list -pn" dir "-mode -name -primary -length -no_header") (setq fpathname dir) ;for user (do-forever (go-to-beginning-of-line) (insert-string TAB) (if (lastlinep)(stop-doing)) (next-line)) (go-to-beginning-of-buffer) (dired-mode) (setq dired-segs-to-delete nil) (setq dired-buffer-to-go-back-to previous-buffer) (setq dired-dir dir) (setq read-only-flag t buffer-modified-flag nil) (select-buffer-find-window current-buffer 'cursize)) (defun dired-mode () (setq current-buffer-mode 'DIRED) (register-local-var 'dired-segs-to-delete) (register-local-var 'dired-buffer-to-go-back-to) (register-local-var 'dired-dir) (set-key 'D 'dired-mark-for-deletion) (set-key 'd 'dired-mark-for-deletion) (set-key 'n 'next-line-command) (set-key 'p 'prev-line-command) (set-key 'N 'next-line-command) (set-key 'P 'prev-line-command) (set-key 'R 'dired-rename) (set-key 'r 'dired-rename) (set-key 'U 'dired-unmark-for-deletion) (set-key 'u 'dired-unmark-for-deletion) (set-key 'E 'dired-examine-file) (set-key 'e 'dired-examine-file) (set-key 'Q 'dired-quit) (set-key 'q 'dired-quit) (set-key '^X^Q 'dired-quit) (set-key '^XB 'dired-quit-and-go-buffer)) (defcom dired-mark-for-deletion (if (lastlinep) (command-quit)) ;Last line is empty (go-to-beginning-of-line) (if-at "D" else (without-modifying (insert-string "D")) (setq dired-segs-to-delete (cons (dired-get-filename) dired-segs-to-delete))) (next-line)) (defcom dired-unmark-for-deletion (if (lastlinep) (command-quit)) ;Last line is empty (go-to-beginning-of-line) (if-at "D" (without-modifying (delete-char)) (setq dired-segs-to-delete (delete (dired-get-filename) dired-segs-to-delete))) (next-line)) (defcom dired-examine-file (let ((dname dired-dir) (ename (dired-get-filename))) (find-buffer-in-window '|Dired Examine|) (set-key '^X^Q 'dired-exit-examine-buffer) (read-in-file (catenate dname ">" ename)) (minibuffer-remark "Use ^X^Q to return to DIRED"))) (defcom dired-exit-examine-buffer (set-buffer-self-destruct current-buffer) (find-buffer-in-window '|Dir Edit|)) (defcom dired-quit (cond ((null dired-segs-to-delete) (set-buffer-self-destruct current-buffer) (select-buffer-window dired-buffer-to-go-back-to nil) (setq previous-buffer current-buffer)) (t (dired-m-access-check) ;aborts if access lacking (init-local-displays) (local-display-generator-nnl "Files to delete:") (local-display-generator-nnl "") (mapc 'local-display-generator-nnl dired-segs-to-delete) (local-display-generator "---------------") (if (yesp "Deleting the above listed files, OK? ") (dired-delete-files dired-segs-to-delete) (set-buffer-self-destruct current-buffer) (select-buffer-window dired-buffer-to-go-back-to nil) (setq previous-buffer current-buffer) else (go-to-beginning-of-buffer))))) (defcom dired-quit-and-go-buffer &arguments ((buffer &symbol &prompt "Select Buffer: " &default &eval dired-buffer-to-go-back-to)) (set-buffer-self-destruct current-buffer) (let ((prevbuf dired-buffer-to-go-back-to)) (select-buffer-window buffer nil) (setq previous-buffer prevbuf))) (defun dired-get-filename () (go-to-end-of-line) (skip-back-whitespace) (with-mark m (go-to-beginning-of-line) (go-to-hpos 20.) (prog1 (point-mark-to-string m) (go-to-beginning-of-line)))) (declare (defpl1 delete_$path "" (char (*))(char (*))(bit (6))(char (*)) (return fixed bin (35.)))) (defun dired-delete-files (seg-list) ;bsg 5/3/79 for delete_ (let ((err-list nil) (code)) (mapc '(lambda (file) (setq code (delete_$path dired-dir file (lsh 44 30.) "emacs")) (or (= 0 code)(setq err-list (cons (cons file code) err-list)))) seg-list) (if (not (null err-list)) (init-local-displays) (mapc 'local-display-generator-nnl '("Errors encountered during deletions:" "These files not deleted:" "")) (mapc '(lambda (x)(local-display-generator-nnl (catenate (e_lap_$trim (cadr (convert_status_code_ (cdr x)))) " " (car x)))) err-list) (end-local-displays)))) (defun dired-access-check (dir) (let ((epr (expand_pathname_ dir))) (let ((hcssr (hcs_$get_user_effmode (car epr)(cadr epr) "" (cu_$level_get)))) (if (not (zerop (cadr hcssr))) (if (= (cadr hcssr)(error_table_ 'incorrect_access)) (rplaca hcssr 77) (display-error-noabort "Warning: cannot check access on " dir ".") else (display-com-error (cadr hcssr) dir))) (let ((mode (car hcssr))) (if (zerop (boole 1 mode 10)) (display-error "dired: Status permission on " dir " lacking.")) (not (zerop (boole 1 2 mode))))))) ;; 11/24/79 BSG (declare (defpl1 hcs_$chname_file "" (char (*))(char (*))(char (*))(char (*))(return fixed bin (35.)))) (defcom dired-rename &prologue dired-m-access-check &arguments ((new &string &prompt &eval (catenate "New name for " (dired-get-filename) ": "))) (let ((old (dired-get-filename))) (let ((code (hcs_$chname_file dired-dir old old new))) (or (zerop code) (display-com-error code new)) (go-to-hpos 20.) (without-modifying (without-saving (kill-to-end-of-line)) (insert-string new) (go-to-beginning-of-line))))) (defun dired-m-access-check () (if (not (dired-access-check dired-dir)) (display-error "Modify access lacking on " dired-dir)))  emacs-extended-searches.lisp 08/20/86 2313.5r w 08/20/86 2245.0 362871 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * 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 ;;; Gratuitous marks 11/06/81 by Barmar ;;; JSL's regular expressions and other stuff, 30 August 1982 Barmar ;;; Added ^_ (self-documentation) response to searches, ;;; and moved query-replace out to e_macops_. 31 August 1982 Barmar ;;; (%include backquote) ;;; 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 (defun chars-left-in-line macro (x) `(- curlinel curpointpos 1)) (defun save-excursion-on-search-failure macro (x) (let ((dummy (gensym)) (forms (cdr x)) (mark (gensym))) `(let ((,dummy nil) (,mark nil)) (unwind-protect (progn (setq ,mark (set-mark)) (setq ,dummy (progn . ,forms))) (if ,mark (if (null ,dummy) (go-to-mark ,mark)) (release-mark ,mark)))))) (%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 ITS-string-search-set-mark home-mark isearch-exit-char MCS-editing-characters rubout-character) (*expr minibuffer-rubout search:maybe-push-default set-permanent-key mark-at-current-point-p exch-point-mark forward-search-bounded go-to-line-point reverse-search-bounded search:announce-partial-failure search:last-string search:numeric-prompt search:prompt search:rotate-ring) (*lexpr gratuitous-mark-setter)) ;;; Command intended for use in start_up.emacs. It sets permanent definitions ;;; of ^S and ^R to specified type of search. Note that when an unrecognized ;;; type is supplied it merely prints an error without using command-quit. (defcom set-search-mode &args ((search-type &symbol &prompt "Search mode: " &completions '(string character ITS-string its-string incremental regexp regular-expression default))) (cond ((memq search-type '(default string)) (set-permanent-key '^S 'string-search) (set-permanent-key '^R 'reverse-string-search)) ((memq search-type '(character)) (set-permanent-key '^S 'character-search) (set-permanent-key '^R 'reverse-character-search)) ((memq search-type '(ITS-string its-string)) (set-permanent-key '^S 'ITS-string-search) (set-permanent-key '^R 'reverse-ITS-string-search)) ((memq search-type '(regular-expression regexp)) (set-permanent-key '^S 'regexp-search) (set-permanent-key '^R 'reverse-regexp-search)) ((eq search-type 'incremental) (set-permanent-key '^S 'incremental-search) (set-permanent-key '^R 'reverse-incremental-search)) (t (display-error-noabort "Unknown search mode: " search-type) (ring-tty-bell)))) ;;; ;;; ;;; Character search commands (from ITS) ;;; GMP, 08/31/78 ;;; ;;; Character search command (defcom character-search (let ((search-forward t)) (character-search-))) ;;; Reverse character search command (defcom reverse-character-search (let ((search-forward nil)) (character-search-))) ;;; Subr that actually does character search (defun character-search- () (with-mark home-mark (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 'string) (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)) (gratuitous-mark-setter home-mark) (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 (and (search-for-default-string) (gratuitous-mark-setter home-mark)) (stop-doing))) ((and (= ch #^S) (not quoted)) ; look for default (and (search-for-default-string) (gratuitous-mark-setter home-mark)) (stop-doing)) ((and (= ch #^_) (not quoted)) (character-search-documentation)) (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) 'string) (if result (gratuitous-mark-setter home-mark) (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))) (or result (display-error "Search fails."))))) (defun character-search-documentation () (init-local-displays) (mapc 'local-display-generator-nnl '("Character search options:" "" "^S Search for default search string" "^R If searching forward, reverse direction, otherwise" " Search back for default string" "^A ITS string search" "CR, LF Search for next newline" "^G Abort search" "^Q Reads a character and searches for it" "^_ Print this description" "anything else" " searches for the character" "" "Type any character to remove this display.")) (end-local-displays) (redisplay) (get-char)) ;;; ;;; ;;; 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 (defcom ITS-string-search (let ((search-forward t)) (ITS-string-search-))) ;;; Reverse ITS string search command (defcom reverse-ITS-string-search (let ((search-forward nil)) (ITS-string-search-))) ;;; Subr to perform ITS string search (defun ITS-string-search- () (with-mark home-mark (setq last-char-was-^S nil search-string "" search-from-end nil) (ITS-string-search-announce) (let ((ITS-string-search-set-mark nil) (rubout-character (cadr MCS-editing-characters))) (do-forever (if (eq (ITS-string-search-process-char (get-char)) 'done) (stop-doing)))) (if (not macro-execution-in-progress) (minibuffer-print-noclear " Done.")))) ;;; Announce direction, type, and search string (defun ITS-string-search-announce () (if (not macro-execution-in-progress) (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) (prog1 (cond ((or (= ch 177) (= ch rubout-character)) (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) (if (not macro-execution-in-progress) (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:rotate-ring)) (setq last-search-string (search:last-string)) ; 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 (if (not ITS-string-search-set-mark) (setq ITS-string-search-set-mark t) ;remember that we did it. (gratuitous-mark-setter home-mark)) (or macro-execution-in-progress (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 'string) (if (= ch #^S) 'continue ; keep looking else 'done))) ; ESC, search terminates ((= ch #^_) (ITS-string-search-documentation) 'continue) ((and (or (< ch 40) (> ch 177)) ; unknown control (not (or (= ch #^M) (= ch #^I)))) (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 (or macro-execution-in-progress (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 macro-execution-in-progress) (minibuffer-print-noclear " Done.")) ; If displaying, output message. (command-quit)) (defun ITS-string-search-documentation () (init-local-displays) (mapc 'local-display-generator-nnl `("ITS string search options:" "" ,(catenate "DEL, " (ItoC rubout-character) " Remove last character from search string") "ESC Exit search, possibly searching first if previous" " character was not ^S" "^S Search for next occurrence of search string or default" "^R Reverse search direction" "^B Toggle ""search from beginning of buffer""" "^E Toggle ""search from end of buffer""" "^Y Add default search string to search string" "^D Rotate default search string ring, and makes it the" " search string" "CR Add newline to search string" "^G Abort search and return to starting point" "^Q Reads a character and adds it to search string" "LF Nothing" "^L Redisplay" "^_ Print this description" "printing characters, TAB, ^I" " Adds to the search string, and searches" "" "Type any character to remove this display.")) (end-local-displays) (redisplay) (get-char)) ;;; ;;; ;;; Incremental Search ;;; ;;; Incremental search command (defcom incremental-search (let ((search-forward t)) (incremental-search-))) ;;; Reverse Incremental search command (defcom 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) (let ((isearch-exit-char nil) (rubout-character (cadr MCS-editing-characters))) (with-mark home-mark (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 (gratuitous-mark-setter home-mark)) (search:maybe-push-default search-string 'string)) (mapc '(lambda (x) (release-mark (cdr x))) isearch-stack) (if (not macro-execution-in-progress) (minibuffer-print-noclear " Done.") (redisplay)) (and isearch-exit-char (process-char isearch-exit-char)))) ;;; Process a single character (defun isearch-process-char (ch) (cond ((or (= ch 177) (= ch rubout-character)) ;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 (or macro-execution-in-progress (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) (or macro-execution-in-progress (minibuffer-clear)) (incremental-search-announce))) (if (not (nullstringp search-string)) (search:maybe-push-default search-string 'string) (setq search-string "") else (or macro-execution-in-progress (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 (or macro-execution-in-progress (minibuffer-clear)) (incremental-search-failure) (incremental-search-announce))) else ;Movin' left... (if (reverse-search nss) (setq search-string nss) 'continue else (or macro-execution-in-progress (minibuffer-clear)) (incremental-search-failure) (incremental-search-announce))))) ((= ch #^[) ; all done 'done) ((= ch #^J) 'continue) ((= ch #^M) (isearch-search-single NL)) ((= ch #^_) (incremental-search-documentation)) ((and (or (< ch 40) (> ch 177)) ;random control char, exits (not (= ch #^I))) ;search, then gets executed (setq isearch-exit-char ch) 'done) (t ;normal char, search for it (isearch-search-single (ascii ch))))) ;;; Delete a character from search string (defun isearch-rubout () (cond ((null (cdr 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))) ;;; Delete a character from search string (defun isearch-rubout () (cond ((null (cdr 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 (CtoI (substr search-string sl 1)))) (setq search-string (substr search-string 1 (1- sl))) (if (and (not tty-no-upmotionp) (not macro-execution-in-progress)) (minibuffer-rubout (cond ((and (> lastch 37) (< lastch 177)) ;printing char 1) (display-ctlchar-with-^ 2) (t 4))))))) ;pretty kludgey, eh? ;;; Search for a single character incrementally (defun isearch-search-single (ch) (if (and (not tty-no-upmotionp) ;put in buffer if needed (not macro-execution-in-progress)) (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 (not macro-execution-in-progress) (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))) (defun incremental-search-documentation () (init-local-displays) (mapc 'local-display-generator-nnl `("Incremental search options:" "" ,(catenate "DEL, " (ItoC rubout-character) " Undo last character") "ESC Exit search" "^S Search for next occurrence of search string or default" "^R Reverse search for next occurrence" "CR Add newline to search string" "^G Abort search and return to starting point" "^Q Reads a character, adds it to search string, and searches" "LF Nothing" "^L Redisplay" "^_ Print this description" "printing characters, TAB, ^I" " Adds to the search string, and searches" "other control characters" " Ends search, executes as an Emacs command" "" "Type any character to remove this display.")) (end-local-displays) (redisplay) (get-char)) ;;; ;;; Global Regular Expression Print ;;; (defcom global-regexp-print &arguments ((string &string &default &eval (regexp:prompt "Global regexp print"))) (setq string (regexp:compile-and-save string)) (let ((foundflag) (tempmark)) (save-excursion (go-to-beginning-of-buffer) (do-forever (setq tempmark (regexp:search string)) (if (not tempmark) (stop-doing)) (if (not foundflag) (setq foundflag t) (init-local-displays)) (if (not (mark-on-current-line-p tempmark)) (exch-point-mark tempmark) (do-forever (local-display-current-line) (next-line) (if (mark-on-current-line-p tempmark) (stop-doing)))) (release-mark tempmark) (local-display-current-line) (if (lastlinep) (stop-doing)) (next-line))) (if foundflag (end-local-displays) else (search-failure-annunciator)))) ;;; These commands autoload from emacs-extended-searches ;;; ;;; Regular Expression searches in Lisp. ;;; J. Spencer Love, 7 May 1982 ;;; (defcom-synonym regexp-search-command regexp-search) (defcom regexp-search &cleanup regexp:command-cleanup &prologue regexp:command-prologue &epilogue regexp:command-epilogue &inverse reverse-regexp-search &negative-function reverse-regexp-search &numeric-argument &repeat &args ((regexp &default &eval (regexp:prompt "Regexp search"))) (setq regexp (regexp:compile-and-save regexp)) (save-excursion-on-search-failure (regexp:search regexp))) (defun regexp-search-in-line (regexp) (setq regexp (regexp:compile-and-save regexp)) (save-excursion-on-search-failure (regexp:match regexp (chars-left-in-line) nil))) (defcom reverse-regexp-search &cleanup regexp:command-cleanup &prologue regexp:command-prologue &epilogue regexp:command-epilogue &inverse regexp-search &negative-function regexp-search &numeric-argument &repeat &args ((regexp &default &eval (regexp:prompt "Reverse regexp search"))) (setq regexp (regexp:reverse (regexp:compile-and-save regexp))) (save-excursion-on-search-failure (regexp:reverse-search regexp))) (defun reverse-regexp-search-in-line (regexp) (setq regexp (regexp:reverse (regexp:compile-and-save regexp))) (save-excursion-on-search-failure (regexp:reverse-match regexp curpointpos nil))) (defun regexp:command-prologue () (list (or numarg 1) 0 (set-mark))) (defun regexp:command-cleanup (prologue-info) (if prologue-info (if (cdddr prologue-info) (release-mark (cdddr prologue-info))) (if (caddr prologue-info) (go-to-mark (caddr prologue-info)) (release-mark (caddr prologue-info))))) (defun regexp:command-epilogue (prologue-info result last-time) (cond (result (rplaca (cdr prologue-info) (1+ (cadr prologue-info))) (and (cdddr prologue-info) (release-mark (cdddr prologue-info))) (or last-time (rplacd (cddr prologue-info) result))) ((null (cdddr prologue-info)) (search-failure-annunciator)) (t (setq result (cdddr prologue-info) last-time t) (save-excursion (go-to-mark (caddr prologue-info)) (set-the-mark)))) (if last-time (exch-point-mark result) (set-the-mark) (exch-point-mark result) (release-mark result) (release-mark (caddr prologue-info)) (rplaca (cddr prologue-info) nil) ; For cleanup (if (< (cadr prologue-info) (car prologue-info)) (search:announce-partial-failure (cadr prologue-info))))) (defun regexp:prompt (prompt) (setq prompt (search:prompt (search:numeric-prompt prompt))) (regexp:compile-and-save prompt) (search:maybe-push-default prompt 'regexp)) ;;; ;;; Translating regular expressions to list form. ;;; ;;; The format of a compiled regular expression is: ;;; ;;; ((original-string . reversed-token-list) . token-list) ;;; ;;; The original-string is the argument given to compile-regexp. ;;; The reversed-token-list is initially nil, and is filled in ;;; by reverse-regexp, which returns the car of the compiled regexp. ;;; ;;; Each token in the token list is of the form: ;;; ;;; (tag . value) ;;; ;;; CONSTRUCT TAG VALUE ;;; ^ begins-string nil ;;; $ ends-string nil ;;; string constant string from (maknam) ;;; .* star nil ;;; * star preceding char from (ascii) ;;; . dots count of contiguous dots ;;; (defvar regexp:saved-compiled-string nil) (defun regexp:compile-and-save (regexp) (cond ((nullstringp regexp) (if regexp:saved-compiled-string regexp:saved-compiled-string else (display-error "No saved regular expression."))) ((samepnamep regexp (caar regexp:saved-compiled-string)) regexp:saved-compiled-string) (t (setq regexp:saved-compiled-string (regexp:compile regexp))))) (defun regexp:reverse (regexp) (cond ((cdar regexp) (car regexp)) ((null (cdr regexp)) (car regexp)) ((< (length (cdr regexp)) 2) (rplacd (car regexp) (cdr regexp))) (t (rplacd (car regexp) (reverse (cdr regexp)))))) ;;; Here follow macros for lexically inserting code into compile-regexp, ;;; which follows them. In some cases the macros are used in multiple ;;; places, but others are split out to make the code clearer and keep ;;; the indentation reasonable for 80 column screens. (defun regexp-emit macro (x) ; A conventional PUSH macro (let ((tag (cadr x)) (value (caddr x))) `(rplacd compiled-regexp (cons (cons ,tag ,value) (cdr compiled-regexp))))) (defun regexp-emit-constant macro (x) ; Construct a constant string (let ((delimiter (cadr x))) ; to be PUSHed, if present. `(cond ((null constant-begins)) ((eq constant-begins ,delimiter) (setq constant-begins nil)) (t (do ((cursor constant-begins (cdr cursor))) ((eq (cdr cursor) ,delimiter) (rplacd cursor nil))) (regexp-emit 'constant (maknam constant-begins)) (setq constant-begins nil))))) (defun regexp-emit-dots macro (x) ; Count the contiguous dots (let ((delimiter (cadr x))) ; and PUSH a token for them. `(cond ((null dots-begin)) ((eq dots-begin ,delimiter) (setq dots-begin nil)) (t (do ((count 1 (1+ count)) (cursor dots-begin (cdr cursor))) ((eq (cdr cursor) ,delimiter) (regexp-emit 'dots count))) (setq dots-begin nil))))) (defun regexp-mark-constant macro (x) ; Note the beginning of a `(progn ; constant string. (regexp-emit-dots this-one) (if (null constant-begins) (setq constant-begins this-one)))) (defun regexp:compile (regexp-string) (let ((regexp-list (exploden regexp-string)) (compiled-regexp (list (list regexp-string)))) (if (= (car regexp-list) #/^) (regexp-emit 'begins-line nil) (setq regexp-list (cdr regexp-list))) (do ((backslash-at 'backslash-at) (ch (car regexp-list) (cadr this-one)) (constant-begins) (dots-begin) (escape) (escape-patch) (last-one nil this-one) (star-at) (this-one regexp-list (cdr this-one))) ((null this-one) (if escape (display-error "Invalid use of ""\c"" at end of regular expression.")) (regexp-emit-constant nil) (regexp-emit-dots nil) (rplacd compiled-regexp (nreverse (cdr compiled-regexp)))) (cond (escape (setq escape nil) (regexp-mark-constant)) ((= ch #/\) (setq backslash-at this-one escape-patch last-one) (regexp-mark-constant)) ((and (= ch #/c) (eq backslash-at last-one)) (setq escape t) (if (eq constant-begins backslash-at) (setq constant-begins nil) else (rplacd escape-patch (cdr this-one)))) ((= ch #/.) (regexp-emit-constant this-one) (if (null dots-begin) (setq dots-begin this-one)) (rplaca this-one nil)) ((= ch #/*) (if (eq last-one star-at) (display-error "Invalid use of ""*"" in regular expression.")) (regexp-emit-constant last-one) (regexp-emit-dots last-one) (regexp-emit 'star (and (car last-one) (ascii (car last-one)))) (setq star-at this-one)) ((and (= ch #/$) (null (cdr this-one))) (regexp-emit-constant this-one) (regexp-emit-dots this-one) (regexp-emit 'ends-line nil)) (t (regexp-mark-constant)))))) ;;; ;;; Regular Expression match routines. ;;; ;;; Here follow a number of pairs of action routines. These routines are ;;; in the form of macros for lexical insertion of code into the routines ;;; regexp: search and match, forward and reverse, which are the recursive ;;; search routines which actually perform regular expression ;;; matching. The macro pairs are for forward and reverse matching ;;; respectively, and are grouped together for ease of maintenance. ;;; (declare (special curline curstuff)) (defun regexp-constant-floating macro (x) `(do ((backup (1- (stringlength (cdar regexp)))) (mark) (string (cdar regexp))) ((not (forward-search string)) nil) (setq mark (regexp:match regexp 0 nil)) (if mark (exch-point-mark mark) (do-times (1+ backup) (backward-char)) (exch-point-mark mark) (return mark)) (do-times backup (backward-char)))) (defun reverse-regexp-constant-floating macro (x) `(do ((backup (1- (stringlength (cdar reverse-regexp)))) (mark) (string (cdar reverse-regexp))) ((not (reverse-search string)) nil) (setq mark (regexp:reverse-match reverse-regexp 0 nil)) (if mark (exch-point-mark mark) (do-times (1+ backup) (forward-char)) (exch-point-mark mark) (return mark)) (do-times backup (forward-char)))) (defun regexp-constant-within-balance macro (x) `(do ((backup (1- (stringlength (cdar regexp)))) (cl curline) (count) (cpp curpointpos) (mark) (string (cdar regexp))) ((not (setq count (forward-search-bounded string balance))) (go-to-line-point cl cpp) nil) (setq mark (regexp:match regexp 0 nil)) (if mark (exch-point-mark mark) (do-times (1+ backup) (backward-char)) (exch-point-mark mark) (return mark)) (setq balance (- balance count 1)) (do-times backup (backward-char)))) (defun reverse-regexp-constant-within-balance macro (x) `(do ((backup (1- (stringlength (cdar reverse-regexp)))) (cl curline) (count) (cpp curpointpos) (mark) (string (cdar reverse-regexp))) ((not (setq count (reverse-search-bounded string balance))) (go-to-line-point cl cpp) nil) (setq mark (regexp:reverse-match reverse-regexp 0 nil)) (if mark (exch-point-mark mark) (do-times (1+ backup) (forward-char)) (exch-point-mark mark) (return mark)) (setq balance (- balance count 1)) (do-times backup (forward-char)))) (defun regexp-dots-floating macro (x) `(do ((count (cdar regexp)) (result)) ((or (if (not (> count (chars-left-in-line))) (setq curpointpos (+ curpointpos count)) (setq result (regexp:match regexp (chars-left-in-line) nil))) (lastlinep)) result) (next-line))) (defun reverse-regexp-dots-floating macro (x) `(do ((count (cdar reverse-regexp)) (result)) ((or (if (not (> count curpointpos)) (setq curpointpos (- curpointpos count)) (setq result (regexp:reverse-match reverse-regexp curpointpos nil))) (firstlinep)) result) (prev-line))) (defun regexp-dots-anchored macro (x) `(let ((count (cdar regexp))) (if (not (> count (chars-left-in-line))) (let ((cl curline) (cpp curpointpos) (result)) (if (> count balance) (setq balance 0 star-mark nil) else (setq balance (- balance count))) (setq curpointpos (+ curpointpos count)) (setq result (regexp:match regexp balance star-mark)) (cond (result (exch-point-mark result) (setq curpointpos cpp) (exch-point-mark result)) (t (go-to-line-point cl cpp))) result)))) (defun reverse-regexp-dots-anchored macro (x) `(let ((count (cdar reverse-regexp))) (if (not (> count curpointpos)) (let ((cl curline) (cpp curpointpos) (result)) (if (> count balance) (setq balance 0 star-mark nil) else (setq balance (- balance count))) (setq curpointpos (- curpointpos count)) (setq result (regexp:reverse-match reverse-regexp balance star-mark)) (cond (result (exch-point-mark result) (setq curpointpos cpp) (exch-point-mark result)) (t (go-to-line-point cl cpp))) result)))) (defun regexp-star-floating macro (x) `(let ((char (cadr regexp)) (cl curline) (cpp curpointpos) (result (regexp:search regexp))) (if result (exch-point-mark result) (cond (char (do () ((and (eq cl curline) (= cpp curpointpos))) (or (eq char (curchar)) (return nil)) (forward-char))) ((eq cl curline) (go-to-line-point cl cpp)) (t (go-to-beginning-of-line))) (exch-point-mark result) result)))) (defun reverse-regexp-star-floating macro (x) `(let ((char (cadr reverse-regexp)) (cl curline) (cpp curpointpos) (result (regexp:reverse-search reverse-regexp))) (if result (exch-point-mark result) (cond (char (do () ((and (eq cl curline) (= cpp curpointpos))) (or (eq char (lefthand-char)) (return nil)) (backward-char))) ((eq cl curline) (go-to-line-point cl cpp)) (t (go-to-end-of-line))) (exch-point-mark result) result)))) (defun regexp-star-anchored macro (x) `(let ((char (cdar regexp)) (cl curline) (cpp curpointpos) (my-mark) (result)) (cond (star-mark (setq my-mark star-mark) (exch-point-mark my-mark)) (t (setq my-mark (set-mark)))) (cond (char (do () ((not (eq char (curchar)))) (forward-char) (setq balance (1+ balance)))) (t (setq balance (+ balance (chars-left-in-line))) (go-to-end-of-line))) (exch-point-mark my-mark) (setq result (regexp:match regexp balance my-mark)) (or star-mark (release-mark my-mark)) (cond (result (exch-point-mark result) (go-to-line-point cl cpp) (exch-point-mark result))) result)) (defun reverse-regexp-star-anchored macro (x) `(let ((char (cdar reverse-regexp)) (cl curline) (cpp curpointpos) (my-mark) (result)) (cond (star-mark (setq my-mark star-mark) (exch-point-mark my-mark)) (t (setq my-mark (set-mark)))) (cond (char (do () ((not (eq char (lefthand-char)))) (backward-char) (setq balance (1+ balance)))) (t (setq balance (+ balance curpointpos)) (go-to-beginning-of-line))) (exch-point-mark my-mark) (setq result (regexp:reverse-match reverse-regexp balance my-mark)) (or star-mark (release-mark my-mark)) (cond (result (exch-point-mark result) (go-to-line-point cl cpp) (exch-point-mark result))) result)) ;;; ;;; The actual top-level recursive forward search routines. ;;; (defun regexp:search (regexp) (setq regexp (cdr regexp)) (cond ((null regexp) (set-mark)) ((eq (caar regexp) 'constant) (regexp-constant-floating)) ((eq (caar regexp) 'dots) (regexp-dots-floating)) ((eq (caar regexp) 'star) (regexp-star-floating)) ((eq (caar regexp) 'ends-line) (go-to-end-of-line) (set-mark)) ;; ;; if we get this far, (caar regexp) = 'begins-line. ;; ((and (lastlinep) (not (bolp))) nil) (t (if (not (bolp)) (next-line)) (do ((result)) ((or (setq result (regexp:match regexp 0 nil)) (lastlinep)) result) (next-line))))) (defun regexp:match (regexp balance star-mark) (setq regexp (cdr regexp)) (cond ((null regexp) (prog1 (set-mark) (if star-mark (go-to-mark star-mark)))) ((eq (caar regexp) 'constant) (regexp-constant-within-balance)) ((eq (caar regexp) 'dots) (regexp-dots-anchored)) ((eq (caar regexp) 'star) (regexp-star-anchored)) ((eq (caar regexp) 'ends-line) (cond ((< balance (chars-left-in-line)) nil) (t (prog1 (set-mark) (go-to-end-of-line))))) ((bolp) ; (caar regexp) = begins-line (regexp:match regexp 0 nil)))) ;;; ;;; The actual top-level recursive reverse search routines. ;;; Note that they closely parallel the forward regexp search, but the ;;; roles of begins-line (^) and ends-line ($) have been interchanged. ;;; (defun regexp:reverse-search (reverse-regexp) (setq reverse-regexp (cdr reverse-regexp)) (cond ((null reverse-regexp) (set-mark)) ((eq (caar reverse-regexp) 'constant) (reverse-regexp-constant-floating)) ((eq (caar reverse-regexp) 'dots) (reverse-regexp-dots-floating)) ((eq (caar reverse-regexp) 'star) (reverse-regexp-star-floating)) ((eq (caar reverse-regexp) 'begins-line) (go-to-beginning-of-line) (set-mark)) ;; ;; if we get this far, (caar reverse-regexp) = 'ends-line. ;; ((and (firstlinep) (not (eolp))) nil) (t (if (not (eolp)) (prev-line) (go-to-end-of-line)) (do ((result)) ((or (setq result (regexp:reverse-match reverse-regexp 0 nil)) (firstlinep)) result) (prev-line) (go-to-end-of-line))))) (defun regexp:reverse-match (reverse-regexp balance star-mark) (setq reverse-regexp (cdr reverse-regexp)) (cond ((null reverse-regexp) (prog1 (set-mark) (if star-mark (go-to-mark star-mark)))) ((eq (caar reverse-regexp) 'constant) (reverse-regexp-constant-within-balance)) ((eq (caar reverse-regexp) 'dots) (reverse-regexp-dots-anchored)) ((eq (caar reverse-regexp) 'star) (reverse-regexp-star-anchored)) ((eq (caar reverse-regexp) 'begins-line) (cond ((> balance curpointpos) nil) (t (prog1 (set-mark) (go-to-beginning-of-line))))) ((eolp) ; (caar reverse-regexp = ends-line (regexp:reverse-match reverse-regexp 0 nil))))  emacs-fortran-mode.lisp 08/20/86 2313.5rew 08/20/86 2242.8 71631 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; ;;; Fortran mode extension for Multics EMACS ;;; Written by Paul Schauble DVCP mail station C34 HVN 357-4531 ;;; On January 17, 1979 ;;; HISTORY COMMENTS: ;;; 1) change(86-04-23,Margolin), approve(86-04-23,MCR7325), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Added missing *expr declarations. ;;; END HISTORY COMMENTS ;;; (%include e-macros) (defvar fortran-mode-hook nil) (declare (special fortran-begin-comment-line fortran-end-comment-line fill-prefix current-buffer-mode compiler compile-options buffer-uid mode-identification error-list-builder buffer-minor-modes error-list e-list)) (declare (*expr conditional-new-line cv_dec_check_ exit-error-scan-mode internedp kill-contents-of-line)) ;;; ;;; Mode initialization ;;; (defun fortran-mode () (mapc '(lambda (x) (set-key (car x) (cadr x))) '((esc-/; fortran-comment-line) (^xc fortran-begin-comment-block) (esc-/: fortran-label) (^i fortran-indent-statement) (esc-^m fortran-continue) (esc-^c compile-buffer) (/' fortran-abbrev-expander) (esc-p undefined-command) ; I don't know what these (esc-n undefined-command) ; mean to Fortran (^x^d locate-next-error) (^xt exit-error-scan-mode))) (setq current-buffer-mode 'Fortran) (setq fill-prefix " ") (if (line-is-blank) (without-saving (kill-contents-of-line) (insert-string " "))) (register-local-var 'fortran-begin-comment-line) (register-local-var 'fortran-end-comment-line) (register-local-var 'compiler) (register-local-var 'compile-options) (register-local-var 'mode-identification) (register-local-var 'error-list-builder) (setq fortran-begin-comment-line "c ========================================" fortran-end-comment-line fortran-begin-comment-line compiler "ft " compile-options " -tb" error-list-builder 'fortran-error-list-builder mode-identification -1) (if (boundp 'error-list) ; end error scan mode if needed. (if error-list (exit-error-scan-mode)) else (setq error-list nil e-list nil)) (if fortran-mode-hook (errset (funcall fortran-mode-hook)))) ;;; ;;; One time initialization, done when file is loaded ;;; (mapc '(lambda (item) ;; initial list of abbrevs (putprop (car item) (cdr item) 'fortran-abbrev)) '((in integer/ nil nil) (su subroutine/ nil nil) (di dimension/ nil nil) (co continue t t) (re return t t) (fu function/ nil nil) (au automatic/ nil nil) (eq equivalence/ /( nil nil) (ex external/ nil nil) (cn common/ nil nil) (fo format/ /( t nil) (im implicit/ nil nil) ) ) ;;; ;;; Basic Fortran formating 1/17/79 ;;; (defun fortran-set-begin-comment () (setq fortran-begin-comment-line (trim-minibuf-response "Begin comment block: " NL ))) (defun fortran-set-end-comment () (setq fortran-end-comment-line (trim-minibuf-response "End comment block: " NL))) (defun fortran-begin-comment-block () (if (memq 'comment buffer-minor-modes) (conditional-new-line fortran-end-comment-line) (setq fill-prefix " ") (new-line) (negate-minor-mode 'comment) else (conditional-new-line fortran-begin-comment-line) (setq fill-prefix "c ") (new-line) (assert-minor-mode 'comment) )) (defun fortran-continue () (conditional-new-line " & ")) (defun fortran-comment-line () (conditional-new-line "c ")) (defun fortran-label () (save-excursion (go-to-beginning-of-line) (delete-white-sides)) (delete-white-sides) (if (> (cur-hpos) 5) (display-error "Statement number too long") else (whitespace-to-hpos 6) )) (defun fortran-indent-statement () (if (< (cur-hpos) 6) (whitespace-to-hpos 6) else (insert-char TAB))) ;;; ;;; Fortran abbrevs - January 29, 1979 ;;; (defun set-fortran-abbrev n (if (< n 2) (display-error "Too few arguments") else (let ((lab nil) (el nil)) (do i 3 (1+ i) (> i n) ((lambda (x) (cond ((eq x 'label) (setq lab t)) ((eq x 'eol) (setq el t)) (t (display-error (catenate "Invalid option: " x))))) (arg i))) (putprop (arg 1) (list (arg 2) lab el) 'fortran-abbrev)))) (defun fortran-abbrev-expander () (prog (the-abbr) (with-mark m (backward-char) (backward-char) (setq the-abbr (internedp (point-mark-to-string m))) (setq the-abbr (if (symbolp the-abbr) (get the-abbr 'fortran-abbrev) else nil)) (if the-abbr (if (cadr the-abbr) (fortran-label)) (without-saving (wipe-point-mark m)) (insert-string (car the-abbr)) (redisplay) (if (caddr the-abbr) (if (or (lastlinep) (save-excursion (next-line) (line-is-blank))) (new-line))) else (go-to-mark m) (release-mark m) (display-error "Undefined abbreviation")) ))) ;;; Language dependant part of error scanner. (defun fortran-error-list-builder () (if (= buffer-uid -1) (let ((er-list nil) (line-num)) (do-forever (go-to-beginning-of-line) (if (or (looking-at "WARNING") (looking-at "ERROR")) (go-to-end-of-line) (with-mark m (skip-back-to-whitespace) (setq line-num (point-mark-to-string m))) (do-times 5 (backward-char)) (setq line-num (if (looking-at "line") (let ((z (cv_dec_check_ line-num))) (if (= 0 (car z)) (cadr z))))) ;; line-num is now fixnum of source error line number or nil if message ;; had no line number (go-to-beginning-of-line) (setq er-list (cons (cons (set-mark) line-num) er-list))) (insert-string " ") (if (firstlinep) (stop-doing) else (prev-line))) ;; er-list is now list of ( . ) ;; return it as the defun value. er-list) else ;; Buffer does not contain a compilation, return error 'not-compile)) ;; ;; Change History ;; ;; Original begun 1/17/79 ;; 1/29/79 Added fortran-compile and supporting extended commands. ;; 1/30/79 Added fortran-abbrev-expanded and supporting commands. ;; 1/31/79 Modified fortran-abbrev-expanded package to make the ;; label and new-line hacks available to user abbrevs. ;; 2/1/79 Modified fortran-compile into compile buffer. Changed ;; supporting commands to accepts args on command line rather ;; than in minibuffer. Changed handling of local variables ;; to be unconditionally set in each buffer. ;; 2/3/79 Added without-saving to all deletes, so that normal use ;; does not crud up the kill-ring. ;; 2/3/79 Changed abbrev-expanded to simplify use of properties. ;; Added abbrev im for implicit. ;; 2/3/79 Changed fortran-abbrev-expander to not do automatic ;; new-lines if the next line is not empty. Changed ;; fortran-label so that it doesn't lose if done more than ;; once to a line. ;; 2/11/79 Added first edition of fortran-next-error. Scans backwards. ;; 3/2/79 Changed compile-buffer and error scanner to be language ;; independant and move them to a common segment. Also changed ;; the error scanner to keep a mark list and to work forwards.  emacs-lisp-debug-mode.lisp 08/20/86 2313.5r w 08/20/86 2242.9 147870 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; LDEBUG mode cause i needed it ;;; BSG 2/24/79 ;;; Some features by RWK 9/79 ;;; Lisp trace features by BSG 10/6/79 ;;; Register-option forms commented out and moved to e_option_defaults_, ;;; Barmar 1/19/84 (%include e-macros) (declare (*lexpr ldebug-ioa)(genprefix /!ldb_)) (declare (special ldebug-closure ldebug-break-index ldebug-buf errset ldebug-breaklist ldebug-cur-bkpt ldebug-trace-indent ldebug-cur-bkpte ldebug-level e-lisp-error-mode)) (declare (*expr backward-sexp begin-defun down-list-level e_lap_$get-x7 eval-top-level-form forward-sexp kill-sexp lisp-mode)) (defvar ldebug-mode-hook nil) (setq ldebug-break-index 0 ldebug-breaklist nil ldebug-cur-bkpte nil ldebug-level 0) ; Number of nested breaks ;; User options (declare (special ldebug-prinlevel ldebug-prinlength ldebug-base ldebug-ibase)) ;;; (register-option 'ldebug-prinlevel 6.) ;moved to e_option_defaults_ ;;; (register-option 'ldebug-prinlength 10.) ;moved to e_option_defaults_ ;;; (register-option 'ldebug-base 8.) ;moved to e_option_defaults_ ;;; (register-option 'ldebug-ibase 8.) ;moved to e_option_defaults_ (defprop ldebug "Enables a mode to take advantage of emacs editing capabilities while interacting with lisp. You type in se-expressions with the full emacs command set available, and type CR to send your last expresison to lisp. The output will be inserted into the buffer with prinlevel and prinlength bound to the values of the options ldebug-prinlevel and ldebug-prinlength (default 6. and 10.). The symbol * will be set to the result of the evaluation, as in the default lisp top-level. Errors encountered will enter a break level of editing on the buffer. esc-G will return to the top-level edit loop, exc-P to the previous level, esc-L will list the breaks currently in effect, esc-R resets a break esc-s will show source for a breakpoint, esc-T will print a backtrace. Esc-^S will show where the editor was at the time of the error." documentation) (defun ldebug-mode () (lisp-mode) (dont-notice-modified-buffer current-buffer) (mapc '(lambda (x)(set-key (car x)(cadr x))) '((^M ldebug-eval-and-print-result) (esc-G ldebug-return-to-emacs-top-level) (esc-P ldebug-return) (esc-L ldebug-list-breaks) (esc-R ldebug-reset-break) (esc-S ldebug-show-bkpt-source) (esc-T ldebug-trace-stack) (esc-^S ldebug-display-where-editor-was))) (setq current-buffer-mode 'Lisp/ Debug) (if ldebug-mode-hook (errset (funcall ldebug-mode-hook)))) (defun %% (bx)(ldebug-catch bx (e_lap_$get-x7))) (defun ldebug-catch (bx cl) (let ((ldebug-closure cl) (ldebug-buf current-buffer) (ldebug-cur-bkpt bx) (ldebug-cur-bkpte (ldebug-find-bkpte bx))) (let ((state (car ldebug-cur-bkpte))) (cond ((memq state '(dead benign))) ((eq state 'live)(ldebug-yggdrasil 'curbkpt)) ((not (numberp state))) ; ??? ((< state 2) (rplaca ldebug-cur-bkpte 'live) (ldebug-yggdrasil 'curbkpt)) (t (rplaca ldebug-cur-bkpte (1- state))))))) (defprop ldebug "$$$ enters a buffer LDEBUG in ldebug-mode, to do interactive debugging of lisp code. See the documentation for ldebug-mode for details." documentation) (defun ldebug () (let ((ldebug-buf current-buffer) (*rset t) (ldebug-trace-indent 0) (ldebug-closure (e_lap_$get-x7)) (ldebug-cur-bkpte nil) (e-lisp-error-mode 'ldebug-lisp-toplevel-error-handler)) (ldebug-yggdrasil 'ldebug))) (defun ldebug-lisp-toplevel-error-handler (arg) (setq arg arg) (let ((ldebug-buf current-buffer) (ldebug-level (1+ ldebug-level)) (ldebug-closure (cadddr (errframe nil))) (* nil)) (ldebug-yggdrasil 'errbreak))) (defun ldebug-in-breakp () (or ldebug-cur-bkpte (display-error "No current break."))) (defun within-LDEBUG/'s-buffer-window macro (x) `(let ((oldbuf current-buffer) (oldfdw (buffer-on-display-in-window current-buffer))) (find-buffer-in-window 'LDEBUG) (prog2 0 (progn ,@(cdr x)) (if (null oldfdw) (go-to-buffer oldbuf) else (find-buffer-in-window oldbuf))))) (defun ldebug-yggdrasil (key) (within-LDEBUG/'s-buffer-window (if (empty-buffer-p current-buffer) (new-line) (ldebug-mode) else (go-to-end-of-buffer)) (if (not (line-is-blank))(new-line)) (if (eq key 'errbreak) (errset (ring-tty-bell) (let ((f (caddr (errframe nil)))) (new-line) (ldebug-ioa "Lisp breakpoint " (caddr f) " at level " (decimal-rep ldebug-level) " in buffer " ldebug-buf ":") (ldebug-ioa (car f)(maknam (explodec (cadr f))))))) (if (eq key 'trace-break) (ring-tty-bell) (ldebug-ioa "Entry breakpoint to function " (cadr ldebug-cur-bkpte))) (if (eq key 'curbkpt) (ring-tty-bell) (ldebug-ioa "Break " (decimal-rep ldebug-cur-bkpt) " in " (cadr ldebug-cur-bkpte))) (let ((*rset t) (ldebug-trace-indent ldebug-trace-indent)) (let ((val (catch (charlisten) gazongues-des-lispes))) (if (eq val 'tres-grandes-gazongues) (go-to-buffer ldebug-buf) (command-quit) else val))))) (defprop ldebug-return-to-emacs-top-level "Release the current level of LDEBUG mode, returning to the previous level. All executing code betweent the two levels is aborted." documentation) (defun ldebug-return-to-emacs-top-level () (ldebug-ioa "$g") (throw 'tres-grandes-gazongues gazongues-des-lispes)) (defun ldebug-ioa n (go-to-end-of-buffer) (insert-string (apply 'catenate (listify n))) (redisplay) (new-line)) (defprop ldebug-eval-and-print-result "Takes the contents of the current line, reads it as an s-expression, and inserts the result into the buffer, with prinlength and prinlevel bound according to the ldebug-prinlength and ldebug-prinlevel options. The variable * is set to the result of the evaluation, as in the default lisp top-level." documentation) ;Make this loser use backward-sexp to get entire sexpression! (defun ldebug-eval-and-print-result () (let ((string (e_lap_$trim (let ((s (curline-as-string))) (let ((sl (stringlength s))) (and (samepnamep (substr s sl 1) NL) (setq s (substr s 1 (1- sl))))) s)))) (if (not (nullstringp string)) (let ((errset 'ldebug-lisp-toplevel-error-handler)) (ldebug-output-to-buffer (let ((fail-act 'ldebug-lisp-toplevel-error-handler) ; (gc-daemon 'ldebug-lisp-toplevel-error-handler) (pdl-overflow 'ldebug-lisp-toplevel-error-handler) (wrng-type-arg 'ldebug-lisp-toplevel-error-handler) (*rset-trap 'ldebug-lisp-toplevel-error-handler) (unbnd-vrbl 'ldebug-lisp-toplevel-error-handler) (undf-fnctn 'ldebug-lisp-toplevel-error-handler) (unseen-go-tag 'ldebug-lisp-toplevel-error-handler) (wrng-no-args 'ldebug-lisp-toplevel-error-handler) (ibase ldebug-ibase)) (car (errset (prog2 0 (setq * (eval (read-from-string string))) (new-line) (insert-string "=> ")) nil))))) else (new-line)))) ;ldebug-flush-whitespace deletes extra white-space off the both ends of ;a string for passing to readline. Clobbers (defun ldebug-flush-whitespace (string) (nreverse (ldebug-flush-whitespace-beginning (nreverse (ldebug-flush-whitespace-beginning string))))) (defun ldebug-flush-whitespace-beginning (string) (do ((string string (cdr string))) ((not (memq (car string) '(9. 10. 32.))) string))) (defprop ldebug-return "Restart the current breakpoint or Lisp error which entered the LDEBUG buffer, restoring buffer, point, and window. If a numeric argument is given, restart this (trace or code) break that many times automatically (including this time). If a Lisp error is being restarted, return the current line's Lisp value to the Lisp error breakpoint." documetation) (defun ldebug-return () (if numarg (ldebug-in-breakp) (ldebug-ioa "Set for " (decimal-rep numarg) " proceeds.") (rplaca ldebug-cur-bkpte numarg)) (throw (prog2 0 (if (not (line-is-blank)) (car (errset (let ((ibase ldebug-ibase)) (read-from-string (curline-as-string))))) else nil) (ldebug-ioa "$p")) gazongues-des-lispes)) ;;; ;;; Break format is (number . (state function buffer mark)) ;;; (defprop ldebug-set-break "Set a breakpoint in the Lisp code pointed at by the cursor. The break number, in decimal, is plaed in the break code, which is placed in the current buffer. The function pointed at is reevaluated. When the break is executed, LDEBUG will be entered." documentation) (defun ldebug-set-break () (setq *rset t) (let ((fn nil)) (save-excursion (begin-defun) (down-list-level) (do-times 2 (forward-sexp)) (with-mark m (backward-sexp) (setq fn (point-mark-to-string m)))) (insert-string (catenate " (%% " (decimal-rep (setq ldebug-break-index (1+ ldebug-break-index))) ".)")) (backward-sexp) (setq ldebug-breaklist (cons (cons ldebug-break-index (list 'live fn current-buffer (set-mark))) ldebug-breaklist)) (save-excursion (eval-top-level-form)))) (defun ldebug-errset-trap (x) (setq x (caddr (errframe nil))) (find-buffer-in-window 'LDEBUG) (new-line) (ldebug-ioa "<>: " (car x)) (ldebug-ioa " " (maknam (explodec (cdr x)))) (command-quit)) (defprop ldebug-trace-stack "Insert into the buffer a traceback of the stack." documentation) (defun ldebug-trace-stack () (ldebug-ioa "--STACK TRACE--") (do x (evalframe nil)(evalframe (cadddr x))(null x) (if (< (cadddr x) ldebug-closure) (ldebug-output-to-buffer (caddr x)) (redisplay))) ;Show while ye grinds. (ldebug-ioa "--END TRACE--") (new-line)) (defprop ldebug-show-bkpt-source "Show the source for the current LDEBUG code breakpoint. If a numeric argument is given, show the source for that breakpoint, by break number." documentation) (defun ldebug-show-bkpt-source () (if numarg (ldebug-display-bkpt-source (ldebug-find-bkpte numarg)) else (ldebug-in-breakp) (if (eq (cadddr ldebug-cur-bkpte) '*trace) (display-error "Trace breaks have no source.")) (ldebug-display-bkpt-source ldebug-cur-bkpte))) (defun ldebug-display-bkpt-source (brk) (find-buffer-in-window (caddr brk)) (go-to-mark (cadddr brk))) (defprop ldebug-reset-break "With no numeric argument, reset the current (active) LDEBUG code or trace entry break. With a numeric argument, reset the code break of that break number." documentation) (defun ldebug-reset-break () (if numarg (ldebug-reset-bkpte numarg (ldebug-find-bkpte numarg)) else (ldebug-in-breakp) (if (eq (cadddr ldebug-cur-bkpte) '*trace) (let ((fn (cadr ldebug-cur-bkpte))) (if (caar (errset (eval (list 'untrace fn)))) (rplaca ldebug-cur-bkpte 'dead) (ldebug-ioa "Reset entry break to function " fn))) else (ldebug-reset-bkpte ldebug-cur-bkpt ldebug-cur-bkpte)))) (defun ldebug-reset-bkpte (bx bkpte) (rplaca bkpte 'dead) (save-excursion-buffer (go-to-buffer (caddr bkpte)) (go-to-mark (cadddr bkpte)) (backward-char) (kill-sexp) (eval-top-level-form)) (minibuffer-print "Reset break " (decimal-rep bx))) (defun ldebug-find-bkpte (no) (or (cdr (assoc no ldebug-breaklist)) (display-error "Breakpoint " (decimal-rep no) " somehow got lost."))) (defprop ldebug-list-breaks "Insert into the LDEBUG buffer a list of all active breakpoints: their number, function, status, and buffer." documentation) (defun ldebug-list-breaks () (if (null ldebug-breaklist)(display-error "No active breaks.") else (ldebug-ioa "BREAK LIST") (ldebug-ioa "# Function Status Buffer") (do l (setq ldebug-breaklist (sort ldebug-breaklist '(lambda (x y)(< (car x)(car y))))) (cdr l) (null l) (let ((n (caar l))(brk (cdar l))) (if (not (eq (car brk) 'dead)) (insert-string (decimal-rep n)) (format-to-col 6.) (insert-string (cadr brk)) (format-to-col 21.) (insert-string (maknam (explodec (car brk)))) (format-to-col 30.) (insert-string (caddr brk)) (if (eq brk ldebug-cur-bkpte) (format-to-col 50.) (insert-string "<<<")) (redisplay) (new-line)))) (ldebug-ioa "END BREAK LIST"))) (defprop ldebug-display-where-editor-was "Select the buffer (and window, if that buffer is on display), where Emacs was when the current breakpoint was taken. The cursor will be moved to the place where point was when the break was taken. If point is moved, it will remain moved when the break is restarted." documentation) (defun ldebug-display-where-editor-was () (let ((m (save-excursion-buffer (go-to-buffer ldebug-buf) (set-mark)))) (find-buffer-in-window ldebug-buf) (go-to-mark m) (release-mark m))) ;print the desired lisp form into the buffer, with right base, prinlevel, ;etc. (defun ldebug-output-to-buffer (form) (insert-string (maknam (let ((prinlevel ldebug-prinlevel) (prinlength ldebug-prinlength) (base ldebug-base)) (explode form)))) (redisplay) (new-line)) ;;; ;;; Trace Hackery ;;; BSG 10/6/79 ;;; (%include e-macros) (declare (special trace-indent-incr trace-indent-max trace-ok-flag ldebug-prinlength ldebug-prinlevel rdis-suppress-redisplay)) (setq ldebug-trace-indent 0) (defun ldebug-trace-printer (arg) (if trace-ok-flag (let ((trace-ok-flag nil)) (save-excursion-buffer (go-to-or-create-buffer 'LDEBUG) (go-to-end-of-buffer) (if (empty-buffer-p current-buffer)(ldebug-mode)) (ldebug-trace-real-printer (car arg)(cadr arg)(caddr arg)(cadddr arg)(cddddr arg)) (if (not (buffer-on-display-in-window 'LDEBUG)) (local-display-current-line))) (if (buffer-on-display-in-window 'LDEBUG) (within-LDEBUG/'s-buffer-window (redisplay)))))) (defun ldebug-trace-real-printer (recurlev type fn arg stuff) (setq ldebug-trace-indent (max 0 ldebug-trace-indent)) (new-line) (and (eq type 'exit)(setq ldebug-trace-indent (- ldebug-trace-indent trace-indent-incr))) (whitespace-to-hpos (max 0 (min trace-indent-max ldebug-trace-indent))) (and (eq type 'enter)(setq ldebug-trace-indent (+ ldebug-trace-indent trace-indent-incr))) (insert-string "(") (insert-string (decimal-rep recurlev)) (insert-string " ") (insert-string type) (insert-string " ") (insert-string fn) (insert-string " ") (ldebug-trace-insert-lisp-string arg) (mapc '(lambda (x)(insert-string " ")(ldebug-trace-insert-lisp-string x)) stuff) (insert-string ")")))) (defun ldebug-trace-insert-lisp-string (x) (let ((prinlength ldebug-prinlength) (prinlevel ldebug-prinlevel) (base ldebug-base)) (insert-string (maknam (explode x))))) (defun ldebug-trace-break (fname) (let ((ldebug-closure (e_lap_$get-x7)) (ldebug-buf current-buffer) (ldebug-cur-bkpt '*trace) (ldebug-cur-bkpte (or (get fname 'ldebug-trace-break) (putprop fname (list 'live fname '*trace '*trace) 'ldebug-trace-break)))) (let ((state (car ldebug-cur-bkpte))) (cond ((memq state '(dead benign))) ((eq state 'live)(ldebug-yggdrasil 'trace-break)) ((not (numberp state))) ; ??? ((< state 2) (rplaca ldebug-cur-bkpte 'live) (ldebug-yggdrasil 'curbkpt)) (t (rplaca ldebug-cur-bkpte (1- state)))))))  emacs-lisp-mode.lisp 08/20/86 2313.5rew 08/20/86 2242.9 217395 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; Lisp Mode. Extracted and modified from e_macops_, ;;; HISTORY COMMENTS: ;;; 1) change(80-05-06,Greenberg), approve(), audit(), ;;; install(86-08-20,MR12.0-1136): ;;; pre-hcom history: ;;; BSG & WMY 9/11/78 ;;; GMP, 09/16/78 to add evaluation functions. ;;; Indented by indent-to-lisp 9/18!! ;;; Hook to LDEBUG BSG 2/25/79 ;;; Clean up compiler segs, elcp feature, backquote, comma BSG 5/6/80 ;;; 2) change(85-01-03,Margolin), approve(86-02-24,MCR7186), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Changed eval-lisp-region to load e_macros_ and e_define_command_, ;;; defvar'ed loaded-e-macros. ;;; 3) change(85-01-27,Margolin), approve(86-02-24,MCR7186), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Declared lots of functions *expr. ;;; END HISTORY COMMENTS (%include e-macros) (declare (special OPEN-PAREN CLOSE-PAREN SEMI SINGLEQUOTE DOUBLEQUOTE SLASH BACKQUOTE COMMA elcp lisptable sexp-searcher-mark-list instack infile env-dir lisp-indent-fuzz fill-column comment-column comment-prefix current-buffer-mode whitespace-charactertbl include-dir tty-no-upmotionp) (*lexpr comout-get-output)) (declare (*expr delete_$path hcs_$initiate_count indent-for-comment kill-contents-of-line mark-whole-buffer one-back-is-a redisplay-current-window-relative search-charset-backwards search-charset-forward unwind-sexp-searchers-marks-and-nlgoto view-region-as-lines)) (setq OPEN-PAREN '/( CLOSE-PAREN '/) SEMI '/; DOUBLEQUOTE '/" SLASH '// SINGLEQUOTE '/' BACKQUOTE '/` COMMA '/,) (defvar ((sexp-searcher-mark-list nil) (elcp t) ;t 9/12/80 (lisp-mode-clean-up-lcp-temps-list nil) (lisptable (charscan-table (catenate TAB SPACE SEMI OPEN-PAREN CLOSE-PAREN NL COMMA DOUBLEQUOTE SINGLEQUOTE SLASH BACKQUOTE))) (lisp-mode-hook nil))) (register-option 'elcp t) (define-autoload-lib emacs-lisp-debug-mode ldebug-set-break) ;;; Extended command to enter LISP mode (defun lisp-mode () (establish-local-var 'compiler 'lisp_compiler) (establish-local-var 'compile-options "") (setq current-buffer-mode 'Lisp comment-column 50. comment-prefix ";") (mapc '(lambda (x) (set-key (car x) (cadr x))) '((TAB indent-to-lisp) ("ESC-(" lisp-one-less-paren) ("ESC-)" lisp-one-more-paren) (ESC-/& ldebug-set-break) (ESC-Q lisp-indent-function) (ESC-^A begin-defun) (ESC-^B backward-sexp) (ESC-^C compile-function) ;;; (^Z^C compile-buffer) ;file-output kind (ESC-^D down-list-level) (ESC-^E end-defun) (ESC-^F forward-sexp) (ESC-^H mark-defun) (ESC-^I indent-to-lisp) (ESC-^K kill-sexp) (ESC-^M lisp-cret-and-indent) (ESC-^N forward-list) (ESC-^P backward-list) (ESC-^Q lisp-indent-region) (ESC-^R move-defun-to-screen-top) (ESC-^T mark-sexp) (ESC-^Z eval-top-level-form))) (if tty-no-upmotionp ;if not on a display (set-key 'ESC-^V 'view-defun)) ;add this useful function (and lisp-mode-hook (errset (funcall lisp-mode-hook)))) (defun begin-defun () (do-forever (go-to-beginning-of-line) (if (firstlinep) (stop-doing)) (if-at OPEN-PAREN (stop-doing)) (prev-line))) (defun end-defun () (begin-defun) (forward-sexp)) (defun mark-defun () (begin-defun) (set-the-mark) (forward-sexp)) (defun view-defun () (mark-defun) (view-region-as-lines)) (defun skip-lisp-whitespace-and-comments () (do-forever (skip-over-whitespace) (dispatch-on-current-char (SEMI (if (lastlinep)(stop-doing)) (next-line) (go-to-beginning-of-line)) (else (stop-doing))))) (defun forward-sexp () (prog () (skip-close-parens-and-comments-and-whitespace) retry (dispatch-on-current-char (CLOSE-PAREN (return t)) (OPEN-PAREN (forward-char) (forward-list)) (SINGLEQUOTE (forward-char)(forward-sexp)) (BACKQUOTE (forward-char)(forward-sexp)) (COMMA (forward-char)(forward-sexp)) (SLASH (forward-char) (forward-char) (go retry)) (DOUBLEQUOTE (forward-char) (if (forward-search DOUBLEQUOTE) else (display-error-noabort "Unbalanced doublequote.") (unwind-sexp-searchers-marks-and-nlgoto)) (if-at DOUBLEQUOTE (go retry)) (return nil)) (else (if (search-charset-forward lisptable) (if-at SLASH (forward-char) (forward-char) (go retry)) (return t) else (error "forward-sexp: whaah? delim?")))))) (defun skip-close-parens-and-comments-and-whitespace () (do-forever (skip-lisp-whitespace-and-comments) (dispatch-on-current-char (CLOSE-PAREN (forward-char)) (else (stop-doing))))) (defun forward-list () (skip-lisp-whitespace-and-comments) (with-mark mm (setq sexp-searcher-mark-list (cons mm sexp-searcher-mark-list)) (if (at-end-of-buffer) (display-error "Unbalanced Parentheses") else (do-forever (if-at CLOSE-PAREN (forward-char)(stop-doing)) (if (at-end-of-buffer) (display-error-noabort "Unbalanced Parentheses.") (go-to-mark mm) (unwind-sexp-searchers-marks-and-nlgoto)) (if (or (at-white-char)(looking-at ";")) (skip-lisp-whitespace-and-comments) (if-at CLOSE-PAREN (forward-char)(stop-doing))) (forward-sexp))))) (defun down-list-level () (do-forever (skip-close-parens-and-comments-and-whitespace) (if (at-end-of-buffer)(stop-doing)) (if-at "(" (forward-char)(stop-doing)) (forward-sexp))) (defprop nextlist-sexp forward-list expr) (defun backward-sexp () (prog () (skip-backwards-open-parens-comments-and-other-cruft) retry (if (one-back-is-a SLASH) (if (and (back-at """") (lisp-mode-slash-quote-sneak)) ;heh heh else (do-times 2 (backward-char)) (go retry))) (dispatch-on-lefthand-char (OPEN-PAREN (return t)) (CLOSE-PAREN (backward-char) ;get closeparen out (backward-list) (do-forever (if (memq (lefthand-char) '(/' /` /,)) (backward-char) else (stop-doing)))) (SINGLEQUOTE (backward-char)(go retry)) (BACKQUOTE (backward-char)(go retry)) (COMMA (backward-char)(go retry)) (DOUBLEQUOTE (backward-char) (if (reverse-search DOUBLEQUOTE) else (display-error-noabort "Unbalanced Doublequote.") (unwind-sexp-searchers-marks-and-nlgoto)) (if-back-at DOUBLEQUOTE (go retry)) (return nil)) (else (if (search-charset-backwards lisptable) (if (one-back-is-a SLASH)(go retry)) (do-forever (if-back-at SINGLEQUOTE (backward-char) else (stop-doing))) (return t) else (return nil)))))) (defun lisp-mode-slash-quote-sneak () (save-excursion (with-mark m ;go thru balancing act (let ((qct)) (go-to-beginning-of-line) (do-forever (if (mark-reached m)(return t)) (dispatch-on-current-char (SEMI (if qct (forward-char) else (return t))) ; WAS quoted (DOUBLEQUOTE (setq qct (not qct)) (forward-char)) (SLASH (forward-char) (if (mark-reached m)(return t)) ;; The above should never happen. (if (not qct) (forward-char) (if (mark-reached m)(return nil)))) ;; The above finds slashed quotes. (else (forward-char)))))))) (defun backward-list () (with-mark mm (setq sexp-searcher-mark-list (cons mm sexp-searcher-mark-list)) (if (at-beginning-of-buffer) ;;fall through to test for same below else (do-forever (if-back-at OPEN-PAREN (backward-char)(stop-doing)) (if (at-beginning-of-buffer) (display-error-noabort "Unbalanced Parentheses.") (go-to-mark mm) (unwind-sexp-searchers-marks-and-nlgoto)) (if (or (bolp)(get (lefthand-char) 'whiteness)) (skip-backwards-lisp-whitespace-comment-cruft) (if (and (back-at OPEN-PAREN) (not (one-back-is-a SLASH))) (backward-char) (stop-doing))) (backward-sexp))))) (defun skip-backwards-open-parens-comments-and-other-cruft () (do-forever (skip-backwards-lisp-whitespace-comment-cruft) (dispatch-on-lefthand-char (OPEN-PAREN (backward-char) (if-back-at SLASH (forward-char)(stop-doing))) (else (stop-doing))))) (defun skip-backwards-lisp-whitespace-comment-cruft () (do-forever tbolp (if (at-beginning-of-buffer)(stop-doing)) (if (bolp)(backward-char) (if (bolp)(go tbolp)) (skip-backwards-possible-lisp-comment) (go tbolp)) (dispatch-on-lefthand-char (TAB (backward-char)) (SPACE (backward-char)) (NL (backward-char)) (SLASH (forward-char)(stop-doing)) (else (stop-doing))))) (defun skip-backwards-possible-lisp-comment () (go-to-end-of-line) (find-lisp-comment-start)) (defun find-lisp-comment-start () (prog (qct foundit) (go-to-beginning-of-line) (if (not (forward-search-in-line ";")) (go-to-end-of-line) (return nil) else (go-to-beginning-of-line)) (setq qct nil) (do-forever (if (eolp)(stop-doing)) (dispatch-on-current-char (DOUBLEQUOTE (setq qct (not qct))(forward-char)) (SEMI (if qct (forward-char) else (setq foundit t) (stop-doing))) (SLASH (forward-char) (if (eolp)(stop-doing)) (if (not qct) (forward-char))) (else (forward-char)))) (return foundit))) (defprop prevlist-sexp backward-list expr) (defun mark-sexp () (skip-lisp-whitespace-and-comments) (if-at CLOSE-PAREN (forward-char) else (forward-sexp)) (set-the-mark) (backward-sexp) (exchange-point-and-mark)) (defprop kill-sexp forward kills) (defun kill-sexp ()(with-mark m (forward-sexp) (kill-backwards-to-mark m) (merge-kills-forward))) (defun move-defun-to-screen-top () (begin-defun) (redisplay-current-window-relative 0)) ;;; ;;; ;;; Your're not going to believe this, but... ;;; Function compiling functions. ;;; BSG and archy 7/28/78 ;;; (defun compile-function () (prog (fnname) (if elcp (return (elcp-compile-top-level-form-from-buffer))) (compile-string (save-excursion (begin-defun) (down-list-level) (forward-sexp) (skip-lisp-whitespace-and-comments) (with-mark n (forward-sexp) (killsave-string (setq fnname (point-mark-to-string n)))) (begin-defun) (with-mark m (forward-sexp) (point-mark-to-string m))) fnname))) (defun compile-string (stuff function-name) (set-emacs-epilogue-handler '(lisp-mode-clean-up-lcp-temps) t) (let ((source-name (catenate process-dir ">!!e!lcptemp!.lisp")) (object-name (catenate "!ect" (maknam (explodec (runtime)))))) (save-excursion-buffer (go-to-or-create-buffer 'compiler-temp) (putprop current-buffer t 'temporary-buffer) (setq buffer-modified-flag t) (destroy-buffer-contents) (insert-string "(declare (use c))") (new-line) (insert-string "(declare (setq seg-name ""[pd]>") (insert-string object-name) (insert-string """)(use w))") (new-line) (insert-string "(declare (inpush (openi """) (insert-string include-dir) (insert-string ">e-macros.incl.lisp"")))") (new-line) (insert-string stuff) (write-out-file source-name) (setq lisp-mode-clean-up-lcp-temps-list (cons object-name lisp-mode-clean-up-lcp-temps-list)) (display-error-noabort "Compiling " function-name " ...")) (display-as-printout (comout-get-output "lisp_compiler" source-name)) (loadfile (catenate process-dir ">" object-name)) (sstatus uuolinks nil))) (defun lisp-mode-clean-up-lcp-temps () (delete_$path process-dir "!!e!lcptemp!.lisp" (lsh 44 30.) "emacs") (mapc '(lambda (x) (delete_$path process-dir x (lsh 44 30.) "emacs")) lisp-mode-clean-up-lcp-temps-list)) ;;; ;;; ;;; Functions for evaluating LISP ;;; GMP, 09/16/78 ;;; (defvar loaded-e-macros nil) ; non-nil => don't loadlib e-macros (defun eval-lisp-region () ; evaluate the current region (with-the-mark-last m (if (not loaded-e-macros) (load (catenate env-dir ">e_macros_")) (load (catenate env-dir ">e_define_command_")) (setq loaded-e-macros t)) (let ((answer (car (errset (eval (read-from-string (catenate "(progn " (point-mark-to-string m) " )"))))))) (let ((prinlevel 3) (prinlength 6)) (minibuffer-print "Value: " (maknam (explode answer))))) (do ((next-file infile (car instack))) ((eq infile t)) (close next-file)) ; close any loaded files (sstatus uuolinks nil))) (defun eval-top-level-form () ; command (ESC-^Z) to evaluate form (save-excursion (mark-defun) ; marks any form starting in column one (eval-lisp-region))) (defun eval-buffer () ; extended command to eval buffer (save-excursion (mark-whole-buffer) (eval-lisp-region))) ;;; ;;; ;;; Lisp indenter ;;; Made winning 9/18 by archy & BSG ;;; (register-option 'lisp-indent-fuzz 1) (defun indent-to-lisp () ;this one's a goody, kids! (go-to-beginning-of-line) (indent-to-lisp-1)) (defun indent-to-lisp-1 () (if (charset-member (curchar) lisptable) (delete-white-sides) (if (not (bolp))(insert-char " ")) (whitespace-to-hpos (save-excursion (do-forever ;get to right line (backward-sexp) (if (not (and (bolp)(not (charset-member (curchar) lisptable)))) (stop-doing))) ;find non-label last sexp (cond ((not (skip-back-whitespace-in-line))) ;'twas all white ((back-at "(") (skip-over-whitespace)) ; (cond ((FOO.. etc (t (with-mark start-of-predecessor (backward-list) (if (mark-on-current-line-p start-of-predecessor) (down-list-level) (forward-sexp) (skip-lisp-whitespace-and-comments) else (down-list-level) (do-forever (skip-lisp-whitespace-and-comments) (if (and (mark-on-current-line-p start-of-predecessor) (or (mark-reached start-of-predecessor) (and (bolp)(at "(")) (not (bolp)))) (stop-doing)) (forward-sexp)))))) (if (and (back-at OPEN-PAREN) (not (at OPEN-PAREN))) (+ (cur-hpos) lisp-indent-fuzz) else (cur-hpos)))) else (forward-sexp) (search-for-first-not-charset-line whitespace-charactertbl) (if (not (or (eolp)(at ";"))) (indent-to-lisp-1)))) (defun lisp-cret-and-indent () (delete-white-sides) (new-line) (insert-char " ") ;not a label (indent-to-lisp)) (defun lisp-indent-region () (copy-region) (with-the-mark-last m (do-forever (if (line-is-blank)(without-saving (kill-contents-of-line)) else (go-to-beginning-of-line) ;Rule out comment lines (if-at OPEN-PAREN ;Don't indent these lines. else (search-for-first-not-charset-line whitespace-charactertbl) (if (not (at ";"))(indent-to-lisp))) (if (find-lisp-comment-start) (place-lisp-comments))) (if (mark-on-current-line-p m)(stop-doing)) (next-line))))) (defun place-lisp-comments () (cond ((looking-at ";;;")(delete-white-sides)) ((looking-at ";;")(indent-to-lisp)) (t (indent-for-comment)))) (defun lisp-indent-function () (mark-defun) (lisp-indent-region)) ;;; ;;; BSG 5/6/80 put his favorite two fcns here.. ;;; (defcom lisp-one-more-paren &na (&repeat) (save-excursion (go-to-beginning-of-line) (skip-backwards-lisp-whitespace-comment-cruft) (insert-char ")")) (indent-to-lisp)) (defcom lisp-one-less-paren &na (&repeat) (save-excursion (go-to-beginning-of-line) (skip-backwards-lisp-whitespace-comment-cruft) (if-back-at ")" (rubout-char) else (display-error "Previous s-exp doesn't end in close paren."))) (indent-to-lisp)) ;;; ;;; In-house LCPery, integrated 5/6/80 ;;; ;;; ;;; 5/1/80 BSG ;;; (declare (*expr runoff-fill-region compile-top-level-forms)) (declare (special elcp-@seg-name lisp-system-dir elcp-internmes elcp-spake)) (declare (special elcp-@undfuns elcp-@being-compiled)) (setq elcp-internmes ;;This slight inelegance has to duplicate the global list of the compiler ;;because by time the compiler can even be looked at, it has already ;;interned its own things on the wrong obarray. This is unclean, but.. '(cf cl pause genprefix nfunvars special fixnum flonum fixsw flosw notype arith array* closed muzzled unspecial reducible irreducible noargs mapex symbols lisp put-in-tree ;request of H. Lieberman expr-hash system-file compile-top-level-forms ;for GSB & BSG 5/4/80 sobarray cobarray eoc-eval compiler-state compile maklap top-level coutput gofoo ;jonl's crocks for owl nocompile -db -debug -eval -tm -time -times -ps -pause -pause_at -mc -macros -gp -gnp -genprefix -nw -nowarn -tt -total -total_time -list -ls -long -lg -all_special -pathname -pn -p -no_compile -ncp -ck -check -ioc -messioc -mioc -hd -hold -pedigree -pdg -brief -bf arith *expr *fexpr *lexpr **array messioc check debug macros dataerrp barfp defpl1 update return ignore fixed bin binary float packed-pointer packed-ptr pointer ptr bit aligned unaligned character varying char lisp array l le g ge n e)) (defun elcp-load-lcp () (let ((obarray (get '*VIRGIN-OBARRAY* 'array)) (errlist errlist)) ;clever bastard (makoblist 'compiler-obarray) (setq obarray (get 'compiler-obarray 'array)) (mapc 'intern elcp-internmes) (putprop (intern (copysymbol 'use nil)) 'elcp-use 'expr) (putprop (intern (copysymbol 'global nil)) 'elcp-global 'expr) (setq elcp-@seg-name (intern (copysymbol 'seg-name nil))) (setq elcp-@undfuns (intern (copysymbol 'undfuns nil))) (setq elcp-@being-compiled (intern (copysymbol 'being-compiled nil))) (set (intern (copysymbol 'compiler-revision nil)) "Emacs") (mapc '(lambda (x) (hcs_$initiate_count lisp-system-dir x x 0) ;; lisp_cg_utility_ snaps link to x$symbol_table (load (catenate lisp-system-dir ">" x))) '(lcp_semant_ lcp_cg_)) (putprop (intern (copysymbol 'printmes nil)) 'elcp-lcp-error-printer 'expr))) (defun elcp-use fexpr (x) (let ((x (getchar (car x) 1))) ; get the first char of the argument. (cond ((eq x 'c) (setq obarray (get 'compiler-obarray 'array)) 'compiler-obarray) ((eq x 'w) (setq obarray (get 'obarray 'array)) 'working-obarray) ((eq x 'n) (setq obarray (get '*VIRGIN-OBARRAY* 'array)) (makoblist 'obarray) ; copy it (setq obarray (get 'obarray 'array)) 'new-working-obarray) (t (display-error-noabort "use: argument must be c, w, or n."))) nil)) (defun elcp-global fexpr (x) (let ((obarray (get 'obarray 'array))) (mapc '(lambda (y) (setq x (intern y)) (or (eq x y) (display-error-noabort "elcp-global: obarray ""already interned"" conflict: " y))) x))) (defun cfun (fname) (let ((prop (getl fname '(expr fexpr macro)))) (or prop (display-error "cfun: " fname " not a function")) (elcp-compile-and-load `((defprop ,fname ,(cadr prop) ,(car prop)))))) (defun elcp-compile-and-load (forms) (set-emacs-epilogue-handler '(lisp-mode-clean-up-lcp-temps) t) (setq elcp-spake nil) (if (null (get 'compiler-obarray 'array)) (display-error-remark "Loading LCP into Emacs environment...") (elcp-load-lcp) (display-error-remark "Precompiling e-macros.incl.lisp...") (setq loaded-e-macros t) (compile-top-level-forms `((declare (setq eoc-eval ;idea is no obj seg. '((cf ,(catenate include-dir ">e-macros.incl.lisp")))))) nil)) (let ((segname (catenate "!ect" (maknam (explodec (runtime))))) (fname (cond ((or (atom forms)(atom (car forms)))) ((cdr forms) "...") ((memq (caar forms) '(defun defcom define-command defmacro defstruct)) (cadar forms)) (t "....")))) (setq lisp-mode-clean-up-lcp-temps-list (cons segname lisp-mode-clean-up-lcp-temps-list)) (display-error-remark "Compiling " fname "...") (compile-top-level-forms forms (catenate "[pd]>" segname)) (let ((undfuns (symeval elcp-@undfuns))) (setq undfuns (mapcan '(lambda (x)(cond ((getl x '(subr lsubr fsubr expr fexpr)) nil) (t (list x)))) undfuns)) (if undfuns (elcp-lcp-error-printer undfuns " - functions referenced but not defined. " nil) (set elcp-@undfuns nil))) (minibuffer-print-noclear " Loading ..") (loadfile (catenate process-dir ">" segname)) (sstatus uuolinks nil) (and (symbolp fname)(killsave-string fname)) (minibuffer-print "Compiled.")) (and elcp-spake (end-local-displays))) (defun elcp-compile-top-level-form-from-buffer () (let ((stuff (save-excursion (mark-defun) (with-the-mark-last m (car (errset (read-from-string (point-mark-to-string m)))))))) (elcp-compile-and-load (list stuff)) (and stuff (not (atom stuff)) (not (cdr stuff)) (not (atom (car stuff))) (cdar stuff) (memq (caar stuff)'(defun defmacro defcom define-command defstruct)) (putprop (caar stuff) current-buffer 'tagbuf)))) (defun elcp-lcp-error-printer (data msg error-type) (if (not elcp-spake) (init-local-displays) (setq elcp-spake t)) (save-excursion-buffer (go-to-or-create-buffer 'Compiler/ Diagnostics) (go-to-end-of-buffer) (without-modifying (if (not (at-beginning-of-buffer)) (new-line)) (set-the-mark) (if (and (boundp elcp-@being-compiled) (symeval elcp-@being-compiled)) (if (not (at-beginning-of-buffer)) (new-line) (set-the-mark)) (insert-string "*** DIAGNOSTICS FOR ") (insert-string (maknam (explodec (symeval elcp-@being-compiled)))) (insert-string " ***") (new-line) (set elcp-@being-compiled nil) (elcp-filled-print-region) (new-line) (set-the-mark)) (setq error-type (let ((obarray (get 'obarray 'array))) (intern error-type))) (insert-string (cdr (assq error-type '((warn . "Warning: ") (nonfatal . "Error: ") (data . "Severe error: ") (barf . "Compiler error: ") (nil . "lisp_compiler: "))))) (if data (insert-string " ") (insert-string (let ((prinlevel 3)(prinlength 6)) (maknam (explode data)))) (new-line)) (insert-string " ") (insert-string msg) (new-line) (elcp-filled-print-region)))) (defun elcp-filled-print-region () (without-saving (runoff-fill-region)) (with-mark x (go-to-mark der-wahrer-mark) (do-forever (local-display-current-line) (if (mark-on-current-line-p x)(stop-doing)) (next-line))) (go-to-end-of-buffer))  emacs-macro-compile.lisp 08/20/86 2313.5r w 08/20/86 2245.0 93105 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; A hairy toy all for show. ;;; The Emacs keyboard macro compiler. ;;; BSG 2/18,24-25/78 (%include e-macros) (declare (special comment-column)) ;;; ;;; Interim grinder. ;;; (defun macomp-output-to-buffer (x) (macomp-bufout-r x nil) ;recurse (new-line)) (defun macomp-bufout-r (x indent) (if (null indent)(setq indent (cur-hpos)) else (whitespace-to-hpos indent)) (cond ((fixp x)(insert-string (decimal-rep x))(insert-string ".")) ((atom x)(insert-string (maknam (explode x)))) ((memq (car x) '(if if-at if-back-at lambda cond let)) (insert-string "(") (insert-string (car x)) (insert-string " ") (macomp-bufout-finish-form (cdr x)(cur-hpos))) ((eq (car x) 'defun) (insert-string "(defun ") (let ((hp (cur-hpos))) (macomp-bufout-r (cadr x) hp) (insert-string " ") (if (null (caddr x)) ;null lambda list (insert-string "()") else (macomp-bufout-r (caddr x) nil)) (new-line) (macomp-bufout-finish-form (cdddr x) hp))) ((and (eq (car x) 'quote)(null (cddr x))) (insert-string "'") (macomp-bufout-r (cadr x)(1+ indent))) ((eq (car x) 'do-forever) (insert-string "(do-forever ") (new-line) (macomp-bufout-finish-form (cdr x)(+ 2 indent))) ((memq (car x) '(prog2 progn)) (insert-string "(") (insert-string (car x)) (insert-string " ") (macomp-bufout-finish-form (cdr x)(cur-hpos))) ((eq (car x) 'prog) (insert-string "(prog ") (let ((hp (cur-hpos))) (macomp-bufout-r (cadr x) hp) (new-line) (do l (cddr x)(cdr l)(null l) (if (atom (car l)) (macomp-bufout-r (car l) 0) (if (> (cur-hpos)(1+ hp))(insert-string " ")) (setq l (cdr l))) (macomp-bufout-r (car l) hp) (if (not (null (cdr l)))(new-line))) (insert-string ")"))) (t (macomp-bufout-random-list (car x)(cdr x) indent)))) (defun macomp-bufout-random-list (the-car the-cdr indent) (insert-string "(") (macomp-bufout-r the-car (1+ indent)) (if (> (+ (cur-hpos) 4) comment-column) (setq indent (if (atom the-car)(+ 2 indent) else (+ 1 indent))) else (if (atom the-car))(setq indent (1+ (cur-hpos))) else (setq indent (1+ indent))) (do l the-cdr (cdr l) nil (if (null l)(insert-string ")")(stop-doing)) (if (atom l) (insert-string " . ") (macomp-bufout-r l nil) (insert-string ")") (stop-doing)) (if (and (> (+ (cur-hpos) 4) comment-column) (or (not (atom (cdr l))) (not (atom (car l))))) (new-line) (whitespace-to-hpos indent) else (if (not (and (back-at '/) )(not (atom (car l))))) (insert-string " "))) (macomp-bufout-r (car l) nil))) (defun macomp-bufout-finish-form (x hp) (do l x (cdr l)(null l) (macomp-bufout-r (car l) hp) (if (not (null (cdr l)))(new-line))) (insert-string ")")) ;;; ;;; The actual displaylist-keyboard-macro to Lisp compiler. ;;; (declare (special macomp-last-cmd macomp-prog-needed-p macomp-default-search-string)) (defun macomp-compile-to-expr (name interp) (setq macomp-last-cmd 'noop macomp-prog-needed-p nil macomp-default-search-string nil) (do ((outl nil)(inl (map 'macomp-preoptimize interp)(cdr inl)) (thisform)(thisfun)(lastfun '@) (thisct)(lastct -1)) ((null inl) (setq outl (nreverse outl)) (if macomp-prog-needed-p (setq outl (list (cons 'prog (cons '() outl))))) (append (list 'defun name '()) outl)) (setq thisform (macomp-term-compile inl)) (if (not (null thisform)) (setq thisfun (cond ((eq (car thisform) 'do-times) (setq thisct (cadr thisform)) (caddr thisform)) (t (setq thisct 1) thisform))) (if (equal thisfun lastfun) (setq outl (cons (list 'do-times (setq thisct (+ thisct lastct)) thisfun) (cdr outl))) else (if (and (eq (car thisfun) 'insert-string) (eq (car lastfun) 'insert-string)) (setq outl (cons (list 'insert-string (catenate (cadr lastfun) (cadr thisfun))) (cdr outl))) else (setq outl (cons thisform outl)))) (setq lastct thisct lastfun thisfun)))) (defun macomp-preoptimize (term) (let ((fun (cdar term))) (cond ((eq fun 'quote-char) (cond ((eq (cdadr term) 'String) (rplacd (cadr term) 'Input/ Characters))) (cond ((eq (cdadr term) 'Input/ Characters) ;;cant happen from macro edit buffer (cond ((samepnamep (caadr term) (ascii 15)) (rplaca (cadr term)(get_pname NL)))) (rplaca term (cons (get_pname (maknam (explode (caadr term)))) 'String)) (rplacd term (cddr term))) (t (rplaca term '("Quote-char saw no input" . %macomp-ierr))))) ((eq fun 're-execute-command) (rplacd (car term) macomp-last-cmd)) ((not (memq fun '(noop Numeric/ argument multiplier noop))) (setq macomp-last-cmd fun))))) (defun macomp-term-compile (term) (let ((sym (caar term))(fun (cdar term))) (cond ((eq fun 'noop) nil) ((eq fun '%macomp-ierr) (list 'error sym)) ((eq fun 'String) (setq sym (read-from-string sym)) (do-forever ;Reduce strings. (or (memq (cdadr term) '(rubout-char String))(stop-doing)) (if (eq (cdadr term) 'rubout-char) (if (not (> (stringlength sym) 0))(stop-doing)) (rplacd term (cddr term)) (setq sym (substr sym 1 (1- (stringlength sym))))) (if (eq (cdadr term) 'String) (setq sym (catenate sym (read-from-string (caadr term)))) (rplacd term (cddr term)))) (if (> (stringlength sym) 0) (list 'insert-string sym))) ((eq (cdadr term) 'Numeric/ argument) (macomp-comp-multipliers term)) ((eq fun 'multiplier) (macomp-comp-multipliers term)) ((let ((prop (get fun 'search-command))) (and prop (macomp-comp-searches prop term)))) ((memq fun '(next-line-command prev-line-command)) (let ((template (cond ((eq fun 'prev-line-command) '(if (firstlinep)(command-quit) else (prev-line))) (t '(if (lastlinep)(command-quit) else (next-line)))))) (if (get (cdadr term) 'linepos-insensitive) template else (list fun)))) ((eq fun 'macro-query) (setq macomp-prog-needed-p t) '(if (not (macro-query-get-answer))(return nil))) (t (list fun))))) (mapc '(lambda (x)(putprop x t 'linepos-insensitive)) '(go-to-beginning-of-line go-to-end-of-line skip-over-indentation indent-to-lisp indent-relative prev-line-command next-line-command)) (defun macomp-comp-searches (prop term) (prog (string cmd strterm escterm) (setq cmd (car prop) strterm (cdr term) escterm (cdr strterm)) (if (memq (cdar strterm) '(escape new-line)) ;null string (setq escterm strterm strterm '(("""""" . String)))) (if (and (eq (cdar strterm) 'String) (memq (cdar escterm) '(new-line escape))) (setq string (read-from-string (caar strterm))) (or (stringp (setq string (macomp-search-defaultify string))) (go sdf-err)) (setq cmd (list cmd string)) (if (eq (car cmd) 'regexp-search) (setq cmd (list 'let (list (list 'm cmd)) '(and m (progn (release-mark m) t))))) (return (prog2 0 (list 'if (list 'not cmd) '(search-failure-annunciator)) (rplacd term (cdr escterm)))) else (setq string (caar strterm)) (if (and (eq (cdar strterm) 'Input/ characters) (= (getcharn string (stringlength string)) 33)) (setq string (substr string 1 (1- (stringlength string)))) (or (stringp (setq string (macomp-search-defaultify string))) (progn (setq escterm strterm) (go sdf-err))) (return (prog2 0 (list 'if (list 'not (list cmd string)) '(search-failure-annunciator)) (rplacd term (cdr strterm)))))) (return '(error "Search string too complex. Edit the macro first.")) sdf-err (rplacd term (cdr escterm)) (return '(error "Default search string may not be assumed in extension.")))) (defun macomp-search-defaultify (s) (cond ((nullstringp s) macomp-default-search-string) (t (setq macomp-default-search-string s)))) (mapc '(lambda (x)(putprop (car x)(cdr x) 'search-command)) '((string-search forward-search) (reverse-string-search reverse-search) (regexp-search-command regexp-search) (incremental-search forward-search) (reverse-incremental-search reverse-search) (multi-word-search WORD-SEARCH-FRAMMIS))) (defun macomp-stfix-to-fixnum (x) (let ((ibase 10.))(read-from-string x))) (defun macomp-comp-multipliers (term) (let ((rest term)(num 1)) (do-forever (cond ((eq (cdadr rest) 'Numeric/ argument) (setq num (macomp-stfix-to-fixnum (caadr rest))) (setq rest (cddr rest))) ((eq (cdar rest) 'multiplier) (setq num (* 4 num)) (setq rest (cdr rest))) (t (stop-doing)))) (prog2 0 (let ((fun (cdar rest)) (data (caar rest))) ;look at function (cond ((eq fun 'String) (setq data (read-from-string data)) (rplaca (car rest) (maknam (explode (catenate (do ((l nil (cons c l)) (x 0 (1+ x)) (c (getchar data 1))) ((= x num) (get_pname (maknam l)))) (substr data 2))))) nil) ((get fun 'argwants) (setq rest (cdr rest)) (list 'do-times num (list fun))) (t (setq rest (cdr rest)) (list 'let (list (list 'numarg num))(list fun))))) (rplacd term rest))))  emacs-macro-edit.lisp 08/20/86 2313.5r w 08/20/86 2245.0 117342 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; Emacs keyboard macro editor ;;; February 16-18, 1979 by BSG ;;; Modified: 30 January 1984, Barmar: to fix parsing of ESC <+/->NUM. ;;; (%include e-macros) (declare (defpl1 date_time_af_ "date_time" (return char (26.) varying))) (declare (special fill-column macedit-whats-escape-today-vbl comment-prefix include-dir comment-column macedit-source-buffer)) (declare (*expr begin-defun find-file-subr find-key-in-buf get-key-binding get-key-name key-prompt kill-line-contents kmacro-display-interpret lisp-mode macomp-compile-to-expr macomp-output-to-buffer one-back-is-a parse-key-description)) (defun macedit-find-all-macros () (let ((l nil)) (mapatoms '(lambda (x) (let ((y (get x 'editor-macro))) (if y (setq l (cons (cons x y) l)))))) l)) ;Return the gotten list (defun macedit-display-all-macros-to-buffer () (mapc '(lambda (mac) (macedit-display-to-buffer (car mac)(cdr mac) (find-key-in-buf (car mac) macedit-source-buffer)) (new-line) (new-line)) (macedit-find-all-macros))) (defun macedit-display-to-buffer (fun list key) (insert-string (catenate "macro " fun)) (if key (insert-string (catenate " on " key))) (new-line) (insert-string " ") (mapc 'macedit-display-one-enmacroed-command-to-buffer (save-excursion-buffer (go-to-buffer macedit-source-buffer) (kmacro-display-interpret list))) (if (line-is-blank)(without-saving (kill-line-contents)) else (new-line)) (insert-string (catenate "end-macro " fun))) (defun macedit-display-one-enmacroed-command-to-buffer (comcons) (let ((key (car comcons)) (fun (cdr comcons))) (if (eq fun 'Input/ Characters) ;doublequote input chars (setq key (apply 'catenate (append '("." """") (mapcar '(lambda (x) (cond ((= x (CtoI """")) """""") (t (ItoC x)))) (exploden key)) '(""""))))) (if (> (+ 1 (stringlength key) (cur-hpos)) comment-column) (new-line) (insert-string " ") else (insert-string " ")) (insert-string key))) (defun macedit-find-beginning-of-macdef () (go-to-beginning-of-line) (do-forever (if (looking-at "macro")(stop-doing)) (if (firstlinep)(display-error "No macro definition found")) (prev-line))) (defun macedit-scan-atom () (macedit-skip-over-whitespace) (cond ((at-end-of-buffer) nil) ((looking-at ".""") (forward-char) (cons 'input-chars (macedit-scan-atom))) ((at '/" )(macedit-scan-quoted-string)) ((at '+) (forward-char) (macedit-scan-number)) ((at '-) (forward-char) (- (macedit-scan-number))) ((macedit-digitp (curchar)) (macedit-scan-number)) (t (with-mark begin (skip-to-whitespace) (intern (make_atom (point-mark-to-string begin))))))) (defun macedit-digitp (x) (or (numberp x)(setq x (CtoI x))) (and (> x (1- (CtoI "0")))(< x (1- (CtoI "9")))(- x (CtoI "0")))) (defun macedit-scan-number () (cond ((and (not (at-end-of-buffer)) (macedit-digitp (curchar))) (do ((acc 0) (dp (macedit-digitp (curchar)) (and (not (at-end-of-buffer)) (macedit-digitp (curchar))))) ((null dp) acc) (setq acc (+ (* 10. acc) dp)) (forward-char))) (t 1))) ;nothing, defaults to 1 (defun macedit-scan-quoted-string () (do ((s ""))(nil) (forward-char) (with-mark bos (if (forward-search """") (if-at '/" (backward-char) (setq s (catenate s (point-mark-to-string bos) """" )) (forward-char) else (backward-char) (setq s (catenate s (point-mark-to-string bos))) (forward-char) (release-mark bos) (return s)) else (go-to-mark bos) (release-mark bos) (display-error "Unbalanced string"))))) (defun macedit-skip-over-whitespace () (do-forever (skip-over-whitespace) (if (not (looking-at "/*"))(stop-doing)) (do-times 2 (forward-char)) (if (not (forward-search "*/")) (display-error "Unbalanced comment.")))) (defun macedit-produce-macro-definition () (prog (macname keyname mlist) (macedit-find-beginning-of-macdef) (or (eq (macedit-scan-atom) 'macro) (return '(nil . "Mangled macro definition"))) (setq macname (macedit-scan-atom)) (if (memq macname '(nil end-macro on)) (return '(nil . "Bad or empty macro definition"))) (macedit-skip-over-whitespace) (if (looking-at "on") ;Key given (macedit-scan-atom) (setq keyname (macedit-scan-atom))) (do ((x nil (nconc (macedit-scan-commands) x))) ((memq (car x) '(macend error)) (setq mlist x))) (if (eq (car mlist) 'error)(return (cadr mlist))) (if (not (eq macname (macedit-scan-atom))) (return '(nil . "Macro end does not match beginning"))) (return (list macname keyname (nreverse mlist))))) (defun macedit-scan-commands () (if (or (not (boundp 'macedit-whats-escape-today-vbl)) (null macedit-whats-escape-today-vbl)) (setq macedit-whats-escape-today-vbl (cadr (parse-key-description (find-key-in-buf 'escape macedit-source-buffer))))) ;Feelthy magic. (let ((atom (macedit-scan-atom))) (cond ((eq atom nil)(list 'error "Macro ran off end.")) ((eq atom 'end-macro)(list 'macend)) ((numberp atom)(nreverse (exploden (decimal-rep atom)))) ((symbolp atom) (if (and (> (stringlength atom) 5) (samepnamep (substr atom 1 5) "meta-")) (+ 200 (cadr (parse-key-description (substr atom 6)))) else (setq atom (parse-key-description atom)) (cond ((= (car atom) 1) ;escape char (list (cadr atom) (cons 'toplevel-char macedit-whats-escape-today-vbl))) ((caddr atom) ;prefix char (list (cadr atom)(cons 'toplevel-char (caddr atom)))) (t (list (cons 'toplevel-char (cadr atom))))))) ;no pfx, no esc ((stringp atom) (mapcar '(lambda (x)(cons 'toplevel-char x)) (nreverse (exploden atom)))) ((and (not (atom atom))(eq (car atom) 'input-chars)) (nreverse (exploden (cdr atom)))) (t (break macedit-scan-commands t))))) (defprop emacro macro-edit-mode suffix-mode) (defun macro-edit-mode () (setq current-buffer-mode 'Macro/ Edit) (establish-local-var 'macedit-source-buffer current-buffer) (mapc '(lambda (x)(set-key (car x)(cadr x))) '((ESC-^A macedit-find-beginning-of-macdef) (ESC-^B macedit-backward-term) (ESC-^C macedit-compile-to-lisp) (ESC-^E macedit-find-end-of-macdef) (ESC-^F macedit-forward-term) (ESC-^H macedit-mark-whole-macro) (ESC-^K macedit-kill-term) (ESC-^N macedit-forward-macdef) (ESC-^P macedit-backward-macdef) (ESC-^S macedit-state-keyboard-macro) (ESC-^Z macedit-take-up-definition))) (setq comment-prefix "/*" comment-column 51.)) (defun macedit-state-keyboard-macro () (let ((k (key-prompt "Macro Key: "))) (let ((f (save-excursion-buffer (go-to-buffer macedit-source-buffer) (get-key-binding k)))) (let ((l (get f 'editor-macro))) (if (null l) (display-error " " (get-key-name k) " is not a macro.")) (go-to-end-of-buffer) (macedit-display-to-buffer f l (get-key-name k)) (new-line))))) (defun macedit-take-up-definition () (macedit-find-beginning-of-macdef) (let ((mac (macedit-produce-macro-definition))) (if (car mac) (putprop (car mac)(caddr mac) 'editor-macro) (if (cadr mac)(set-perm-key (cadr mac)(car mac))) else (display-error-noabort (cdr mac))))) (defun load-these-macros () (go-to-beginning-of-buffer) (do-forever (macedit-skip-over-whitespace) (if (at-end-of-buffer)(stop-doing)) (if (looking-at "macro") (macedit-take-up-definition) else (display-error "Bad format in macro file")))) (defun load-macrofile (filepath) (save-excursion-buffer (load-macrofile- filepath))) (defun load-macrofile- (filepath) (let ((thatbuf current-buffer)) (find-file-subr filepath) (macro-edit-mode) (setq macedit-source-buffer thatbuf) (load-these-macros) (go-to-beginning-of-buffer))) (defun edit-macrofile () (load-macrofile- (trim-minibuf-response "Edit Macro File: " NL))) (defun edit-macros () (let ((thatbuf current-buffer)) (go-to-or-create-buffer 'emacs-macros) (if (empty-buffer-p current-buffer) (insert-string "/* Emacs macros ") (with-mark m (insert-string (date_time_af_)) (go-to-mark m) (insert-string (prog2 0 (macedit-scan-quoted-string) (go-to-mark m) (without-saving (kill-to-end-of-line))))) (insert-string " */") (do-times 2 (new-line)) (macro-edit-mode) else (go-to-end-of-buffer)) (setq macedit-source-buffer thatbuf) (save-excursion (macedit-display-all-macros-to-buffer)))) ;;; ;;; Crufty lispmode-like functions ;;; (defprop macedit-forward-term t argwants) (defun macedit-forward-term () (macedit-skip-over-whitespace) (if (not (at-end-of-buffer)) (macedit-scan-atom))) (defprop macedit-forward-macdef t argwants) (defun macedit-forward-macdef () (if (and (bolp)(looking-at "macro")) (macedit-scan-atom)) (do-forever (macedit-skip-over-whitespace) (if (at-end-of-buffer)(stop-doing)) (if (and (bolp)(looking-at "macro")) (stop-doing)) (macedit-scan-atom))) (defun macedit-find-end-of-macdef () (macedit-find-beginning-of-macdef) (do-forever (if (eq (macedit-scan-atom) 'end-macro) (macedit-scan-atom) (go-to-end-of-line) (stop-doing)) (if (at-end-of-buffer)(stop-doing)))) (defun macedit-mark-whole-macro () (macedit-find-beginning-of-macdef) (set-the-mark) (macedit-find-end-of-macdef)) (defprop macedit-kill-term forward kills) (defprop macedit-kill-term t argwants) (defun macedit-kill-term () (with-mark m (macedit-forward-term) (wipe-point-mark m))) (defun macedit-skip-back-whitespace () (do-forever (skip-back-whitespace) (if (at-beginning-of-buffer)(stop-doing)) (if-back-at '// (if (one-back-is-a '*) (if (not (reverse-search "/*")) (display-error "Unbalanced comment.")) else (stop-doing)) else (stop-doing)))) (defprop macedit-backward-term t argwannts) (defun macedit-backward-term () (macedit-skip-back-whitespace) (if-back-at '/" (macedit-skip-back-quoted-string) else (skip-back-to-whitespace))) (defun macedit-skip-back-quoted-string () (do-forever (backward-char) (if (not (reverse-search """")) (display-error "Unbalanced string.")) (if-back-at '/" nil else (stop-doing))) (if-back-at '/. (backward-char))) (defun macedit-backward-macdef () (if (firstlinep)(go-to-beginning-of-line) else (if (and (bolp)(looking-at "macro")) (backward-char)) (macedit-find-beginning-of-macdef))) ;;; ;;; Here's some new ground ... ;;; Automatic Lisp-program writing. ;;; BSG 2/18/79 (defun macedit-compile-to-lisp () (macedit-find-beginning-of-macdef) (let ((mac (macedit-produce-macro-definition))) (if (null (car mac)) (display-error "Syntax error: " (cdr mac))) (let ((interp (save-excursion-buffer (go-to-buffer macedit-source-buffer) (kmacro-display-interpret (caddr mac))))) (go-to-or-create-buffer (intern (make_atom (catenate macedit-source-buffer ".e-macros.lisp")))) (if (empty-buffer-p current-buffer)(lisp-mode) (macomp-output-to-buffer '(%include e-macros)) (insert-string ";;; e-macros.incl.lisp is found in ") (insert-string include-dir) (do-times 2 (new-line)) else (go-to-end-of-buffer)) (if (cadr mac) (macomp-output-to-buffer (list 'set-perm-key (get_pname (cadr mac)) (list 'quote (car mac))))) (macomp-output-to-buffer (macomp-compile-to-expr (car mac) interp)) (new-line) (begin-defun)))) (define-autoload-lib emacs-macro-compile macomp-output-to-buffer macomp-compile-to-expr)  emacs-object-mode.lisp 08/20/86 2313.5rew 08/20/86 2242.9 115704 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; Emacs Object Mode, because it was necessary. ;;; HISTORY COMMENTS: ;;; 1) change(81-05-05,Soley), approve(), audit(), ;;; install(86-08-20,MR12.0-1136): ;;; pre-hcom history: ;;; Originally written. ;;; 2) change(86-02-24,Margolin), approve(86-02-24,MCR7325), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Converted to use the new e_multics_files_ primitives. Changed the # ;;; read-macro to the more standard #o macro. Changed lsh/boole ;;; combinations into ldb. ;;; END HISTORY COMMENTS ;;; (%include e-macros) (%include emacs-internal-macros) (%include defun) (%include other_other) (%include sharpsign) (%include runtime) (eval-when (eval compile load) (sstatus feature runtime)) ; write-around bug (declare (special object-mode-count object-mode-chars last-input-char known-buflist NL object-mode-total) (*lexpr absolute-pathname close-file open-file) (*expr check-minibuffer-file-command open-star-name-single)) ;;; Returns octal string representation, padded on the left with 0. (defun pad-left-octal (number) (let ((rep (octal-rep number))) (cond ((= (stringlength rep) 3) rep) ((= (stringlength rep) 2) (catenate "0" rep)) ('else (catenate "00" rep))))) (defun pad-left-6octal (number) (let ((rep (octal-rep number))) (catenate (substr "000000" 1 (- 6. (stringlength rep))) rep))) ;;; Returns octal string representation. (defun octal-rep (x) (let ((base 8.) (*nopoint t)) (maknam (explodec x)))) ;;; This is the end-of-file-function for object-mode-read-file. (defun object-mode-eoffn (a b) a b (throw 'done object-mode-tag)) ;;; This functions reads in a file, inserting the object in object-mode ;;; format into the current buffer. Doesn't check pathname at all. (defun object-mode-read-file (pathname) (let ((read-only-flag nil)) (destroy-buffer-contents) (setq object-mode-count 0 object-mode-chars () fpathname (e_lap_$rtrim pathname) object-mode-total 0) (let ((fo (open pathname '(in ascii fixnum)))) (eoffn fo 'object-mode-eoffn) (minibuffer-remark "Reading...") (catch (do () (()) (object-mode-read-word fo)) object-mode-tag) (close fo)) (or (zerop object-mode-count) (object-mode-finish-line)) (go-to-beginning-of-buffer) (setq buffer-modified-flag nil))) ;;; Function to read in one word from the input file and update ;;; the current line with that information. (defun object-mode-read-word (file) (let ((word (in file))) (setq object-mode-count (1+ object-mode-count)) (let ((c1 (ldb #o3311 word)) (c2 (ldb #o2211 word)) (c3 (ldb #o1111 word)) (c4 (ldb #o0011 word))) (setq object-mode-chars (list* c4 c3 c2 c1 object-mode-chars)) (insert-string (catenate (pad-left-octal c1) " " (pad-left-octal c2) " " (pad-left-octal c3) " " (pad-left-octal c4) " ")))) (and (= object-mode-count 3) (object-mode-finish-line))) ;;; Finish off a line of object. (defun object-mode-finish-line () (save-excursion (go-to-beginning-of-line) (insert-string (pad-left-6octal object-mode-total)) (insert-string " ")) (setq object-mode-total (+ object-mode-total 3)) (or (= object-mode-count 3) (do n object-mode-count (1+ n) (> n 2) (insert-string " "))) (setq object-mode-count 0) (do ((n 0 (1+ n)) (chars (nreverse object-mode-chars) (cdr chars))) ((or (null chars) (= n 12.))) (and (zerop (\ n 4)) (insert-string " ")) (let ((this (car chars))) (object-mode-insert-letter this))) (setq object-mode-chars ()) (new-line)) ;;; To write an object file. Real work done below: this just insures ;;; access, etc. (defun object-mode-write-file (file-name &aux (file-object nil)) (protect (setq file-object (open-file file-name 'write-force)) (object-mode-write (absolute-pathname (fobj-path file-object))) &always ;;restore access, bit-count set by "close" below ;; this kludge necessary because "close" may also ;; terminate the segment (let ((new-fo (open-file file-name 'write nil))) (when new-fo (setf (fobj-original-access new-fo) ;copy access restoration info (fobj-original-access file-object)) ;to useful file object (close-file new-fo nil) ;restore access (setf (fobj-original-access file-object) nil))) (close-file file-object nil))) ;clean up FCB ;;; Function to output an object-code buffer. Besides the side ;;; effect of writing out the buffer, returns 4 times the amount ;;; of words in the file. (defun object-mode-write (file) (save-excursion (let ((fo (open file '(out ascii fixnum)))) (go-to-beginning-of-buffer) (setq object-mode-count 0) (minibuffer-remark "Writing...") (let ((total-words 1)) (catch (do () (()) (object-mode-write-word fo) (setq total-words (1+ total-words))) object-mode-tag) (setq buffer-modified-flag nil fpathname (e_lap_$rtrim file)) (minibuffer-remark "Written.") (close fo) (* 4. total-words))))) ;;; Reads the octal word at the point in the buffer, and moves ;;; forward to the next group. (defun object-mode-get-octal () (with-mark beginning-of-word (forward-word) (prog1 (readlist (exploden (point-mark-to-string beginning-of-word))) (forward-char)))) ;;; Function to output a single word of a file, given that we ;;; are at the beginning of the representation of that word ;;; in the buffer. (defun object-mode-write-word (file) (and (zerop (cur-hpos)) (go-to-hpos 9.)) (out file (+ (lsh (object-mode-get-octal) 27.) (lsh (object-mode-get-octal) 18.) (lsh (object-mode-get-octal) 9.) (object-mode-get-octal))) (forward-char) (forward-char) (setq object-mode-count (1+ object-mode-count)) (cond ((= 3 object-mode-count) (setq object-mode-count 0) (next-line))) (cond ((or (line-is-blank) (eolp) (looking-at " ")) (throw 'done object-mode-tag)))) ;;; Insert letter in letters column. (defun object-mode-insert-letter (number) (cond ((and (> number #o37) (< number #o177)) (insert-char (ItoC number))) ('else (insert-char ".")))) ;;; Give an error message stipulating that we're in ;;; a non-editable column. (defun object-mode-bad-column () (display-error "Nothing to edit in this column.")) ;;; Decides what type of column we are currently in: ;;; 'numbers => the numeric kind of column. ;;; 'letters => the alphabetic kind of column. ;;; If in a bad column type, gives an error message. (defun object-mode-column-type () (let ((h (cur-hpos))) (cond ((< h 9.) (object-mode-bad-column)) ((or (> h 77.) (eolp)) (object-mode-bad-column)) ((> h 63.) (cond ((member h '(68. 73.)) (object-mode-bad-column)) ('else 'letters))) ((eq (curchar) '/ ) (object-mode-bad-column)) ('else 'numbers)))) ;;; Given that we are IN a numeric column, this updates this ;;; group of numbers AND the associated ascii to the right. We ;;; assume that the new number has been inserted already. (defun object-mode-update-number () (save-excursion (forward-char) (backward-word) (let ((h (- (cur-hpos) 9.)) (number (with-mark beginning-of-word (forward-word) (readlist (exploden (point-mark-to-string beginning-of-word)))))) (go-to-hpos (+ 64. (* (// h 18.) 5.) (// (\ h 18.) 4.))) (delete-char) (object-mode-insert-letter number)))) ;;; Given that we are IN a letter column, this updates this ;;; letter AND the associated numbers to the right. We ;;; assume that the new letter has been inserted already. (defun object-mode-update-letter () (save-excursion (let ((h (- (cur-hpos) 64.)) (number (CtoI (curchar)))) (delete-char) (object-mode-insert-letter number) (go-to-hpos (+ 9. (* 18. (// h 5.)) (* 4. (\ h 5)))) (delete-word) (insert-string (pad-left-octal number))))) ;;; Replacement for self-insert. (defun object-mode-self-insert () (cond ((eq (object-mode-column-type) 'letters) (let ((read-only-flag nil)) (delete-char) (insert-char last-input-char) (backward-char) (object-mode-update-letter))) ((member last-input-char '(/0 /1 /2 /3 /4 /5 /6 /7)) (let ((read-only-flag nil)) (delete-char) (insert-char last-input-char) (backward-char) (object-mode-update-number))) ('else (display-error "You may only enter an octal number in this column."))) (object-mode-forward-char)) ;;; Replacement for quote-char. (defun object-mode-quote-char () (let ((last-input-char (make_atom (ItoC (get-char))))) (object-mode-self-insert))) ;;; Save-same-file for object mode. (defcom object-mode-save-same-file (check-minibuffer-file-command) (or fpathname (display-error "No default pathname for this buffer.")) (object-mode-write-file fpathname)) ;;; write-file for object mode. (defcom object-mode-write-buffer &args ((file &prompt "Write Object File: " &default &eval (or fpathname (display-error "No default pathname for this buffer.")))) (check-minibuffer-file-command) (or file (display-error "No default pathname for this buffer.")) (object-mode-write-file file)) ;;; Command to read a file in in object mode. (defcom object-mode-find-file &args ((name &prompt "Find Object File: " &default &eval (display-error "You must supply a pathname."))) (let ((in (open-star-name-single name 'read))) ;Check existence/access (close-file in nil) (setq name (fobj-path in)) (unless (nullstringp (pn-component name)) (report-error 'error_table_$archive_pathname)) (go-to-or-create-buffer (object-mode-pick-buffer (pn-entry name))) (object-mode-read-file (absolute-pathname name)) (object-mode))) ;;; Pick a good buffer to go to. (defun object-mode-pick-buffer (buffer) (cond ((memq (make_atom buffer) known-buflist) (ring-tty-bell) (object-mode-pick-buffer (minibuf-response (catenate "Buffer " buffer " is already in use. New buffer: ") NL))) ('else (make_atom buffer)))) ;;; Same as read-file for object-mode. When using this, ;;; we can assume you are in an object-mode buffer. (defcom object-mode-read-command &prologue &eval (or (eq current-buffer-mode 'Object) (display-error "You must be in Object mode.")) &args ((name &prompt "Read Object File: " &default &eval (or fpathname (display-error "No default pathname for this buffer.")))) (let ((in (open-star-name-single name 'read))) (close-file in nil) (setq name (fobj-path in)) (unless (nullstringp (pn-component name)) (report-error 'error_table_$archive_pathname)) (object-mode-read-file (absolute-pathname name)))) ;;; Go forward one character in an interesting way. (defcom object-mode-forward-char (forward-char) (let ((h (cur-hpos))) (cond ((< h 60.) (skip-over-whitespace-in-line)) ((= h 60.) (next-line) (go-to-hpos 9.)) ((member h '(68. 73.)) (forward-char)) ((eolp) (next-line) (go-to-hpos 64.))))) ;;; Instate object mode. (defun object-mode () (setq current-buffer-mode 'Object) (setq read-only-flag 't) (map-over-emacs-commands '(lambda (symbol function junk) junk (and (eq function 'self-insert) (set-key symbol 'object-mode-self-insert))) ()) (set-key "^M" 'object-mode-self-insert) (set-key "^Q" 'object-mode-quote-char) (set-key "^X-^S" 'object-mode-save-same-file) (set-key "^X-^W" 'object-mode-write-buffer) (set-key "^X-^R" 'object-mode-read-command))  emacs-overwrite-mode.lisp 08/20/86 2313.5r w 08/20/86 2245.0 32823 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; Modified: 1 July 1981 RMSoley to use Multics rubout character ;;; and to add overwrite-mode-off. ;;; Modified: 3 December 1983 B. Margolin to fix overwrite-mode-off ;;; to correctly reset ^D. ;;; (%include e-macros) (declare (special MCS-editing-characters) (*expr self-insert)) (defun rubout-character macro (form) '(ItoC (cadr MCS-editing-characters))) (defun overwrite-mode () (assert-minor-mode 'overwrite) (set-key 'esc-D 'overwrite-mode-delete-word) (set-key 'esc-# 'overwrite-mode-rubout-word) (set-key 'esc-\177 'overwrite-mode-rubout-word) (set-key (rubout-character) 'overwrite-mode-rubout-char) (set-key '\177 'overwrite-mode-rubout-char) (set-key '^D 'overwrite-mode-delete-char) (map-over-emacs-commands '(lambda (sym fun arg) (and (eq fun 'self-insert) (set-key sym 'overwrite-mode-self-insert)) arg) nil)) (defprop overwrite-off overwrite-mode-off expr) (defprop overwriteoff overwrite-mode-off expr) (defun overwrite-mode-off () (negate-minor-mode 'overwrite) (set-key 'esc-D 'delete-word) (set-key 'esc-# 'rubout-word) (set-key 'esc-\177 'rubout-word) (set-key (rubout-character) 'rubout-char) (set-key '\177 'rubout-char) (set-key '^D 'delete-char) (map-over-emacs-commands '(lambda (sym fun arg) (and (eq fun 'overwrite-mode-self-insert) (set-key sym 'self-insert)) arg) nil)) (defun overwrite-mode-self-insert () (or (eolp)(delete-char)) (self-insert)) (defun overwrite-mode-delete-char () (if (not (eolp)) (delete-char) (insert-char " "))) ;;; old delete-char left cursor in same place, "gobbled" chars ;;;(defun overwrite-mode-delete-char () ;;; (if (not (eolp)) ;;; (if (at-white-char)(forward-char) ;;; else (delete-char) ;;; (save-excursion ;;; (skip-to-whitespace) ;;; (insert-string " "))))) (defun overwrite-mode-rubout-char () (or (bolp)(progn (backward-char) (delete-char) (insert-char " ") (backward-char)))) (defprop overwrite-mode-delete-word forward kills) (defun overwrite-mode-delete-word () (with-mark m (forward-word) (let ((hp (cur-hpos))) (kill-backwards-to-mark m) (spaces-to-hpos hp))) (merge-kills-forward)) (defprop overwrite-mode-rubout-word reverse kills) (defun overwrite-mode-rubout-word () (with-mark m (let ((hpos (cur-hpos))) (backward-word) (kill-forward-to-mark m) (merge-kills-reverse) (save-excursion (spaces-to-hpos hpos))))) (defun spaces-to-hpos (x) (do ((hpdiff (- x (cur-hpos)) (1- hpdiff))) ((< hpdiff 1)) (insert-char " "))) (defun overwrite-mode-insert-string (string) (with-mark start (let ((start-pos curpointpos)) (go-to-end-of-line) (if (< (- curpointpos start-pos) (stringlength string)) (kill-backwards-to-mark start) else (go-to-mark start) (do-times (stringlength string) (delete-char))))) (insert-string string))  emacs-text-mode.lisp 08/20/86 2313.5r w 08/20/86 2245.0 12906 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1981 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; Text mode, cause why not. ;;; Richard Mark Soley 23 November 1981 ;;; Modified sometime before 2 November 1984 by B. Margolin to ;;; allow text-mode-delete-line-indentation to take a numeric ;;; argument. ;;; (%include e-macros) (declare (special SPACE text-mode-hook)) (declare (*expr delete-line-indentation fill-mode)) (defcom text-mode (setq current-buffer-mode 'Text) (establish-local-var 'comment-column 0) (establish-local-var 'comment-prefix "") (mapc '(lambda (x) (set-key (car x) (cadr x))) '( (ESC-^ text-mode-delete-line-indentation) )) (fill-mode) (and (boundp 'text-mode-hook) (funcall text-mode-hook))) (defcom text-mode-delete-line-indentation &numeric-argument (&pass) (delete-line-indentation) (insert-string SPACE)) (defcom-synonym runoff-mode text-mode) (defcom-synonym compose-mode text-mode)  emacs_pl1_mode_.lisp 08/20/86 2313.5r w 08/20/86 2245.0 417339 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; Multics EMACS PL/I mode ;;; Bernie Greenberg and statement_type_, Memorial Day Weekend, '78. ;;; ;;; Change History ;;; ;;; 1) Paul Schauble ;;; 03/05/79 Added hooks for compile-buffer and error scan mode. ;;; 03/07/79 Added comment mode for pl1. ;;; ;;; 2) Gary Dixon ;;; 04/02/79 Added improved pl1dcl (ESC-^D) ;;; 05/07/80 Merge GDixon's changes with installed pl1-mode ;;; 05/13/80 Added pl1-comment-current-line and comment style ;;; 3) Richard Mark Soley ;;; 24 November 1981 Fixed pl1dcl to not use backward-word. ;;; 4) Barry Margolin ;;; 3 December 1983 Fixed ^ZI to give a reasonable error if ;;; fpathname is null, and to leave the cursor ;;; in a more reasonable place. ;;; 19 January 1984 Fixed pl1-error-list-builder to recognize ;;; FATAL ERROR, not misuse pl1-indentation, ;;; and move register-option forms to e_option_defaults_. ;;; (%include e-macros) (declare (*expr delete-blank-lines delete-line-indentation delete-word exit-error-scan-mode filloff fillon get-key-binding mark-at-current-point-p open-space runoff-fill-region set-fill-column unwind-sexp-searchers-marks-and-nlgoto backward-n-chars)) (declare (special pl1-interesting-keywords good-word-charactertbl pl1-wordscantable pl1-com-quote-lab-charactertbl comment-prefix comment-prefix-trim ; comment data comment-suffix pl1-box-start pl1-mid-box fill-prefix fill-column ; fill-mode data fill-mode-delimiters pl1-key-bindings-pre-fill error-list-builder error-list e-list ; error scan data mode-identification macro-execution-in-progress ; prevent redisplay for printing tty's buffer-minor-modes buffer-uid ; buffer stuff current-buffer-mode compiler compile-options ; compile-buffer pl1-compile-options pl1-inding-style ; pl1-mode options pl1-dcl-style pl1-dcl-column pl1-line-length pl1-comment-column pl1-comment-column-delta pl1-comment-style)) (declare (defpl1 entry_point_dcl_ "get_entry_point_dcl_$emacs" (char (*)) (fixed bin) (fixed bin) ; pl1dcl support (return char(2000.) varying) (return char(32.) varying) (return char (100.) varying))) (declare (defpl1 cv_dec_check_ "" (char(*)) (return fixed bin(35.)) (return fixed bin(35.)))) (setq pl1-wordscantable (charscan-table "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz$_0123456789")) (setq pl1-com-quote-lab-charactertbl (charscan-table """/:")) (setq pl1-interesting-keywords '(proc end begin do procedure if else on dcl declare)) (defvar ((pl1-mode-hook nil) (COLON '/:) (OPEN-PAREN '/( ) (CLOSE-PAREN '/) ) (SEMI '/; ) (SLASH '// ) (FF (ascii 14)) (TAB (ascii 11)) (pl1-indentation 5) (pl1-first-column 10.))) ;;; ;;; ;;; PL/I MODE ;;; ;;; (register-option 'pl1-indentation 5) ;moved to e_option_defaults_ ;;; (register-option 'pl1-first-column 10.) ;moved to e_option_defaults_ ;;; (register-option 'pl1-compile-options "-table") ;moved to e_option_defaults_ ;;; (register-option 'pl1-inding-style 1) ;moved to e_option_defaults_ ;;; (register-option 'pl1-dcl-style 1) ;moved to e_option_defaults_ ;;; (register-option 'pl1-dcl-column 41.) ;moved to e_option_defaults_ ;;; (register-option 'pl1-line-length 112.) ;moved to e_option_defaults_ ;;; (register-option 'pl1-comment-style 1) ;moved to e_option_defaults_ ;;; (register-option 'pl1-comment-column 61.) ;moved to e_option_defaults_ ;;; (register-option 'pl1-comment-column-delta 10.) ;moved to e_option_defaults_ (defcom pl1-mode &numeric-argument (&reject) (register-local-var 'compiler) ; per-buffer compiler for a ; possible CDS mode, etc. (establish-local-var 'compile-options pl1-compile-options) (register-local-var 'pl1-line-length) ; per-buffer maximum line len (register-local-var 'pl1-inding-style) ; per-buffer indenting style ; =1: do; /* like the indent command */ ; ..... ; end; ; ; =2: do; ; ..... ; end; ; (register-local-var 'pl1-dcl-style) ; per-buffer declare style ; =0: dcl x entry (...); ; /* no line breaking, 1 space between tokens. ; ; =1: dcl x entry (..., ; ....,....); ; /* like indent command, assumes dcl in column 0, followed ; by 2 spaces and variable name. Lines are folded into ; column 10 when longer than pl1-line-length. */ ; ; =2: dcl x entry (...., ; ....,....); ; /* dcl begins in column 5, variable name in column 10, ; attributes in column 40 (to make variable names easier ; to find), with lines folding into column 45 when ; longer than pl1-line-length. See also ESC-SP. */ ; (register-local-var 'pl1-dcl-column) ; per-buffer column in which ; attributes start when in ; pl1-dcl-style 2 (register-local-var 'pl1-comment-style) ; per-buffer comment control for comments on lines whose text extends ; beyond comment column. Values are: ; ; =1: comment placed after text on the current line ; ; =2: if text extends beyond ; (pl1-comment-column + pl1-comment-column-delta) ; then comment placed on a new line below current line. Else ; comment placed after text on the current line. ; ; =3: comment placed on new line following text ; (register-local-var 'pl1-comment-column) ; per-buffer comment column (register-local-var 'pl1-comment-column-delta) ; per-buffer comment delta (register-local-var 'good-word-charactertbl) ; per-buffer PL/I word tbl (register-local-var 'mode-identification) ; per-buffer error scan mode (register-local-var 'error-list-builder) ; per-buffer name of error ; scan routine. (register-local-var 'comment-prefix) ; per-buffer comment start (register-local-var 'comment-prefix-trim) (register-local-var 'comment-suffix) ; per-buffer comment end (register-local-var 'pl1-key-bindings-pre-fill) ; per-buffer saved key bind. (register-local-var 'pl1-box-start) ; per-buffer comment box mark (register-local-var 'pl1-mid-box) ; mid comment box insert flag (setq current-buffer-mode 'PL//I ; PL/I mode comment-prefix "/* " ; PL/I comment delimiters comment-prefix-trim "/*" comment-suffix "*/" good-word-charactertbl pl1-wordscantable ; Use PL/I words for word ; scanning compiler "pl1" ; Use pl1 compiler compile-options pl1-compile-options mode-identification -2 ; Setup for error scan mode error-list-builder 'pl1-error-list-builder) (if (boundp 'error-list) ; end error scan mode if needed. (if error-list (exit-error-scan-mode)) else (setq error-list nil e-list nil)) (negate-minor-mode 'electric) (mapc '(lambda (x) ; Establish key bindings (set-key (car x) (cadr x))) '((TAB indent-pl1-statement) (/: self-insert) ;electro negate (/; self-insert) (ESC-N pl1-comment-next-line) (ESC-P pl1-comment-prev-line) (ESC-Q undefined-command) ; Avoid paragraph-fill (ESC-^A pl1-backward-statement) (ESC-^C compile-buffer) (ESC-^D pl1dcl) (ESC-^E pl1-forward-statement) (ESC-^H roll-back-pl1-indentation) ;;; (ESC-^Q pl1-reindent-region) ; This is not ready (ESC-TAB pl1-tab-one-more-level) (ESC-CR pl1-cret-and-indent) (ESC-/; pl1-comment-current-line) (ESC-* pl1-comment-end) (ESC-SPACE pl1-skip-to-dcl-column) (^X^D locate-next-error) (^XT exit-error-scan-mode) (^XC pl1-comment-box) (^ZC pl1-refill-comment-box-region) (^ZD pl1-line-between-procs) (^ZI pl1-include-file-comment-start-end))) (if pl1-mode-hook (errset (funcall pl1-mode-hook)))) ;;; ;;; ELECTRIC PL/I MODE ;;; (defcom electric-pl1-mode &numeric-argument (&reject) (pl1-mode) (electric-mode)) (defprop elpl1 electric-mode expr) (defcom electric-mode &numeric-argument (&reject) (set-key '/; 'electric-pl1-semicolon) (set-key '/: 'electric-pl1-colon) (assert-minor-mode 'electric)) ;;; ;;; The following set of functions do PL/I lexical analysis. ;;; (defun get-pl1-token-forwards () (prog () lupo (skip-over-whitespace) (if (at-end-of-buffer)(return nil)) (let ((rh (curchar))) (if (looking-at comment-prefix-trim) (skip-forwards-pl1-comment) (go lupo)) (if (memq rh '(/- /+ /* // /, /. /; /: /& /| /^ /= /< /> /( /) /%)) (forward-char) (return rh)) (if-at "/" (forward-char)(return rh)) (if-at """" (return (get-pl1-quoted-string-forward))) (return (with-mark start-token (forward-word) (point-mark-to-string start-token)))))) (defun skip-forwards-pl1-comment () (do-times (stringlength comment-prefix-trim) (forward-char)) (if (not (forward-search comment-suffix)) (display-error-noabort "Unbalanced Comment") (unwind-sexp-searchers-marks-and-nlgoto))) (defun get-pl1-quoted-string-forward () (with-mark bgqs (prog () loop (forward-char) (if (forward-search """") else (display-error-noabort "Unbalanced PL/I quotes") (go-to-mark bgqs) (release-mark bgqs) (unwind-sexp-searchers-marks-and-nlgoto)) (if-at """" (go loop)) (return (point-mark-to-string bgqs))))) (defun skip-pl1-whitespace () (do-forever (skip-over-whitespace) (if (looking-at comment-prefix-trim) (skip-forwards-pl1-comment) else (return nil)))) (defun get-pl1-token-backwards () (prog () lupo (skip-back-whitespace) (let ((lh (lefthand-char))) (if (at-beginning-of-buffer) (return nil)) (if (looking-back-at comment-suffix) (skip-backwards-pl1-comment) (go lupo)) (if (memq lh '(/- /+ /* // /, /. /; /: /& /| /^ /= /< /> /( /) /%)) (backward-char) (return lh)) (if (eq lh '/") (return (get-pl1-quoted-string-backwards))) (if-back-at '// (backward-char) (return lh)) (return (with-mark endtoken (backward-word) (point-mark-to-string endtoken)))))) (defun get-pl1-quoted-string-backwards () (with-mark endqs (prog () loop (backward-char) (if (reverse-search """") else (display-error-noabort "Unbalanced PL/I quotes") (go-to-mark endqs) (release-mark endqs) (unwind-sexp-searchers-marks-and-nlgoto)) (if-back-at '/" (go loop)) (return (point-mark-to-string endqs))))) (defun skip-backwards-pl1-comment () (do-times (stringlength comment-suffix) (backward-char)) (if (not (reverse-search comment-prefix-trim)) (display-error-noabort "Unbalanced comment") (unwind-sexp-searchers-marks-and-nlgoto))) (defun get-pl1-statement-backwards () (let ((lt (get-pl1-token-backwards))) (and lt (do ((a-building (ncons lt) (cons curtoken a-building)) (curtoken)) (nil) (setq curtoken (get-pl1-token-backwards)) (if (eq curtoken nil) (return (cons lt a-building))) (if (eq curtoken SEMI) (forward-char) (return (cons lt a-building))))))) (defun pl1-find-start-prev-sta () (save-excursion (prog (prev-sta incomplete-flag) chomp-backwards-some-more (setq prev-sta (get-pl1-statement-backwards)) (or prev-sta (return 'first-statement)) (if (eq (car prev-sta) COLON) ;guy just typed label (go chomp-backwards-some-more)) (if (not (eq (car prev-sta) SEMI)) (setq incomplete-flag t)) (setq prev-sta (cdr prev-sta)) ;real stuff (setq prev-sta (pl1-skip-over-labels prev-sta t)) (skip-pl1-whitespace) (return (list (set-mark)(cur-hpos) prev-sta incomplete-flag))))) ;;; ;;; ;;; This set of functions parse PL/I statements, ALL PL/I statements. ;;; (defun pl1-skip-over-labels (sta parsit) (prog (close-ptr) rescan (if (eq (cadr sta) COLON) (if parsit (pl1-parse-chk (car sta)) (pl1-parse-chk COLON)) (setq sta (cddr sta)) (go rescan)) (if (and (stringp (car sta)) ; could be label array! (eq (cadr sta) OPEN-PAREN) (stringp (caddr sta)) (pl1-string-fixnump (caddr sta)) (eq (cadddr sta) CLOSE-PAREN) (eq (car (cddddr sta)) COLON)) ;got one (if parsit (pl1-parse-chk (car sta)) ;foo (pl1-parse-chk OPEN-PAREN) ; ( (pl1-parse-chk (caddr sta)) ; 13 (pl1-parse-chk CLOSE-PAREN) ;) (pl1-parse-chk COLON)) (setq sta (cdr (cddddr sta))) (go rescan)) (if (and (eq (car sta) OPEN-PAREN) ;c/b a condition prefix (setq close-ptr (memq CLOSE-PAREN (cdr sta))) (eq (cadr close-ptr) COLON) (progn (do x sta (cdr x) (eq x (cddr close-ptr)) (and parsit (pl1-parse-chk (car sta))) (setq sta (cdr sta))) (go rescan)))) (return sta))) (defun pl1-string-fixnump (x) (and (stringp x) (let ((ch1 (getcharn x 1))) (and (< ch1 (1+ (CtoI "9"))) (> ch1 (1- (CtoI "0"))))))) (defun pl1-declare-p (prev-sta) (and (not (atom prev-sta)) (memq (cadr (pl1-typify-statement (caddr prev-sta) nil)) '(dcl declare /%)))) (defun pl1-typify-statement (sta parsit) (prog (key) (setq key (car sta)) (if (eq key SEMI)(return (list nil 'null))) (if (not (stringp key))(return (list nil 'random))) (setq key (intern (make_atom key))) (if (not (memq key pl1-interesting-keywords)) (return (list sta 'random))) (if (eq (cadr sta) SEMI) (if parsit (pl1-parse-chk (car sta))) (return (list (cdr sta) key))) (if (eq key 'if)(return (pl1-typify-if-hacker sta parsit))) (if (and (symbolp (cadr sta)) (not (eq (cadr sta) OPEN-PAREN))) (return (list sta 'random))) (if (eq key 'begin) (if (stringp (cadr sta)) (return (list sta key)) else (return (list sta 'random)))) (if (eq key 'on)(return (pl1-typify-on-hacker sta parsit))) (if (eq key 'do)(return (pl1-typify-do-hacker sta))) (if (eq key 'else) (if parsit (pl1-parse-chk "else")) (return (list (cdr sta) 'else))) (if (pl1-typify-0lev-parencheck sta)(return (list sta 'random))) (return (list (cdr sta) key)))))) (defun pl1-typify-0lev-parencheck (sta) (do ((parnct 0) (x sta (cdr x))) ((or (null x)(eq (car x) SEMI)) nil) (cond ((eq (car x) OPEN-PAREN) (setq parnct (1+ parnct))) ((eq (car x) CLOSE-PAREN) (setq parnct (1- parnct))) ((not (= parnct 0))) ((eq (car x) '/=)(return t))))) (defun pl1-typify-do-hacker (sta) (cond ((stringp (cadr sta))(list sta 'do)) ((eq (cadr sta) SEMI)(list sta 'do)) ;redundant (t (list sta 'random)))) (defun pl1-typify-if-hacker (sta parsit) (prog () (and (symbolp (cadr sta)) (not (eq (cadr sta) OPEN-PAREN)) (not (memq (cadr sta) '(/- /+ /^))) (return (list sta 'random))) (and (eq (cadr sta) '/-) (eq (caddr sta) '/>) (return (list sta 'random))) (return (do ((parnct 0) (prev '/=) (tsta sta (cdr tsta))) ((or (null tsta)(eq (car tsta) SEMI)) (list sta 'random)) (cond ((eq (car tsta) OPEN-PAREN) (setq parnct (1+ parnct))) ((eq (car tsta) CLOSE-PAREN) (setq parnct (1- parnct))) ((not (= parnct 0))) ((not (stringp (car tsta)))) ((not (samepnamep (car tsta) "then"))) ((or (stringp prev)(eq prev CLOSE-PAREN)(eq prev '/.)) (return (do ((x sta (cdr x))) ((eq x (cdr tsta)) (list x 'if)) (if parsit (pl1-parse-chk (car x))))))) (setq prev (car tsta)))))) (defun pl1-typify-on-hacker (sta parsit) (prog () (cond ((stringp (cadr sta)) (and parsit (pl1-parse-chk "on")) (and parsit (pl1-parse-chk (cadr sta))) (setq sta (cddr sta))) (t (return (list sta 'random)))) (do-forever (if (and (eq (car sta) OPEN-PAREN) (stringp (cadr sta)) (eq (caddr sta) CLOSE-PAREN)) (if (eq (cadddr sta) COLON)(stop-doing) else (if parsit (pl1-parse-chk OPEN-PAREN) (pl1-parse-chk (cadr sta)) (pl1-parse-chk CLOSE-PAREN)) (setq sta (cdddr sta)))) (if (and (stringp (cadr sta)) (eq (car sta) '/,)) (if parsit (pl1-parse-chk (car sta)) (pl1-parse-chk (cadr sta))) (setq sta (cddr sta)) else (stop-doing))) (and (eq (cadr sta) SEMI) (stringp (car sta)) (samepnamep (car sta) "system") (progn (and parsit (pl1-parse-chk "system")) (setq sta (cdr sta)))) (if (and (stringp (car sta)) (samepnamep (car sta) "snap") (pl1-typify-ridiculous-snap-screw sta)) (if parsit (pl1-parse-chk "snap")) (setq sta (cdr sta))) (return (list sta 'on)))) (defun pl1-typify-ridiculous-snap-screw (sta) ;have snap x x x ... (cond ((eq (cadr sta) SEMI) t) ;for sure ((null (cdr sta)) t) ;why not ((stringp (cadr sta)) t) ;snap begin; etc. ((not (eq (cadr sta) OPEN-PAREN)) nil) ;no chance, snap =, snap -> etc. ;;at this point snap (13): is problem, as is snap (fixedov).. so... ((not (eq (pl1-skip-over-labels sta nil) sta)) nil) ;label array ((eq (pl1-skip-over-labels (cdr sta) nil) (cdr sta)) nil) ;assgt sta (t t))) ;real snappo (defun pl1-parse-chk (lexeme) (let ((parsed (get-pl1-token-forwards))) (cond ((symbolp parsed) (or (eq parsed lexeme) (error "pl1-parse-chk: out of sync 1"))) ((not (stringp lexeme)) (error "pl1-parse-chk: out of sync 2")) ((not (samepnamep parsed lexeme)) (error "pl1-parse-chk: out of sync 3"))))) ;;; ;;; ;;; INDENTATION (written by Greenberg) ;;; (defun compute-pl1-indentation () (prog (prevhpos prev-sta incomp-flag) (setq prev-sta (pl1-find-start-prev-sta)) (if (pl1-declare-p prev-sta) (save-excursion (do-forever (go-to-mark (car prev-sta)) (release-mark (car prev-sta)) (setq prev-sta (pl1-find-start-prev-sta)) (if (not (pl1-declare-p prev-sta)) (return t))))) (if (eq prev-sta 'first-statement) (return pl1-first-column)) (release-mark (car prev-sta)) (setq prevhpos (cadr prev-sta) incomp-flag (cadddr prev-sta) prev-sta (caddr prev-sta)) (if incomp-flag (return (+ pl1-indentation prevhpos))) (do ((levels 0) (s (pl1-typify-statement prev-sta nil) (pl1-typify-statement (pl1-skip-over-labels (car s) nil) nil))) (nil) (cond ((memq (cadr s) '(if else on))(setq levels (1+ levels))) ((memq (cadr s) '(do begin )) ;no proc for now (setq prevhpos (+ prevhpos (* pl1-indentation (max levels 1)))) (return t)) ((and (eq (cadr s) 'end)(= pl1-inding-style 2)) (setq prevhpos (- prevhpos pl1-indentation)) (return t)) (t (return nil)))) (return prevhpos))) (defcom pl1-cret-and-indent &numeric-argument (&reject) (delete-white-sides) (new-line) (indent-pl1-statement)) (defcom indent-pl1-statement &numeric-argument (&reject) (delete-white-sides) (whitespace-to-hpos (compute-pl1-indentation))) (defcom roll-back-pl1-indentation &numeric-argument (&repeat) (let ((hp (cur-hpos))) (delete-white-sides) (whitespace-to-hpos (- hp pl1-indentation)))) (defcom pl1-tab-one-more-level &numeric-argument (&repeat) (let ((cur-hpos (cur-hpos))) (delete-white-sides) (whitespace-to-hpos (+ pl1-indentation cur-hpos)))) ;;; ;;; ;;; Reindentation of a Region (written by Dixon in May 80) ;;; (defcom pl1-reindent-region &numeric-argument (&reject) (if (point>markp der-wahrer-mark) (exchange-point-and-mark)) (prog (token) (if numarg else (do-forever (if (line-is-blank) (delete-white-sides) else (go-to-beginning-of-line) (skip-over-whitespace-in-line) (if (looking-at comment-prefix-trim) (pl1-comment-current-line) else (if (bolp) (with-mark bol (pl1-forward-statement) (do-forever (setq token (get-pl1-token-backwards)) (if (and (eq token COLON) (save-excursion (get-pl1-token-backwards) (pl1-legitimate-label-context))) (delete-char) (electric-pl1-colon) (stop-doing)) (if (mark-at-current-point-p bol) (pl1-rindent-pl1-statement)))) else (pl1-rindent-pl1-statement)) (if (pl1-comment-in-line) (pl1-comment-current-line)))) (if (mark-on-current-line-p der-wahrer-mark) (go-to-beginning-of-line) (stop-doing)) (next-line))))) (defun pl1-rindent-pl1-statement () (indent-pl1-statement) (if (and (= pl1-inding-style 1)(forward-search-in-line "end")) ;;do type 2 tomorrow (save-excursion (pl1-forward-statement) (pl1-adjust-for-this-maybe-being-an-end-statement)))) (defun pl1-comment-in-line () (prog () loop (if (search-for-first-charset-line pl1-com-quote-lab-charactertbl) (if-at COLON (forward-char) (go loop)) (if-at """" (with-mark ind-line (get-pl1-quoted-string-forward) (if (mark-on-current-line-p ind-line) (go-to-mark ind-line) (return nil))) (go loop)) (if (looking-at comment-prefix-trim) (return t)) (go loop)) (return nil))) ;;; ;;; Indentation of Attributes in dcl Statement ;;; (written by Dixon in May 79 as part of pl1dcl rewrite) (defcom pl1-skip-to-dcl-column &numeric-argument (&reject) (delete-white-sides) (if (> (cur-hpos) (- pl1-dcl-column 2)) (new-line)) (whitespace-to-hpos (1- pl1-dcl-column))) (defprop pl1-skip-to-dcl-attributes "Skips from name of variable in a dcl line to pl1-dcl-column. This is especially useful when pl1-dcl-style option is set to 2. The pl1-dcl-column and pl1-dcl-style can be set using $$extended-command$ opt." documentation) ;;; ;;; ;;; Last are the user-visible Emacs commands for PL/I mode. ;;; ;;; ;;; COMMENT INSERTION ;;; ;;; Comment Box ;;; (written by Schauble in March 79) ;;; (rewritten by Dixon in May 79 to fix bugs) ;;; (enhanced by Dixon in May 80) (defcom pl1-comment-box () &numeric-argument (&reject) (prog (fill-to-col) (if (memq 'comment buffer-minor-modes) ; exit comment mode (if (or (point>markp pl1-box-start) (mark-at-current-point-p pl1-box-start)) (do-forever (go-to-beginning-of-line) (if (lastlinep) (go-to-end-of-line) (stop-doing) else (if (or (looking-at (catenate TAB comment-prefix)) (looking-at (catenate TAB comment-prefix-trim TAB))) (if pl1-mid-box (go-to-end-of-line) (if (looking-back-at comment-suffix) (prev-line) (go-to-end-of-line) (stop-doing)) (go-to-beginning-of-line)) (next-line) else (prev-line) (go-to-end-of-line) (stop-doing)))) (filloff) (setq fill-prefix "") (pl1-restore-key-bindings-post-fill) (setq fill-to-col (- pl1-line-length 10. (stringlength comment-suffix))) (if pl1-mid-box (next-line) else (pl1-conditional-new-line (catenate TAB comment-prefix)) (new-line) ; cursor now on close line (insert-string (catenate TAB comment-prefix)) (do-times (// (- pl1-line-length 20. (stringlength comment-prefix) (stringlength comment-suffix)) 3) (insert-string " * ")) (whitespace-to-hpos fill-to-col) (insert-string comment-suffix) (new-line) (prev-line)) (with-mark box-end (do-forever (prev-line) (go-to-end-of-line) (delete-white-sides) (whitespace-to-hpos fill-to-col) (insert-string comment-suffix) (if (mark-on-current-line-p pl1-box-start) (stop-doing))) (go-to-mark box-end)) else ;; cursor is before start of box (go-to-mark pl1-box-start) (display-error "Cursor not at end of comment box" (if pl1-mid-box " insert lines"))) (release-mark pl1-box-start) ; clear up the mode (negate-minor-mode 'comment) (if pl1-mid-box else (next-line) (go-to-end-of-line) (pl1-cret-and-indent)) ;;; else ; start of comment box (go-to-beginning-of-line) (if (or (looking-at (catenate TAB comment-prefix)) (looking-at (catenate TAB comment-prefix-trim TAB))) (prev-line) ; check for inserting line in middle ; of an existing comment box (if (or (looking-at (catenate TAB comment-prefix)) (looking-at (catenate TAB comment-prefix-trim TAB))) (setq pl1-mid-box t) else (prev-line) (setq pl1-mid-box nil)) else (setq pl1-mid-box nil)) (if pl1-mid-box (go-to-end-of-line) (pl1-save-key-bindings-pre-fill) (fillon) (set-fill-column (- pl1-line-length 10. (1+ (stringlength comment-suffix)))) (setq fill-prefix (catenate TAB comment-prefix)) (new-line) (setq pl1-box-start (set-mark)) else (pl1-conditional-new-line "") (new-line) (insert-string (catenate TAB comment-prefix)) (do-times (// (- pl1-line-length 20. (stringlength comment-prefix) (stringlength comment-suffix)) 3) (insert-string " * ")) (pl1-save-key-bindings-pre-fill) (fillon) (set-fill-column (- pl1-line-length 10. (1+ (stringlength comment-suffix)))) (whitespace-to-hpos (- pl1-line-length 10. (stringlength comment-suffix))) (insert-string comment-suffix) (setq fill-prefix (catenate TAB comment-prefix)) (new-line) (setq pl1-box-start (set-mark)) (new-line)) (assert-minor-mode 'comment)))) (defprop pl1-comment-box "Generates a comment box containing text describing the program. When $$$ is first given, comment minor mode is entered. The first two lines of the box are created and the cursor is positioned at the end of the third line, ready to begin typing the text. Fill mode is enabled, to facilitate typing of textual input (type ""$$extended-command$ describe fillon"" for information on fill mode), but can be disabled during comment mode by typing: $$extended-command$ filloff After all text is typed in, use $$$ again to turn of comment mode and return to normal PL/I editing. To add text to an existing comment box, position the cursor to the line above which the new text is to be inserted, then type $$$." documentation) (defun pl1-conditional-new-line (prefix) (go-to-beginning-of-line) (if (or (line-is-blank) (and (looking-at prefix) (= curlinel (1+ (stringlength prefix))))) (without-saving (kill-to-end-of-line)) else (go-to-end-of-line) (let ((fill-prefix "")) (new-line))) (if (eq prefix "") else (insert-string prefix))) (defun pl1-save-key-bindings-pre-fill () (setq pl1-key-bindings-pre-fill (mapcar '(lambda (x) (get-key-binding (list 0 (getcharn x 1) nil))) fill-mode-delimiters))) (defun pl1-restore-key-bindings-post-fill () (mapc 'set-key fill-mode-delimiters pl1-key-bindings-pre-fill)) (defun looking-back-at (string) ((lambda (linel sl) (cond ((> sl linel) nil) ((= sl 0) t) (t (prog2 (do-times sl (backward-char)) (looking-at string) (do-times sl (forward-char)))))) curlinel (stringlength string))) ;;; (defcom pl1-refill-comment-box-region &numeric-argument (&reject) (if (point>markp der-wahrer-mark) (exchange-point-and-mark)) (go-to-beginning-of-line) ; region begins at start of (setq pl1-box-start (set-mark)) ; line containing the point (go-to-mark der-wahrer-mark) (go-to-end-of-line) (set-the-mark) ; region ends at end of line (go-to-mark pl1-box-start) ; containing the-mark (do-forever ; make sure entire region is (go-to-beginning-of-line) ; part of comment box (if (or (looking-at (catenate TAB comment-prefix)) (looking-at (catenate TAB comment-prefix-trim TAB))) else (display-error "Region lies (totally or partially) outside comment box.")) (go-to-end-of-line) (delete-white-sides) (if (looking-back-at comment-suffix) else (display-error "Region lies (totally or partially) outside comment box.")) (if (mark-on-current-line-p der-wahrer-mark) (stop-doing)) (next-line)) (go-to-mark pl1-box-start) ; save the region in case (copy-region) ; filling is disastrous ; remove comment prefix, ; comment suffix, & (do-forever ; trailing whitespace from (go-to-beginning-of-line) ; each line of region (do-times (1+ (stringlength comment-prefix)) (delete-char)) (go-to-end-of-line) (do-times (stringlength comment-suffix) (rubout-char)) (delete-white-sides) ; Remove suffix & trail (if (mark-on-current-line-p der-wahrer-mark) (stop-doing)) (next-line)) (set-fill-column (- pl1-line-length 10. (stringlength comment-prefix) 10. (1+ (stringlength comment-suffix)))) (setq fill-prefix "") (go-to-mark pl1-box-start) ; refill the region (exchange-point-and-mark) (without-saving (runoff-fill-region)) (exchange-point-and-mark) ; put back comment prefix (do-forever ; & suffix on each line (go-to-beginning-of-line) (insert-string (catenate TAB comment-prefix)) (go-to-end-of-line) (delete-white-sides) (whitespace-to-hpos (- pl1-line-length 10. (stringlength comment-suffix))) (insert-string comment-suffix) (if (mark-on-current-line-p der-wahrer-mark) (stop-doing)) (next-line)) (go-to-end-of-line) (set-the-mark) (go-to-mark pl1-box-start) ; Mark text just filled (exchange-point-and-mark) (release-mark pl1-box-start)) (defprop pl1-refill-comment-box-region "Refills text inside a comment block between the line containing the-mark and the line containing the cursor. Unfilled text is saved on the kill-ring in case filling produces unexpected results." documentation) ;;; ;;; ;;; Beginning of Comment (written May 80 by Dixon) ;;; (defcom pl1-comment-current-line &numeric-argument (&reject) (go-to-beginning-of-line) (if (forward-search-in-line comment-prefix) (do-times (stringlength comment-prefix) (backward-char)) (if (and (> pl1-comment-style 1) (= (cur-hpos) (1- pl1-comment-column))) (save-excursion ; for comment on a line by (skip-back-whitespace-in-line) ; itself, see if it should be (if (bolp) ; put on previous line. It (prev-line) ; may have been split from (if (line-is-blank) ; prev line because line had else ; text in comment column ; which may no longer be ; there. (if (or (forward-search-in-line comment-prefix) (forward-search-in-line comment-prefix-trim)) else (go-to-end-of-line) (delete-white-sides) (next-line) (delete-line-indentation)))))) (if (= (cur-hpos) (1- pl1-comment-column)) else ; comment not positioned ok (delete-white-sides) (if (> (cur-hpos) (1- pl1-comment-column)) ; comment starts beyond (if (= pl1-comment-style 1) ; pl1-comment-column (do ((column (1- pl1-comment-column) (+ column pl1-indentation))) ((> column (cur-hpos)) (whitespace-to-hpos column))) else (if (= pl1-comment-style 2) (if (< (+ (1- pl1-comment-column) pl1-comment-column-delta) (cur-hpos)) ; comment won't fit within (new-line) ; delta chars of ; pl1-comment-column (whitespace-to-hpos (1- pl1-comment-column)) else ; comment will fit within ; delta chars (do ((column (1- pl1-comment-column) (+ column pl1-indentation))) ((> column (cur-hpos)) (whitespace-to-hpos column)))) else ; assume pl1-comment-style 3 (new-line) ; put comment on a new line (whitespace-to-hpos (1- pl1-comment-column)))) else ; cur-hpos count numarg)) (if (lastlinep) (go-to-end-of-line) (new-line) (insert-string comment-prefix) (setq count numarg) else (next-line))) (pl1-comment-current-line)) (defcom pl1-comment-prev-line &numeric-argument (&pass) &negative-function pl1-comment-next-line (if numarg else (setq numarg 1)) (do ((count 1 (1+ count))) ((> count numarg)) (if (firstlinep) (go-to-beginning-of-line) (open-space) (insert-string comment-prefix) (setq count numarg) else (prev-line))) (pl1-comment-current-line)) (defprop pl1-comment-current-line "Searches for this line's comment. If one is found, it is indented to the comment column for this line. If not found, a comment prefix is inserted at the comment column. Use $$extended-command$ opt to set the following comment-related options: pl1-comment-style, pl1-comment-column, and pl1-comment-column-delta. pl1-comment-style controls commenting when PL/I statements on the current line already extend beyond the pl1-comment-column. It can have the following values: 1 = begin the comment beyond the end of the statements. 2 = if PL/I statements extend beyond pl1-comment-column + pl1-comment-column-delta then put comment on a new line below the current line. Otherwise, put comment on current line beyond end of the statements. 3 = put comment on a new line below the current line." documentation) (defprop pl1-comment-prev-line "Searches for a comment on the previous line. If one is found, it is indented to the comment column for this line. If not found, a comment prefix is inserted at the comment column. Essentially the same as $$prev-line-command$ $$pl1-comment-current-line$. See $$pl1-comment-current-line$." documentation) (defprop pl1-comment-next-line "Searches for a comment on the next line. If one is found, it is indented to the comment column for this line. If not found, a comment prefix is inserted at the comment column. Essentially the same as $$next-line-command$ $$pl1-comment-current-line$. See $$pl1-comment-current-line$." documentation) ;;; ;;; End of Comment (written by Dixon in May 79) ;;; (defcom pl1-comment-end &numeric-argument (&reject) (if (forward-search-in-line comment-suffix) ; comment already ended (do-times (stringlength comment-suffix) (rubout-char)) (delete-white-sides) else (go-to-end-of-line)) (if (> (cur-hpos) (- pl1-line-length (stringlength comment-suffix))) (insert-string comment-suffix) (display-error (catenate "Comment ends beyond column " (decimal-rep (- pl1-line-length (stringlength comment-suffix))))) else (whitespace-to-hpos (- pl1-line-length (stringlength comment-suffix)))) (insert-string comment-suffix) (if (or (lastlinep) (save-excursion (next-line) (line-is-blank))) (pl1-cret-and-indent))) (defprop pl1-end-comment "Skips to end of a comment line and inserts a comment end delimiter (*/) in the column defined by the pl1-line-length option. This option can be set using $$extended-command$ opt." documentation) ;;; Comment line between program sections (written by Dixon) (defcom pl1-line-between-procs &numeric-argument (&pass) (go-to-end-of-line) (delete-white-sides) (if (line-is-blank) else (new-line)) (delete-blank-lines) (if (looking-at (catenate comment-prefix " * * * * *")) (pl1-insert-divider) ; Already a divider there. (new-line) ; Create a page separator (insert-string FF) (new-line) else (pl1-insert-divider) (new-line) (if numarg ; Force a page separator (insert-string FF) (new-line) (pl1-insert-divider) (new-line)) (new-line) (new-line))) (defun pl1-insert-divider () ; Insert divider across page (insert-string comment-prefix) ; /* * * ... * * */ (do-times (// (- pl1-line-length (stringlength comment-prefix) (stringlength comment-suffix)) 3.) (insert-string " * ")) (whitespace-to-hpos (- pl1-line-length (stringlength comment-suffix))) (insert-string comment-suffix)) (defprop pl1-line-between-procs "Inserts comment line which divides the page. A numeric arg (eg, ^U$$$) generates a dividing comment, a newpage char, and a second dividing comment. This comment divider is used to separate procedures in PL/I source." documentation) ;;; (defcom pl1-include-file-comment-start-end &numeric-argument (&reject) (if (null fpathname) (display-error "The buffer does not have a pathname.")) (let ((path-list (namelist fpathname))) (let ((rpath-list (reverse path-list)) (entry-name (cadr path-list))) (mapc '(lambda (x) (setq entry-name (catenate entry-name "." x))) (cddr path-list)) (if (and (eq 'incl (cadr rpath-list)) (eq 'pl1 (car rpath-list))) else (display-error "This file is not an include file.")) (save-excursion (go-to-beginning-of-buffer) (if (or (empty-buffer-p current-buffer) (not (looking-at (catenate comment-prefix " START OF")))) (if (line-is-blank) else (open-space)) (insert-string (catenate comment-prefix " START OF:")) (whitespace-to-hpos 20.) (insert-string entry-name) (whitespace-to-hpos 61.) (do-times (// (- pl1-line-length 61. (stringlength comment-suffix)) 3.) (insert-string " * ")) (whitespace-to-hpos (- pl1-line-length (stringlength comment-suffix))) (insert-string comment-suffix) (next-line) (if (lastlinep) else (if (line-is-blank) else (open-space)))) (go-to-end-of-buffer) (if (bolp) (prev-line) ;buffer ends in newline, go up one else (go-to-beginning-of-line)) (if (not (looking-at (catenate comment-prefix " END OF:"))) (go-to-end-of-line) (if (line-is-blank) else (new-line)) (new-line) (insert-string (catenate comment-prefix " END OF:")) (whitespace-to-hpos 20.) (insert-string entry-name) (whitespace-to-hpos 61.) (do-times (// (- pl1-line-length 61. (stringlength comment-suffix)) 3.) (insert-string " * ")) (whitespace-to-hpos (- pl1-line-length (stringlength comment-suffix))) (insert-string comment-suffix) (insert-string NL)))))) (defprop pl1-include-file-comment-start-end "Generates starting and ending comment lines indentifying name of a PL/I include file at top and bottom of the buffer." documentation) ;;; ;;; ;;; STATEMENT MOVEMENT (written by Dixon in May 79) ;;; (defcom pl1-forward-statement &numeric-argument (&repeat &lower-bound 1) &negative-function pl1-backward-statement (prog (token) (do-forever (setq token (get-pl1-token-forwards)) (if (eq token SEMI) (stop-doing)) (if (null token) (display-error))))) ; at end of file. (defcom pl1-backward-statement &numeric-argument (&repeat &lower-bound 1) &negative-function pl1-forward-statement (prog (token) (with-mark current-loc (setq token (get-pl1-token-backwards)) (if (null token) (go-to-mark current-loc) (display-error))) ; at beginning of file. (do-forever (with-mark current-loc (setq token (get-pl1-token-backwards)) (if (eq token SEMI) (do-times 2 (get-pl1-token-forwards)) (get-pl1-token-backwards) (stop-doing)) (if (null token) (go-to-mark current-loc) (stop-doing)))))) (defprop pl1-backward-statement "Goes to the beginning of the current statement. If already at the beginning of a statement, goes to the beginning of the previous statement." documentation) (defprop pl1-forward-statement "Goes forward to the end of this statement. If at the end of a statement, goes forward to the end of the next statement." documentation) ;;; ;;; ;;; AUTO-DECLARATOR (integrated 7/31/78) ;;; (written by Greenberg in April 78) ;;; (rewritten by Dixon in May 79 to use get_entry_point_dcl_) ;;; (defcom pl1dcl &numeric-argument (&reject) (prog (the-entry the-error the-dcl the-type) (save-excursion (skip-back-whitespace-in-line) (with-mark here (skip-back-to-whitespace) (setq the-entry (point-mark-to-string here)))) (let ((result (entry_point_dcl_ the-entry pl1-dcl-style pl1-line-length))) (setq the-dcl (car result)) (setq the-type (cadr result)) (setq the-error (caddr result)) (cond ((samepnamep the-type 'abbrev) (save-excursion (backward-word) (insert-string the-dcl) (delete-word))) ((> (stringlength the-dcl) 0) (if (not (get (lefthand-char) 'whiteness)) (insert-char " ")) (insert-string (substr the-dcl 2)))) (if (> (stringlength the-error) 0) (if (not (samepnamep the-error 'abbrev)) ;disagree with GDixon here. (minibuffer-print the-error)))))) ;;; ;;; ;;; ELECTRIC MODE Functions (written by Greenberg on 07/31/78) ;;; (defcom electric-pl1-semicolon &numeric-argument (&reject) (insert-string ";") (pl1-adjust-for-this-maybe-being-an-end-statement) (or macro-execution-in-progress (redisplay)) ;for benefit of printing ttys (if (or (lastlinep) (save-excursion (next-line) (line-is-blank))) (pl1-cret-and-indent))) (defun pl1-adjust-for-this-maybe-being-an-end-statement () (if (= pl1-inding-style 1) (with-mark m (go-to-beginning-of-line) (if (forward-search-in-line "end") (go-to-mark m) (let ((s (pl1-find-start-prev-sta))) (if (eq 'end (cadr (pl1-typify-statement (caddr s) nil))) (go-to-mark (car s)) (roll-back-pl1-indentation)) (release-mark (car s)))) (go-to-mark m)))) (defcom electric-pl1-colon &numeric-argument (&reject) (insert-string ":") (if (pl1-legitimate-label-context) (save-excursion (backward-word) (delete-white-sides) (if (not (bolp)) (new-line))) (indent-pl1-statement) ; IS THIS RIGHT? (or macro-execution-in-progress (redisplay)) ;for printing tty's (if-back-at COLON (pl1-cret-and-indent)))) (defun pl1-legitimate-label-context () (save-excursion (do-forever (let ((tok (get-pl1-token-backwards))) (if (eq tok SEMI)(return t)) ;just after another statement (if (eq tok nil)(return t)) ;at beginning of file (if (not (eq tok COLON))(return nil))) ;gotta be a label or condition prefix (let ((tok (get-pl1-token-backwards))) (cond ((stringp tok)) ; the preceding label (perhaps), but keep looking ((eq tok CLOSE-PAREN)(return t)) ; subscript or prefix. good enuff for now. (t (return nil))))))) ; no good, give up ;;; ;;; ;;; Language dependent part of ERROR SCANNER. ;;; (written by Schauble in March 79) (defun pl1-error-list-builder () (if (= buffer-uid -2) (let ((er-list nil) (line-num)) (do-forever (go-to-beginning-of-line) (if (or (looking-at "WARNING") (looking-at "FATAL ERROR") (looking-at "ERROR")) (go-to-end-of-line) (with-mark m (skip-back-to-whitespace) (setq line-num (point-mark-to-string m))) (backward-n-chars (stringlength "LINE ")) (setq line-num (if (looking-at "LINE") (let ((z (cv_dec_check_ line-num))) (if (= 0 (car z)) (cadr z))))) ;; line-num is now fixnum of source error line number or nil if message ;; had no line number (go-to-beginning-of-line) (setq er-list (cons (cons (set-mark) line-num) er-list))) (insert-string " ") (if (firstlinep) (stop-doing) else (prev-line))) ;; er-list is now list of ( . ) ;; return it as the defun value. er-list) else ;; Buffer does not contain a compilation, return error 'not-compile))  emacs-history-comment.lisp 08/20/86 2311.7rew 08/20/86 2244.7 49923 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1986 * ;;; * * ;;; *********************************************************** ;;; HISTORY COMMENTS: ;;; 1) change(86-02-10,LJAdams), approve(86-02-25,MCR7361), ;;; audit(86-04-17,Margolin), install(86-08-20,MR12.0-1136): ;;; EMACS extension to add history comments while within emacs. ;;; 2) change(86-04-21,Margolin), approve(86-04-21,MCR7361), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Added *expr declaration for requote_string_. Made add-history-comment ;;; write out the buffer first. ;;; 3) change(86-05-04,Margolin), approve(86-05-04,MCR7361), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Changed hcom:get-summary to skip back over trailing whitespace in the ;;; summary. Changed hcom:add-hcom-apv to use without-saving around its ;;; wipe-point-mark. ;;; END HISTORY COMMENTS (%include e-macros) (declare (*expr create-new-window-and-go-there buffer-kill fill-mode delete-window go-to-or-create-buffer minibuffer-clear-all redisplay-command reverse-string-search requote_string_ save-same-file redisplay-current-window-relative)) (defcom-synonym add-hcom add-history-comment) (defvar hcom:apv-value) (defvar hcom:cfix) (defvar hcom:ctl-arg) (defvar hcom:orig-buffer) (defvar hcom:pathname) (defvar hcom:summary) (defvar nuwindows) (defcom add-history-comment &doc "Adds a history comment to the current source program." (setq hcom:orig-buffer current-buffer) (if (not fpathname) (display-error "Current buffer has not been written to a file.")) (if buffer-modified-flag (save-same-file)) (setq hcom:pathname fpathname) (create-new-window-and-go-there) ;if user has one window split the screen ;if user has multiple windows dont destroy what he has (go-to-or-create-buffer 'hcom/ Result/ Buffer) (fill-mode) (setq fill-column 72.) (minibuffer-print "Type in summary. Type ^X^S to end summary") (set-key '^X^S 'hcom:get-summary)) (defcom hcom:get-summary () &doc "Gets the summary and approve value." (minibuffer-clear) (go-to-beginning-of-buffer) (skip-over-whitespace) (go-to-beginning-of-line) ;skip any leading blank lines (with-mark mark (go-to-end-of-buffer) (skip-back-whitespace) ;trim any trailing whitespace (setq hcom:summary (requote_string_ (point-mark-to-string mark)))) (hcom:get-approve-value)) (defun hcom:get-approve-value () (setq hcom:apv-value (trim-minibuffer-response "Type approve value: ")) (if (samepnamep hcom:apv-value "") ;null string treated as no approve value (hcom:put-hcom-napv) else (requote_string_ hcom:apv-value) (if (samepnamep "fix_" (substr hcom:apv-value 1 4)) (setq hcom:cfix t) (setq hcom:ctl-arg " -cfix") else (setq hcom:ctl-arg "") (setq hcom:cfix nil)) (hcom:put-hcom-apv))) (defun hcom:put-hcom-apv () (hcom:add-hcom-apv t) (go-to-beginning-of-buffer) (if (eolp) ;hcom returns a blank line if there is no error (if hcom:cfix ;no database checking is done for cfixes (hcom:display) else (if (yesp "OK?") ;user verifies if mcr number is all right (hcom:add-hcom-apv nil) (if (not (eolp)) ;error was found (find-buffer-in-window hcom:orig-buffer) (display-buffer-as-printout) (end-local-displays) (hcom:error) else (hcom:display)) else (hcom:get-approve-value))) ;wrong mcr entered else (hcom:error))) (defun hcom:display () (if (> nuwindows 1) (select-other-window) (delete-window nuwindows)) (minibuffer-clear-all) (read-in-file hcom:pathname) (if (not (forward-search "END HISTORY COMMENTS")) (go-to-beginning-of-buffer)) (redisplay-current-window-relative -1) (buffer-kill 'hcom/ Result/ Buffer)) (defun hcom:error () (ring-tty-bell) (if (yesp "re-enter approve value?") (hcom:get-approve-value) else (hcom:display))) (defun hcom:add-hcom-apv (get-question) (go-to-or-create-buffer hcom:orig-buffer) (comout-get-output (if get-question "answer no" else "answer yes -brief") (requote_string_ (catenate "history_comment add " (requote_string_ hcom:pathname) " -approve " hcom:apv-value " -summary " hcom:summary hcom:ctl-arg))) (if get-question (go-to-end-of-buffer) (if (reverse-string-search "OK?") (go-to-beginning-of-line) (with-mark mark (go-to-end-of-buffer) (without-saving (wipe-point-mark mark)))) (display-buffer-as-printout) (end-local-displays))) (defun hcom:put-hcom-napv () (go-to-or-create-buffer hcom:orig-buffer) (comout-get-output "history_comment add " (requote_string_ hcom:pathname) " -no_approve -summary " hcom:summary) (go-to-beginning-of-buffer) (if (eolp) (hcom:display) else (hcom:error))) bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved