/[cmucl]/src/hemlock/lispmode.lisp
ViewVC logotype

Diff of /src/hemlock/lispmode.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by ram, Fri Jul 13 15:13:08 1990 UTC revision 1.3 by ram, Fri Feb 11 21:53:25 1994 UTC
# Line 1  Line 1 
1  ;;; -*- Log: hemlock.log; Package: Hemlock -*-  ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the Spice Lisp project at  ;;; This code was written as part of the CMU Common Lisp project at
5  ;;; Carnegie-Mellon University, and has been placed in the public domain.  ;;; Carnegie Mellon University, and has been placed in the public domain.
6  ;;; Spice Lisp is currently incomplete and under active development.  ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7  ;;; If you want to use this code or any part of Spice Lisp, please contact  ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8  ;;; Scott Fahlman (FAHLMAN@CMUC).  ;;;
9    (ext:file-comment
10      "$Header$")
11    ;;;
12  ;;; **********************************************************************  ;;; **********************************************************************
13  ;;;  ;;;
14  ;;; Hemlock LISP Mode commands  ;;; Hemlock LISP Mode commands
# Line 15  Line 18 
18    
19  (in-package "HEMLOCK")  (in-package "HEMLOCK")
20    
21    (declaim (optimize (speed 2))); turn off byte compilation.
22    
23    
24  ;;;;  ####  VARIABLES  ####  ;;;; Variables and lisp-info structure.
25  ;;;  
26  ;;; These routines are used to define, for standard LISP mode, the start and end  ;;; These routines are used to define, for standard LISP mode, the start and end
27  ;;; of a block to parse.  If these need to be changed for a minor mode that sits  ;;; of a block to parse.  If these need to be changed for a minor mode that sits
28  ;;; on top of LISP mode, simply do a DEFHVAR with the minor mode and give the  ;;; on top of LISP mode, simply do a DEFHVAR with the minor mode and give the
# Line 35  Line 39 
39    :value 'end-of-parse-block)    :value 'end-of-parse-block)
40    
41    
42  ;;;; #### STRUCTURES ####  ;;; LISP-INFO is the structure used to store the data about the line in its
43  ;;;  ;;; Plist.
44  ;;; LISP-INFO is the structure used to store the data about the line in its Plist.  ;;;
 ;;;  
45  ;;;     -> BEGINS-QUOTED, ENDING-QUOTED are both Boolean slots that tell whether  ;;;     -> BEGINS-QUOTED, ENDING-QUOTED are both Boolean slots that tell whether
46  ;;;        or not a line's begining and/or ending are quoted.  ;;;        or not a line's begining and/or ending are quoted.
47  ;;;  ;;;
# Line 62  Line 65 
65    
66    
67    
68  ;;;;  ####  MACROS  ####  ;;;; Macros.
69  ;;;  
70  ;;; The following Macros exist to make it easy to acces the Syntax primitives  ;;; The following Macros exist to make it easy to acces the Syntax primitives
71  ;;; without uglifying the code.  They were originally written by Maddox.  ;;; without uglifying the code.  They were originally written by Maddox.
72  ;;;  ;;;
# Line 154  Line 157 
157        `(line-previous ,line)))        `(line-previous ,line)))
158    
159    
160  ;;;; #### PARSING FUNCTIONS ###  ;;;; Parsing functions.
 ;;;  
 ;;; PRE-COMMAND-PARSE-CHECK  
161    
162    ;;; PRE-COMMAND-PARSE-CHECK -- Public.
163    ;;;
164  (defun pre-command-parse-check (mark &optional (fer-sure-parse nil))  (defun pre-command-parse-check (mark &optional (fer-sure-parse nil))
165    "Parse the area before the command is actually executed."    "Parse the area before the command is actually executed."
166    (with-mark ((top mark)    (with-mark ((top mark)
# Line 166  Line 169 
169      (funcall (value parse-end-function) bottom)      (funcall (value parse-end-function) bottom)
170      (parse-over-block (mark-line top) (mark-line bottom) fer-sure-parse)))      (parse-over-block (mark-line top) (mark-line bottom) fer-sure-parse)))
171    
 ;;;  
172  ;;; PARSE-OVER-BLOCK  ;;; PARSE-OVER-BLOCK
173    ;;;
174  (defun parse-over-block (start-line end-line &optional (fer-sure-parse nil))  (defun parse-over-block (start-line end-line &optional (fer-sure-parse nil))
175    "Parse over an area indicated from END-LINE to START-LINE."    "Parse over an area indicated from END-LINE to START-LINE."
176    (let ((test-line start-line)    (let ((test-line start-line)
# Line 226  Line 228 
228           (setq test-line (line-next test-line)))))))           (setq test-line (line-next test-line)))))))
229    
230    
231  ;;;;  ####  PARSE BLOCK FINDERS  ####  ;;;; Parse block finders.
 ;;;  
232    
233  (defhvar "Minimum Lines Parsed"  (defhvar "Minimum Lines Parsed"
234    "The minimum number of lines before and after the point parsed by Lisp mode."    "The minimum number of lines before and after the point parsed by Lisp mode."
# Line 288  Line 289 
289      (setq line (mark-line mark))))      (setq line (mark-line mark))))
290    
291    
292  ;;; PARSE-LISP-LINE-INFO parses through the line doing the following things:  ;;;; PARSE-LISP-LINE-INFO.
293  ;;;  
294    ;;; PARSE-LISP-LINE-INFO -- Internal.
295    ;;;
296    ;;; This parses through the line doing the following things:
297    ;;;
298  ;;;      Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS.  ;;;      Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS.
299  ;;;  ;;;
300  ;;;      Making all areas of the line that should be invalid (comments,  ;;;      Making all areas of the line that should be invalid (comments,
301  ;;;      char-quotes, and the inside of strings) and such be in  ;;;      char-quotes, and the inside of strings) and such be in
302  ;;;      RANGES-TO-IGNORE.  ;;;      RANGES-TO-IGNORE.
303  ;;;  ;;;
304  ;;;      Set BEGINS-QUOTED and ENDING-QUOTED  ;;;      Set BEGINS-QUOTED and ENDING-QUOTED
305  ;;;  ;;;
   
