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

Contents of /src/hemlock/lispmode.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Wed Jun 18 09:23:09 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.10: +2 -2 lines
	Remove package nicknames USER from COMMON-LISP-USER.  Add a new
	package COMMON-LISP which LISP uses, so that COMMON-LISP no longer
	has the non-ANSI nickname LISP.

	To bootstrap, use boot13.lisp as target:bootstrap.lisp with pmai's
	build scripts, and do a full compile.

	* src/bootfiles/18e/boot13.lisp: Change for all the package
	changes.

	* src/code/exports.lisp: New package common-lisp,
	which lisp uses.

	* src/tools/worldload.lisp:
	* src/tools/setup.lisp: Use cl-user instead of user.
	Use lisp:: instead of cl::.

	* src/tools/worldcom.lisp:
	* src/tools/snapshot-update.lisp:
	* src/tools/pclcom.lisp:
	* src/tools/mk-lisp:
	* src/tools/hemcom.lisp:
	* src/tools/config.lisp:
	* src/tools/comcom.lisp:
	* src/tools/clxcom.lisp:
	* src/tools/clmcom.lisp:
	* src/pcl/defsys.lisp:
	* src/motif/lisp/initial.lisp:
	* src/interface/initial.lisp:
	* src/hemlock/lispmode.lisp (setup-lisp-mode):
	Use cl-user instead of user.

	* src/code/save.lisp (assert-user-package):
	* src/code/print.lisp (%with-standard-io-syntax): Find
	cl-user package instead of user.

	* src/code/package.lisp (package-locks-init): Add lisp.
	(package-init): Don't add user nickname to cl-user.

	* src/code/ntrace.lisp (*trace-encapsulate-package-names*):
	Add common-lisp.

	* src/code/hash.lisp (toplevel):
	* src/code/hash-new.lisp (toplevel): Use in-package :lisp
	instead of :common-lisp.

	* src/code/float-trap.lisp (sigfpe-handler): Don't
	qualify floating-point-inexact with ext:.

	* src/pcl/simple-streams/strategy.lisp (sc):
	* src/pcl/simple-streams/null.lisp (null-read-char):
	* src/pcl/simple-streams/internal.lisp (allocate-buffer)
	(free-buffer):
	* src/pcl/simple-streams/impl.lisp (%check, %read-line)
	(%peek-char, %read-byte):
	* src/pcl/simple-streams/file.lisp (open-file-stream)
	(device-close):
	* src/pcl/simple-streams/classes.lisp (simple-stream)
	(device-close):
	* src/pcl/macros.lisp (toplevel):
	* src/pcl/braid.lisp (lisp::sxhash-instance):
	* src/pcl/env.lisp (toplevel):
	* src/compiler/generic/objdef.lisp (symbol-hash):
	* src/code/stream.lisp (read-sequence, write-sequence):
	* src/code/macros.lisp (defmacro, deftype):
	* src/code/eval.lisp (interpreted-function):
	* src/code/defstruct.lisp (defstruct):
	* src/code/debug.lisp (debug-eval-print): Use lisp:: instead
	of cl::.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.3 ;;; 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.
