Changeset 13186


Ignore:
Timestamp:
Nov 10, 2009, 3:23:55 PM (10 years ago)
Author:
gz
Message:

A bunch of Hemlock Lisp mode changes:

  • Add parsing support for |symbol quoting| and #| nested comments |#. This fixes bug 421.
  • Change comment syntax coloring color from light gray to brown. Use it to color #| |# blocks as well as ;;; comments. Do NOT use it to color escaped symbol constituents.
  • Add support for moving over lisp forms without pre-parsing info, for use when pre-parsing info is not available. Use this to allow navigation (i.e. c-m-f et. al.) inside strings and comment (seems like there would have been a ticket for this but I didn't find one).
  • Make meta-. work inside comments
  • Extend double-click selection to work inside comments/strings, ditto for Enter. This fixes bug 503 and bug 509.
  • Fix a couple bugs in pre-parsing of lines with escape at end. This was the underlying cause of bug 444, so this fixes bug 444.
  • Make triple-click select symbols vs. words for double-click. This addresses bug 496.
  • parse-over-block: fix the constant reparsing of the first line.
  • set-temporary-character-attributes: do not force reparsing, as this is called a lot.
  • fix macroexpand commands to act in-lisp context
  • Init hemlock syntax attributes from ccl::%standard-readtable%
  • Replace Editor Compile Defun and Editor Evaluate Defun with Editor Execute Defun, and replace Editor Compile Region and Editor Evaluate Region with Editor Execute Expression.
  • Make the form selected by double-clicking be the same as the form used for execution and macroexpansion commands, and make it be more general. This fixes bug 577 and bug 65 and bug 188.
  • some other changes that I no longer remember because I had this checked out for way too long...
Location:
trunk/source/cocoa-ide
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/cocoa-editor.lisp

    r12916 r13186  
    12711271
    12721272
     1273(defvar *lisp-string-color* (#/blueColor ns:ns-color))
     1274(defvar *lisp-comment-color* (#/brownColor ns:ns-color))
    12731275
    12741276;;; LAYOUT is an NSLayoutManager in which we'll set temporary character
     
    12831285  (ns:with-ns-range (range)
    12841286    (let* ((color-attribute #&NSForegroundColorAttributeName)
    1285            (string-color  (#/blueColor ns:ns-color) )
    1286            (comment-color (#/darkGrayColor ns:ns-color)))
     1287           (string-color  *lisp-string-color* )
     1288           (comment-color *lisp-comment-color*))
    12871289      (hi::with-mark ((m (hi::buffer-start-mark hi::*current-buffer*)))
    12881290        (hi::line-start m start-line)
    1289         (hi::pre-command-parse-check m t))
     1291        (hi::pre-command-parse-check m))
    12901292      (do ((p pos (+ p (1+ (hi::line-length line))))
    12911293           (line start-line (hi::line-next line)))
    12921294          ((eq line end-line))
    1293         (let* ((parse-info (getf (hi::line-plist line) 'hemlock::lisp-info)))
     1295        (let* ((parse-info (getf (hi::line-plist line) 'hemlock::lisp-info))
     1296               (last-end 0))
    12941297          (when parse-info
    12951298            (dolist (r (hemlock::lisp-info-ranges-to-ignore parse-info))
    12961299              (destructuring-bind (istart . iend) r
    1297                 (let* ((is-string (if (= istart 0)
    1298                                     (hemlock::lisp-info-begins-quoted parse-info)
    1299                                     (eql (hi::line-character line (1- istart))
    1300                                          #\")))
    1301                        (color (if is-string
    1302                                 string-color
    1303                                 comment-color)))
    1304                   (if (and is-string (not (= istart 0)))
    1305                     (decf istart))
    1306                   (setf (ns:ns-range-location range) (+ p istart)
    1307                         (ns:ns-range-length range) (1+ (- iend istart)))
    1308                   (let ((attrs (#/dictionaryWithObject:forKey:
    1309                                 ns:ns-dictionary color color-attribute)))
    1310                     (#/addTemporaryAttributes:forCharacterRange:
    1311                      layout attrs range)))))))))))
     1300                (let* ((attr (if (= istart 0)
     1301                               (hemlock::lisp-info-begins-quoted parse-info)
     1302                               (if (< last-end istart)
     1303                                 (hi:character-attribute :lisp-syntax
     1304                                                         (hi::line-character line (1- istart)))
     1305                                 :comment)))
     1306                       (type (case attr
     1307                               ((:char-quote :symbol-quote) nil)
     1308                               (:string-quote :string)
     1309                               (t :comment)))
     1310                       (start (+ p istart))
     1311                       (len (- iend istart)))
     1312                  (when type
     1313                    (when (eq type :string)
     1314                      (decf start)
     1315                      (incf len 2))
     1316                    (setf (ns:ns-range-location range) start
     1317                          (ns:ns-range-length range) len)
     1318                    (let ((attrs (#/dictionaryWithObject:forKey:
     1319                                  ns:ns-dictionary
     1320                                  (if (eq type :string) string-color comment-color)
     1321                                  color-attribute)))
     1322                      (#/addTemporaryAttributes:forCharacterRange:
     1323                       layout attrs range)))
     1324                  (setq last-end iend))))))))))
    13121325
    13131326#+no
     
    13251338(objc:defmethod (#/evalSelection: :void) ((self hemlock-text-view) sender)
    13261339  (declare (ignore sender))
     1340  ;; TODO: this should just invoke editor-evaluate-region-command instead of reinventing the wheel.
    13271341  (let* ((buffer (hemlock-buffer self))
    13281342         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
     
    14931507                  (buffer (buffer-cache-buffer cache))
    14941508                  (hi::*current-buffer* buffer)
    1495                   (point (hi::buffer-point buffer)))
     1509                  (point (hi::buffer-point buffer))
     1510                  (atom-mode (or (eql g #$NSSelectByParagraph)
     1511                                 (and (eql index (#/length textstorage))
     1512                                      (let* ((event (#/currentEvent (#/window self))))
     1513                                        (and (eql (#/type event) #$NSLeftMouseDown)
     1514                                             (> (#/clickCount event) 2)))))))
    14961515             (hi::with-mark ((mark point))
    14971516               (move-hemlock-mark-to-absolute-position mark cache index)
    1498                (when (selection-offset-for-double-click buffer mark)
    1499                  ;; Act as if we started the selection at the other end, so the heuristic
    1500                  ;; in #/selectionRangeForProposedRange does the right thing.  ref bug #565.
    1501                  (hi::move-mark point mark)
    1502                  (let ((start index)
    1503                        (end (hi::mark-absolute-position mark)))
    1504                    (when (< end start) (rotatef start end))
    1505                    (ns:init-ns-range r start (- end start)))
    1506                  #+debug
    1507                  (#_NSLog #@"range = %@, proposed = %@, granularity = %d"
    1508                           :address (#_NSStringFromRange r)
    1509                           :address (#_NSStringFromRange proposed)
    1510                           :<NSS>election<G>ranularity g)
    1511                  (return-from HANDLED r))))))
     1517               (let ((region (selection-for-click mark atom-mode)))
     1518                 (when region
     1519                   ;; Act as if we started the selection at the other end, so the heuristic
     1520                   ;; in #/selectionRangeForProposedRange does the right thing.  ref bug #565.
     1521                   (cond ((hi::mark= (hi::region-start region) mark)
     1522                          (hi::move-mark point (hi::region-end region)))
     1523                         ((hi::mark= (hi::region-end region) mark)
     1524                          (hi::move-mark point (hi::region-start region))))
     1525                   (let ((start (hi::mark-absolute-position (hi::region-start region)))
     1526                         (end (hi::mark-absolute-position (hi::region-end region))))
     1527                     (assert (<= start end))
     1528                     (ns:init-ns-range r start (- end start)))
     1529                   #+debug
     1530                   (#_NSLog #@"range = %@, proposed = %@, granularity = %d"
     1531                            :address (#_NSStringFromRange r)
     1532                            :address (#_NSStringFromRange proposed)
     1533                            :<NSS>election<G>ranularity g)
     1534                   (return-from HANDLED r)))))))
    15121535       (prog1
    15131536           (call-next-method proposed g)
     
    15191542
    15201543;; Return nil to use the default Cocoa selection, which will be word for double-click, line for triple.
    1521 ;; TODO: make this consistent with "current sexp".
    1522 (defun selection-offset-for-double-click (buffer mark)
    1523   (when (string= (hi::buffer-major-mode buffer) "Lisp") ;; gag
     1544(defun selection-for-click (mark paragraph-mode-p)
     1545  (unless paragraph-mode-p
     1546    ;; Select a word if near one
     1547    (hi::with-mark ((fwd mark)
     1548                    (bwd mark))
     1549      (or (hi::find-attribute fwd :word-delimiter)
     1550          (hi::buffer-end fwd))
     1551      (or (hi::reverse-find-attribute bwd :word-delimiter)
     1552          (hi::buffer-start bwd))
     1553      (unless (hi::mark= bwd fwd)
     1554        (return-from selection-for-click (hi::region bwd fwd)))))
     1555  (when (string= (hi::buffer-major-mode (hi::mark-buffer mark)) "Lisp") ;; gag
    15241556    (hemlock::pre-command-parse-check mark)
    1525     (when (hemlock::valid-spot mark nil)
    1526       (cond ((eql (hi::next-character mark) #\()
    1527              (hemlock::list-offset mark 1))
    1528             ((eql (hi::previous-character mark) #\))
    1529              (hemlock::list-offset mark -1))))))
     1557    (hemlock::form-region-at-mark mark)))
    15301558
    15311559(defun append-output (view string)
  • trunk/source/cocoa-ide/hemlock/src/bindings.lisp

    r12860 r13186  
    356356(bind-key "Editor Evaluate Expression" #k"control-meta-escape")
    357357(bind-key "Editor Evaluate Expression" #k"meta-escape"  :mode "Editor")
    358 (bind-key "Editor Evaluate Defun" #k"control-x control-e" :mode "Editor")
    359 (bind-key "Editor Evaluate Region" #k"enter" :mode "Editor")
    360 (bind-key "Editor Evaluate Defun" #k"control-meta-x" :mode "Editor")
    361 (bind-key "Editor Compile Defun" #k"control-x control-c" :mode "Editor")
    362 (bind-key "Editor Compile Defun" #k"control-x control-C" :mode "Editor")
     358
     359(bind-key "Editor Execute Expression" #k"enter" :mode "Editor")
     360(bind-key "Editor Execute Expression" #k"control-x control-e" :mode "Editor")
     361(bind-key "Editor Execute Defun" #k"control-meta-x" :mode "Editor")
     362(bind-key "Editor Execute Defun" #k"control-x control-c" :mode "Editor")
     363(bind-key "Editor Execute Defun" #k"control-x control-C" :mode "Editor")
    363364
    364365(bind-key "Editor Macroexpand-1 Expression" #k"control-m" :mode "Editor")
  • trunk/source/cocoa-ide/hemlock/src/defsyn.lisp

    r12511 r13186  
    116116   :close-paren - A closing bracket.
    117117   :prefix - A character that is a part of any form it appears before.
     118   :prefix-dispatch - a prefix char that converts :symbol-quote to multi-line comment
    118119   :string-quote - The character that quotes a string.
    119120   :char-quote - The character that escapes a single character.
     121   :symbol-quote - The character that escapes a range of characters
    120122   :comment - The character that comments out to end of line.
    121123   :constituent - Things that make up symbols."
    122124  'symbol nil)
    123125
    124 (setf (character-attribute :lisp-syntax #\space) :space)
    125 (setf (character-attribute :lisp-syntax #\tab) :space)
     126;; Default from lisp readtable.
     127(dotimes (i 256)
     128 (let ((c (code-char i)))
     129  (setf (character-attribute :lisp-syntax c)
     130   (case (ccl::%get-readtable-char c ccl::%standard-readtable%)
     131    (#.ccl::$cht_wsp :space)
     132    (#.ccl::$cht_sesc :char-quote)
     133    (#.ccl::$cht_mesc :symbol-quote)
     134    (#.ccl::$cht_cnst :constituent)))))
    126135
    127136(setf (character-attribute :lisp-syntax #\() :open-paren)
    128137(setf (character-attribute :lisp-syntax #\)) :close-paren)
    129138(setf (character-attribute :lisp-syntax #\') :prefix)
    130 (setf (character-attribute :lisp-syntax #\`) :prefix) 
    131 (setf (character-attribute :lisp-syntax #\#) :prefix)
     139(setf (character-attribute :lisp-syntax #\`) :prefix)
    132140(setf (character-attribute :lisp-syntax #\,) :prefix)
     141(setf (character-attribute :lisp-syntax #\#) :prefix-dispatch)
    133142(setf (character-attribute :lisp-syntax #\") :string-quote)
    134 (setf (character-attribute :lisp-syntax #\\) :char-quote)
    135143(setf (character-attribute :lisp-syntax #\;) :comment)
     144
    136145(setf (character-attribute :lisp-syntax #\newline) :newline)
    137146(setf (character-attribute :lisp-syntax nil) :newline)
    138147
     148#|
    139149(do-alpha-chars (ch :both)
    140150  (setf (character-attribute :lisp-syntax ch) :constituent))
     
    173183(setf (character-attribute :lisp-syntax #\.) :constituent)
    174184(setf (character-attribute :lisp-syntax #\:) :constituent)
    175 
     185|#
    176186
    177187(defattribute "Sentence Terminator"
  • trunk/source/cocoa-ide/hemlock/src/edit-defs.lisp

    r12878 r13186  
    5353            ;; Try to get whole form
    5454            (pre-command-parse-check point)
    55             (when (valid-spot point t)
    56               (move-mark mark1 point)
    57               (form-offset mark1 -1)
    58               (move-mark mark2 mark1)
    59               (form-offset mark2 1)))))
     55            (move-mark mark1 point)
     56            (form-offset mark1 -1)
     57            (move-mark mark2 mark1)
     58            (form-offset mark2 1))))
    6059    (unless (mark= mark1 mark2)
    6160      (region-to-string (region mark1 mark2)))))
     
    9190      (editor-error "unreadable name: ~s" string)
    9291      (handler-case (edit-definition fun-name)
    93         (error (c) (editor-error (format nil "~a" c)))))))
    94      
     92        (error (c) (editor-error "~a" c))))))
     93
    9594(defcommand "Edit Command Definition" (p)
    9695  "Prompts for command definition name and goes to it for editing."
     
    107106    (declare (ignore name))
    108107    (handler-case (edit-definition (command-function command))
    109       (error (c) (editor-error (format nil "~a" c))))))
     108      (error (c) (editor-error "~a" c)))))
    110109
    111110#|
     
    390389    (let* ((info (get-source-alist name))
    391390           (msg nil))
    392       (when (null info)
     391      (when (and (null info) (symbolp name))
    393392        (let* ((seen (list name))
    394393               (found ())
  • trunk/source/cocoa-ide/hemlock/src/htext2.lisp

    r12859 r13186  
    293293(defun mark-after (mark)
    294294  "Changes the Mark to point one character after where it currently points.
    295   NIL is returned if there is no previous character."
     295  NIL is returned if there is no next character."
    296296  (let ((line (mark-line mark))
    297297        (charpos (mark-charpos mark)))
  • trunk/source/cocoa-ide/hemlock/src/lispmode.lisp

    r12635 r13186  
    4242;;; Plist.
    4343;;;
    44 ;;;     -> BEGINS-QUOTED, ENDING-QUOTED are both Boolean slots that tell whether
    45 ;;;        or not a line's begining and/or ending are quoted.
     44;;;     -> BEGINS-QUOTED, ENDING-QUOTED are both slots that tell whether or not
     45;;;        a line's begining and/or ending are quoted, and if so, how.
    4646;;;
    4747;;;     -> RANGES-TO-IGNORE is a list of cons cells, each having the form
    4848;;;        ( [begining-charpos] [end-charpos] ) each of these cells indicating
    49 ;;;        a range to ignore.  End is exclusive.
     49;;;        a range where :lisp-syntax attributes are ignored.  End is exclusive.
    5050;;;
    5151;;;     -> NET-OPEN-PARENS, NET-CLOSE-PARENS integers that are the number of
     
    5656
    5757(defstruct (lisp-info (:constructor make-lisp-info ()))
    58   (begins-quoted nil)           ; (or t nil)
    59   (ending-quoted nil)           ; (or t nil)
     58  (begins-quoted nil)           ; nil or quote char attribute or comment nesting depth
     59  (ending-quoted nil)           ; nil or quote char attribute or comment nesting depth
    6060  (ranges-to-ignore nil)
    6161  (net-open-parens 0 :type fixnum)
     
    110110  `(find-attribute ,mark :lisp-syntax
    111111                   #'(lambda (x)
    112                        (member x '(:open-paren :close-paren :newline :comment
    113                                                :char-quote :string-quote)))))
     112                       (member x '(:open-paren :close-paren :newline :comment :prefix-dispatch
     113                                               :char-quote :symbol-quote :string-quote)))))
    114114;;;
    115115;;; PUSH-RANGE
     
    205205         
    206206         (when (or fer-sure-parse     
    207                    (not line-info)     
    208                    (not prev-line-info)
    209                    
    210                    (not (eq (lisp-info-begins-quoted line-info)
    211                             (lisp-info-ending-quoted prev-line-info)))
    212                    
    213                    (not (eql (line-signature test-line)     
     207                   (not line-info)
     208                   (not (eq (lisp-info-begins-quoted line-info)
     209                            (let ((prev (and prev-line-info (lisp-info-ending-quoted prev-line-info))))
     210                              (and (not (eq prev :char-quote)) prev))))
     211                   (not (eql (line-signature test-line)
    214212                             (lisp-info-signature-slot line-info))))
    215            
     213
    216214           (move-to-position mark 0 test-line)
    217215           
     
    280278        (net-close-parens 0))
    281279    (declare (fixnum net-open-parens net-close-parens))
    282    
     280
    283281    ;; Re-set the slots necessary
    284    
     282
    285283    (setf (lisp-info-ranges-to-ignore line-info) nil)
    286    
     284
     285    (setf (lisp-info-ending-quoted line-info) nil)
     286
    287287    ;; The only way the current line begins quoted is when there
    288288    ;; is a previous line and it's ending was quoted.
     
    290290    (setf (lisp-info-begins-quoted line-info)
    291291          (and prev-line-info
    292                (lisp-info-ending-quoted prev-line-info)))
    293    
    294     (if (lisp-info-begins-quoted line-info)
    295       (deal-with-string-quote mark line-info)
    296       (setf (lisp-info-ending-quoted line-info) nil))
    297    
     292               (let ((prev (lisp-info-ending-quoted prev-line-info)))
     293                 (and (not (eq prev :char-quote)) prev))))
     294
    298295    (assert (eq (hi::mark-buffer mark) (current-buffer)))
     296
     297    (when (lisp-info-begins-quoted line-info)
     298      (deal-with-quote (lisp-info-begins-quoted line-info) mark line-info))
    299299
    300300    (unless (lisp-info-ending-quoted line-info)
     
    330330                  (nextpos (1+ charpos))
    331331                  (linelen (line-length (mark-line mark))))
    332              (when (> linelen nextpos)
    333                (push-range (cons charpos nextpos)
    334                            line-info)))
    335            (mark-after mark))
    336          
     332             (when (< linelen nextpos)
     333               (setf (lisp-info-ending-quoted line-info) :char-quote)
     334               (return t))
     335             (push-range (cons charpos nextpos) line-info)
     336             (mark-after mark)))
     337
     338          (:prefix-dispatch
     339           (mark-after mark)
     340           (when (test-char (next-character mark) :lisp-syntax :symbol-quote)
     341             (mark-after mark)
     342             (unless (deal-with-quote 1 mark line-info (- (mark-charpos mark) 2))
     343               (return t))))
     344
     345          (:symbol-quote
     346           (mark-after mark)
     347           (unless (deal-with-quote :symbol-quote mark line-info)
     348             (return t)))
     349
    337350          (:string-quote
    338351           (mark-after mark)
    339            (unless (deal-with-string-quote mark line-info)
    340              (setf (lisp-info-ending-quoted line-info) t)
     352           (unless (deal-with-quote :string-quote mark line-info)
    341353             (return t)))
     354
    342355          (t (ERROR "character attribute of: ~s is ~s, at ~s"
    343356                    (next-character mark)
    344357                    (character-attribute :lisp-syntax (next-character mark))
    345358                    mark)))))
    346 
    347359    (setf (lisp-info-net-open-parens line-info) net-open-parens)
    348360    (setf (lisp-info-net-close-parens line-info) net-close-parens)
     
    353365
    354366
    355 ;;;; String quote utilities.
    356 
    357 ;;; VALID-STRING-QUOTE-P
    358 ;;;
    359 (defmacro valid-string-quote-p (mark forwardp)
     367;;;; String/symbol quote utilities.
     368
     369;;; VALID-QUOTE-P
     370;;;
     371(defmacro valid-quote-p (quote mark forwardp)
    360372  "Return T if the string-quote indicated by MARK is valid."
    361   (let ((test-mark (gensym)))
    362     `(with-mark ((,test-mark ,mark))
    363        ,(unless forwardp
    364           ;; TEST-MARK should always be right before the String-quote to be
    365           ;; checked.
    366           `(mark-before ,test-mark))
    367        (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote)
    368          (let ((slash-count 0))
    369            (loop
    370              (mark-before ,test-mark)
    371              (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote)
    372                  (incf slash-count)
    373                  (return t)))
    374            (not (oddp slash-count)))))))
     373  `(and (eq (character-attribute :lisp-syntax (direction-char ,mark ,forwardp)) ,quote)
     374        (not (char-quoted-at-mark-p ,mark ,forwardp))))
     375
     376(defun char-quoted-at-mark-p (mark forwardp)
     377  (unless forwardp
     378    (unless (mark-before mark)
     379      (return-from char-quoted-at-mark-p nil)))
     380  (loop for count upfrom 0
     381    do (unless (test-char (previous-character mark) :lisp-syntax :char-quote)
     382         (character-offset mark count) ;; go back to where started
     383         (unless forwardp
     384           (mark-after mark))
     385         (return (oddp count)))
     386    do (mark-before mark)))
    375387
    376388;;;
    377 ;;; FIND-VALID-STRING-QUOTE
    378 
    379 (defmacro find-valid-string-quote (mark &key forwardp (cease-at-eol nil))
     389;;; FIND-VALID-QUOTE
     390
     391(defmacro find-valid-quote (quote mark &key forwardp (cease-at-eol nil))
    380392  "Expand to a form that will leave MARK before a valid string-quote character,
    381393  in either a forward or backward direction, according to FORWARDP.  If
    382394  CEASE-AT-EOL is T then it will return nil if encountering the EOL before a
    383395  valid string-quote."
    384   (let ((e-mark (gensym)))
     396  (let ((e-mark (gensym))
     397        (pred (gensym)))
    385398    `(with-mark ((,e-mark ,mark))
    386        
    387        (loop
    388         (unless (scan-direction ,e-mark ,forwardp :lisp-syntax
    389                                 ,(if cease-at-eol
    390                                      `(or :newline :string-quote)
    391                                      `:string-quote))
    392           (return nil))
    393        
     399       (let ((,pred ,(if cease-at-eol
     400                       `#'(lambda (x) (or (eq x :newline) (eq x ,quote)))
     401                       `#'(lambda (x) (eq x ,quote)))))
     402
     403         (loop
     404           (unless (,(if forwardp 'find-attribute 'reverse-find-attribute)
     405                    ,e-mark :lisp-syntax ,pred)
     406             (return nil))
     407
    394408        ,@(if cease-at-eol
    395409              `((when (test-char (direction-char ,e-mark ,forwardp) :lisp-syntax
     
    397411                  (return nil))))
    398412       
    399         (when (valid-string-quote-p ,e-mark ,forwardp)
     413        (when (valid-quote-p ,quote ,e-mark ,forwardp)
    400414          (move-mark ,mark ,e-mark)
    401415          (return t))
    402416       
    403         (neighbor-mark ,e-mark ,forwardp)))))
    404 
    405 
    406 ;;;; DEAL-WITH-STRING-QUOTE.
    407 
    408 ;;; DEAL-WITH-STRING-QUOTE
    409 ;;;
    410 ;;; Called when a string is begun (i.e. parse hits a #\").  It checks for a
     417        (neighbor-mark ,e-mark ,forwardp))))))
     418
     419
     420;;; DEAL-WITH-QUOTE
     421;;;
     422;;; Called when a quoted area is begun (i.e. parse hits a #\" or #\|).  It checks for a
    411423;;; matching quote on the line that MARK points to, and puts the appropriate
    412424;;; area in the RANGES-TO-IGNORE slot and leaves MARK pointing after this area.
     
    414426;;; string-quote, whichever comes first.
    415427;;;
    416 (defun deal-with-string-quote (mark info-struct)
     428
     429(defun deal-with-quote (quote mark info-struct &optional (start (mark-charpos mark)))
    417430  "Alter the current line's info struct as necessary as due to encountering a
    418    string quote character."
    419   (with-mark ((e-mark mark))
    420     (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t)
     431  string or symbol quote character."
     432  (if (fixnump quote) ;; nesting multi-line comments
     433    (loop
     434      (unless (and (scan-char mark :lisp-syntax (or :newline :symbol-quote))
     435                   (test-char (next-character mark) :lisp-syntax :symbol-quote))
     436        (line-end mark)
     437        (push-range (cons start (mark-charpos mark)) info-struct)
     438        (setf (lisp-info-ending-quoted info-struct) quote)
     439        (return nil))
     440      (if (prog1 (test-char (previous-character mark) :lisp-syntax :prefix-dispatch) (mark-after mark))
     441        (incf quote)
     442        (when (test-char (next-character mark) :lisp-syntax :prefix-dispatch)
     443          (mark-after mark)
     444          (decf quote)
     445          (when (<= quote 0)
     446            (push-range (cons start (mark-charpos mark)) info-struct)
     447            (setf (lisp-info-ending-quoted info-struct) nil)
     448            (return mark)))))
     449    (cond ((find-valid-quote quote mark :forwardp t :cease-at-eol t)
    421450           ;; If matching quote is on this line then mark the area between the
    422451           ;; first quote (MARK) and the matching quote as invalid by pushing
    423452           ;; its begining and ending into the IGNORE-RANGE.
    424            (push-range (cons (mark-charpos mark) (mark-charpos e-mark))
    425                        info-struct)
    426            (setf (lisp-info-ending-quoted info-struct) nil)
    427            (mark-after e-mark)
    428            (move-mark mark e-mark))
     453           (push-range (cons start (mark-charpos mark)) info-struct)
     454           (mark-after mark))
    429455          ;; If the EOL has been hit before the matching quote then mark the
    430456          ;; area from MARK to the EOL as invalid.
    431457          (t
    432            (push-range (cons (mark-charpos mark)
    433                              (line-length (mark-line mark)))
    434                        info-struct)
     458           (line-end mark)
     459           (push-range (cons start (mark-charpos mark)) info-struct)
    435460           ;; The Ending is marked as still being quoted.
    436            (setf (lisp-info-ending-quoted info-struct) t)
    437            (line-end mark)
     461           (setf (lisp-info-ending-quoted info-struct) quote)
    438462           nil))))
    439 
    440 
    441 
    442463
    443464;;;; Character validity checking:
     
    489510      (and line (not region)))))
    490511
    491 
    492512;;; Scan-Direction-Valid  --  Internal
    493513;;;
     
    516536           ;; to infinitely loop.
    517537           (when (> (mark-charpos ,n-mark) (line-length ,n-line))
     538             #+gz (break "This shouldn't happen any more")
    518539             (line-offset ,n-mark 1 0))
    519540           (unless (scan-direction ,n-mark ,forwardp ,@forms)
     
    533554   according to the FORWARDP flag."
    534555  (let ((mark (gensym)))
    535     `(let ((paren-count ,extra-parens))
    536        (declare (fixnum paren-count))
    537        (with-mark ((,mark ,actual-mark))
    538          (loop
    539            (scan-direction ,mark ,forwardp :lisp-syntax
    540                            (or :close-paren :open-paren :newline))
    541            (let ((ch (direction-char ,mark ,forwardp)))
    542              (unless ch (return nil))
    543              (when (valid-spot ,mark ,forwardp)
    544                (case (character-attribute :lisp-syntax ch)
    545                  (:close-paren
    546                   (decf paren-count)
    547                   ,(when forwardp
    548                      ;; When going forward, an unmatching close-paren means the
    549                      ;; end of list.
    550                      `(when (<= paren-count 0)
    551                         (neighbor-mark ,mark ,forwardp)
    552                         (move-mark ,actual-mark ,mark)
    553                         (return t))))
    554                  (:open-paren
    555                   (incf paren-count)
    556                   ,(unless forwardp             ; Same as above only end of list
    557                      `(when (>= paren-count 0)  ; is opening parens.
    558                         (neighbor-mark ,mark ,forwardp)
    559                         (move-mark ,actual-mark ,mark)
    560                         (return t))))
    561                  
    562                  (:newline
    563                   ;; When a #\Newline is hit, then the matching paren must lie
    564                   ;; on some other line so drop down into the multiple line
    565                   ;; balancing function: QUEST-FOR-BALANCING-PAREN If no paren
    566                   ;; seen yet, keep going.
    567                   (cond ((zerop paren-count))
    568                         ((quest-for-balancing-paren ,mark paren-count ,forwardp)
    569                          (move-mark ,actual-mark ,mark)
    570                          (return t))
    571                         (t
    572                          (return nil)))))))
    573            
    574            (neighbor-mark ,mark ,forwardp))))))
     556    `(with-mark ((,mark ,actual-mark))
     557       (if (valid-spot ,mark ,forwardp)
     558         (let ((paren-count ,extra-parens))
     559           (declare (fixnum paren-count))
     560           (loop
     561             (unless (scan-direction-valid ,mark ,forwardp :lisp-syntax
     562                                           (or :close-paren :open-paren :newline))
     563               (return nil))
     564             (let ((ch (direction-char ,mark ,forwardp)))
     565               (case (character-attribute :lisp-syntax ch)
     566                 (:close-paren
     567                  (decf paren-count)
     568                  ,(when forwardp
     569                     ;; When going forward, an unmatching close-paren means the
     570                     ;; end of list.
     571                     `(when (<= paren-count 0)
     572                        (neighbor-mark ,mark ,forwardp)
     573                        (move-mark ,actual-mark ,mark)
     574                        (return t))))
     575                 (:open-paren
     576                  (incf paren-count)
     577                  ,(unless forwardp             ; Same as above only end of list
     578                     `(when (>= paren-count 0)  ; is opening parens.
     579                        (neighbor-mark ,mark ,forwardp)
     580                        (move-mark ,actual-mark ,mark)
     581                          (return t))))
     582                   
     583                   (:newline
     584                    ;; When a #\Newline is hit, then the matching paren must lie
     585                    ;; on some other line so drop down into the multiple line
     586                    ;; balancing function: QUEST-FOR-BALANCING-PAREN If no paren
     587                    ;; seen yet, keep going.
     588                    (cond ((zerop paren-count))
     589                          ((quest-for-balancing-paren ,mark paren-count ,forwardp)
     590                           (move-mark ,actual-mark ,mark)
     591                           (return t))
     592                          (t
     593                           (return nil))))))
     594             (neighbor-mark ,mark ,forwardp)))
     595         ;; We're inside a comment or a string.  Try anyway.
     596         (when ,(if forwardp
     597                  `(%forward-list-at-mark ,mark ,extra-parens t)
     598                  `(%backward-list-at-mark ,mark ,extra-parens t))
     599           (move-mark ,actual-mark ,mark))))))
    575600
    576601;;;
     
    729754       (test-char (next-character mark) :lisp-syntax :open-paren)))
    730755
    731 
    732 
    733 
    734756;;;; Form offseting.
    735757
     758;; Heuristic versions, for navigating inside comments, doesn't make use of line info
     759
     760(defun unparsed-form-offset (mark forwardp)
     761  ;; TODO: if called in "invalid" spot, arrange to stay within bounds of current invalid region.
     762  ;; For now, just stop at #||# boundaries, as first approximation.
     763  (if forwardp
     764    (forward-form mark t)
     765    (backward-form mark t)))
     766
     767(defun forward-form (mark &optional in-comment-p)
     768  ;; If in-comment-p is true, tries not to go past a |#.
     769  (with-mark ((m mark))
     770    (when (and (scan-char m :lisp-syntax (or :open-paren :close-paren :prefix-dispatch
     771                                             :symbol-quote :string-quote :char-quote
     772                                             :comment :constituent))
     773               (%forward-form-at-mark m in-comment-p))
     774      (move-mark mark m))))
     775
     776(defun backward-form (mark &optional in-comment-p)
     777  ;; If in-comment-p is true, tries not to go past a #|.
     778  (with-mark ((m mark))
     779    (when (%backward-form-at-mark m in-comment-p)
     780      (loop while (test-char (previous-character m) :lisp-syntax :prefix) do (mark-before m))
     781      (move-mark mark m))))
     782
     783(defun %forward-form-at-mark (mark in-comment-p)
     784  ;; Warning: moves mark even if returns nil (hence the % in name).
     785  (case (character-attribute :lisp-syntax (next-character mark))
     786    (:open-paren
     787     (mark-after mark)
     788     (%forward-list-at-mark mark 1))
     789    (:close-paren
     790     nil)
     791    (:char-quote
     792     (%forward-symbol-at-mark mark in-comment-p))
     793    (:symbol-quote
     794     (mark-after mark)
     795     (unless (and in-comment-p (test-char (next-character mark) :lisp-syntax :prefix-dispatch))
     796       (mark-before mark)
     797       (%forward-symbol-at-mark mark in-comment-p)))
     798    (:prefix-dispatch
     799     (mark-after mark)
     800     (if (test-char (next-character mark) :lisp-syntax :symbol-quote)
     801       (progn
     802         (mark-after mark)
     803         (%forward-nesting-comment-at-mark mark 1))
     804       (progn
     805         (mark-before mark)
     806         (%forward-symbol-at-mark mark in-comment-p))))
     807    (:string-quote
     808     (%forward-string-at-mark mark))
     809    (:constituent
     810     (%forward-symbol-at-mark mark in-comment-p))
     811    (:comment
     812     (%forward-comments-at-mark mark))
     813    (t
     814     (mark-after mark)
     815     (%forward-form-at-mark mark in-comment-p))))
     816
     817(defun %backward-form-at-mark (mark in-comment-p)
     818  ;; Warning: moves mark even if returns nil (hence the % in name).
     819  (let* ((char (previous-character mark))
     820         (attrib (character-attribute :lisp-syntax char)))
     821    (when char
     822      (mark-before mark)
     823      (when (char-quoted-at-mark-p mark t)
     824        (setq attrib :constituent))
     825      (case attrib
     826        (:open-paren
     827         nil)
     828        (:close-paren
     829         (%backward-list-at-mark mark 1))
     830        (:char-quote  ;;; can only happen if starting right after an unquoted char-quote
     831         (%backward-symbol-at-mark mark in-comment-p))
     832        (:symbol-quote
     833         (unless (and in-comment-p (test-char (previous-character mark) :lisp-syntax :prefix-dispatch))
     834           (mark-after mark)
     835           (%backward-symbol-at-mark mark in-comment-p)))
     836        (:prefix-dispatch
     837         (if (test-char (previous-character mark) :lisp-syntax :symbol-quote)
     838           (progn
     839             (mark-before mark)
     840             (%backward-nesting-comment-at-mark mark 1))
     841           (progn
     842             (mark-after mark)
     843             (%backward-symbol-at-mark mark in-comment-p))))
     844        (:string-quote
     845         (mark-after mark)
     846         (%backward-string-at-mark mark))
     847        (:constituent
     848         (mark-after mark)
     849         (%backward-symbol-at-mark mark in-comment-p))
     850        (:prefix
     851         (loop while (test-char (previous-character mark) :lisp-syntax :prefix) do (mark-before mark))
     852         mark)
     853        (:comment
     854         (loop while (test-char (previous-character mark) :lisp-syntax :comment) do (mark-before mark))
     855         mark)
     856        ;; TODO: it would be nice to skip over ;; comments if starting outside one, i.e. if encounter a newline
     857        ;; before a form starts.
     858        (t (%backward-form-at-mark mark in-comment-p))))))
     859
     860(defun %forward-symbol-at-mark (mark in-comment-p)
     861  ;; Warning: moves mark even if returns nil (hence the % in name).
     862  (loop
     863    (unless (scan-char mark :lisp-syntax (not (or :constituent :prefix-dispatch)))
     864      (return (buffer-end mark)))
     865    (case (character-attribute :lisp-syntax (next-character mark))
     866      (:symbol-quote
     867       (mark-after mark)
     868       (when (and in-comment-p (test-char (next-character mark) :lisp-syntax :prefix-dispatch))
     869         (return (mark-before mark)))
     870       (unless (loop
     871                 (unless (scan-char mark :lisp-syntax (or :char-quote :symbol-quote))
     872                   (return nil))
     873                 (when (test-char (next-character mark) :lisp-syntax :symbol-quote)
     874                   (return t))
     875                 (character-offset mark 2))
     876         (return nil))
     877       (mark-after mark))
     878      (:char-quote
     879       (character-offset mark 2))
     880      (t (return mark)))))
     881
     882(defun %backward-symbol-at-mark (mark in-comment-p)
     883  (loop
     884    (unless (rev-scan-char mark :lisp-syntax (not (or :constituent :prefix-dispatch :char-quote)))
     885      (buffer-start mark)
     886      (return mark))
     887    (mark-before mark)
     888    (if (char-quoted-at-mark-p mark t)
     889      (mark-before mark)
     890      (let* ((char (next-character mark)))
     891        (case (character-attribute :lisp-syntax char)
     892          (:symbol-quote
     893           (when (and in-comment-p (test-char (previous-character mark) :lisp-syntax :prefix-dispatch))
     894             (return (mark-after mark)))
     895           (unless (loop
     896                     (unless (rev-scan-char mark :lisp-syntax :symbol-quote)
     897                       (return nil))
     898                     (mark-before mark)
     899                     (unless (char-quoted-at-mark-p mark t)
     900                       (return t))
     901                     (mark-before mark))
     902             (return nil)))
     903          (t (mark-after mark)
     904             (return mark)))))))
     905
     906(defun %forward-nesting-comment-at-mark (mark nesting)
     907  ;; Warning: moves mark even if returns nil (hence the % in name).
     908  (loop
     909    (unless (scan-char mark :lisp-syntax :symbol-quote)
     910      (return nil))
     911    (let ((prev (previous-character mark)))
     912      (mark-after mark)
     913      (cond ((test-char prev :lisp-syntax :prefix-dispatch)
     914             (incf nesting))
     915            ((test-char (next-character mark) :lisp-syntax :prefix-dispatch)
     916             (mark-after mark)
     917             (when (<= (decf nesting) 0)
     918               (return mark)))))))
     919
     920(defun %backward-nesting-comment-at-mark (mark nesting)
     921  ;; Warning: moves mark even if returns nil (hence the % in name).
     922  (loop
     923    (unless (rev-scan-char mark :lisp-syntax :symbol-quote)
     924      (return nil))
     925    (let ((next (next-character mark)))
     926      (mark-before mark)
     927      (cond ((test-char next :lisp-syntax :prefix-dispatch)
     928             (incf nesting))
     929            ((test-char (previous-character mark) :lisp-syntax :prefix-dispatch)
     930             (mark-before mark)
     931             (when (<= (decf nesting) 0)
     932               (return mark)))))))
     933
     934
     935;; %FORM-OFFSET
     936
    736937(defmacro %form-offset (mark forwardp)
    737   `(with-mark ((m ,mark))
    738      (when (scan-direction-valid m ,forwardp :lisp-syntax
    739                                  (or :open-paren :close-paren
    740                                      :char-quote :string-quote
    741                                      :constituent))
    742        (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
    743          (:open-paren
    744           (when ,(if forwardp `(list-offset m 1) `(mark-before m))
    745             ,(unless forwardp
    746                '(scan-direction m nil :lisp-syntax (not :prefix)))
    747             (move-mark ,mark m)
    748             t))
    749          (:close-paren
    750           (when ,(if forwardp `(mark-after m) `(list-offset m -1))
    751             ,(unless forwardp
    752                '(scan-direction m nil :lisp-syntax (not :prefix)))
    753             (move-mark ,mark m)
    754             t))
    755          ((:constituent :char-quote)
    756           (scan-direction-valid m ,forwardp :lisp-syntax
    757                                 (not (or :constituent :char-quote)))
    758           ,(if forwardp
    759                `(scan-direction-valid m t :lisp-syntax
    760                                       (not (or :constituent :char-quote)))
    761                `(scan-direction-valid m nil :lisp-syntax
    762                                       (not (or :constituent :char-quote
    763                                                :prefix))))
    764           (move-mark ,mark m)
    765           t)
    766          (:string-quote
    767           (cond ((valid-spot m ,(not forwardp))
    768                  (neighbor-mark m ,forwardp)
    769                  (when (scan-direction-valid m ,forwardp :lisp-syntax
    770                                              :string-quote)
    771                    (neighbor-mark m ,forwardp)
    772                    (move-mark ,mark m)
    773                    t))
    774                 (t (neighbor-mark m ,forwardp)
    775                    (move-mark ,mark m)
    776                    t)))))))
    777 
     938  `(if (valid-spot ,mark ,forwardp)
     939     (with-mark ((m ,mark))
     940       (when (scan-direction-valid m ,forwardp :lisp-syntax
     941                                   (or :open-paren :close-paren
     942                                       :char-quote :string-quote :symbol-quote
     943                                       :prefix-dispatch :constituent))
     944         (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
     945           (:open-paren
     946            (when ,(if forwardp `(list-offset m 1) `(mark-before m))
     947              ,(unless forwardp
     948                 '(scan-direction m nil :lisp-syntax (not :prefix)))
     949              (move-mark ,mark m)
     950              t))
     951           (:close-paren
     952            (when ,(if forwardp `(mark-after m) `(list-offset m -1))
     953              ,(unless forwardp
     954                 '(scan-direction m nil :lisp-syntax (not :prefix)))
     955              (move-mark ,mark m)
     956              t))
     957           ((:constituent :char-quote :symbol-quote :prefix-dispatch)
     958            ,(if forwardp
     959               `(scan-direction-valid m t :lisp-syntax
     960                                      (not (or :constituent :char-quote :symbol-quote :prefix-dispatch)))
     961               `(scan-direction-valid m nil :lisp-syntax
     962                                      (not (or :constituent :char-quote :symbol-quote :prefix-dispatch
     963                                               :prefix))))
     964            (move-mark ,mark m)
     965            t)
     966           (:string-quote
     967            (neighbor-mark m ,forwardp)
     968            (when (scan-direction-valid m ,forwardp :lisp-syntax
     969                                        :string-quote)
     970              (neighbor-mark m ,forwardp)
     971              (move-mark ,mark m)
     972              t)))))
     973     ;; Inside a comment or a string.  Switch to heuristic method.
     974     (unparsed-form-offset ,mark ,forwardp)))
     975
     976(defun %forward-list-at-mark (mark nesting &optional in-comment-p)
     977  ;; Warning: moves mark even if returns nil (hence the % in name).
     978  (loop
     979    (unless (scan-char mark :lisp-syntax (or :open-paren :close-paren :prefix-dispatch
     980                                             :symbol-quote :string-quote :char-quote :comment))
     981      (return nil))
     982    (case (character-attribute :lisp-syntax (next-character mark))
     983      (:open-paren
     984       (mark-after mark)
     985       (incf nesting))
     986      (:close-paren
     987       (mark-after mark)
     988       (when (<= (decf nesting) 0)
     989         (return (and (eql nesting 0) mark))))
     990      (t
     991       (unless (%forward-form-at-mark mark in-comment-p)
     992         (return nil))))))
     993
     994(defun %backward-list-at-mark (mark nesting &optional in-comment-p)
     995  ;; Warning: moves mark even if returns nil (hence the % in name).
     996  (loop
     997    (unless (rev-scan-char mark :lisp-syntax (or :open-paren :close-paren :prefix-dispatch
     998                                                 :symbol-quote :string-quote :comment))
     999      (return nil))
     1000    (mark-before mark)
     1001    (if (char-quoted-at-mark-p mark t)
     1002      (mark-before mark)
     1003      (case (character-attribute :lisp-syntax (next-character mark))
     1004        (:close-paren
     1005         (incf nesting))
     1006        (:open-paren
     1007         (when (<= (decf nesting) 0)
     1008           (return mark)))
     1009        (t
     1010         (mark-after mark)
     1011         (unless (%backward-form-at-mark mark in-comment-p)
     1012           (return nil)))))))
     1013
     1014(defun %forward-string-at-mark (mark)
     1015  ;; Warning: moves mark even if returns nil (hence the % in name).
     1016  (mark-after mark)
     1017  (loop
     1018    (unless (scan-char mark :lisp-syntax (or :char-quote :string-quote))
     1019      (return nil))
     1020    (unless (test-char (next-character mark) :lisp-syntax :char-quote)
     1021      (return (mark-after mark)))
     1022    (character-offset mark 2)))
     1023
     1024
     1025(defun %backward-string-at-mark (mark)
     1026  ;; Warning: moves mark even if returns nil (hence the % in name).
     1027  (mark-before mark)
     1028  (loop
     1029    (unless (rev-scan-char mark :lisp-syntax :string-quote)
     1030      (return nil))
     1031    (mark-before mark)
     1032    (unless (char-quoted-at-mark-p mark t)
     1033      (return mark))
     1034    (mark-before mark)))
     1035
     1036(defun %forward-comments-at-mark (mark)
     1037  ;; Warning: moves mark even if returns nil (hence the % in name).
     1038  (with-mark ((m mark))
     1039    (loop
     1040      (line-end m)
     1041      (mark-after m)
     1042      (move-mark mark m)
     1043      (unless (and (scan-char m :lisp-syntax (not :space))
     1044                   (test-char (next-character m) :lisp-syntax :comment))
     1045        (return mark)))))
    7781046
    7791047(defun form-offset (mark offset)
     
    7871055        (unless (%form-offset mark nil) (return nil)))))
    7881056
    789 
    790 
     1057;; Return region for the "current form" at mark.
     1058;; TODO: See also mark-nearest-form, should merge them
     1059(defun form-region-at-mark (mark)
     1060  (with-mark ((bwd-start mark)
     1061              (bwd-end mark)
     1062              (fwd-start mark)
     1063              (fwd-end mark))
     1064    (let* ((fwd (and (or (and (char-quoted-at-mark-p mark t)       ;; back-up so get whole character
     1065                              (mark-before fwd-end))
     1066                         (test-char (next-character mark) :lisp-syntax
     1067                                    (or :open-paren :string-quote
     1068                                        :char-quote :symbol-quote :constituent :prefix-dispatch
     1069                                        :prefix)))
     1070                     (form-offset fwd-end 1)
     1071                     (form-offset (move-mark fwd-start fwd-end) -1)
     1072                     (mark<= fwd-start mark)))
     1073           (bwd (and (or (char-quoted-at-mark-p mark nil)
     1074                         (test-char (previous-character mark) :lisp-syntax
     1075                                    (or :close-paren :string-quote
     1076                                        :char-quote :symbol-quote :constituent :prefix-dispatch)))
     1077                     ;; Special case - if at an open paren, always select forward because that's
     1078                     ;; the matching paren that's highlighted.
     1079                     (not (and fwd (test-char (next-character mark) :lisp-syntax :open-paren)))
     1080                     ;; Also prefer string over anything but close paren.
     1081                     (not (and fwd (test-char (next-character mark) :lisp-syntax :string-quote)
     1082                               (not (test-char (previous-character mark) :lisp-syntax :close-paren))))
     1083                     (form-offset bwd-start -1)
     1084                     (form-offset (move-mark bwd-end bwd-start) 1)
     1085                     (mark<= mark bwd-end))))
     1086      (if bwd
     1087        (when (or (not fwd) ;; back is only option
     1088                  (and (mark= bwd-start fwd-start) (mark= bwd-end fwd-end)) ;; or they're the same
     1089                  (and (mark= bwd-start fwd-end)  ;; or had to skip prefix chars to get to forward
     1090                       (test-char (next-character fwd-start) :lisp-syntax (or :prefix :prefix-dispatch))))
     1091          (region bwd-start bwd-end))
     1092        (if fwd
     1093          (region fwd-start fwd-end))))))
    7911094
    7921095;;;; Table of special forms with special indenting requirements.
     
    9841287    (with-mark ((start m))
    9851288      (unless (and (scan-char m :lisp-syntax
    986                               (not (or :space :prefix :char-quote)))
     1289                              (not (or :space :prefix :prefix-dispatch :char-quote)))
    9871290                   (test-char (next-character m) :lisp-syntax :constituent))
    9881291        (return-from lisp-indentation (mark-column start)))
     
    10621365         (mark-after temp1)
    10631366         (unless (and (scan-char temp1 :lisp-syntax
    1064                                  (not (or :space :prefix :char-quote)))
     1367                                 (not (or :space :prefix :prefix-dispatch :char-quote)))
    10651368                      (test-char (next-character temp1) :lisp-syntax
    10661369                                 :constituent))
     
    11641467;;; undo-region.
    11651468;;;
    1166 (defun lisp-indent-region (region &optional (undo-text "Lisp region indenting"))  (let* ((start (region-start region))
     1469(defun lisp-indent-region (region &optional (undo-text "Lisp region indenting"))
     1470  (let* ((start (region-start region))
    11671471         (end (region-end region))
    11681472         (buffer (hi::line-%buffer (mark-line start))))
  • trunk/source/cocoa-ide/hemlock/src/listener.lisp

    r12877 r13186  
    199199(defcommand "Confirm Listener Input" (p)
    200200  "Evaluate Listener Mode input between point and last prompt."
    201   "Evaluate Listener Mode input between point and last prompt."
    202201  (declare (ignore p))
    203202  (let* ((input-region (get-interactive-input))
     
    319318(defcommand "Confirm Listener Input" (p)
    320319    "Evaluate Listener Mode input between point and last prompt."
    321     "Evaluate Listener Mode input between point and last prompt."
    322320  (declare (ignore p))
    323321  (if (point-at-prompt-p)
     
    341339
    342340(defcommand "POP or Delete Forward" (p)
    343   "Send :POP if input-mark is at buffer's end, else delete forward character."
    344341  "Send :POP if input-mark is at buffer's end, else delete forward character."
    345342  (let* ((input-mark (value buffer-input-mark))
     
    422419  "Search backward through the interactive history using the current input as
    423420   a search string.  Consecutive invocations repeat the previous search."
    424   "Search backward through the interactive history using the current input as
    425    a search string.  Consecutive invocations repeat the previous search."
    426421  (declare (ignore p))
    427422  (let* ((mark (value buffer-input-mark))
     
    488483  "Rotate the interactive history backwards.  The region is left around the
    489484   inserted text.  With prefix argument, rotate that many times."
    490   "Call previous-interactive-input-command with negated arg."
    491485  (previous-interactive-input-command (- (or p 1))))
    492486
    493487(defcommand "Kill Interactive Input" (p)
    494   "Kill any input to an interactive mode (Listener or Typescript)."
    495488  "Kill any input to an interactive mode (Listener or Typescript)."
    496489  (declare (ignore p))
     
    511504
    512505(defcommand "Reenter Interactive Input" (p)
    513   "Copies the form to the left of point to be after the interactive buffer's
    514    input mark.  When the current region is active, it is copied instead."
    515506  "Copies the form to the left of point to be after the interactive buffer's
    516507   input mark.  When the current region is active, it is copied instead."
     
    541532
    542533(defcommand "Editor Mode" (p)
    543   "Turn on \"Editor\" mode in the current buffer.  If it is already on, turn it
    544   off.  When in editor mode, most lisp compilation and evaluation commands
     534  "Toggle \"Editor\" mode in the current buffer. 
     535  When in editor mode, most lisp compilation and evaluation commands
    545536  manipulate the editor process instead of the current eval server."
    546   "Toggle \"Editor\" mode in the current buffer."
    547537  (declare (ignore p))
    548538  (setf (buffer-minor-mode (current-buffer) "Editor")
     
    554544
    555545
    556 
    557 (defcommand "Editor Compile Defun" (p)
    558   "Compiles the current or next top-level form in the editor Lisp.
    559    First the form is evaluated, then the result of this evaluation
    560    is passed to compile.  If the current region is active, this
    561    compiles the region."
    562   "Evaluates the current or next top-level form in the editor Lisp."
    563   (declare (ignore p))
    564   (if (region-active-p)
    565       (editor-compile-region (current-region))
    566       (editor-compile-region (defun-region (current-point)) t)))
    567 
    568 (defcommand "Editor Compile Region" (p)
    569   "Compiles lisp forms between the point and the mark in the editor Lisp."
    570   "Compiles lisp forms between the point and the mark in the editor Lisp."
    571   (declare (ignore p))
    572   (editor-compile-region (current-region)))
    573546
    574547(defun defun-region (mark)
     
    583556          (t (region start end)))))
    584557
     558(defun current-form-region (&optional (error t))
     559  (if (region-active-p)
     560    (current-region)
     561    (let ((point (current-point)))
     562      (pre-command-parse-check point)
     563      (or (form-region-at-mark point)
     564          (and error (editor-error "No current expression"))))))
     565
    585566(defun eval-region (region
    586567                    &key
     
    595576
    596577
    597 (defun editor-compile-region (region &optional quiet)
    598   (unless quiet (message "Compiling region ..."))
    599   (eval-region region))
    600 
    601 
    602 (defcommand "Editor Evaluate Defun" (p)
    603   "Evaluates the current or next top-level form.
    604    If the current region is active, this evaluates the region."
    605   (declare (ignore p))
    606   (if (region-active-p)
    607     (editor-evaluate-region-command nil)
    608     (eval-region (defun-region (current-point)))))
    609 
    610 (defcommand "Editor Evaluate Region" (p)
    611   "Evaluates lisp forms between the point and the mark"
     578(defcommand "Editor Execute Defun" (p)
     579  "Executes the current or next top-level form in the editor Lisp."
    612580  (declare (ignore p))
    613581  (if (region-active-p)
    614582    (eval-region (current-region))
    615     (let* ((point (current-point)))
    616       (pre-command-parse-check point)
    617       (when (valid-spot point nil)      ; not in the middle of a comment
    618         (cond ((eql (next-character point) #\()
    619                (with-mark ((m point))
    620                  (if (form-offset m 1)
    621                    (eval-region (region point m)))))
    622               ((eql (previous-character point) #\))
    623                (with-mark ((m point))
    624                  (if (form-offset m -1)
    625                    (eval-region (region m point)))))
    626               (t
    627                (with-mark ((start point)
    628                            (end point))
    629                  (when (mark-symbol start end)
    630                    (eval-region (region start end))))))))))
     583    (eval-region (defun-region (current-point)))))
     584
     585(defcommand "Editor Execute Expression" (p)
     586  "Executes the current region in the editor Lisp."
     587  (declare (ignore p))
     588  (eval-region (current-form-region)))
    631589
    632590(defcommand "Editor Re-evaluate Defvar" (p)
     
    643601
    644602(defun macroexpand-expression (expander)
    645   (let* ((point (buffer-point (current-buffer)))
    646          (region (if (region-active-p)
    647                    (current-region)
    648                    (with-mark ((start point))
    649                      (pre-command-parse-check start)
    650                      (with-mark ((end start))
    651                        (unless (form-offset end 1) (editor-error))
    652                        (region start end)))))
    653          (expr (with-input-from-region (s region)
    654                  (read s))))
    655     (let* ((*print-pretty* t)
    656            (expansion (funcall expander expr)))
    657       (format t "~&~s~&" expansion))))
     603  (in-lisp
     604   (let* ((region (current-form-region))
     605          (expr (with-input-from-region (s region)
     606                  (read s))))
     607     (let* ((*print-pretty* t)
     608            (expansion (funcall expander expr)))
     609       (format t "~&~s~&" expansion)))))
    658610
    659611(defcommand "Editor Macroexpand-1 Expression" (p)
    660612  "Show the macroexpansion of the current expression in the null environment.
    661613   With an argument, use MACROEXPAND instead of MACROEXPAND-1."
    662   "Show the macroexpansion of the current expression in the null environment.
    663    With an argument, use MACROEXPAND instead of MACROEXPAND-1."
    664614  (macroexpand-expression (if p 'macroexpand 'macroexpand-1)))
    665615
     
    667617  "Show the macroexpansion of the current expression in the null environment.
    668618   With an argument, use MACROEXPAND-1 instead of MACROEXPAND."
    669   "Show the macroexpansion of the current expression in the null environment.
    670    With an argument, use MACROEXPAND-1 instead of MACROEXPAND."
    671619  (macroexpand-expression (if p 'macroexpand-1 'macroexpand)))
    672620
    673621
    674622(defcommand "Editor Evaluate Expression" (p)
    675   "Prompt for an expression to evaluate in the editor Lisp."
    676623  "Prompt for an expression to evaluate in the editor Lisp."
    677624  (declare (ignore p))
     
    700647   and binary write dates.  Does not check any buffer for that file for
    701648   whether the buffer needs to be saved."
    702   "Prompts for file to compile."
    703649  (declare (ignore p))
    704650  (let ((pn (prompt-for-file :default
     
    771717(defcommand "Editor Describe Function Call" (p)
    772718  "Describe the most recently typed function name in the editor Lisp."
    773   "Describe the most recently typed function name in the editor Lisp."
    774719  (declare (ignore p))
    775720  (with-mark ((mark1 (current-point))
     
    788733(defcommand "Editor Describe Symbol" (p)
    789734  "Describe the previous s-expression if it is a symbol in the editor Lisp."
    790   "Describe the previous s-expression if it is a symbol in the editor Lisp."
    791735  (declare (ignore p))
    792736  (with-mark ((mark1 (current-point))
     
    794738    (mark-symbol mark1 mark2)
    795739    (with-input-from-region (s (region mark1 mark2))
    796       (let ((thing (read s)))
     740      (let ((thing (in-lisp (read s))))
    797741        (if (symbolp thing)
    798742          (with-pop-up-display (*standard-output* :title (format nil "~s" thing))
     
    835779  "Call Describe on a Lisp object.
    836780  Prompt for an expression which is evaluated to yield the object."
    837   "Prompt for an object to describe."
    838781  (declare (ignore p))
    839782  (in-lisp
  • trunk/source/cocoa-ide/hemlock/src/macros.lisp

    r13134 r13186  
    348348   these are errors that a normal user could encounter in the course of editing
    349349   such as a search failing or an attempt to delete past the end of the buffer."
    350   (if (current-view)
     350  (if (current-view nil)
    351351    (let ((message (and args (apply #'format nil args))))
    352352      (abort-current-command message))
Note: See TracChangeset for help on using the changeset viewer.