306  (defun parse-lisp-line-info (mark line-info prev-line-info)  (defun parse-lisp-line-info (mark line-info prev-line-info)
307    "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS,    "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS,
308  RANGES-TO-INGORE, and ENDING-QUOTED."     RANGES-TO-INGORE, and ENDING-QUOTED."
309    (let ((net-open-parens 0)    (let ((net-open-parens 0)
310          (net-close-parens 0))          (net-close-parens 0))
311      (declare (fixnum net-open-parens net-close-parens))      (declare (fixnum net-open-parens net-close-parens))
# Line 362  RANGES-TO-INGORE, and ENDING-QUOTED." Line 366  RANGES-TO-INGORE, and ENDING-QUOTED."
366      (setf (lisp-info-net-close-parens line-info) net-close-parens)      (setf (lisp-info-net-close-parens line-info) net-close-parens)
367      (setf (lisp-info-signature-slot line-info)      (setf (lisp-info-signature-slot line-info)
368            (line-signature (mark-line mark)))))            (line-signature (mark-line mark)))))
369    
370    
371    
372  ;;;;  #### STRING QUOTE UTILITIES ####  ;;;; String quote utilities.
 ;;;  
 ;;;  
   
 ;;;  
 ;;; VALID-STRING-QUOTE-P  
