Context Navigation

for.lisp @ 258

Revision 258, 21.5 KB (checked in by rjs, 21 months ago)
Update.

Line
1	;;;-- Mode:LISP; Package:ZWEI --
2	;;; (c) Copyright 1980 Massachusetts Institute of Technology
3
4	;;; Functions in this file know about bps, lines, and intervals.
5	;;; They use INTERVAL for their limit-checking.
6
7	;;; Standard motion functions.
8
9	(DEFUN FORWARD-CHAR (BP &OPTIONAL (TIMES 1) FIXUP-P)
10	(COND ((ZEROP TIMES)
11	(COPY-BP BP))
12	((> TIMES 0)
13	(DO ((LINE (BP-LINE BP) (LINE-NEXT LINE))
14	(INDEX (BP-INDEX BP) 0)
15	(LAST-LINE (BP-LINE (INTERVAL-LAST-BP INTERVAL)))
16	(LAST-INDEX (BP-INDEX (INTERVAL-LAST-BP INTERVAL))))
17	(NIL)
18	(LET ((LL (LINE-LENGTH LINE))
19	(I (+ INDEX TIMES)))
20	(COND ((AND (EQ LINE LAST-LINE)
21	(> I LAST-INDEX))
22	(RETURN (IF FIXUP-P (CREATE-BP LINE LAST-INDEX) NIL)))
23	(( I LL)
24	(RETURN (CREATE-BP LINE I))))
25	(SETQ TIMES (- TIMES (- LL INDEX) 1)))))
26	(T
27	(SETQ TIMES (- TIMES))
28	(DO ((LINE (BP-LINE BP))
29	(INDEX (- (BP-INDEX BP) TIMES))
30	(LINE-LENGTH (BP-INDEX BP))
31	(FIRST-LINE (BP-LINE (INTERVAL-FIRST-BP INTERVAL)))
32	(FIRST-INDEX (BP-INDEX (INTERVAL-FIRST-BP INTERVAL))))
33	(NIL)
34	(COND ((AND (EQ LINE FIRST-LINE) (< INDEX FIRST-INDEX))
35	(RETURN (IF FIXUP-P (CREATE-BP FIRST-LINE FIRST-INDEX) NIL)))
36	(( INDEX 0)
37	(RETURN (CREATE-BP LINE INDEX))))
38	(SETQ TIMES (- TIMES LINE-LENGTH 1)
39	LINE (LINE-PREVIOUS LINE)
40	LINE-LENGTH (LINE-LENGTH LINE)
41	INDEX (- LINE-LENGTH TIMES))))))
42
43	;;; Move forward TIMES characters, the way a program on ITS would count
44	;;; characters. This means that CRs and LFs get counted separately; that
45	;;; is, a newline counts as two characters. If the TIMES given would give
46	;;; a BP between a CR and an LF, which we do not represent, we return the
47	;;; position just after the newline.
48	(DEFUN FORWARD-ITS-CHAR (BP &OPTIONAL (TIMES 1) FIXUP-P)
49	(COND ((ZEROP TIMES)
50	(COPY-BP BP))
51	((> TIMES 0)
52	(DO ((LINE (BP-LINE BP) (LINE-NEXT LINE))
53	(INDEX (BP-INDEX BP) 0)
54	(LAST-LINE (BP-LINE (INTERVAL-LAST-BP INTERVAL)))
55	(LAST-INDEX (BP-INDEX (INTERVAL-LAST-BP INTERVAL))))
56	(NIL)
57	(LET ((LL (LINE-LENGTH LINE))
58	(I (+ INDEX TIMES)))
59	(COND ((AND (EQ LINE LAST-LINE)
60	(> I LAST-INDEX))
61	(RETURN (IF FIXUP-P (CREATE-BP LINE LAST-INDEX) NIL)))
62	(( I LL)
63	(RETURN (CREATE-BP LINE I))))
64	(SETQ TIMES (MAX 0 (- TIMES (- LL INDEX) 2))))))
65	(T
66	(SETQ TIMES (- TIMES))
67	(DO ((LINE (BP-LINE BP))
68	(INDEX (- (BP-INDEX BP) TIMES))
69	(LINE-LENGTH (BP-INDEX BP))
70	(FIRST-LINE (BP-LINE (INTERVAL-FIRST-BP INTERVAL)))
71	(FIRST-INDEX (BP-INDEX (INTERVAL-FIRST-BP INTERVAL))))
72	(NIL)
73	(COND ((AND (EQ LINE FIRST-LINE) (< INDEX FIRST-INDEX))
74	(RETURN (IF FIXUP-P (CREATE-BP FIRST-LINE FIRST-INDEX) NIL)))
75	(( INDEX 0)
76	(RETURN (CREATE-BP LINE INDEX))))
77	(SETQ TIMES (MAX 0 (- TIMES LINE-LENGTH 2))
78	LINE (LINE-PREVIOUS LINE)
79	LINE-LENGTH (LINE-LENGTH LINE)
80	INDEX (- LINE-LENGTH TIMES))))))
81
82	(DEFUN FORWARD-LINE (BP &OPTIONAL (TIMES 1) FIXUP-P)
83	(COND ((ZEROP TIMES) (COPY-BP BP))
84	((PLUSP TIMES)
85	(DO ((LAST-LINE (BP-LINE (INTERVAL-LAST-BP INTERVAL)))
86	(LINE (BP-LINE BP) (LINE-NEXT LINE))
87	(I 0 (1+ I)))
88	(( I TIMES)
89	(CREATE-BP LINE 0))
90	(COND ((EQ LINE LAST-LINE)
91	(RETURN (IF FIXUP-P
92	(CREATE-BP LINE 0)
93	NIL))))))
94	(T
95	(DO ((FIRST-LINE (BP-LINE (INTERVAL-FIRST-BP INTERVAL)))
96	(LINE (BP-LINE BP) (LINE-PREVIOUS LINE))
97	(I 0 (1- I)))
98	(( I TIMES)
99	(CREATE-BP LINE (IF (EQ LINE FIRST-LINE)
100	(BP-INDEX (INTERVAL-FIRST-BP INTERVAL))
101	0)))
102	(COND ((EQ LINE FIRST-LINE)
103	(RETURN (IF FIXUP-P
104	(CREATE-BP LINE (BP-INDEX (INTERVAL-FIRST-BP INTERVAL)))
105	NIL))))))))
106
107	;; This is the function for moving from BP forward or backward over lists
108	;; as opposed to sexps. That is, atoms are ignored (treated like spaces).
109	;; LEVEL can be positive to move up in the list structure.
110	;; To move down, supply DOWNP as T and make LEVEL minus the number of levels to move.
111	;; NO-UP-P means it is an error to move past an ) to a higher level
112	(DEFUN FORWARD-LIST (BP &OPTIONAL (TIMES 1) FIXUP-P (LEVEL 0) DOWNP NO-UP-P
113	&AUX (ORIGINAL-LEVEL LEVEL))
114	(COND ((ZEROP TIMES) (COPY-BP BP))
115	((PLUSP TIMES)
116	(LET ((STATE 'NORMAL)
117	(TIME 0)
118	(LAST-BP (INTERVAL-LAST-BP INTERVAL)))
119	(CHARMAP (BP LAST-BP (IF FIXUP-P LAST-BP NIL))
120	RESTART
121	(LET ((SYNTAX (LIST-SYNTAX (CHARMAP-CHAR))))
122	(SELECTQ STATE
123	(STRING
124	(SELECT SYNTAX
125	(LIST-DOUBLE-QUOTE
126	(SETQ STATE 'NORMAL))
127	(LIST-SLASH
128	(CHARMAP-INCREMENT (IF FIXUP-P LAST-BP NIL)))))
129	(NORMAL
130	(SELECT SYNTAX
131	(LIST-SLASH
132	(CHARMAP-INCREMENT (IF FIXUP-P LAST-BP NIL)))
133	(LIST-DOUBLE-QUOTE
134	(SETQ STATE 'STRING))
135	(LIST-CLOSE
136	(SETQ LEVEL (1- LEVEL))
137	(COND (DOWNP
138	(COND ((< LEVEL ORIGINAL-LEVEL)
139	(CHARMAP-RETURN (IF FIXUP-P LAST-BP NIL)))))
140	((AND NO-UP-P (< LEVEL 0))
141	(CHARMAP-RETURN NIL))
142	(( LEVEL 0)
143	(IF ( (SETQ TIME (1+ TIME)) TIMES)
144	(CHARMAP-RETURN (CHARMAP-BP-AFTER))))))
145	(LIST-OPEN
146	(COND ((AND ( (SETQ LEVEL (1+ LEVEL)) 0) DOWNP)
147	(IF ( (SETQ TIME (1+ TIME)) TIMES)
148	(CHARMAP-RETURN (CHARMAP-BP-AFTER)))))))))))))
149	(T
150	(LET ((STATE 'NORMAL)
151	(TIME 0)
152	(FIRST-BP (INTERVAL-FIRST-BP INTERVAL)))
153	(RCHARMAP (BP FIRST-BP (IF FIXUP-P FIRST-BP NIL))
154	RESTART
155	(LET ((SYNTAX (LIST-SYNTAX (RCHARMAP-CHAR))))
156	(SELECTQ STATE
157	(STRING
158	(SELECT SYNTAX
159	(LIST-DOUBLE-QUOTE
160	(SETQ STATE 'NORMAL))))
161	(NORMAL
162	(SELECT SYNTAX
163	(LIST-DOUBLE-QUOTE
164	(SETQ STATE 'STRING))
165	(LIST-CLOSE
166	(AND ( (SETQ LEVEL (1+ LEVEL)) 0) DOWNP
167	(IF ( (SETQ TIME (1- TIME)) TIMES)
168	(RCHARMAP-RETURN (RCHARMAP-BP-BEFORE)))))
169	(LIST-OPEN
170	(SETQ LEVEL (1- LEVEL))
171	(AND NO-UP-P (< LEVEL 0) (RCHARMAP-RETURN NIL))
172	(AND ( LEVEL 0) (NOT DOWNP)
173	(IF ( (SETQ TIME (1- TIME)) TIMES)
174	(RCHARMAP-RETURN (RCHARMAP-BP-BEFORE))))))))))))))
175
176	;Return true if the line starts a list which it doesn't end, i.e.
177	;contains an unmatched open paren
178	(DEFUN LINE-OPENS-PARENS (LINE)
179	(DO ((I (IF (EQ LINE (BP-LINE (INTERVAL-FIRST-BP INTERVAL)))
180	(BP-INDEX (INTERVAL-FIRST-BP INTERVAL))
181	0)
182	(1+ I))
183	(LIM (IF (EQ LINE (BP-LINE (INTERVAL-LAST-BP INTERVAL)))
184	(BP-INDEX (INTERVAL-LAST-BP INTERVAL))
185	(LINE-LENGTH LINE)))
186	(STATE 'NORMAL)
187	(LEVEL 0))
188	(( I LIM) (> LEVEL 0))
189	(LET* ((CH (LDB %%CH-CHAR (AREF LINE I)))
190	(SYNTAX (LIST-SYNTAX CH)))
191	(SELECTQ STATE
192	(STRING (SELECT SYNTAX
193	(LIST-DOUBLE-QUOTE (SETQ STATE 'NORMAL))
194	(LIST-SLASH (SETQ I (1+ I)))))
195	(NORMAL (SELECT SYNTAX
196	(LIST-SLASH (SETQ I (1+ I)))
197	(LIST-DOUBLE-QUOTE (SETQ STATE 'STRING))
198	(LIST-CLOSE (SETQ LEVEL (MAX (1- LEVEL) 0)))
199	(LIST-OPEN (SETQ LEVEL (1+ LEVEL)))))))))
200
201	(DEFUN FORWARD-WORD (BP &OPTIONAL (TIMES 1) FIXUP-P)
202	(COND ((ZEROP TIMES) (COPY-BP BP))
203	((PLUSP TIMES)
204	(LET ((STATE NIL)
205	(TIME 0)
206	(LAST-BP (INTERVAL-LAST-BP INTERVAL)))
207	(CHARMAP (BP LAST-BP (IF (OR FIXUP-P
208	(AND STATE (= (1+ TIME) TIMES)))
209	LAST-BP
210	NIL))
211	(LET ((SYNTAX (WORD-SYNTAX (CHARMAP-CHAR))))
212	(SELECTQ STATE
213	(NIL
214	(SELECT SYNTAX
215	(WORD-ALPHABETIC
216	(SETQ STATE T))))
217	(T
218	(SELECT SYNTAX
219	(WORD-DELIMITER
220	(SETQ TIME (1+ TIME))
221	(IF ( TIME TIMES)
222	(CHARMAP-RETURN (CHARMAP-BP-BEFORE))
223	(SETQ STATE NIL))))))))))
224	(T
225	(LET ((STATE NIL)
226	(TIME 0)
227	(FIRST-BP (INTERVAL-FIRST-BP INTERVAL)))
228	(RCHARMAP (BP FIRST-BP (IF (OR FIXUP-P
229	(AND STATE (= (1- TIME) TIMES)))
230	FIRST-BP
231	NIL))
232	(LET ((SYNTAX (WORD-SYNTAX (RCHARMAP-CHAR))))
233	(SELECTQ STATE
234	(NIL
235	(SELECT SYNTAX
236	(WORD-ALPHABETIC
237	(SETQ STATE T))))
238	(T
239	(SELECT SYNTAX
240	(WORD-DELIMITER
241	(SETQ TIME (1- TIME))
242	(IF ( TIME TIMES)
243	(RCHARMAP-RETURN (RCHARMAP-BP-AFTER))
244	(SETQ STATE NIL))))))))))))
245
246	(DEFUN FORWARD-TO-WORD (BP &OPTIONAL (TIMES 1) FIXUP-P)
247	(*CATCH 'LOSSAGE
248	(COND ((ZEROP TIMES) (COPY-BP BP))
249	((PLUSP TIMES)
250	(LET ((LAST-BP (INTERVAL-LAST-BP INTERVAL)))
251	(COND ((> TIMES 1)
252	(SETQ BP (FORWARD-WORD BP (1- TIMES)))
253	(COND ((NULL BP)
254	(*THROW 'LOSSAGE (IF FIXUP-P LAST-BP NIL))))))
255	(CHARMAP (BP LAST-BP (IF FIXUP-P LAST-BP NIL))
256	(LET ((SYNTAX (WORD-SYNTAX (CHARMAP-CHAR))))
257	(SELECT SYNTAX
258	(WORD-ALPHABETIC
259	(CHARMAP-RETURN (CHARMAP-BP-BEFORE))))))))
260	(T
261	(LET ((FIRST-BP (INTERVAL-FIRST-BP INTERVAL)))
262	(COND ((< TIMES -1)
263	(SETQ BP (FORWARD-WORD BP (1+ TIMES)))
264	(COND ((NULL BP)
265	(*THROW 'LOSSAGE (IF FIXUP-P FIRST-BP NIL))))))
266	(RCHARMAP (BP FIRST-BP (IF FIXUP-P FIRST-BP NIL))
267	(LET ((SYNTAX (WORD-SYNTAX (RCHARMAP-CHAR))))
268	(SELECT SYNTAX
269	(WORD-ALPHABETIC
270	(RCHARMAP-RETURN (RCHARMAP-BP-AFTER)))))))))))
271
272	(DEFUN FORWARD-DEFUN (BP &OPTIONAL (TIMES 1) FIXUP-P)
273	(COND ((ZEROP TIMES) (COPY-BP BP))
274	((PLUSP TIMES)
275	(DO-NAMED LUPO
276	((I 0 (1+ I)))
277	(( I TIMES)
278	BP)
279	(DO () (NIL)
280	(SETQ BP (BEG-LINE BP 1))
281	(COND ((NULL BP)
282	(RETURN-FROM LUPO (IF FIXUP-P
283	(COPY-BP (INTERVAL-LAST-BP INTERVAL))
284	NIL)))
285	((= (LIST-SYNTAX (BP-CH-CHAR BP)) LIST-OPEN)
286	(RETURN NIL))))))
287	(T
288	(DO-NAMED LUPO
289	((I 0 (1- I)))
290	(( I TIMES)
291	BP)
292	(DO ((FIRSTP T NIL)) (NIL)
293	(SETQ BP (BEG-LINE BP (IF (AND FIRSTP (NOT (BEG-LINE-P BP)))
294	0
295	-1)))
296	(COND ((NULL BP)
297	(RETURN-FROM LUPO (IF FIXUP-P
298	(COPY-BP (INTERVAL-FIRST-BP INTERVAL))
299	NIL)))
300	((= (LIST-SYNTAX (BP-CH-CHAR BP)) LIST-OPEN)
301	(RETURN NIL))))))))
302
303	(DEFUN FORWARD-PAGE (BP &OPTIONAL (TIMES 1) FIXUP-P)
304	(COND ((ZEROP TIMES) (COPY-BP BP))
305	((PLUSP TIMES)
306	(LET ((STOP-LINE (BP-LINE (INTERVAL-LAST-BP INTERVAL)))
307	(FIRST-LINE (BP-LINE BP)))
308	(COND ((EQ FIRST-LINE STOP-LINE)
309	(AND FIXUP-P (COPY-BP (INTERVAL-LAST-BP INTERVAL))))
310	(T (DO ((LINE (LINE-NEXT FIRST-LINE) (LINE-NEXT LINE)))
311	((EQ LINE STOP-LINE)
312	(COPY-BP (INTERVAL-LAST-BP INTERVAL)))
313	(COND ((AND ( (LINE-LENGTH LINE) 1)
314	(= #\FF (LDB %%CH-CHAR (AREF LINE 0))))
315	(AND ( (SETQ TIMES (1- TIMES)) 0)
316	(RETURN (CREATE-BP LINE 1))))))))))
317	(T
318	(LET ((STOP-LINE (BP-LINE (INTERVAL-FIRST-BP INTERVAL)))
319	(FIRST-LINE (BP-LINE BP)))
320	(COND ((EQ FIRST-LINE STOP-LINE)
321	(AND FIXUP-P (COPY-BP (INTERVAL-FIRST-BP INTERVAL))))
322	(T (DO ((LINE (LINE-PREVIOUS FIRST-LINE) (LINE-PREVIOUS LINE)))
323	((EQ LINE STOP-LINE)
324	(AND FIXUP-P (COPY-BP (INTERVAL-FIRST-BP INTERVAL))))
325	(COND ((AND ( (LINE-LENGTH LINE) 1)
326	(= #\FF (LDB %%CH-CHAR (AREF LINE 0))))
327	(AND ( (SETQ TIMES (1+ TIMES)) 0)
328	(RETURN (CREATE-BP LINE 1))))))))))))
329
330	(DEFUN FORWARD-INTERVAL (BP &OPTIONAL (TIMES 1) FIXUP-P)
331	BP FIXUP-P ;Never out of range
332	(COPY-BP (IF (MINUSP TIMES)
333	(INTERVAL-FIRST-BP INTERVAL)
334	(INTERVAL-LAST-BP INTERVAL))))
335
336	(DEFUN FORWARD-PARAGRAPH (BP &OPTIONAL (TIMES 1) FIXUP-P
337	&AUX BACKWARD-P
338	(FILL-PREFIX-P (PLUSP (STRING-LENGTH FILL-PREFIX)))
339	BLANK-P PREV-BLANK-P)
340	(AND (MINUSP TIMES) (SETQ TIMES (- TIMES) BACKWARD-P T))
341	(COND ((NOT BACKWARD-P) ;Move to the beginning of a line
342	(SETQ BP (BEG-LINE BP)))
343	((NOT (BEG-LINE-P BP))
344	(SETQ BP (BEG-LINE BP 1 T))))
345	(DO ((I 0 (1+ I)))
346	((OR (NULL BP) ( I TIMES)) BP)
347	(SETQ BLANK-P T)
348	(DO ((FIRST-P (IF (AND BACKWARD-P (BP-= BP (INTERVAL-LAST-BP INTERVAL))) 1 0)
349	(1+ FIRST-P)))
350	(NIL)
351	(SETQ PREV-BLANK-P BLANK-P BLANK-P NIL)
352	(AND (SETQ BLANK-P (OR (LINE-BLANK-P (BP-LINE BP))
353	(AND (NOT FILL-PREFIX-P) ;If no fill prefix
354	(BP-LOOKING-AT-LIST BP TEXT-JUSTIFIER-ESCAPE-LIST)
355	(OR (BP-LOOKING-AT-LIST BP PARAGRAPH-DELIMITER-LIST)
356	(BP-LOOKING-AT-LIST BP PAGE-DELIMITER-LIST)))))
357	(NOT PREV-BLANK-P)
358	(OR (> FIRST-P 1)
359	(NOT BACKWARD-P))
360	(RETURN))
361	(COND ((NOT (IF BACKWARD-P
362	(OR (SETQ BP (BEG-LINE BP -1)) (RETURN))
363	(OR (SETQ BP (BEG-LINE BP 1)) (RETURN))
364	(NOT BLANK-P))))
365	(FILL-PREFIX-P
366	(OR (LOOKING-AT BP FILL-PREFIX) (RETURN)))
367	(T
368	(AND (OR (BP-LOOKING-AT-LIST BP PARAGRAPH-DELIMITER-LIST)
369	(BP-LOOKING-AT-LIST BP PAGE-DELIMITER-LIST))
370	(NOT (BP-LOOKING-AT-LIST BP TEXT-JUSTIFIER-ESCAPE-LIST))
371	(RETURN))))))
372	(COND (BP
373	(AND BACKWARD-P BLANK-P (NOT PREV-BLANK-P)
374	(SETQ BP (BEG-LINE BP 1 T)))
375	(LET ((BP1 (BEG-LINE BP -1)))
376	(AND BP1 (LINE-BLANK-P (BP-LINE BP1))
377	(SETQ BP BP1)))))
378	(OR BP
379	(COND ((NOT FIXUP-P) NIL)
380	(BACKWARD-P (INTERVAL-FIRST-BP INTERVAL))
381	(T (INTERVAL-LAST-BP INTERVAL)))))
382
383	(DEFUN FORWARD-OVER-BLANK-OR-TEXT-JUSTIFIER-LINES (BP)
384	(DO ((BP BP (BEG-LINE BP 1)))
385	((OR (NULL BP)
386	(NOT (OR (LINE-BLANK-P (BP-LINE BP))
387	(AND (BP-LOOKING-AT-LIST BP TEXT-JUSTIFIER-ESCAPE-LIST)
388	(OR (BP-LOOKING-AT-LIST BP PARAGRAPH-DELIMITER-LIST)
389	(BP-LOOKING-AT-LIST BP PAGE-DELIMITER-LIST))))))
390	(OR BP (INTERVAL-LAST-BP INTERVAL)))))
391
392	(DEFUN FORWARD-ATOM (BP &OPTIONAL (TIMES 1) FIXUP-P)
393	(ATOM-WORD-SYNTAX-BIND
394	(FORWARD-WORD BP TIMES FIXUP-P)))
395
396	(DEFUN FORWARD-SENTENCE (BP &OPTIONAL (TIMES 1) FIXUP-P)
397	(COND ((ZEROP TIMES) (COPY-BP BP))
398	((PLUSP TIMES)
399	(DO ((LAST-BP (INTERVAL-LAST-BP INTERVAL))
400	(TIME 0 (1+ TIME))
401	(STATE NIL)
402	(CH))
403	(( TIME TIMES) BP)
404	(SETQ BP (FORWARD-OVER '(#\CR) BP)) ;Skip initial blank lines
405	(SETQ BP (CHARMAP (BP LAST-BP (AND (OR STATE FIXUP-P) LAST-BP))
406	(SETQ CH (CHARMAP-CH-CHAR))
407	(AND STATE ;If special character last time...
408	(COND ((OR (= CH #\CR) ;"<cr><cr>" ".<cr>" or ". <cr>" win
409	(AND (EQ STATE 'SP) (= CH #\SP))) ;". " wins
410	(CHARMAP-RETURN (COND ((EQ STATE 'DOT) ;".<cr>"
411	(CHARMAP-BP-BEFORE))
412	(T (FORWARD-CHAR (CHARMAP-BP-BEFORE)
413	-1)))))
414	((AND (EQ STATE 'DOT) (= CH #\SP)) ;". "
415	(SETQ STATE 'SP))
416	(T (SETQ STATE NIL))))
417	(COND ((= CH #\CR) ;If at end of line, check for another
418	(SETQ STATE 'CR)) ;<cr> next time
419	((MEMQ CH '(#/. #/! #/?))
420	;;Skip over closing frobs that might contain the sentence
421	(DO NIL
422	((NOT (MEMQ CH '(#/" #/' #/) #/]))))
423	(CHARMAP-INCREMENT (AND FIXUP-P LAST-BP))
424	(SETQ CH (CHARMAP-CH-CHAR)))
425	(SETQ STATE 'DOT)))))))
426	(T
427	(DO ((START-BP (INTERVAL-FIRST-BP INTERVAL))
428	(TIME 0 (1- TIME))
429	(STATE NIL)
430	(NFROBS)
431	(CH))
432	(( TIME TIMES) (FORWARD-OVER WHITESPACE-CHARS (FORWARD-CHAR BP NFROBS)))
433	(SETQ BP (BACKWARD-OVER '(#\CR #\SP #/" #/' #/) #/]) BP)
434	NFROBS 0)
435	(SETQ BP (RCHARMAP (BP START-BP (AND FIXUP-P START-BP))
436	(SETQ CH (RCHARMAP-CH-CHAR))
437	(COND ((MEMQ STATE '(CR SPSP))
438	(DO NIL
439	((NOT (MEMQ CH '(#/" #/' #/) #/]))))
440	(RCHARMAP-DECREMENT (AND FIXUP-P START-BP))
441	(SETQ CH (RCHARMAP-CH-CHAR)
442	NFROBS (1+ NFROBS)))
443	(AND (OR (MEMQ CH '(#/. #/! #/?))
444	(AND (= CH #\CR) (EQ STATE 'CR) (ZEROP NFROBS)))
445	(RCHARMAP-RETURN (RCHARMAP-BP-AFTER)))
446	(SETQ STATE NIL
447	NFROBS 0)))
448	(COND ((EQ STATE 'SP)
449	(SETQ STATE (AND (= CH #\SP) 'SPSP)))
450	((= CH #\SP)
451	(SETQ STATE 'SP))
452	((= CH #\CR)
453	(SETQ STATE 'CR)))))
454	(OR BP (RETURN NIL))))))
455
456	;;; Not-so-standard motion functions.
457
458	;;; Return an interval surrounding the DEFUN that BP is in, or NIL if it fails.
459
460	(DEFUN DEFUN-INTERVAL (BP &OPTIONAL (TIMES 1) FIXUP-P (COMMENTS-P T) (TOP-BLANK-P NIL))
461	(PROG (BP1 BP2 BP3 BP4 SBP)
462	(COND ((NULL (SETQ BP1 (FORWARD-DEFUN BP -1)))
463	(SETQ BP1 (BEG-LINE BP 0))
464	(COND ((= (LIST-SYNTAX (BP-CHAR BP1)) LIST-OPEN)
465	(GO BUFBEG1))
466	(T (GO BUFBEG)))))
467	(OR (SETQ BP2 (FORWARD-SEXP BP1 TIMES))
468	(IF (NOT FIXUP-P) (RETURN NIL)
469	(SETQ BP2 (BEG-LINE (BACKWARD-OVER-COMMENT-LINES (FORWARD-DEFUN BP1 1 T)
470	TOP-BLANK-P)
471	-1))))
472	(OR (BP-< (END-LINE BP2) BP)
473	;; We were in the middle of the defun.
474	(GO FOUND))
475	(SETQ BP BP1)
476	BUFBEG
477	(COND ((NULL (SETQ BP1 (FORWARD-DEFUN BP)))
478	(AND BP2 (SETQ BP1 (FORWARD-DEFUN BP2 -1))
479	(GO FOUND)) ;At end of buffer, take previous
480	(RETURN NIL)))
481	BUFBEG1
482	(OR (SETQ BP2 (FORWARD-SEXP BP1 TIMES)) (RETURN NIL))
483	FOUND
484	;; At this point, BP1 and BP2 surround a "defun". Now we should grab any
485	;; comment lines and intervening blank lines before the beginning, and the
486	;; rest of the last line.
487	(SETQ SBP BP1) ;Save real starting line
488	CONTIN
489	(AND COMMENTS-P (SETQ BP1 (BACKWARD-OVER-COMMENT-LINES BP1 TOP-BLANK-P)))
490	(SETQ BP3 (FORWARD-OVER BLANKS BP2))
491	(AND BP3 (OR (= (LIST-SYNTAX (BP-CHAR BP3)) LIST-COMMENT)
492	(= (BP-CH-CHAR BP3) #\CR))
493	(SETQ BP2 (BEG-LINE BP2 1 T)))
494	;; Now try to find any extra close-parens because of a LOCAL-DECLARE
495	(SETQ BP3 (FORWARD-OVER '(#/)) BP2))
496	(AND (NOT (BP-= BP2 BP3))
497	(SETQ BP4 (FORWARD-SEXP BP3 (- TIMES)))
498	(BP-< BP4 BP1)
499	(SETQ BP1 BP4 BP2 BP3)
500	(GO CONTIN))
501	;; Now try to find a package prefix
502	(SETQ BP3 (BACKWARD-OVER WHITESPACE-CHARS BP1)
503	BP4 (FORWARD-WORD BP3 -1 T))
504	(COND ((AND (CHAR-EQUAL (BP-CHAR-BEFORE BP3) #/:) (BEG-LINE-P BP4))
505	(SETQ BP1 BP4)
506	(GO CONTIN)))
507	(RETURN (CREATE-INTERVAL BP1 BP2) SBP)))
508
509	;; Decide how much text before a defun to include with the defun when marking the defun.
510	;; It moves over all comment lines and intervening blank lines,
511	;; and also over one blank line before them (unless TOP-BLANK-P is NIL).
512	;; It includes all blank lines at the beginning of the interval so
513	;; as not to leave them orphaned.
514	;; If there is List structure before the defun that encloses it, e.g.
515	;; a LOCAL-DECLARE, it gets included.
516
517	(DEFUN BACKWARD-OVER-COMMENT-LINES (BP &OPTIONAL (TOP-BLANK-P T)
518	&AUX (LAST-GOOD-LINE (BP-LINE BP)))
519	(DO ((LINE (LINE-PREVIOUS (BP-LINE BP)) (LINE-PREVIOUS LINE)))
520	((NULL LINE)
521	(SETQ LAST-GOOD-LINE (BP-LINE (INTERVAL-FIRST-BP INTERVAL))))
522	(SELECTQ (LINE-TYPE LINE)
523	(:BLANK)
524	(:COMMENT (SETQ LAST-GOOD-LINE LINE))
525	(:NORMAL (IF (LINE-OPENS-PARENS LINE) (SETQ LAST-GOOD-LINE LINE)
526	(RETURN)))
527	(OTHERWISE (RETURN))))
528	(COND ((EQ LAST-GOOD-LINE (BP-LINE (INTERVAL-FIRST-BP INTERVAL))))
529	((NOT TOP-BLANK-P))
530	((MEMQ (LINE-TYPE (LINE-PREVIOUS LAST-GOOD-LINE)) ':(BLANK FORM))
531	(SETQ LAST-GOOD-LINE (LINE-PREVIOUS LAST-GOOD-LINE))))
532	(IF (EQ (LINE-TYPE LAST-GOOD-LINE) ':FORM) (END-OF-LINE LAST-GOOD-LINE)
533	(BEG-OF-LINE LAST-GOOD-LINE)))
534
535	;; Return a bp to the front of the first non-blank non-comment line after BP.
536	;; If there is non-blank non-comment data following BP on the same line
537	;; we return a pointer to that.
538	;; This is good for finding the next interesting piece of lisp code after a point.
539	(DEFUN SKIP-OVER-BLANK-LINES-AND-COMMENTS (BP &OPTIONAL FIXUP-P)
540	(SETQ BP (FORWARD-OVER BLANKS BP))
541	(AND BP (OR (= (BP-CH-CHAR BP) #/;)
542	(= (BP-CH-CHAR BP) #\CR))
543	(DO () (NIL)
544	(SETQ BP (BEG-LINE BP 1))
545	(OR BP (RETURN NIL))
546	(SELECTQ (LINE-TYPE (BP-LINE BP))
547	(:BLANK)
548	(:COMMENT)
549	(OTHERWISE (RETURN BP)))))
550	(OR BP (AND FIXUP-P (COPY-BP (INTERVAL-LAST-BP INTERVAL)))))
551
552	(DEFUN BEG-LINE (BP &OPTIONAL (TIMES 0) FIXUP-P)
553	(COND (( TIMES 0)
554	(DO ((LINE (BP-LINE BP) (LINE-NEXT LINE))
555	(I TIMES (1- I))
556	(LAST-LINE (BP-LINE (INTERVAL-LAST-BP INTERVAL))))
557	(NIL)
558	(COND ((EQ LINE LAST-LINE)
559	(RETURN (IF (OR ( I 0) FIXUP-P)
560	(CREATE-BP LINE (IF ( I 0) 0 (LINE-LENGTH LINE)))
561	NIL)))
562	(( I 0)
563	(RETURN (CREATE-BP LINE 0))))))
564	(T
565	(DO ((LINE (BP-LINE BP) (LINE-PREVIOUS LINE))
566	(I TIMES (1+ I))
567	(FIRST-LINE (BP-LINE (INTERVAL-FIRST-BP INTERVAL))))
568	(NIL)
569	(COND ((EQ LINE FIRST-LINE)
570	(RETURN (IF (OR ( I 0) FIXUP-P)
571	(CREATE-BP LINE (BP-INDEX (INTERVAL-FIRST-BP INTERVAL)))
572	NIL)))
573	(( I 0)
574	(RETURN (CREATE-BP LINE 0))))))))
575
576	(DEFUN END-LINE (BP &OPTIONAL (TIMES 0) FIXUP-P)
577	(COND (( TIMES 0)
578	(DO ((LINE (BP-LINE BP) (LINE-NEXT LINE))
579	(I TIMES (1- I))
580	(LAST-LINE (BP-LINE (INTERVAL-LAST-BP INTERVAL))))
581	(NIL)
582	(COND ((EQ LINE LAST-LINE)
583	(RETURN (IF (OR ( I 0) FIXUP-P)
584	(CREATE-BP LINE (BP-INDEX (INTERVAL-LAST-BP INTERVAL)))
585	NIL)))
586	(( I 0)
587	(RETURN (CREATE-BP LINE (LINE-LENGTH LINE)))))))
588	(T
589	(DO ((LINE (BP-LINE BP) (LINE-PREVIOUS LINE))
590	(I TIMES (1+ I))
591	(FIRST-LINE (BP-LINE (INTERVAL-FIRST-BP INTERVAL))))
592	(NIL)
593	(COND ((EQ LINE FIRST-LINE)
594	(RETURN (IF (OR ( I 0) FIXUP-P)
595	(CREATE-BP LINE (LINE-LENGTH LINE))
596	NIL)))
597	(( I 0)
598	(RETURN (CREATE-BP LINE (LINE-LENGTH LINE)))))))))
599
600	(DEFUN FORWARD-OVER (LIST BP)
601	(CHARMAP (BP (INTERVAL-LAST-BP INTERVAL) (CHARMAP-BP-BEFORE))
602	(IF (NOT (MEMQ (CHARMAP-CH-CHAR) LIST))
603	(CHARMAP-RETURN (CHARMAP-BP-BEFORE)))))
604
605	(DEFUN BACKWARD-OVER (LIST BP)
606	(RCHARMAP (BP (INTERVAL-FIRST-BP INTERVAL) (RCHARMAP-BP-AFTER))
607	(IF (NOT (MEMQ (RCHARMAP-CH-CHAR) LIST))
608	(RCHARMAP-RETURN (RCHARMAP-BP-AFTER)))))
609
610	(DEFUN DELETE-OVER (LIST BP)
611	(DELETE-INTERVAL BP (FORWARD-OVER LIST BP) T))
612
613	(DEFUN DELETE-BACKWARD-OVER (LIST BP)
614	(DELETE-INTERVAL (BACKWARD-OVER LIST BP) BP T))
615
616	(DEFUN DELETE-AROUND (LIST BP)
617	(DELETE-INTERVAL (BACKWARD-OVER LIST BP) (FORWARD-OVER LIST BP) T))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format