source: trunk/lisp/nzwei/for.lisp @ 258

Last change on this file since 258 was 258, checked in by rjs, 3 years ago

Update.

File size: 21.5 KB
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 repository browser.