6     ;;;
7     (ext:file-comment
8 gerd 1.11 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/lispmode.lisp,v 1.11 2003/06/18 09:23:09 gerd Rel $")
9 ram 1.3 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Hemlock LISP Mode commands
13     ;;;
14     ;;; Written by Ivan Vazquez and Bill Maddox.
15     ;;;
16    
17     (in-package "HEMLOCK")
18    
19 ram 1.3 (declaim (optimize (speed 2))); turn off byte compilation.
20 ram 1.1
21    
22 ram 1.3 ;;;; Variables and lisp-info structure.
23    
24 ram 1.1 ;;; These routines are used to define, for standard LISP mode, the start and end
25     ;;; of a block to parse. If these need to be changed for a minor mode that sits
26     ;;; on top of LISP mode, simply do a DEFHVAR with the minor mode and give the
27     ;;; name of the function to use instead of START-OF-PARSE-BLOCK and
28     ;;; END-OF-PARSE-BLOCK.
29     ;;;
30    
31     (defhvar "Parse Start Function"
32     "Take a mark and move it to the top of a block for paren parsing."
33     :value 'start-of-parse-block)
34    
35     (defhvar "Parse End Function"
36     "Take a mark and move it to the bottom of a block for paren parsing."
37     :value 'end-of-parse-block)
38    
39    
40 ram 1.3 ;;; LISP-INFO is the structure used to store the data about the line in its
41     ;;; Plist.
42     ;;;
43 ram 1.1 ;;; -> BEGINS-QUOTED, ENDING-QUOTED are both Boolean slots that tell whether
44     ;;; or not a line's begining and/or ending are quoted.
45     ;;;
46     ;;; -> RANGES-TO-IGNORE is a list of cons cells, each having the form
47     ;;; ( [begining-charpos] [end-charpos] ) each of these cells indicating
48     ;;; a range to ignore. End is exclusive.
49     ;;;
50     ;;; -> NET-OPEN-PARENS, NET-CLOSE-PARENS integers that are the number of
51     ;;; unmatched opening and closing parens that there are on a line.
52     ;;;
53     ;;; -> SIGNATURE-SLOT ...
54     ;;;
55    
56     (defstruct (lisp-info (:constructor make-lisp-info ()))
57     (begins-quoted nil) ; (or t nil)
58     (ending-quoted nil) ; (or t nil)
59     (ranges-to-ignore nil) ; (or t nil)
60     (net-open-parens 0 :type fixnum)
61     (net-close-parens 0 :type fixnum)
62     (signature-slot))
63    
64    
65    
66 ram 1.3 ;;;; Macros.
67    
68 ram 1.1 ;;; The following Macros exist to make it easy to acces the Syntax primitives
69     ;;; without uglifying the code. They were originally written by Maddox.
70     ;;;
71    
72     (defmacro scan-char (mark attribute values)
73     `(find-attribute ,mark ',attribute ,(attr-predicate values)))
74    
75     (defmacro rev-scan-char (mark attribute values)
76     `(reverse-find-attribute ,mark ',attribute ,(attr-predicate values)))
77    
78     (defmacro test-char (char attribute values)
79     `(let ((x (character-attribute ',attribute ,char)))
80     ,(attr-predicate-aux values)))
81    
82     (eval-when (compile load eval)
83     (defun attr-predicate (values)
84     (cond ((eq values 't)
85     '#'plusp)
86     ((eq values 'nil)
87     '#'zerop)
88     (t `#'(lambda (x) ,(attr-predicate-aux values)))))
89    
90     (defun attr-predicate-aux (values)
91     (cond ((eq values t)
92     '(plusp x))
93     ((eq values nil)
94     '(zerop x))
95     ((symbolp values)
96     `(eq x ',values))
97     ((and (listp values) (member (car values) '(and or not)))
98     (cons (car values) (mapcar #'attr-predicate-aux (cdr values))))
99     (t (error "Illegal form in attribute pattern - ~S" values))))
100    
101     ); Eval-When (Compile Load Eval)
102    
103     ;;;
104     ;;; FIND-LISP-CHAR
105    
106     (defmacro find-lisp-char (mark)
107     "Move MARK to next :LISP-SYNTAX character, if one isn't found, return NIL."
108     `(find-attribute ,mark :lisp-syntax
109     #'(lambda (x)
110     (member x '(:open-paren :close-paren :newline :comment
111     :char-quote :string-quote)))))
112     ;;;
113     ;;; PUSH-RANGE
114    
115     (defmacro push-range (new-range info-struct)
116     "Insert NEW-RANGE into the LISP-INFO-RANGES-TO-IGNORE slot of the INFO-STRUCT."
117     `(when ,new-range
118     (setf (lisp-info-ranges-to-ignore ,info-struct)
119     (cons ,new-range (lisp-info-ranges-to-ignore ,info-struct)))))
120     ;;;
121     ;;; SCAN-DIRECTION
122    
123     (defmacro scan-direction (mark forwardp &rest forms)
124     "Expand to a form that scans either backward or forward according to Forwardp."
125     (if forwardp
126     `(scan-char ,mark ,@forms)
127     `(rev-scan-char ,mark ,@forms)))
128     ;;;
129     ;;; DIRECTION-CHAR
130    
131     (defmacro direction-char (mark forwardp)
132     "Expand to a form that returns either the previous or next character according
133     to Forwardp."
134     (if forwardp
135     `(next-character ,mark)
136     `(previous-character ,mark)))
137    
138     ;;;
139     ;;; NEIGHBOR-MARK
140    
141     (defmacro neighbor-mark (mark forwardp)
142     "Expand to a form that moves MARK either backward or forward one character,
143     depending on FORWARDP."
144     (if forwardp
145     `(mark-after ,mark)
146     `(mark-before ,mark)))
147    
148     ;;;
149     ;;; NEIGHBOR-LINE
150    
151     (defmacro neighbor-line (line forwardp)
152     "Expand to return the next or previous line, according to Forwardp."
153     (if forwardp
154     `(line-next ,line)
155     `(line-previous ,line)))
156    
157    
158 ram 1.3 ;;;; Parsing functions.
159    
160     ;;; PRE-COMMAND-PARSE-CHECK -- Public.
161 ram 1.1 ;;;
162     (defun pre-command-parse-check (mark &optional (fer-sure-parse nil))
163     "Parse the area before the command is actually executed."
164     (with-mark ((top mark)
165     (bottom mark))
166     (funcall (value parse-start-function) top)
167     (funcall (value parse-end-function) bottom)
168     (parse-over-block (mark-line top) (mark-line bottom) fer-sure-parse)))
169    
170     ;;; PARSE-OVER-BLOCK
171 ram 1.3 ;;;
172 ram 1.1 (defun parse-over-block (start-line end-line &optional (fer-sure-parse nil))
173     "Parse over an area indicated from END-LINE to START-LINE."
174     (let ((test-line start-line)
175     prev-line-info)
176    
177     (with-mark ((mark (mark test-line 0)))
178    
179     ; Set the pre-begining and post-ending lines to delimit the range
180     ; of action any command will take. This means set the lisp-info of the
181     ; lines immediately before and after the block to Nil.
182    
183     (when (line-previous start-line)
184     (setf (getf (line-plist (line-previous start-line)) 'lisp-info) nil))
185     (when (line-next end-line)
186     (setf (getf (line-plist (line-next end-line)) 'lisp-info) nil))
187    
188     (loop
189     (let ((line-info (getf (line-plist test-line) 'lisp-info)))
190    
191     ;; Reparse the line when any of the following are true:
192     ;;
193     ;; FER-SURE-PARSE is T
194     ;;
195     ;; LINE-INFO or PREV-LINE-INFO are Nil.
196     ;;
197     ;; If the line begins quoted and the previous one wasn't
198     ;; ended quoted.
199     ;;
200     ;; The Line's signature slot is invalid (the line has changed).
201     ;;
202    
203     (when (or fer-sure-parse
204     (not line-info)
205     (not prev-line-info)
206    
207     (not (eq (lisp-info-begins-quoted line-info)
208     (lisp-info-ending-quoted prev-line-info)))
209    
210     (not (eql (line-signature test-line)
211     (lisp-info-signature-slot line-info))))
212    
213     (move-to-position mark 0 test-line)
214    
215     (unless line-info
216     (setf line-info (make-lisp-info))
217     (setf (getf (line-plist test-line) 'lisp-info) line-info))
218    
219     (parse-lisp-line-info mark line-info prev-line-info))
220    
221     (when (eq end-line test-line)
222     (return nil))
223    
224     (setq prev-line-info line-info)
225    
226     (setq test-line (line-next test-line)))))))
227    
228    
229 ram 1.3 ;;;; Parse block finders.
230 ram 1.1
231     (defhvar "Minimum Lines Parsed"
232     "The minimum number of lines before and after the point parsed by Lisp mode."
233     :value 50)
234     (defhvar "Maximum Lines Parsed"
235     "The maximum number of lines before and after the point parsed by Lisp mode."
236     :value 500)
237     (defhvar "Defun Parse Goal"
238     "Lisp mode parses the region obtained by skipping this many defuns forward
239     and backward from the point unless this falls outside of the range specified
240     by \"Minimum Lines Parsed\" and \"Maximum Lines Parsed\"."
241     :value 2)
242    
243    
244     (macrolet ((frob (step end)
245     `(let ((min (value minimum-lines-parsed))
246     (max (value maximum-lines-parsed))
247     (goal (value defun-parse-goal))
248     (last-defun nil))
249     (declare (fixnum min max goal))
250     (do ((line (mark-line mark) (,step line))
251     (count 0 (1+ count)))
252     ((null line)
253     (,end mark))
254     (declare (fixnum count))
255     (when (char= (line-character line 0) #\()
256     (setq last-defun line)
257     (decf goal)
258     (when (and (<= goal 0) (>= count min))
259     (line-start mark line)
260     (return)))
261     (when (> count max)
262     (line-start mark (or last-defun line))
263     (return))))))
264    
265     (defun start-of-parse-block (mark)
266     (frob line-previous buffer-start))
267    
268     (defun end-of-parse-block (mark)
269     (frob line-next buffer-end)))
270    
271     ;;;
272     ;;; START-OF-SEARCH-LINE
273    
274     (defun start-of-search-line (line)
275     "Set LINE to the begining line of the block of text to parse."
276     (with-mark ((mark (mark line 0)))
277     (funcall (value 'Parse-Start-Function) mark)
278     (setq line (mark-line mark))))
279    
280     ;;;
281     ;;; END-OF-SEACH-LINE
282    
283     (defun end-of-search-line (line)
284     "Set LINE to the ending line of the block of text to parse."
285     (with-mark ((mark (mark line 0)))
286     (funcall (value 'Parse-End-Function) mark)
287     (setq line (mark-line mark))))
288    
289    
290 ram 1.3 ;;;; PARSE-LISP-LINE-INFO.
291    
292     ;;; PARSE-LISP-LINE-INFO -- Internal.
293     ;;;
294     ;;; This parses through the line doing the following things:
295     ;;;
296 ram 1.1 ;;; Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS.
297 ram 1.3 ;;;
298 ram 1.1 ;;; Making all areas of the line that should be invalid (comments,
299     ;;; char-quotes, and the inside of strings) and such be in
300     ;;; RANGES-TO-IGNORE.
301     ;;;
302     ;;; Set BEGINS-QUOTED and ENDING-QUOTED
303 ram 1.3 ;;;
304 ram 1.1 (defun parse-lisp-line-info (mark line-info prev-line-info)
305     "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS,
306 ram 1.3 RANGES-TO-INGORE, and ENDING-QUOTED."
307 ram 1.1 (let ((net-open-parens 0)
308     (net-close-parens 0))
309     (declare (fixnum net-open-parens net-close-parens))
310    
311     ;; Re-set the slots necessary
312    
313     (setf (lisp-info-ranges-to-ignore line-info) nil)
314    
315     ;; The only way the current line begins quoted is when there
316     ;; is a previous line and it's ending was quoted.
317    
318     (setf (lisp-info-begins-quoted line-info)
319     (and prev-line-info
320     (lisp-info-ending-quoted prev-line-info)))
321    
322     (if (lisp-info-begins-quoted line-info)
323     (deal-with-string-quote mark line-info)
324     (setf (lisp-info-ending-quoted line-info) nil))
325    
326     (unless (lisp-info-ending-quoted line-info)
327     (loop
328     (find-lisp-char mark)
329     (ecase (character-attribute :lisp-syntax (next-character mark))
330    
331     (:open-paren
332     (setq net-open-parens (1+ net-open-parens))
333     (mark-after mark))
334    
335     (:close-paren
336     (if (zerop net-open-parens)
337     (setq net-close-parens (1+ net-close-parens))
338     (setq net-open-parens (1- net-open-parens)))
339     (mark-after mark))
340    
341     (:newline
342     (setf (lisp-info-ending-quoted line-info) nil)
343     (return t))
344    
345     (:comment
346     (push-range (cons (mark-charpos mark) (line-length (mark-line mark)))
347     line-info)
348     (setf (lisp-info-ending-quoted line-info) nil)
349     (return t))
350    
351     (:char-quote
352     (mark-after mark)
353     (push-range (cons (mark-charpos mark) (1+ (mark-charpos mark)))
354     line-info)
355     (mark-after mark))
356    
357     (:string-quote
358     (mark-after mark)
359     (unless (deal-with-string-quote mark line-info)
360     (setf (lisp-info-ending-quoted line-info) t)
361     (return t))))))
362    
363     (setf (lisp-info-net-open-parens line-info) net-open-parens)
364     (setf (lisp-info-net-close-parens line-info) net-close-parens)
365     (setf (lisp-info-signature-slot line-info)
366     (line-signature (mark-line mark)))))
367 ram 1.3
368    
369 ram 1.1
370 ram 1.3 ;;;; String quote utilities.
371    
372 ram 1.1 ;;; VALID-STRING-QUOTE-P
373 ram 1.3 ;;;
374 ram 1.1 (defmacro valid-string-quote-p (mark forwardp)
375     "Return T if the string-quote indicated by MARK is valid."
376     (let ((test-mark (gensym)))
377     `(with-mark ((,test-mark ,mark))
378 ram 1.3 ,(unless forwardp
379     ;; TEST-MARK should always be right before the String-quote to be
380     ;; checked.
381     `(mark-before ,test-mark))
382 ram 1.1 (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote)
383     (let ((slash-count 0))
384     (loop
385     (mark-before ,test-mark)
386     (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote)
387     (incf slash-count)
388     (return t)))
389     (not (oddp slash-count)))))))
390    
391     ;;;
392     ;;; FIND-VALID-STRING-QUOTE
393    
394     (defmacro find-valid-string-quote (mark &key forwardp (cease-at-eol nil))
395     "Expand to a form that will leave MARK before a valid string-quote character,
396     in either a forward or backward direction, according to FORWARDP. If
397     CEASE-AT-EOL is T then it will return nil if encountering the EOL before a
398     valid string-quote."
399     (let ((e-mark (gensym)))
400     `(with-mark ((,e-mark ,mark))
401    
402     (loop
403     (unless (scan-direction ,e-mark ,forwardp :lisp-syntax
404     ,(if cease-at-eol
405     `(or :newline :string-quote)
406     `:string-quote))
407     (return nil))
408    
409     ,@(if cease-at-eol
410     `((when (test-char (direction-char ,e-mark ,forwardp) :lisp-syntax
411     :newline)
412     (return nil))))
413    
414     (when (valid-string-quote-p ,e-mark ,forwardp)
415     (move-mark ,mark ,e-mark)
416     (return t))
417    
418     (neighbor-mark ,e-mark ,forwardp)))))
419    
420 ram 1.3 ;;;; DEAL-WITH-STRING-QUOTE.
421    
422     ;;; DEAL-WITH-STRING-QUOTE
423     ;;;
424 ram 1.1 ;;; Called when a string is begun (i.e. parse hits a #\"). It checks for a
425 ram 1.3 ;;; matching quote on the line that MARK points to, and puts the appropriate
426     ;;; area in the RANGES-TO-IGNORE slot and leaves MARK pointing after this area.
427     ;;; The "appropriate area" is from MARK to the end of the line or the matching
428     ;;; string-quote, whichever comes first.
429     ;;;
430 ram 1.1 (defun deal-with-string-quote (mark info-struct)
431     "Alter the current line's info struct as necessary as due to encountering a
432 ram 1.3 string quote character."
433 ram 1.1 (with-mark ((e-mark mark))
434     (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t)
435 ram 1.3 ;; If matching quote is on this line then mark the area between the
436     ;; first quote (MARK) and the matching quote as invalid by pushing
437     ;; its begining and ending into the IGNORE-RANGE.
438 ram 1.1 (push-range (cons (mark-charpos mark) (mark-charpos e-mark))
439     info-struct)
440     (setf (lisp-info-ending-quoted info-struct) nil)
441     (mark-after e-mark)
442     (move-mark mark e-mark))
443 ram 1.3 ;; If the EOL has been hit before the matching quote then mark the
444     ;; area from MARK to the EOL as invalid.
445 ram 1.1 (t
446 ram 1.3 (push-range (cons (mark-charpos mark)
447     (1+ (line-length (mark-line mark))))
448 ram 1.1 info-struct)
449     ;; The Ending is marked as still being quoted.
450     (setf (lisp-info-ending-quoted info-struct) t)
451     (line-end mark)
452     nil))))
453 ram 1.3
454    
455 ram 1.1
456     ;;;; Character validity checking:
457    
458     ;;; Find-Ignore-Region -- Internal
459     ;;;
460     ;;; If the character in the specified direction from Mark is in an ignore
461     ;;; region, then return the region and the line that the region is in as
462     ;;; values. If there is no ignore region, then return NIL and the Mark-Line.
463     ;;; If the line is not parsed, or there is no character (because of being at
464     ;;; the buffer beginning or end), then return both values NIL.
465     ;;;
466     (defun find-ignore-region (mark forwardp)
467     (flet ((scan (line pos)
468     (declare (fixnum pos))
469     (let ((info (getf (line-plist line) 'lisp-info)))
470     (if info
471     (dolist (range (lisp-info-ranges-to-ignore info)
472     (values nil line))
473     (let ((start (car range))
474     (end (cdr range)))
475     (declare (fixnum start end))
476     (when (and (>= pos start) (< pos end))
477     (return (values range line)))))
478     (values nil nil)))))
479     (let ((pos (mark-charpos mark))
480     (line (mark-line mark)))
481     (declare (fixnum pos))
482     (cond (forwardp (scan line pos))
483     ((> pos 0) (scan line (1- pos)))
484     (t
485     (let ((prev (line-previous line)))
486     (if prev
487     (scan prev (line-length prev))
488     (values nil nil))))))))
489    
490    
491     ;;; Valid-Spot -- Public
492     ;;;
493     (defun valid-spot (mark forwardp)
494     "Return true if the character pointed to by Mark is not in a quoted context,
495     false otherwise. If Forwardp is true, we use the next character, otherwise
496     we use the previous."
497     (multiple-value-bind (region line)
498     (find-ignore-region mark forwardp)
499     (and line (not region))))
500    
501    
502     ;;; Scan-Direction-Valid -- Internal
503     ;;;
504     ;;; Like scan-direction, but only stop on valid characters.
505     ;;;
506     (defmacro scan-direction-valid (mark forwardp &rest forms)
507     (let ((n-mark (gensym))
508     (n-line (gensym))
509     (n-region (gensym))
510     (n-won (gensym)))
511     `(let ((,n-mark ,mark) (,n-won nil))
512     (loop
513     (multiple-value-bind (,n-region ,n-line)
514     (find-ignore-region ,n-mark ,forwardp)
515     (unless ,n-line (return nil))
516     (if ,n-region
517     (move-to-position ,n-mark
518     ,(if forwardp
519     `(cdr ,n-region)
520     `(car ,n-region))
521     ,n-line)
522     (when ,n-won (return t)))
523     ;;
524     ;; Peculiar condition when a quoting character terminates a line.
525     ;; The ignore region is off the end of the line causing %FORM-OFFSET
526     ;; to infinitely loop.
527     (when (> (mark-charpos ,n-mark) (line-length ,n-line))
528     (line-offset ,n-mark 1 0))
529     (unless (scan-direction ,n-mark ,forwardp ,@forms)
530     (return nil))
531     (setq ,n-won t))))))
532    
533    
534 ram 1.3 ;;;; List offseting.
535    
536 ram 1.1 ;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built
537     ;;; with the same existing structure, with the altering of one variable.
538     ;;; This one variable being FORWARDP.
539     ;;;
540     (defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) )
541     "Expand to code that will go forward one list either backward or forward,
542 ram 1.3 according to the FORWARDP flag."
543 ram 1.1 (let ((mark (gensym)))
544     `(let ((paren-count ,extra-parens))
545     (declare (fixnum paren-count))
546     (with-mark ((,mark ,actual-mark))
547     (loop
548     (scan-direction ,mark ,forwardp :lisp-syntax
549     (or :close-paren :open-paren :newline))
550     (let ((ch (direction-char ,mark ,forwardp)))
551     (unless ch (return nil))
552     (when (valid-spot ,mark ,forwardp)
553     (case (character-attribute :lisp-syntax ch)
554     (:close-paren
555     (decf paren-count)
556 ram 1.3 ,(when forwardp
557     ;; When going forward, an unmatching close-paren means the
558     ;; end of list.
559     `(when (<= paren-count 0)
560 ram 1.1 (neighbor-mark ,mark ,forwardp)
561     (move-mark ,actual-mark ,mark)
562     (return t))))
563     (:open-paren
564     (incf paren-count)
565     ,(unless forwardp ; Same as above only end of list
566     `(when (>= paren-count 0) ; is opening parens.
567     (neighbor-mark ,mark ,forwardp)
568     (move-mark ,actual-mark ,mark)
569     (return t))))
570    
571     (:newline
572 ram 1.3 ;; When a #\Newline is hit, then the matching paren must lie
573     ;; on some other line so drop down into the multiple line
574     ;; balancing function: QUEST-FOR-BALANCING-PAREN If no paren
575     ;; seen yet, keep going.
576 ram 1.1 (cond ((zerop paren-count))
577     ((quest-for-balancing-paren ,mark paren-count ,forwardp)
578     (move-mark ,actual-mark ,mark)
579     (return t))
580     (t
581     (return nil)))))))
582    
583     (neighbor-mark ,mark ,forwardp))))))
584    
585     ;;;
586     ;;; QUEST-FOR-BALANCING-PAREN
587    
588     (defmacro quest-for-balancing-paren (mark paren-count forwardp)
589     "Expand to a form that finds the the balancing paren for however many opens or
590     closes are registered by Paren-Count."
591     `(let* ((line (mark-line ,mark)))
592     (loop
593     (setq line (neighbor-line line ,forwardp))
594     (unless line (return nil))
595     (let ((line-info (getf (line-plist line) 'lisp-info))
596     (unbal-paren ,paren-count))
597     (unless line-info (return nil))
598    
599     ,(if forwardp
600     `(decf ,paren-count (lisp-info-net-close-parens line-info))
601     `(incf ,paren-count (lisp-info-net-open-parens line-info)))
602    
603     (when ,(if forwardp
604     `(<= ,paren-count 0)
605     `(>= ,paren-count 0))
606     ,(if forwardp
607     `(line-start ,mark line)
608     `(line-end ,mark line))
609     (return (goto-correct-paren-char ,mark unbal-paren ,forwardp)))
610    
611     ,(if forwardp
612     `(incf ,paren-count (lisp-info-net-open-parens line-info))
613     `(decf ,paren-count (lisp-info-net-close-parens line-info)))))))
614    
615    
616     ;;;
617     ;;; GOTO-CORRECT-PAREN-CHAR
618    
619     (defmacro goto-correct-paren-char (mark paren-count forwardp)
620     "Expand to a form that will leave MARK on the correct balancing paren matching
621     however many are indicated by COUNT."
622     `(with-mark ((m ,mark))
623     (let ((count ,paren-count))
624     (loop
625     (scan-direction m ,forwardp :lisp-syntax
626     (or :close-paren :open-paren :newline))
627     (when (valid-spot m ,forwardp)
628     (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
629     (:close-paren
630     (decf count)
631     ,(when forwardp
632     `(when (zerop count)
633     (neighbor-mark m ,forwardp)
634     (move-mark ,mark m)
635     (return t))))
636    
637     (:open-paren
638     (incf count)
639     ,(unless forwardp
640     `(when (zerop count)
641     (neighbor-mark m ,forwardp)
642     (move-mark ,mark m)
643     (return t))))))
644     (neighbor-mark m ,forwardp)))))
645    
646    
647     (defun list-offset (mark offset)
648     (if (plusp offset)
649     (dotimes (i offset t)
650     (unless (%list-offset mark t) (return nil)))
651     (dotimes (i (- offset) t)
652     (unless (%list-offset mark nil) (return nil)))))
653    
654     (defun forward-up-list (mark)
655     "Moves mark just past the closing paren of the immediately containing list."
656     (%list-offset mark t :extra-parens 1))
657    
658     (defun backward-up-list (mark)
659     "Moves mark just before the opening paren of the immediately containing list."
660     (%list-offset mark nil :extra-parens -1))
661    
662    
663    
664     ;;;; Top level form location hacks (open parens beginning lines).
665    
666     ;;; NEIGHBOR-TOP-LEVEL is used only in TOP-LEVEL-OFFSET.
667     ;;;
668     (eval-when (compile eval)
669     (defmacro neighbor-top-level (line forwardp)
670     `(loop
671     (when (test-char (line-character ,line 0) :lisp-syntax :open-paren)
672     (return t))
673     (setf ,line ,(if forwardp `(line-next ,line) `(line-previous ,line)))
674     (unless ,line (return nil))))
675     ) ;eval-when
676    
677     (defun top-level-offset (mark offset)
678     "Go forward or backward offset number of top level forms. Mark is
679     returned if offset forms exists, otherwise nil."
680     (declare (fixnum offset))
681     (let* ((line (mark-line mark))
682     (at-start (test-char (line-character line 0) :lisp-syntax :open-paren)))
683     (cond ((zerop offset) mark)
684     ((plusp offset)
685     (do ((offset (if at-start offset (1- offset))
686     (1- offset)))
687     (nil)
688     (declare (fixnum offset))
689     (unless (neighbor-top-level line t) (return nil))
690     (when (zerop offset) (return (line-start mark line)))
691     (unless (setf line (line-next line)) (return nil))))
692     (t
693     (do ((offset (if (and at-start (start-line-p mark))
694     offset
695     (1+ offset))
696     (1+ offset)))
697     (nil)
698     (declare (fixnum offset))
699     (unless (neighbor-top-level line nil) (return nil))
700     (when (zerop offset) (return (line-start mark line)))
701     (unless (setf line (line-previous line)) (return nil)))))))
702    
703    
704     (defun mark-top-level-form (mark1 mark2)
705     "Moves mark1 and mark2 to the beginning and end of the current or next defun.
706     Mark1 one is used as a reference. The marks may be altered even if
707     unsuccessful. if successful, return mark2, else nil."
708     (let ((winp (cond ((inside-defun-p mark1)
709     (cond ((not (top-level-offset mark1 -1)) nil)
710     ((not (form-offset (move-mark mark2 mark1) 1)) nil)
711     (t mark2)))
712     ((start-defun-p mark1)
713     (form-offset (move-mark mark2 mark1) 1))
714     ((and (top-level-offset (move-mark mark2 mark1) -1)
715     (start-defun-p mark2)
716     (form-offset mark2 1)
717     (same-line-p mark1 mark2))
718     (form-offset (move-mark mark1 mark2) -1)
719     mark2)
720     ((top-level-offset mark1 1)
721     (form-offset (move-mark mark2 mark1) 1)))))
722     (when winp
723     (when (blank-after-p mark2) (line-offset mark2 1 0))
724     mark2)))
725    
726     (defun inside-defun-p (mark)
727     "T if the current point is (supposedly) in a top level form."
728     (with-mark ((m mark))
729     (when (top-level-offset m -1)
730     (form-offset m 1)
731     (mark> m mark))))
732    
733     (defun start-defun-p (mark)
734     "Returns t if mark is sitting before an :open-paren at the beginning of a
735     line."
736     (and (start-line-p mark)
737     (test-char (next-character mark) :lisp-syntax :open-paren)))
738    
739    
740    
741 ram 1.3 ;;;; Form offseting.
742 ram 1.1
743     (defmacro %form-offset (mark forwardp)
744     `(with-mark ((m ,mark))
745     (when (scan-direction-valid m ,forwardp :lisp-syntax
746     (or :open-paren :close-paren
747     :char-quote :string-quote
748     :constituent))
749     (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
750     (:open-paren
751     (when ,(if forwardp `(list-offset m 1) `(mark-before m))
752     ,(unless forwardp
753     '(scan-direction m nil :lisp-syntax (not :prefix)))
754     (move-mark ,mark m)
755     t))
756     (:close-paren
757     (when ,(if forwardp `(mark-after m) `(list-offset m -1))
758     ,(unless forwardp
759     '(scan-direction m nil :lisp-syntax (not :prefix)))
760     (move-mark ,mark m)
761     t))
762     ((:constituent :char-quote)
763     (scan-direction-valid m ,forwardp :lisp-syntax
764     (not (or :constituent :char-quote)))
765     ,(if forwardp
766     `(scan-direction-valid m t :lisp-syntax
767     (not (or :constituent :char-quote)))
768     `(scan-direction-valid m nil :lisp-syntax
769     (not (or :constituent :char-quote
770     :prefix))))
771     (move-mark ,mark m)
772     t)
773     (:string-quote
774     (cond ((valid-spot m ,(not forwardp))
775     (neighbor-mark m ,forwardp)
776     (when (scan-direction-valid m ,forwardp :lisp-syntax
777     :string-quote)
778     (neighbor-mark m ,forwardp)
779     (move-mark ,mark m)
780     t))
781     (t (neighbor-mark m ,forwardp)
782     (move-mark ,mark m)
783     t)))))))
784    
785    
786     (defun form-offset (mark offset)
787     "Move mark offset number of forms, after if positive, before if negative.
788     Mark is always moved. If there weren't enough forms, returns nil instead of
789     mark."
790     (if (plusp offset)
791     (dotimes (i offset t)
792     (unless (%form-offset mark t) (return nil)))
793     (dotimes (i (- offset) t)
794     (unless (%form-offset mark nil) (return nil)))))
795    
796    
797    
798 ram 1.3 ;;;; Table of special forms with special indenting requirements.
799 ram 1.1
800     (defhvar "Indent Defanything"
801     "This is the number of special arguments implicitly assumed to be supplied
802     in calls to functions whose names begin with \"DEF\". If set to NIL, this
803     feature is disabled."
804     :value 2)
805    
806     (defvar *special-forms* (make-hash-table :test #'equal))
807    
808     (defun defindent (fname args)
809     "Define Fname to have Args special arguments. If args is null then remove
810     any special arguments information."
811     (check-type fname string)
812     (let ((fname (string-upcase fname)))
813     (cond ((null args) (remhash fname *special-forms*))
814     (t
815     (check-type args integer)
816     (setf (gethash fname *special-forms*) args)))))
817    
818    
819     ;;; Hemlock forms.
820     ;;;
821     (defindent "with-mark" 1)
822     (defindent "with-random-typeout" 1)
823     (defindent "with-pop-up-display" 1)
824     (defindent "defhvar" 1)
825     (defindent "hlet" 1)
826     (defindent "defcommand" 2)
827     (defindent "defattribute" 1)
828     (defindent "command-case" 1)
829     (defindent "with-input-from-region" 1)
830     (defindent "with-output-to-mark" 1)
831     (defindent "with-output-to-window" 1)
832     (defindent "do-strings" 1)
833     (defindent "save-for-undo" 1)
834     (defindent "do-alpha-chars" 1)
835     (defindent "do-headers-buffers" 1)
836     (defindent "do-headers-lines" 1)
837     (defindent "with-headers-mark" 1)
838     (defindent "frob" 1) ;cover silly FLET and MACROLET names for Rob and Bill.
839     (defindent "with-writable-buffer" 1)
840    
841     ;;; Common Lisp forms.
842     ;;;
843     (defindent "block" 1)
844     (defindent "case" 1)
845     (defindent "catch" 1)
846     (defindent "ccase" 1)
847     (defindent "compiler-let" 1)
848     (defindent "ctypecase" 1)
849     (defindent "defconstant" 1)
850 pw 1.10 (defindent "define-compiler-macro" 2)
851 ram 1.1 (defindent "define-setf-method" 2)
852 pw 1.8 (defindent "destructuring-bind" 2)
853 ram 1.1 (defindent "defmacro" 2)
854 pw 1.5 (defindent "defpackage" 1)
855 ram 1.1 (defindent "defparameter" 1)
856     (defindent "defstruct" 1)
857     (defindent "deftype" 2)
858     (defindent "defun" 2)
859     (defindent "defvar" 1)
860     (defindent "do" 2)
861     (defindent "do*" 2)
862     (defindent "do-all-symbols" 1)
863     (defindent "do-external-symbols" 1)
864     (defindent "do-symbols" 1)
865     (defindent "dolist" 1)
866     (defindent "dotimes" 1)
867     (defindent "ecase" 1)
868     (defindent "etypecase" 1)
869     (defindent "eval-when" 1)
870     (defindent "flet" 1)
871     (defindent "labels" 1)
872     (defindent "lambda" 1)
873     (defindent "let" 1)
874     (defindent "let*" 1)
875 pw 1.7 (defindent "locally" 0)
876 ram 1.1 (defindent "loop" 0)
877     (defindent "macrolet" 1)
878     (defindent "multiple-value-bind" 2)
879     (defindent "multiple-value-call" 1)
880     (defindent "multiple-value-prog1" 1)
881     (defindent "multiple-value-setq" 1)
882     (defindent "prog1" 1)
883     (defindent "progv" 2)
884     (defindent "progn" 0)
885     (defindent "typecase" 1)
886     (defindent "unless" 1)
887     (defindent "unwind-protect" 1)
888     (defindent "when" 1)
889     (defindent "with-input-from-string" 1)
890     (defindent "with-open-file" 1)
891     (defindent "with-open-stream" 1)
892     (defindent "with-output-to-string" 1)
893 dtc 1.9 (defindent "with-package-iterator" 1)
894 ram 1.1
895     ;;; Error/condition system forms.
896     ;;;
897     (defindent "define-condition" 2)
898     (defindent "handler-bind" 1)
899     (defindent "handler-case" 1)
900     (defindent "restart-bind" 1)
901     (defindent "restart-case" 1)
902     (defindent "with-simple-restart" 1)
903     ;;; These are for RESTART-CASE branch formatting.
904     (defindent "store-value" 1)
905     (defindent "use-value" 1)
906     (defindent "muffle-warning" 1)
907     (defindent "abort" 1)
908     (defindent "continue" 1)
909    
910 ram 1.3 ;;; Debug-internals forms.
911     ;;;
912     (defindent "do-debug-function-blocks" 1)
913     (defindent "di:do-debug-function-blocks" 1)
914     (defindent "do-debug-function-variables" 1)
915     (defindent "di:do-debug-function-variables" 1)
916     (defindent "do-debug-block-locations" 1)
917     (defindent "di:do-debug-block-locations" 1)
918     ;;;
919     ;;; Debug-internals conditions
920     ;;; (define these to make uses of HANDLER-CASE indent branches correctly.)
921     ;;;
922     (defindent "debug-condition" 1)
923     (defindent "di:debug-condition" 1)
924     (defindent "no-debug-info" 1)
925     (defindent "di:no-debug-info" 1)
926     (defindent "no-debug-function-returns" 1)
927     (defindent "di:no-debug-function-returns" 1)
928     (defindent "no-debug-blocks" 1)
929     (defindent "di:no-debug-blocks" 1)
930     (defindent "lambda-list-unavailable" 1)
931     (defindent "di:lambda-list-unavailable" 1)
932     (defindent "no-debug-variables" 1)
933     (defindent "di:no-debug-variables" 1)
934     (defindent "invalid-value" 1)
935     (defindent "di:invalid-value" 1)
936     (defindent "ambiguous-variable-name" 1)
937     (defindent "di:ambiguous-variable-name" 1)
938     (defindent "debug-error" 1)
939     (defindent "di:debug-error" 1)
940     (defindent "unhandled-condition" 1)
941     (defindent "di:unhandled-condition" 1)
942     (defindent "unknown-code-location" 1)
943     (defindent "di:unknown-code-location" 1)
944     (defindent "unknown-debug-variable" 1)
945     (defindent "di:unknown-debug-variable" 1)
946     (defindent "invalid-control-stack-pointer" 1)
947     (defindent "di:invalid-control-stack-pointer" 1)
948     (defindent "frame-function-mismatch" 1)
949     (defindent "di:frame-function-mismatch" 1)
950    
951 ram 1.1 ;;; Xlib forms.
952     ;;;
953     (defindent "with-gcontext" 1)
954     (defindent "xlib:with-gcontext" 1)
955     (defindent "with-state" 1)
956     (defindent "xlib:with-state" 1)
957     (defindent "with-display" 1)
958     (defindent "xlib:with-display" 1)
959     (defindent "with-event-queue" 1)
960     (defindent "xlib:with-event-queue" 1)
961     (defindent "with-server-grabbed" 1)
962     (defindent "xlib:with-server-grabbed" 1)
963     (defindent "event-case" 1)
964     (defindent "xlib:event-case" 1)
965    
966     ;;; CLOS forms.
967     ;;;
968     (defindent "with-slots" 1)
969 pw 1.5 (defindent "with-slots*" 2) ; obsolete
970 pw 1.6 (defindent "with-accessors" 2)
971 pw 1.5 (defindent "with-accessors*" 2) ; obsolete
972 ram 1.1 (defindent "defclass" 2)
973 pw 1.5 (defindent "print-unreadable-object" 1)
974 ram 1.1
975     ;;; System forms.
976     ;;;
977     (defindent "alien-bind" 1)
978     (defindent "def-c-record" 1)
979     (defindent "defrecord" 1)
980 pw 1.8 (defindent "add-fd-handler" 2)
981     (defindent "with-fd-handler" 1)
982 ram 1.1
983 ram 1.3 ;;; Wire forms.
984     (defindent "remote" 1)
985     (defindent "wire:remote" 1)
986     (defindent "remote-value" 1)
987     (defindent "wire:remote-value" 1)
988     (defindent "remote-value-bind" 3)
989     (defindent "wire:remote-value-bind" 3)
990 ram 1.1
991 pw 1.8 ;;; Multiprocessing forms.
992     (defindent "with-lock-held" 1)
993     (defindent "process-wait" 1)
994 dtc 1.9
995     ;;; Alien forms.
996     (defindent "with-alien" 1)
997 ram 1.3
998 ram 1.1
999 ram 1.3 ;;;; Indentation.
1000 ram 1.1
1001 ram 1.3 ;;; LISP-INDENTATION -- Internal Interface.
1002     ;;;
1003 ram 1.1 (defun lisp-indentation (mark)
1004 ram 1.3 "Compute number of spaces which mark should be indented according to
1005     local context and lisp grinding conventions. This assumes mark is at the
1006     beginning of the line to be indented."
1007 ram 1.1 (with-mark ((m mark)
1008     (temp mark))
1009 ram 1.3 ;; See if we are in a quoted context.
1010 ram 1.1 (unless (valid-spot m nil)
1011 ram 1.3 (return-from lisp-indentation (lisp-generic-indentation m)))
1012     ;; Look for the paren that opens the containing form.
1013 ram 1.1 (unless (backward-up-list m)
1014     (return-from lisp-indentation 0))
1015 ram 1.3 ;; Move after the paren, save the start, and find the form name.
1016 ram 1.1 (mark-after m)
1017     (with-mark ((start m))
1018 ram 1.3 (unless (and (scan-char m :lisp-syntax
1019     (not (or :space :prefix :char-quote)))
1020 ram 1.1 (test-char (next-character m) :lisp-syntax :constituent))
1021     (return-from lisp-indentation (mark-column start)))
1022     (with-mark ((fstart m))
1023     (scan-char m :lisp-syntax (not :constituent))
1024     (let* ((fname (nstring-upcase (region-to-string (region fstart m))))
1025     (special-args (or (gethash fname *special-forms*)
1026     (and (> (length fname) 2)
1027     (string= fname "DEF" :end1 3)
1028     (value indent-defanything)))))
1029     (declare (simple-string fname))
1030 ram 1.3 ;; Now that we have the form name, did it have special syntax?
1031 ram 1.1 (cond (special-args
1032     (with-mark ((spec m))
1033     (cond ((and (form-offset spec special-args)
1034     (mark<= spec mark))
1035     (1+ (mark-column start)))
1036     ((skip-valid-space m)
1037     (mark-column m))
1038     (t
1039     (+ (mark-column start) 3)))))
1040 ram 1.3 ;; See if the user seems to have altered the editor's
1041     ;; indentation, and if so, try to adhere to it. This usually
1042     ;; happens when you type in a quoted list constant that line
1043     ;; wraps. You want all the items on successive lines to fall
1044     ;; under the first character after the opening paren, not as if
1045     ;; you are calling a function.
1046 ram 1.1 ((and (form-offset temp -1)
1047 ram 1.3 (or (blank-before-p temp) (not (same-line-p temp fstart)))
1048 ram 1.1 (not (same-line-p temp mark)))
1049     (unless (blank-before-p temp)
1050     (line-start temp)
1051     (find-attribute temp :space #'zerop))
1052     (mark-column temp))
1053 ram 1.3 ;; Appears to be a normal form. Is the first arg on the same
1054     ;; line as the form name?
1055 ram 1.1 ((skip-valid-space m)
1056 ram 1.3 (or (lisp-indentation-check-for-local-def
1057     mark temp fstart start t)
1058     (mark-column m)))
1059     ;; Okay, fall under the first character after the opening paren.
1060 ram 1.1 (t
1061 ram 1.3 (or (lisp-indentation-check-for-local-def
1062     mark temp fstart start nil)
1063     (mark-column start)))))))))
1064 ram 1.1
1065 ram 1.3 (defhvar "Lisp Indentation Local Definers"
1066     "Forms with syntax like LABELS, MACROLET, etc."
1067     :value '("LABELS" "MACROLET" "FLET"))
1068    
1069     ;;; LISP-INDENTATION-CHECK-FOR-LOCAL-DEF -- Internal.
1070     ;;;
1071     ;;; This is a temporary hack to see how it performs. When we are indenting
1072     ;;; what appears to be a function call, let's look for FLET or MACROLET to see
1073     ;;; if we really are indenting a local definition. If we are, return the
1074     ;;; indentation for a DEFUN; otherwise, nil
1075     ;;;
1076     ;;; Mark is the argument to LISP-INDENTATION. Start is just inside the paren
1077     ;;; of what looks like a function call. If we are in an FLET, arg-list
1078     ;;; indicates whether the local function's arg-list has been entered, that is,
1079     ;;; whether we need to normally indent for a DEFUN body or indent specially for
1080     ;;; the arg-list.
1081     ;;;
1082     (defun lisp-indentation-check-for-local-def (mark temp1 temp2 start arg-list)
1083     ;; We know this succeeds from LISP-INDENTATION.
1084     (backward-up-list (move-mark temp1 mark)) ;Paren for local definition.
1085     (cond ((and (backward-up-list temp1) ;Paren opening the list of defs
1086     (form-offset (move-mark temp2 temp1) -1)
1087     (mark-before temp2)
1088     (backward-up-list temp1) ;Paren for FLET or MACROLET.
1089     (mark= temp1 temp2)) ;Must be in first arg form.
1090     ;; See if the containing form is named FLET or MACROLET.
1091     (mark-after temp1)
1092     (unless (and (scan-char temp1 :lisp-syntax
1093     (not (or :space :prefix :char-quote)))
1094     (test-char (next-character temp1) :lisp-syntax
1095     :constituent))
1096     (return-from lisp-indentation-check-for-local-def nil))
1097     (move-mark temp2 temp1)
1098     (scan-char temp2 :lisp-syntax (not :constituent))
1099     (let ((fname (nstring-upcase (region-to-string (region temp1 temp2)))))
1100     (cond ((not (member fname (value lisp-indentation-local-definers)
1101     :test #'string=))
1102     nil)
1103     (arg-list
1104     (1+ (mark-column start)))
1105     (t
1106     (+ (mark-column start) 3)))))))
1107    
1108     ;;; LISP-GENERIC-INDENTATION -- Internal.
1109     ;;;
1110     ;;; LISP-INDENTATION calls this when mark is in a invalid spot, or quoted
1111     ;;; context. If we are inside a string, we return the column one greater
1112     ;;; than the opening double quote. Otherwise, we just use the indentation
1113     ;;; of the first preceding non-blank line.
1114     ;;;
1115 ram 1.1 (defun lisp-generic-indentation (mark)
1116 ram 1.3 (with-mark ((m mark))
1117     (form-offset m -1)
1118     (cond ((eq (character-attribute :lisp-syntax (next-character m))
1119     :string-quote)
1120     (1+ (mark-column m)))
1121     (t
1122     (let* ((line (mark-line mark))
1123     (prev (do ((line (line-previous line) (line-previous line)))
1124     ((not (and line (blank-line-p line))) line))))
1125     (cond (prev
1126     (line-start mark prev)
1127     (find-attribute mark :space #'zerop)
1128     (mark-column mark))
1129     (t 0)))))))
1130 ram 1.1
1131     ;;; Skip-Valid-Space -- Internal
1132     ;;;
1133     ;;; Skip over any space on the line Mark is on, stopping at the first valid
1134     ;;; non-space character. If there is none on the line, return nil.
1135     ;;;
1136     (defun skip-valid-space (mark)
1137     (loop
1138     (scan-char mark :lisp-syntax (not :space))
1139     (let ((val (character-attribute :lisp-syntax
1140     (next-character mark))))
1141     (cond ((eq val :newline) (return nil))
1142     ((valid-spot mark t) (return mark))))
1143     (mark-after mark)))
1144    
1145 ram 1.3 (declaim (optimize (speed 0))); byte compile again
1146    
1147 ram 1.1
1148 ram 1.3 ;;;; Indentation commands and hook functions.
1149 ram 1.1
1150     (defcommand "Defindent" (p)
1151     "Define the Lisp indentation for the current function.
1152     The indentation is a non-negative integer which is the number
1153     of special arguments for the form. Examples: 2 for Do, 1 for Dolist.
1154     If a prefix argument is supplied, then delete the indentation information."
1155     "Do a defindent, man!"
1156     (with-mark ((m (current-point)))
1157     (pre-command-parse-check m)
1158     (unless (backward-up-list m) (editor-error))
1159     (mark-after m)
1160     (with-mark ((n m))
1161     (scan-char n :lisp-syntax (not :constituent))
1162     (let ((s (region-to-string (region m n))))
1163     (declare (simple-string s))
1164     (when (zerop (length s)) (editor-error))
1165     (if p
1166     (defindent s nil)
1167     (let ((i (prompt-for-integer
1168     :prompt (format nil "Indentation for ~A: " s)
1169     :help "Number of special arguments.")))
1170     (when (minusp i)
1171     (editor-error "Indentation must be non-negative."))
1172     (defindent s i))))))
1173 ram 1.3 (indent-command nil))
1174 ram 1.1
1175 ram 1.3 (defcommand "Indent Form" (p)
1176     "Indent Lisp code in the next form."
1177     "Indent Lisp code in the next form."
1178     (declare (ignore p))
1179     (let ((point (current-point)))
1180     (pre-command-parse-check point)
1181     (with-mark ((m point))
1182     (unless (form-offset m 1) (editor-error))
1183     (lisp-indent-region (region point m) "Indent Form"))))
1184    
1185     ;;; LISP-INDENT-REGION -- Internal.
1186     ;;;
1187     ;;; This indents a region of Lisp code without doing excessive redundant
1188     ;;; computation. We parse the entire region once, then scan through doing
1189     ;;; indentation on each line. We forcibly reparse each line that we indent so
1190     ;;; that the list operations done to determine indentation of subsequent lines
1191     ;;; will work. This is done undoably with save1, save2, buf-region, and
1192     ;;; undo-region.
1193     ;;;
1194     (defun lisp-indent-region (region &optional (undo-text "Lisp region indenting"))
1195     (check-region-query-size region)
1196     (let ((start (region-start region))
1197     (end (region-end region)))
1198     (with-mark ((m1 start)
1199     (m2 end))
1200     (funcall (value parse-start-function) m1)
1201     (funcall (value parse-end-function) m2)
1202     (parse-over-block (mark-line m1) (mark-line m2)))
1203     (let* ((first-line (mark-line start))
1204     (last-line (mark-line end))
1205     (prev (line-previous first-line))
1206     (prev-line-info
1207     (and prev (getf (line-plist prev) 'lisp-info)))
1208     (save1 (line-start (copy-mark start :right-inserting)))
1209     (save2 (line-end (copy-mark end :left-inserting)))
1210     (buf-region (region save1 save2))
1211     (undo-region (copy-region buf-region)))
1212     (with-mark ((bol start :left-inserting))
1213     (do ((line first-line (line-next line)))
1214     (nil)
1215     (line-start bol line)
1216     (insert-lisp-indentation bol)
1217     (let ((line-info (getf (line-plist line) 'lisp-info)))
1218     (parse-lisp-line-info bol line-info prev-line-info)
1219     (setq prev-line-info line-info))
1220     (when (eq line last-line) (return nil))))
1221     (make-region-undo :twiddle undo-text buf-region undo-region))))
1222    
1223     ;;; INDENT-FOR-LISP -- Internal.
1224     ;;;
1225     ;;; This is the value of "Indent Function" for "Lisp" mode.
1226     ;;;
1227     (defun indent-for-lisp (mark)
1228     (line-start mark)
1229     (pre-command-parse-check mark)
1230     (insert-lisp-indentation mark))
1231    
1232     (defun insert-lisp-indentation (m)
1233     (delete-horizontal-space m)
1234     (funcall (value indent-with-tabs) m (lisp-indentation m)))
1235    
1236    
1237    
1238     ;;;; Most "Lisp" mode commands.
1239    
1240 ram 1.1 (defcommand "Beginning of Defun" (p)
1241     "Move the point to the beginning of a top-level form.
1242     with an argument, skips the previous p top-level forms."
1243     "Move the point to the beginning of a top-level form."
1244     (let ((point (current-point))
1245     (count (or p 1)))
1246     (pre-command-parse-check point)
1247     (if (minusp count)
1248     (end-of-defun-command (- count))
1249     (unless (top-level-offset point (- count))
1250     (editor-error)))))
1251    
1252     ;;; "End of Defun", with a positive p (the normal case), does something weird.
1253     ;;; Get a mark at the beginning of the defun, and then offset it forward one
1254     ;;; less top level form than we want. This sets us up to use FORM-OFFSET which
1255     ;;; allows us to leave the point immediately after the defun. If we used
1256     ;;; TOP-LEVEL-OFFSET one less than p on the mark at the end of the current
1257     ;;; defun, point would be left at the beginning of the p+1'st form instead of
1258     ;;; at the end of the p'th form.
1259     ;;;
1260     (defcommand "End of Defun" (p)
1261     "Move the point to the end of a top-level form.
1262     With an argument, skips the next p top-level forms."
1263     "Move the point to the end of a top-level form."
1264     (let ((point (current-point))
1265     (count (or p 1)))
1266     (pre-command-parse-check point)
1267     (if (minusp count)
1268     (beginning-of-defun-command (- count))
1269     (with-mark ((m point)
1270     (dummy point))
1271     (cond ((not (mark-top-level-form m dummy))
1272     (editor-error "No current or next top level form."))
1273     (t
1274     (unless (top-level-offset m (1- count))
1275     (editor-error "Not enough top level forms."))
1276     ;; We might be one unparsed for away.
1277     (pre-command-parse-check m)
1278     (unless (form-offset m 1)
1279     (editor-error "Not enough top level forms."))
1280     (when (blank-after-p m) (line-offset m 1 0))
1281     (move-mark point m)))))))
1282    
1283     (defcommand "Forward List" (p)
1284     "Skip over the next Lisp list.
1285     With argument, skips the next p lists."
1286     "Skip over the next Lisp list."
1287     (let ((point (current-point))
1288     (count (or p 1)))
1289     (pre-command-parse-check point)
1290     (unless (list-offset point count) (editor-error))))
1291    
1292     (defcommand "Backward List" (p)
1293     "Skip over the previous Lisp list.
1294     With argument, skips the previous p lists."
1295     "Skip over the previous Lisp list."
1296     (let ((point (current-point))
1297     (count (- (or p 1))))
1298     (pre-command-parse-check point)
1299     (unless (list-offset point count) (editor-error))))
1300    
1301     (defcommand "Forward Form" (p)
1302     "Skip over the next Form.
1303     With argument, skips the next p Forms."
1304     "Skip over the next Form."
1305     (let ((point (current-point))
1306     (count (or p 1)))
1307     (pre-command-parse-check point)
1308     (unless (form-offset point count) (editor-error))))
1309    
1310     (defcommand "Backward Form" (p)
1311     "Skip over the previous Form.
1312     With argument, skips the previous p Forms."
1313     "Skip over the previous Form."
1314     (let ((point (current-point))
1315     (count (- (or p 1))))
1316     (pre-command-parse-check point)
1317     (unless (form-offset point count) (editor-error))))
1318    
1319     (defcommand "Mark Form" (p)
1320     "Set the mark at the end of the next Form.
1321     With a positive argument, set the mark after the following p
1322     Forms. With a negative argument, set the mark before
1323     the preceding -p Forms."
1324     "Set the mark at the end of the next Form."
1325     (with-mark ((m (current-point)))
1326     (pre-command-parse-check m)
1327     (let ((count (or p 1))
1328     (mark (push-buffer-mark (copy-mark m) t)))
1329     (if (form-offset m count)
1330     (move-mark mark m)
1331     (editor-error)))))
1332    
1333     (defcommand "Mark Defun" (p)
1334     "Puts the region around the next or containing top-level form.
1335     The point is left before the form and the mark is placed immediately
1336     after it."
1337     "Puts the region around the next or containing top-level form."
1338     (declare (ignore p))
1339     (let ((point (current-point)))
1340     (pre-command-parse-check point)
1341     (with-mark ((start point)
1342     (end point))
1343     (cond ((not (mark-top-level-form start end))
1344     (editor-error "No current or next top level form."))
1345     (t
1346     (move-mark point start)
1347     (move-mark (push-buffer-mark (copy-mark point) t) end))))))
1348    
1349     (defcommand "Forward Kill Form" (p)
1350     "Kill the next Form.
1351     With a positive argument, kills the next p Forms.
1352     Kills backward with a negative argument."
1353     "Kill the next Form."
1354     (with-mark ((m1 (current-point))
1355     (m2 (current-point)))
1356     (pre-command-parse-check m1)
1357     (let ((count (or p 1)))
1358     (unless (form-offset m1 count) (editor-error))
1359     (if (minusp count)
1360     (kill-region (region m1 m2) :kill-backward)
1361     (kill-region (region m2 m1) :kill-forward)))))
1362    
1363     (defcommand "Backward Kill Form" (p)
1364     "Kill the previous Form.
1365     With a positive argument, kills the previous p Forms.
1366     Kills forward with a negative argument."
1367     "Kill the previous Form."
1368     (forward-kill-form-command (- (or p 1))))
1369    
1370 ram 1.2 (defcommand "Extract Form" (p)
1371     "Replace the current containing list with the next form. The entire affected
1372     area is pushed onto the kill ring. If an argument is supplied, that many
1373     upward levels of list nesting is replaced by the next form."
1374     "Replace the current containing list with the next form. The entire affected
1375     area is pushed onto the kill ring. If an argument is supplied, that many
1376     upward levels of list nesting is replaced by the next form."
1377     (let ((point (current-point)))
1378     (pre-command-parse-check point)
1379     (with-mark ((form-start point :right-inserting)
1380     (form-end point))
1381     (unless (form-offset form-end 1) (editor-error))
1382     (form-offset (move-mark form-start form-end) -1)
1383     (with-mark ((containing-start form-start :left-inserting)
1384     (containing-end form-end :left-inserting))
1385     (dotimes (i (or p 1))
1386     (unless (and (forward-up-list containing-end)
1387     (backward-up-list containing-start))
1388     (editor-error)))
1389     (let ((r (copy-region (region form-start form-end))))
1390     (ring-push (delete-and-save-region
1391     (region containing-start containing-end))
1392     *kill-ring*)
1393     (ninsert-region point r)
1394     (move-mark point form-start))))))
1395    
1396 ram 1.1 (defcommand "Extract List" (p)
1397     "Extract the current list.
1398     The current list replaces the surrounding list. The entire affected
1399     area is pushed on the kill-ring. With prefix argument, remove that
1400     many surrounding lists."
1401     "Replace the P containing lists with the current one."
1402     (let ((point (current-point)))
1403     (pre-command-parse-check point)
1404     (with-mark ((lstart point :right-inserting)
1405     (lend point))
1406     (if (eq (character-attribute :lisp-syntax (next-character lstart))
1407     :open-paren)
1408     (mark-after lend)
1409     (unless (backward-up-list lstart) (editor-error)))
1410     (unless (forward-up-list lend) (editor-error))
1411     (with-mark ((rstart lstart)
1412     (rend lend))
1413     (dotimes (i (or p 1))
1414     (unless (and (forward-up-list rend) (backward-up-list rstart))
1415     (editor-error)))
1416     (let ((r (copy-region (region lstart lend))))
1417     (ring-push (delete-and-save-region (region rstart rend))
1418     *kill-ring*)
1419     (ninsert-region point r)
1420     (move-mark point lstart))))))
1421    
1422     (defcommand "Transpose Forms" (p)
1423     "Transpose Forms immediately preceding and following the point.
1424     With a zero argument, tranposes the Forms at the point and the mark.
1425     With a positive argument, transposes the Form preceding the point
1426     with the p-th one following it. With a negative argument, transposes the
1427     Form following the point with the p-th one preceding it."
1428     "Transpose Forms immediately preceding and following the point."
1429     (let ((point (current-point))
1430     (count (or p 1)))
1431     (pre-command-parse-check point)
1432     (if (zerop count)
1433     (let ((mark (current-mark)))
1434     (with-mark ((s1 mark :left-inserting)
1435     (s2 point :left-inserting))
1436     (scan-char s1 :whitespace nil)
1437     (scan-char s2 :whitespace nil)
1438     (with-mark ((e1 s1 :right-inserting)
1439     (e2 s2 :right-inserting))
1440     (unless (form-offset e1 1) (editor-error))
1441     (unless (form-offset e2 1) (editor-error))
1442     (ninsert-region s1 (delete-and-save-region (region s2 e2)))
1443     (ninsert-region s2 (delete-and-save-region (region s1 e1))))))
1444     (let ((fcount (if (plusp count) count 1))
1445     (bcount (if (plusp count) 1 count)))
1446     (with-mark ((s1 point :left-inserting)
1447     (e2 point :right-inserting))
1448     (dotimes (i bcount)
1449     (unless (form-offset s1 -1) (editor-error)))
1450     (dotimes (i fcount)
1451     (unless (form-offset e2 1) (editor-error)))
1452     (with-mark ((e1 s1 :right-inserting)
1453     (s2 e2 :left-inserting))
1454     (unless (form-offset e1 1) (editor-error))
1455     (unless (form-offset s2 -1) (editor-error))
1456     (ninsert-region s1 (delete-and-save-region (region s2 e2)))
1457     (ninsert-region s2 (delete-and-save-region (region s1 e1)))
1458     (move-mark point s2)))))))
1459    
1460    
1461     (defcommand "Insert ()" (p)
1462     "Insert a pair of parentheses ().
1463     With positive argument, puts parentheses around the next p
1464     Forms. The point is positioned after the open parenthesis."
1465     "Insert a pair of parentheses ()."
1466     (let ((point (current-point))
1467     (count (or p 0)))
1468     (pre-command-parse-check point)
1469     (cond ((not (minusp count))
1470     (insert-character point #\()
1471     (with-mark ((tmark point))
1472     (unless (form-offset tmark count) (editor-error))
1473     (cond ((mark= tmark point)
1474     (insert-character point #\))
1475     (mark-before point))
1476     (t (insert-character tmark #\))))))
1477     (t (editor-error)))))
1478    
1479    
1480     (defcommand "Move Over )" (p)
1481     "Move past the next close parenthesis, and start a new line.
1482     Any indentation preceding the preceding the parenthesis is deleted,
1483     and the new line is indented."
1484     "Move past the next close parenthesis, and start a new line."
1485     (declare (ignore p))
1486     (let ((point (current-point)))
1487     (pre-command-parse-check point)
1488 ram 1.3 (with-mark ((m point :left-inserting))
1489 ram 1.1 (cond ((scan-char m :lisp-syntax :close-paren)
1490     (delete-horizontal-space m)
1491     (mark-after m)
1492     (move-mark point m)
1493 ram 1.3 (delete-mark m)
1494 ram 1.1 (indent-new-line-command 1))
1495 ram 1.3 (t
1496     (delete-mark m)
1497     (editor-error))))))
1498 ram 1.1
1499    
1500     (defcommand "Forward Up List" (p)
1501     "Move forward past a one containing )."
1502     "Move forward past a one containing )."
1503     (let ((point (current-point))
1504     (count (or p 1)))
1505     (pre-command-parse-check point)
1506     (if (minusp count)
1507     (backward-up-list-command (- count))
1508     (with-mark ((m point))
1509     (dotimes (i count (move-mark point m))
1510     (unless (forward-up-list m) (editor-error)))))))
1511    
1512    
1513     (defcommand "Backward Up List" (p)
1514     "Move backward past a one containing (."
1515     "Move backward past a one containing (."
1516     (let ((point (current-point))
1517     (count (or p 1)))
1518     (pre-command-parse-check point)
1519     (if (minusp count)
1520     (forward-up-list-command (- count))
1521     (with-mark ((m point))
1522     (dotimes (i count (move-mark point m))
1523     (unless (backward-up-list m) (editor-error)))))))
1524    
1525    
1526     (defcommand "Down List" (p)
1527     "Move down a level in list structure.
1528     With argument, moves down p levels."
1529     "Move down a level in list structure."
1530     (let ((point (current-point))
1531     (count (or p 1)))
1532     (pre-command-parse-check point)
1533     (with-mark ((m point))
1534     (dotimes (i count (move-mark point m))
1535     (unless (and (scan-char m :lisp-syntax :open-paren)
1536     (mark-after m))
1537     (editor-error))))))
1538    
1539    
1540    
1541 ram 1.3 ;;;; Filling Lisp comments, strings, and indented text.
1542 ram 1.1
1543 ram 1.3 (defhvar "Fill Lisp Comment Paragraph Confirm"
1544     "This determines whether \"Fill Lisp Comment Paragraph\" will prompt for
1545     confirmation to fill contiguous lines with the same initial whitespace when
1546     it is invoked outside of a comment or string."
1547     :value t)
1548    
1549     (defcommand "Fill Lisp Comment Paragraph" (p)
1550     "This fills a flushleft or indented Lisp comment.
1551     This also fills Lisp string literals using the proper indentation as a
1552     filling prefix. When invoked outside of a comment or string, this tries
1553     to fill all contiguous lines beginning with the same initial, non-empty
1554     blankspace. When filling a comment, the current line is used to determine a
1555     fill prefix by taking all the initial whitespace on the line, the semicolons,
1556     and any whitespace following the semicolons."
1557     "Fills a flushleft or indented Lisp comment."
1558     (declare (ignore p))
1559     (let ((point (current-point)))
1560     (pre-command-parse-check point)
1561     (with-mark ((start point)
1562     (end point)
1563     (m point))
1564     (let ((commentp (fill-lisp-comment-paragraph-prefix start end)))
1565     (cond (commentp
1566     (fill-lisp-comment-or-indented-text start end))
1567     ((and (not (valid-spot m nil))
1568     (form-offset m -1)
1569     (eq (character-attribute :lisp-syntax (next-character m))
1570     :string-quote))
1571     (fill-lisp-string m))
1572     ((or (not (value fill-lisp-comment-paragraph-confirm))
1573     (prompt-for-y-or-n
1574     :prompt '("Not in a comment or string. Fill contiguous ~
1575     lines with the same initial whitespace? ")))
1576     (fill-lisp-comment-or-indented-text start end)))))))
1577    
1578     ;;; FILL-LISP-STRING -- Internal.
1579     ;;;
1580     ;;; This fills the Lisp string containing mark as if it had been entered using
1581     ;;; Hemlock's Lisp string indentation, "Indent Function" for "Lisp" mode. This
1582     ;;; assumes the area around mark has already been PRE-COMMAND-PARSE-CHECK'ed,
1583     ;;; and it ensures the string ends before doing any filling. This function
1584     ;;; is undo'able.
1585     ;;;
1586     (defun fill-lisp-string (mark)
1587     (with-mark ((end mark))
1588     (unless (form-offset end 1)
1589     (editor-error "Attempted to fill Lisp string, but it doesn't end?"))
1590     (let* ((mark (copy-mark mark :left-inserting))
1591     (end (copy-mark end :left-inserting))
1592     (string-region (region mark end))
1593     (undo-region (copy-region string-region))
1594     (hack (make-empty-region)))
1595     ;; Generate prefix.
1596     (funcall (value indent-with-tabs)
1597     (region-end hack) (1+ (mark-column mark)))
1598     ;; Skip opening double quote and fill string starting on its own line.
1599     (mark-after mark)
1600     (insert-character mark #\newline)
1601     (line-start mark)
1602     (setf (mark-kind mark) :right-inserting)
1603     (fill-region string-region (region-to-string hack))
1604     ;; Clean up inserted prefix on first line, delete inserted newline, and
1605     ;; move before the double quote for undo.
1606     (with-mark ((text mark :left-inserting))
1607     (find-attribute text :whitespace #'zerop)
1608     (delete-region (region mark text)))
1609     (delete-characters mark -1)
1610     (mark-before mark)
1611     ;; Save undo.
1612     (make-region-undo :twiddle "Fill Lisp Comment Paragraph"
1613     string-region undo-region))))
1614    
1615     ;;; FILL-LISP-COMMENT-OR-INDENTED-TEXT -- Internal.
1616     ;;;
1617     ;;; This fills all contiguous lines around start and end containing fill prefix
1618     ;;; designated by the region between start and end. These marks can only be
1619     ;;; equal when there is no comment and no initial whitespace. This is a bad
1620     ;;; situation since this function in that situation would fill the entire
1621     ;;; buffer into one paragraph. This function is undo'able.
1622     ;;;
1623     (defun fill-lisp-comment-or-indented-text (start end)
1624     (when (mark= start end)
1625     (editor-error "This command only fills Lisp comments, strings, or ~
1626     indented text, but this line is flushleft."))
1627     ;;
1628     ;; Find comment block.
1629     (let* ((prefix (region-to-string (region start end)))
1630     (length (length prefix)))
1631     (declare (simple-string prefix))
1632     (flet ((frob (mark direction)
1633     (loop
1634     (let* ((line (line-string (mark-line mark)))
1635     (line-len (length line)))
1636     (declare (simple-string line))
1637     (unless (string= line prefix :end1 (min line-len length))
1638     (when (= direction -1)
1639     (unless (same-line-p mark end) (line-offset mark 1 0)))
1640     (return)))
1641     (unless (line-offset mark direction 0)
1642     (when (= direction 1) (line-end mark))
1643     (return)))))
1644     (frob start -1)
1645     (frob end 1))
1646     ;;
1647     ;; Do it undoable.
1648     (let* ((start1 (copy-mark start :right-inserting))
1649     (end2 (copy-mark end :left-inserting))
1650     (region (region start1 end2))
1651     (undo-region (copy-region region)))
1652     (fill-region region prefix)
1653     (make-region-undo :twiddle "Fill Lisp Comment Paragraph"
1654     region undo-region))))
1655    
1656     ;;; FILL-LISP-COMMENT-PARAGRAPH-PREFIX -- Internal.
1657     ;;;
1658     ;;; This sets start and end around the prefix to be used for filling. We
1659     ;;; assume we are dealing with a comment. If there is no ";", then we try to
1660     ;;; find some initial whitespace. If there is a ";", we make sure the line is
1661     ;;; blank before it to eliminate ";"'s in the middle of a line of text.
1662     ;;; Finally, if we really have a comment instead of some indented text, we skip
1663     ;;; the ";"'s and any immediately following whitespace. We allow initial
1664     ;;; whitespace, so we can fill strings with the same command.
1665     ;;;
1666     (defun fill-lisp-comment-paragraph-prefix (start end)
1667     (line-start start)
1668     (let ((commentp t)) ; Assumes there's a comment.
1669     (unless (to-line-comment (line-start end) ";")
1670     (find-attribute end :whitespace #'zerop)
1671     #|(when (start-line-p end)
1672     (editor-error "No comment on line, and no initial whitespace."))|#
1673     (setf commentp nil))
1674     (when commentp
1675     (unless (blank-before-p end)
1676     (find-attribute (line-start end) :whitespace #'zerop)
1677     #|(when (start-line-p end)
1678     (editor-error "Semicolon preceded by unindented text."))|#
1679     (setf commentp nil)))
1680     (when commentp
1681     (find-attribute end :lisp-syntax #'(lambda (x) (not (eq x :comment))))
1682     (find-attribute end :whitespace #'zerop))
1683     commentp))
1684    
1685    
1686    
1687     ;;;; "Lisp" mode.
1688    
1689 ram 1.1 (defcommand "LISP Mode" (p)
1690     "Put current buffer in LISP mode."
1691     "Put current buffer in LISP mode."
1692     (declare (ignore p))
1693     (setf (buffer-major-mode (current-buffer)) "LISP"))
1694    
1695    
1696     (defmode "Lisp" :major-p t :setup-function 'setup-lisp-mode)
1697    
1698     (defun setup-lisp-mode (buffer)
1699     (unless (hemlock-bound-p 'current-package :buffer buffer)
1700     (defhvar "Current Package"
1701     "The package used for evaluation of Lisp in this buffer."
1702     :buffer buffer
1703 gerd 1.11 :value "CL-USER")))
1704 ram 1.1
1705    
1706    
1707     ;;;; Matching parenthesis display.
1708    
1709     (defhvar "Paren Pause Period"
1710     "This is how long commands that deal with \"brackets\" shows the cursor at
1711     the matching \"bracket\" for this number of seconds."
1712     :value 0.5)
1713    
1714     (defcommand "Lisp Insert )" (p)
1715     "Inserts a \")\" and briefly positions the cursor at the matching \"(\"."
1716     "Inserts a \")\" and briefly positions the cursor at the matching \"(\"."
1717     (declare (ignore p))
1718     (let ((point (current-point)))
1719     (insert-character point #\))
1720     (pre-command-parse-check point)
1721     (when (valid-spot point nil)
1722     (with-mark ((m point))
1723     (if (list-offset m -1)
1724     (let ((pause (value paren-pause-period))
1725     (win (current-window)))
1726     (if pause
1727     (unless (show-mark m win pause)
1728     (clear-echo-area)
1729     (message "~A" (line-string (mark-line m))))
1730     (unless (displayed-p m (current-window))
1731     (clear-echo-area)
1732     (message "~A" (line-string (mark-line m))))))
1733     (editor-error))))))
1734    
1735     ;;; Since we use paren highlighting in Lisp mode, we do not want paren
1736     ;;; flashing too.
1737     ;;;
1738     (defhvar "Paren Pause Period"
1739     "This is how long commands that deal with \"brackets\" shows the cursor at
1740     the matching \"bracket\" for this number of seconds."
1741     :value nil
1742     :mode "Lisp")
1743     ;;;
1744     (defhvar "Highlight Open Parens"
1745     "When non-nil, causes open parens to be displayed in a different font when
1746     the cursor is directly to the right of the corresponding close paren."
1747     :value t
1748     :mode "Lisp")
1749 ram 1.3
1750    
1751     (defhvar "Open Paren Finder Function"
1752     "Should be a function that takes a mark for input and returns either NIL
1753     if the mark is not after a close paren, or two (temporary) marks
1754     surrounding the corresponding open paren."
1755     :mode "Lisp"
1756     :value 'lisp-open-paren-finder-function)
1757    
1758     (defun lisp-open-paren-finder-function (mark)
1759     (when (eq (character-attribute :lisp-syntax (previous-character mark))
1760     :close-paren)
1761     (with-mark ((mark mark))
1762     (pre-command-parse-check mark)
1763     (if (not (and (valid-spot mark nil) (list-offset mark -1)))
1764     (values nil nil)
1765     (values mark (mark-after (copy-mark mark)))))))
1766 ram 1.1
1767    
1768    
1769     ;;;; Some mode variables to coordinate with other stuff.
1770    
1771     (defhvar "Auto Fill Space Indent"
1772     "When non-nil, uses \"Indent New Comment Line\" to break lines instead of
1773     \"New Line\"."
1774     :mode "Lisp" :value t)
1775    
1776     (defhvar "Comment Start"
1777     "String that indicates the start of a comment."
1778     :mode "Lisp" :value ";")
1779    
1780     (defhvar "Comment Begin"
1781     "String that is inserted to begin a comment."
1782     :mode "Lisp" :value "; ")
1783    
1784     (defhvar "Indent Function"
1785     "Indentation function which is invoked by \"Indent\" command.
1786     It must take one argument that is the prefix argument."
1787     :value 'indent-for-lisp
1788     :mode "Lisp")

  ViewVC Help
Powered by ViewVC 1.1.5