373    
374    ;;; VALID-STRING-QUOTE-P
375    ;;;
376  (defmacro valid-string-quote-p (mark forwardp)  (defmacro valid-string-quote-p (mark forwardp)
377    "Return T if the string-quote indicated by MARK is valid."    "Return T if the string-quote indicated by MARK is valid."
378    (let ((test-mark (gensym)))    (let ((test-mark (gensym)))
379      `(with-mark ((,test-mark ,mark))      `(with-mark ((,test-mark ,mark))
380           ,(unless forwardp
381         ,(unless forwardp              ; TEST-MARK should always be right before the            ;; TEST-MARK should always be right before the String-quote to be
382            `(mark-before ,test-mark))   ; String-quote to be checked.            ;; checked.
383              `(mark-before ,test-mark))
384         (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote)         (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote)
   
385           (let ((slash-count 0))           (let ((slash-count 0))
   
386             (loop             (loop
387               (mark-before ,test-mark)               (mark-before ,test-mark)
388               (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote)               (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote)
# Line 418  RANGES-TO-INGORE, and ENDING-QUOTED." Line 419  RANGES-TO-INGORE, and ENDING-QUOTED."
419    
420          (neighbor-mark ,e-mark ,forwardp)))))          (neighbor-mark ,e-mark ,forwardp)))))
421    
422  ;;; DEAL-WITH-STRING-QUOTE  ;;;; DEAL-WITH-STRING-QUOTE.
 ;;;  
 ;;; Called when a string is begun (i.e. parse hits a #\").  It checks for a  
 ;;; matching quote on the line that MARK points to, and puts the  
 ;;; appropriate area in the RANGES-TO-IGNORE slot and leaves MARK pointing  
 ;;; after this area.  The "appropriate area" is from MARK to the end of the  
 ;;; line or the matching string-quote, whichever comes first.  
423    
424    ;;; DEAL-WITH-STRING-QUOTE
425    ;;;
426    ;;; Called when a string is begun (i.e. parse hits a #\").  It checks for a
427    ;;; matching quote on the line that MARK points to, and puts the appropriate
428    ;;; area in the RANGES-TO-IGNORE slot and leaves MARK pointing after this area.
429    ;;; The "appropriate area" is from MARK to the end of the line or the matching
430    ;;; string-quote, whichever comes first.
431    ;;;
432  (defun deal-with-string-quote (mark info-struct)  (defun deal-with-string-quote (mark info-struct)
433    "Alter the current line's info struct as necessary as due to encountering a    "Alter the current line's info struct as necessary as due to encountering a
434  string quote character."     string quote character."
435    (with-mark ((e-mark mark))    (with-mark ((e-mark mark))
   
436      (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t)      (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t)
437               ;; If matching quote is on this line then mark the area between the
438             ;; If matching quote is on this line then mark the area between             ;; first quote (MARK) and the matching quote as invalid by pushing
439             ;; the first quote (MARK) and the matching quote as invalid by             ;; its begining and ending into the IGNORE-RANGE.
            ;; pushing its begining and ending into the IGNORE-RANGE.  
   
440             (push-range (cons (mark-charpos mark) (mark-charpos e-mark))             (push-range (cons (mark-charpos mark) (mark-charpos e-mark))
441                         info-struct)                         info-struct)
   
442             (setf (lisp-info-ending-quoted info-struct) nil)             (setf (lisp-info-ending-quoted info-struct) nil)
443             (mark-after e-mark)             (mark-after e-mark)
444             (move-mark mark e-mark))             (move-mark mark e-mark))
445              ;; If the EOL has been hit before the matching quote then mark the
446            ;; If the EOL has been hit before the matching quote then mark            ;; area from MARK to the EOL as invalid.
           ;; the area from MARK to the EOL as invalid.  
   
447            (t            (t
448             (push-range (cons (mark-charpos mark) (1+ (line-length (mark-line mark))))             (push-range (cons (mark-charpos mark)
449                                 (1+ (line-length (mark-line mark))))
450                         info-struct)                         info-struct)
   
451             ;; The Ending is marked as still being quoted.             ;; The Ending is marked as still being quoted.
   
452             (setf (lisp-info-ending-quoted info-struct) t)             (setf (lisp-info-ending-quoted info-struct) t)
453             (line-end mark)             (line-end mark)
454             nil))))             nil))))
455    
456    
457    
458  ;;;; Character validity checking:  ;;;; Character validity checking:
459    
# Line 469  string quote character." Line 466  string quote character."
466  ;;; the buffer beginning or end), then return both values NIL.  ;;; the buffer beginning or end), then return both values NIL.
467  ;;;  ;;;
468  (defun find-ignore-region (mark forwardp)  (defun find-ignore-region (mark forwardp)
   (declare (fixnum pos))  
469    (flet ((scan (line pos)    (flet ((scan (line pos)
470             (declare (fixnum pos))             (declare (fixnum pos))
471             (let ((info (getf (line-plist line) 'lisp-info)))             (let ((info (getf (line-plist line) 'lisp-info)))
# Line 537  string quote character." Line 533  string quote character."
533             (setq ,n-won t))))))             (setq ,n-won t))))))
534    
535    
536  ;;;; #### LIST-OFFSETING ####  ;;;; List offseting.
537  ;;;  
538  ;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built  ;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built
539  ;;; with the same existing structure, with the altering of one variable.  ;;; with the same existing structure, with the altering of one variable.
540  ;;; This one variable being FORWARDP.  ;;; This one variable being FORWARDP.
541  ;;;  ;;;
542  (defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) )  (defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) )
543    "Expand to code that will go forward one list either backward or forward,    "Expand to code that will go forward one list either backward or forward,
544  according to the FORWARDP flag."     according to the FORWARDP flag."
545    (let ((mark (gensym)))    (let ((mark (gensym)))
546      `(let ((paren-count ,extra-parens))      `(let ((paren-count ,extra-parens))
547         (declare (fixnum paren-count))         (declare (fixnum paren-count))
# Line 559  according to the FORWARDP flag." Line 555  according to the FORWARDP flag."
555                 (case (character-attribute :lisp-syntax ch)                 (case (character-attribute :lisp-syntax ch)
556                   (:close-paren                   (:close-paren
557                    (decf paren-count)                    (decf paren-count)
558                    ,(when forwardp               ; When going forward, an unmatching                    ,(when forwardp
559                       `(when (<= paren-count 0)  ; close-paren means the end of list.                       ;; When going forward, an unmatching close-paren means the
560                         ;; end of list.
561                         `(when (<= paren-count 0)
562                          (neighbor-mark ,mark ,forwardp)                          (neighbor-mark ,mark ,forwardp)
563                          (move-mark ,actual-mark ,mark)                          (move-mark ,actual-mark ,mark)
564                          (return t))))                          (return t))))
# Line 573  according to the FORWARDP flag." Line 571  according to the FORWARDP flag."
571                          (return t))))                          (return t))))
572    
573                   (:newline                   (:newline
574                    ;; When a #\Newline is hit, then the matching paren must lie on                    ;; When a #\Newline is hit, then the matching paren must lie
575                    ;; some other line so drop down into the multiple line balancing                    ;; on some other line so drop down into the multiple line
576                    ;; function:  QUEST-FOR-BALANCING-PAREN                    ;; balancing function: QUEST-FOR-BALANCING-PAREN If no paren
577                    ;; If no paren seen yet, keep going.                    ;; seen yet, keep going.
578                    (cond ((zerop paren-count))                    (cond ((zerop paren-count))
579                          ((quest-for-balancing-paren ,mark paren-count ,forwardp)                          ((quest-for-balancing-paren ,mark paren-count ,forwardp)
580                           (move-mark ,actual-mark ,mark)                           (move-mark ,actual-mark ,mark)
# Line 742  according to the FORWARDP flag." Line 740  according to the FORWARDP flag."
740    
741    
742    
743  ;;;; #### FORM OFFSETING ####  ;;;; Form offseting.
744    
745  (defmacro %form-offset (mark forwardp)  (defmacro %form-offset (mark forwardp)
746    `(with-mark ((m ,mark))    `(with-mark ((m ,mark))
# Line 799  according to the FORWARDP flag." Line 797  according to the FORWARDP flag."
797    
798    
799    
800  ;;; Table of special forms with special indenting requirements.  ;;;; Table of special forms with special indenting requirements.
   
801    
802  (defhvar "Indent Defanything"  (defhvar "Indent Defanything"
803    "This is the number of special arguments implicitly assumed to be supplied    "This is the number of special arguments implicitly assumed to be supplied
# Line 907  according to the FORWARDP flag." Line 904  according to the FORWARDP flag."
904  (defindent "abort" 1)  (defindent "abort" 1)
905  (defindent "continue" 1)  (defindent "continue" 1)
906    
907    ;;; Debug-internals forms.
908    ;;;
909    (defindent "do-debug-function-blocks" 1)
910    (defindent "di:do-debug-function-blocks" 1)
911    (defindent "do-debug-function-variables" 1)
912    (defindent "di:do-debug-function-variables" 1)
913    (defindent "do-debug-block-locations" 1)
914    (defindent "di:do-debug-block-locations" 1)
915    ;;;
916    ;;; Debug-internals conditions
917    ;;; (define these to make uses of HANDLER-CASE indent branches correctly.)
918    ;;;
919    (defindent "debug-condition" 1)
920    (defindent "di:debug-condition" 1)
921    (defindent "no-debug-info" 1)
922    (defindent "di:no-debug-info" 1)
923    (defindent "no-debug-function-returns" 1)
924    (defindent "di:no-debug-function-returns" 1)
925    (defindent "no-debug-blocks" 1)
926    (defindent "di:no-debug-blocks" 1)
927    (defindent "lambda-list-unavailable" 1)
928    (defindent "di:lambda-list-unavailable" 1)
929    (defindent "no-debug-variables" 1)
930    (defindent "di:no-debug-variables" 1)
931    (defindent "invalid-value" 1)
932    (defindent "di:invalid-value" 1)
933    (defindent "ambiguous-variable-name" 1)
934    (defindent "di:ambiguous-variable-name" 1)
935    (defindent "debug-error" 1)
936    (defindent "di:debug-error" 1)
937    (defindent "unhandled-condition" 1)
938    (defindent "di:unhandled-condition" 1)
939    (defindent "unknown-code-location" 1)
940    (defindent "di:unknown-code-location" 1)
941    (defindent "unknown-debug-variable" 1)
942    (defindent "di:unknown-debug-variable" 1)
943    (defindent "invalid-control-stack-pointer" 1)
944    (defindent "di:invalid-control-stack-pointer" 1)
945    (defindent "frame-function-mismatch" 1)
946    (defindent "di:frame-function-mismatch" 1)
947    
948  ;;; Xlib forms.  ;;; Xlib forms.
949  ;;;  ;;;
950  (defindent "with-gcontext" 1)  (defindent "with-gcontext" 1)
# Line 935  according to the FORWARDP flag." Line 973  according to the FORWARDP flag."
973  (defindent "def-c-record" 1)  (defindent "def-c-record" 1)
974  (defindent "defrecord" 1)  (defindent "defrecord" 1)
975    
976    ;;; Wire forms.
977    (defindent "remote" 1)
978    (defindent "wire:remote" 1)
979    (defindent "remote-value" 1)
980    (defindent "wire:remote-value" 1)
981    (defindent "remote-value-bind" 3)
982    (defindent "wire:remote-value-bind" 3)
983    
984    
985    
986  ;;; Compute number of spaces which mark should be indented according to  ;;;; Indentation.
 ;;; local context and lisp grinding conventions.  
987    
988    ;;; LISP-INDENTATION -- Internal Interface.
989    ;;;
990  (defun lisp-indentation (mark)  (defun lisp-indentation (mark)
991      "Compute number of spaces which mark should be indented according to
992       local context and lisp grinding conventions.  This assumes mark is at the
993       beginning of the line to be indented."
994    (with-mark ((m mark)    (with-mark ((m mark)
995                (temp mark))                (temp mark))
996        ;; See if we are in a quoted context.
997      (unless (valid-spot m nil)      (unless (valid-spot m nil)
998        (return-from lisp-indentation        (return-from lisp-indentation (lisp-generic-indentation m)))
999                     (lisp-generic-indentation m)))      ;; Look for the paren that opens the containing form.
1000      (unless (backward-up-list m)      (unless (backward-up-list m)
1001        (return-from lisp-indentation 0))        (return-from lisp-indentation 0))
1002        ;; Move after the paren, save the start, and find the form name.
1003      (mark-after m)      (mark-after m)
1004      (with-mark ((start m))      (with-mark ((start m))
1005        (unless (and (scan-char m :lisp-syntax (not (or :space :prefix :char-quote)))        (unless (and (scan-char m :lisp-syntax
1006                                  (not (or :space :prefix :char-quote)))
1007                     (test-char (next-character m) :lisp-syntax :constituent))                     (test-char (next-character m) :lisp-syntax :constituent))
1008          (return-from lisp-indentation (mark-column start)))          (return-from lisp-indentation (mark-column start)))
1009        (with-mark ((fstart m))        (with-mark ((fstart m))
# Line 961  according to the FORWARDP flag." Line 1014  according to the FORWARDP flag."
1014                                        (string= fname "DEF" :end1 3)                                        (string= fname "DEF" :end1 3)
1015                                        (value indent-defanything)))))                                        (value indent-defanything)))))
1016            (declare (simple-string fname))            (declare (simple-string fname))
1017              ;; Now that we have the form name, did it have special syntax?
1018            (cond (special-args            (cond (special-args
1019                   (with-mark ((spec m))                   (with-mark ((spec m))
1020                     (cond ((and (form-offset spec special-args)                     (cond ((and (form-offset spec special-args)
# Line 970  according to the FORWARDP flag." Line 1024  according to the FORWARDP flag."
1024                            (mark-column m))                            (mark-column m))
1025                           (t                           (t
1026                            (+ (mark-column start) 3)))))                            (+ (mark-column start) 3)))))
1027                    ;; See if the user seems to have altered the editor's
1028                    ;; indentation, and if so, try to adhere to it.  This usually
1029                    ;; happens when you type in a quoted list constant that line
1030                    ;; wraps.  You want all the items on successive lines to fall
1031                    ;; under the first character after the opening paren, not as if
1032                    ;; you are calling a function.
1033                  ((and (form-offset temp -1)                  ((and (form-offset temp -1)
1034                        (or (blank-before-p temp)                        (or (blank-before-p temp) (not (same-line-p temp fstart)))
                           (not (same-line-p temp fstart)))  
1035                        (not (same-line-p temp mark)))                        (not (same-line-p temp mark)))
1036                   (unless (blank-before-p temp)                   (unless (blank-before-p temp)
1037                     (line-start temp)                     (line-start temp)
1038                     (find-attribute temp :space #'zerop))                     (find-attribute temp :space #'zerop))
1039                   (mark-column temp))                   (mark-column temp))
1040                    ;; Appears to be a normal form.  Is the first arg on the same
1041                    ;; line as the form name?
1042                  ((skip-valid-space m)                  ((skip-valid-space m)
1043                   (mark-column m))                   (or (lisp-indentation-check-for-local-def
1044                          mark temp fstart start t)
1045                         (mark-column m)))
1046                    ;; Okay, fall under the first character after the opening paren.
1047                  (t                  (t
1048                   (mark-column start))))))))                   (or (lisp-indentation-check-for-local-def
1049                          mark temp fstart start nil)
1050                         (mark-column start)))))))))
1051    
1052    (defhvar "Lisp Indentation Local Definers"
1053      "Forms with syntax like LABELS, MACROLET, etc."
1054      :value '("LABELS" "MACROLET" "FLET"))
1055    
1056    ;;; LISP-INDENTATION-CHECK-FOR-LOCAL-DEF -- Internal.
1057    ;;;
1058    ;;; This is a temporary hack to see how it performs.  When we are indenting
1059    ;;; what appears to be a function call, let's look for FLET or MACROLET to see
1060    ;;; if we really are indenting a local definition.  If we are, return the
1061    ;;; indentation for a DEFUN; otherwise, nil
1062    ;;;
1063    ;;; Mark is the argument to LISP-INDENTATION.  Start is just inside the paren
1064    ;;; of what looks like a function call.  If we are in an FLET, arg-list
1065    ;;; indicates whether the local function's arg-list has been entered, that is,
1066    ;;; whether we need to normally indent for a DEFUN body or indent specially for
1067    ;;; the arg-list.
1068    ;;;
1069    (defun lisp-indentation-check-for-local-def (mark temp1 temp2 start arg-list)
1070      ;; We know this succeeds from LISP-INDENTATION.
1071      (backward-up-list (move-mark temp1 mark)) ;Paren for local definition.
1072      (cond ((and (backward-up-list temp1)      ;Paren opening the list of defs
1073                  (form-offset (move-mark temp2 temp1) -1)
1074                  (mark-before temp2)
1075                  (backward-up-list temp1)      ;Paren for FLET or MACROLET.
1076                  (mark= temp1 temp2))          ;Must be in first arg form.
1077             ;; See if the containing form is named FLET or MACROLET.
1078             (mark-after temp1)
1079             (unless (and (scan-char temp1 :lisp-syntax
1080                                     (not (or :space :prefix :char-quote)))
1081                          (test-char (next-character temp1) :lisp-syntax
1082                                     :constituent))
1083               (return-from lisp-indentation-check-for-local-def nil))
1084             (move-mark temp2 temp1)
1085             (scan-char temp2 :lisp-syntax (not :constituent))
1086             (let ((fname (nstring-upcase (region-to-string (region temp1 temp2)))))
1087               (cond ((not (member fname (value lisp-indentation-local-definers)
1088                                   :test #'string=))
1089                      nil)
1090                     (arg-list
1091                      (1+ (mark-column start)))
1092                     (t
1093                      (+ (mark-column start) 3)))))))
1094    
1095    ;;; LISP-GENERIC-INDENTATION -- Internal.
1096    ;;;
1097    ;;; LISP-INDENTATION calls this when mark is in a invalid spot, or quoted
1098    ;;; context.  If we are inside a string, we return the column one greater
1099    ;;; than the opening double quote.  Otherwise, we just use the indentation
1100    ;;; of the first preceding non-blank line.
1101    ;;;
1102  (defun lisp-generic-indentation (mark)  (defun lisp-generic-indentation (mark)
1103    (let* ((line (mark-line mark))    (with-mark ((m mark))
1104           (prev (do ((line (line-previous line) (line-previous line)))      (form-offset m -1)
1105                     ((or (null line) (not (blank-line-p line))) line))))      (cond ((eq (character-attribute :lisp-syntax (next-character m))
1106      (cond (prev                 :string-quote)
1107             (line-start mark prev)             (1+ (mark-column m)))
1108             (find-attribute mark :space #'zerop)            (t
1109             (mark-column mark))             (let* ((line (mark-line mark))
1110            (t 0))))                    (prev (do ((line (line-previous line) (line-previous line)))
1111                                ((not (and line (blank-line-p line))) line))))
1112                 (cond (prev
1113                        (line-start mark prev)
1114                        (find-attribute mark :space #'zerop)
1115                        (mark-column mark))
1116                       (t 0)))))))
1117    
1118  ;;; Skip-Valid-Space  --  Internal  ;;; Skip-Valid-Space  --  Internal
1119  ;;;  ;;;
# Line 1007  according to the FORWARDP flag." Line 1129  according to the FORWARDP flag."
1129              ((valid-spot mark t) (return mark))))              ((valid-spot mark t) (return mark))))
1130      (mark-after mark)))      (mark-after mark)))
1131    
1132    (declaim (optimize (speed 0))); byte compile again
1133    
1134    
1135  ;;;; LISP Mode commands  ;;;; Indentation commands and hook functions.
1136    
1137  (defcommand "Defindent" (p)  (defcommand "Defindent" (p)
1138    "Define the Lisp indentation for the current function.    "Define the Lisp indentation for the current function.
# Line 1016  according to the FORWARDP flag." Line 1140  according to the FORWARDP flag."
1140    of special arguments for the form.  Examples: 2 for Do, 1 for Dolist.    of special arguments for the form.  Examples: 2 for Do, 1 for Dolist.
1141    If a prefix argument is supplied, then delete the indentation information."    If a prefix argument is supplied, then delete the indentation information."
1142    "Do a defindent, man!"    "Do a defindent, man!"
   (declare (ignore p))  
1143    (with-mark ((m (current-point)))    (with-mark ((m (current-point)))
1144      (pre-command-parse-check m)      (pre-command-parse-check m)
1145      (unless (backward-up-list m) (editor-error))      (unless (backward-up-list m) (editor-error))
# Line 1034  according to the FORWARDP flag." Line 1157  according to the FORWARDP flag."
1157                (when (minusp i)                (when (minusp i)
1158                  (editor-error "Indentation must be non-negative."))                  (editor-error "Indentation must be non-negative."))
1159                (defindent s i))))))                (defindent s i))))))
1160    (indent-command ()))    (indent-command nil))
1161    
1162    (defcommand "Indent Form" (p)
1163      "Indent Lisp code in the next form."
1164      "Indent Lisp code in the next form."
1165      (declare (ignore p))
1166      (let ((point (current-point)))
1167        (pre-command-parse-check point)
1168        (with-mark ((m point))
1169          (unless (form-offset m 1) (editor-error))
1170          (lisp-indent-region (region point m) "Indent Form"))))
1171    
1172    ;;; LISP-INDENT-REGION -- Internal.
1173    ;;;
1174    ;;; This indents a region of Lisp code without doing excessive redundant
1175    ;;; computation.  We parse the entire region once, then scan through doing
1176    ;;; indentation on each line.  We forcibly reparse each line that we indent so
1177    ;;; that the list operations done to determine indentation of subsequent lines
1178    ;;; will work.  This is done undoably with save1, save2, buf-region, and
1179    ;;; undo-region.
1180    ;;;
1181    (defun lisp-indent-region (region &optional (undo-text "Lisp region indenting"))
1182      (check-region-query-size region)
1183      (let ((start (region-start region))
1184            (end (region-end region)))
1185        (with-mark ((m1 start)
1186                    (m2 end))
1187          (funcall (value parse-start-function) m1)
1188          (funcall (value parse-end-function) m2)
1189          (parse-over-block (mark-line m1) (mark-line m2)))
1190        (let* ((first-line (mark-line start))
1191               (last-line (mark-line end))
1192               (prev (line-previous first-line))
1193               (prev-line-info
1194                (and prev (getf (line-plist prev) 'lisp-info)))
1195               (save1 (line-start (copy-mark start :right-inserting)))
1196               (save2 (line-end (copy-mark end :left-inserting)))
1197               (buf-region (region save1 save2))
1198               (undo-region (copy-region buf-region)))
1199          (with-mark ((bol start :left-inserting))
1200            (do ((line first-line (line-next line)))
1201                (nil)
1202              (line-start bol line)
1203              (insert-lisp-indentation bol)
1204              (let ((line-info (getf (line-plist line) 'lisp-info)))
1205                (parse-lisp-line-info bol line-info prev-line-info)
1206                (setq prev-line-info line-info))
1207              (when (eq line last-line) (return nil))))
1208          (make-region-undo :twiddle undo-text buf-region undo-region))))
1209    
1210    ;;; INDENT-FOR-LISP -- Internal.
1211    ;;;
1212    ;;; This is the value of "Indent Function" for "Lisp" mode.
1213    ;;;
1214    (defun indent-for-lisp (mark)
1215      (line-start mark)
1216      (pre-command-parse-check mark)
1217      (insert-lisp-indentation mark))
1218    
1219    (defun insert-lisp-indentation (m)
1220      (delete-horizontal-space m)
1221      (funcall (value indent-with-tabs) m (lisp-indentation m)))
1222    
1223    
1224    
1225    ;;;; Most "Lisp" mode commands.
1226    
1227  (defcommand "Beginning of Defun" (p)  (defcommand "Beginning of Defun" (p)
1228    "Move the point to the beginning of a top-level form.    "Move the point to the beginning of a top-level form.
# Line 1257  according to the FORWARDP flag." Line 1445  according to the FORWARDP flag."
1445                (move-mark point s2)))))))                (move-mark point s2)))))))
1446    
1447    
 (defcommand "Indent Form" (p)  
   "Indent Lisp code in the next form."  
   "Indent Lisp code in the next form."  
   (declare (ignore p))  
   (let ((point (current-point)))  
     (pre-command-parse-check point)  
     (with-mark ((m point))  
       (unless (form-offset m 1) (editor-error))  
       (lisp-indent-region (region point m) "Indent Form"))))  
   
 ;;; LISP-INDENT-REGION indents a region of Lisp code without doing excessive  
 ;;; redundant computation.  We parse the entire region once, then scan through  
 ;;; doing indentation on each line.  We forcibly reparse each line that we  
 ;;; indent so that the list operations done to determine indentation of  
 ;;; subsequent lines will work.  This is done undoably with save1, save2,  
 ;;; buf-region, and undo-region.  
 ;;;  
 (defun lisp-indent-region (region &optional (undo-text "Lisp region indenting"))  
   (check-region-query-size region)  
   (let ((start (region-start region))  
         (end (region-end region)))  
     (with-mark ((m1 start)  
                 (m2 end))  
       (funcall (value parse-start-function) m1)  
       (funcall (value parse-end-function) m2)  
       (parse-over-block (mark-line m1) (mark-line m2)))  
     (let* ((first-line (mark-line start))  
            (last-line (mark-line end))  
            (prev (line-previous first-line))  
            (prev-line-info  
             (and prev (getf (line-plist prev) 'lisp-info)))  
            (save1 (line-start (copy-mark start :right-inserting)))  
            (save2 (line-end (copy-mark end :left-inserting)))  
            (buf-region (region save1 save2))  
            (undo-region (copy-region buf-region)))  
       (with-mark ((bol start :left-inserting))  
         (do ((line first-line (line-next line)))  
             (nil)  
           (line-start bol line)  
           (insert-lisp-indentation bol)  
           (let ((line-info (getf (line-plist line) 'lisp-info)))  
             (parse-lisp-line-info bol line-info prev-line-info)  
             (setq prev-line-info line-info))  
           (when (eq line last-line) (return nil))))  
       (make-region-undo :twiddle undo-text buf-region undo-region))))  
   
 ;;; INDENT-FOR-LISP is the value of "Indent Function" for "Lisp" mode.  
 ;;;  
 (defun indent-for-lisp (mark)  
   (line-start mark)  
   (pre-command-parse-check mark)  
   (insert-lisp-indentation mark))  
   
 (defun insert-lisp-indentation (m)  
   (delete-horizontal-space m)  
   (funcall (value indent-with-tabs) m (lisp-indentation m)))  
   
   
1448  (defcommand "Insert ()" (p)  (defcommand "Insert ()" (p)
1449    "Insert a pair of parentheses ().    "Insert a pair of parentheses ().
1450     With positive argument, puts parentheses around the next p     With positive argument, puts parentheses around the next p
# Line 1342  according to the FORWARDP flag." Line 1472  according to the FORWARDP flag."
1472    (declare (ignore p))    (declare (ignore p))
1473    (let ((point (current-point)))    (let ((point (current-point)))
1474      (pre-command-parse-check point)      (pre-command-parse-check point)
1475      (with-mark ((m point))      (with-mark ((m point :left-inserting))
1476        (cond ((scan-char m :lisp-syntax :close-paren)        (cond ((scan-char m :lisp-syntax :close-paren)
1477               (delete-horizontal-space m)               (delete-horizontal-space m)
1478               (mark-after m)               (mark-after m)
1479               (move-mark point m)               (move-mark point m)
1480                 (delete-mark m)
1481               (indent-new-line-command 1))               (indent-new-line-command 1))
1482              (t (editor-error))))))              (t
1483                 (delete-mark m)
1484                 (editor-error))))))
1485    
1486    
1487  (defcommand "Forward Up List" (p)  (defcommand "Forward Up List" (p)
# Line 1392  according to the FORWARDP flag." Line 1525  according to the FORWARDP flag."
1525    
1526    
1527    
1528  ;;;; "Lisp Mode".  ;;;; Filling Lisp comments, strings, and indented text.
1529    
1530    (defhvar "Fill Lisp Comment Paragraph Confirm"
1531      "This determines whether \"Fill Lisp Comment Paragraph\" will prompt for
1532       confirmation to fill contiguous lines with the same initial whitespace when
1533       it is invoked outside of a comment or string."
1534      :value t)
1535    
1536    (defcommand "Fill Lisp Comment Paragraph" (p)
1537      "This fills a flushleft or indented Lisp comment.
1538       This also fills Lisp string literals using the proper indentation as a
1539       filling prefix.  When invoked outside of a comment or string, this tries
1540       to fill all contiguous lines beginning with the same initial, non-empty
1541       blankspace.  When filling a comment, the current line is used to determine a
1542       fill prefix by taking all the initial whitespace on the line, the semicolons,
1543       and any whitespace following the semicolons."
1544      "Fills a flushleft or indented Lisp comment."
1545      (declare (ignore p))
1546      (let ((point (current-point)))
1547        (pre-command-parse-check point)
1548        (with-mark ((start point)
1549                    (end point)
1550                    (m point))
1551          (let ((commentp (fill-lisp-comment-paragraph-prefix start end)))
1552            (cond (commentp
1553                   (fill-lisp-comment-or-indented-text start end))
1554                  ((and (not (valid-spot m nil))
1555                        (form-offset m -1)
1556                        (eq (character-attribute :lisp-syntax (next-character m))
1557                            :string-quote))
1558                   (fill-lisp-string m))
1559                  ((or (not (value fill-lisp-comment-paragraph-confirm))
1560                       (prompt-for-y-or-n
1561                        :prompt '("Not in a comment or string.  Fill contiguous ~
1562                                   lines with the same initial whitespace? ")))
1563                   (fill-lisp-comment-or-indented-text start end)))))))
1564    
1565    ;;; FILL-LISP-STRING -- Internal.
1566    ;;;
1567    ;;; This fills the Lisp string containing mark as if it had been entered using
1568    ;;; Hemlock's Lisp string indentation, "Indent Function" for "Lisp" mode.  This
1569    ;;; assumes the area around mark has already been PRE-COMMAND-PARSE-CHECK'ed,
1570    ;;; and it ensures the string ends before doing any filling.  This function
1571    ;;; is undo'able.
1572    ;;;
1573    (defun fill-lisp-string (mark)
1574      (with-mark ((end mark))
1575        (unless (form-offset end 1)
1576          (editor-error "Attempted to fill Lisp string, but it doesn't end?"))
1577        (let* ((mark (copy-mark mark :left-inserting))
1578               (end (copy-mark end :left-inserting))
1579               (string-region (region mark end))
1580               (undo-region (copy-region string-region))
1581               (hack (make-empty-region)))
1582          ;; Generate prefix.
1583          (funcall (value indent-with-tabs)
1584                   (region-end hack) (1+ (mark-column mark)))
1585          ;; Skip opening double quote and fill string starting on its own line.
1586          (mark-after mark)
1587          (insert-character mark #\newline)
1588          (line-start mark)
1589          (setf (mark-kind mark) :right-inserting)
1590          (fill-region string-region (region-to-string hack))
1591          ;; Clean up inserted prefix on first line, delete inserted newline, and
1592          ;; move before the double quote for undo.
1593          (with-mark ((text mark :left-inserting))
1594            (find-attribute text :whitespace #'zerop)
1595            (delete-region (region mark text)))
1596          (delete-characters mark -1)
1597          (mark-before mark)
1598          ;; Save undo.
1599          (make-region-undo :twiddle "Fill Lisp Comment Paragraph"
1600                            string-region undo-region))))
1601    
1602    ;;; FILL-LISP-COMMENT-OR-INDENTED-TEXT -- Internal.
1603    ;;;
1604    ;;; This fills all contiguous lines around start and end containing fill prefix
1605    ;;; designated by the region between start and end.  These marks can only be
1606    ;;; equal when there is no comment and no initial whitespace.  This is a bad
1607    ;;; situation since this function in that situation would fill the entire
1608    ;;; buffer into one paragraph.  This function is undo'able.
1609    ;;;
1610    (defun fill-lisp-comment-or-indented-text (start end)
1611      (when (mark= start end)
1612        (editor-error "This command only fills Lisp comments, strings, or ~
1613                       indented text, but this line is flushleft."))
1614      ;;
1615      ;; Find comment block.
1616      (let* ((prefix (region-to-string (region start end)))
1617             (length (length prefix)))
1618        (declare (simple-string prefix))
1619        (flet ((frob (mark direction)
1620                 (loop
1621                   (let* ((line (line-string (mark-line mark)))
1622                          (line-len (length line)))
1623                     (declare (simple-string line))
1624                     (unless (string= line prefix :end1 (min line-len length))
1625                       (when (= direction -1)
1626                         (unless (same-line-p mark end) (line-offset mark 1 0)))
1627                       (return)))
1628                   (unless (line-offset mark direction 0)
1629                     (when (= direction 1) (line-end mark))
1630                     (return)))))
1631          (frob start -1)
1632          (frob end 1))
1633        ;;
1634        ;; Do it undoable.
1635        (let* ((start1 (copy-mark start :right-inserting))
1636               (end2 (copy-mark end :left-inserting))
1637               (region (region start1 end2))
1638               (undo-region (copy-region region)))
1639          (fill-region region prefix)
1640          (make-region-undo :twiddle "Fill Lisp Comment Paragraph"
1641                            region undo-region))))
1642    
1643    ;;; FILL-LISP-COMMENT-PARAGRAPH-PREFIX -- Internal.
1644    ;;;
1645    ;;; This sets start and end around the prefix to be used for filling.  We
1646    ;;; assume we are dealing with a comment.  If there is no ";", then we try to
1647    ;;; find some initial whitespace.  If there is a ";", we make sure the line is
1648    ;;; blank before it to eliminate ";"'s in the middle of a line of text.
1649    ;;; Finally, if we really have a comment instead of some indented text, we skip
1650    ;;; the ";"'s and any immediately following whitespace.  We allow initial
1651    ;;; whitespace, so we can fill strings with the same command.
1652    ;;;
1653    (defun fill-lisp-comment-paragraph-prefix (start end)
1654      (line-start start)
1655      (let ((commentp t)) ; Assumes there's a comment.
1656        (unless (to-line-comment (line-start end) ";")
1657          (find-attribute end :whitespace #'zerop)
1658          #|(when (start-line-p end)
1659            (editor-error "No comment on line, and no initial whitespace."))|#
1660          (setf commentp nil))
1661        (when commentp
1662          (unless (blank-before-p end)
1663            (find-attribute (line-start end) :whitespace #'zerop)
1664            #|(when (start-line-p end)
1665              (editor-error "Semicolon preceded by unindented text."))|#
1666            (setf commentp nil)))
1667        (when commentp
1668          (find-attribute end :lisp-syntax #'(lambda (x) (not (eq x :comment))))
1669          (find-attribute end :whitespace #'zerop))
1670        commentp))
1671    
1672    
1673    
1674    ;;;; "Lisp" mode.
1675    
1676  (defcommand "LISP Mode" (p)  (defcommand "LISP Mode" (p)
1677    "Put current buffer in LISP mode."    "Put current buffer in LISP mode."
# Line 1456  according to the FORWARDP flag." Line 1735  according to the FORWARDP flag."
1735    :mode "Lisp")    :mode "Lisp")
1736    
1737    
1738    (defhvar "Open Paren Finder Function"
1739      "Should be a function that takes a mark for input and returns either NIL
1740       if the mark is not after a close paren, or two (temporary) marks
1741       surrounding the corresponding open paren."
1742      :mode "Lisp"
1743      :value 'lisp-open-paren-finder-function)
1744    
1745    (defun lisp-open-paren-finder-function (mark)
1746      (when (eq (character-attribute :lisp-syntax (previous-character mark))
1747                :close-paren)
1748        (with-mark ((mark mark))
1749          (pre-command-parse-check mark)
1750          (if (not (and (valid-spot mark nil) (list-offset mark -1)))
1751              (values nil nil)
1752              (values mark (mark-after (copy-mark mark)))))))
1753    
1754    
1755    
1756  ;;;; Some mode variables to coordinate with other stuff.  ;;;; Some mode variables to coordinate with other stuff.
1757    

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

  ViewVC Help
Powered by ViewVC 1.1.5