-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathzczwei-lmiti.lisp
1422 lines (1282 loc) · 60.2 KB
/
zczwei-lmiti.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
; -*- mode: Lisp; Package: Zwei; Base: 10 -*-
; File: ZCZWEI.LISP
;
; This code has been placed in the public domain.
;
; This file contains C mode for ZMACS, for MIT system 98, TI Rel 2, LMI Sys 102.
(defvariable *C-block-indentation* nil :fixnum-or-nil
"The distance, in spaces, to indent nested C blocks. If NIL, defaults to the
current tab width.")
(defvariable *C-indent-}-as-outside* t :boolean
"If T, a } is lined up with the statements *outside* the block it closes; if NIL,
with the *inside* of the block.")
(defprop *flash-matching-paren* t mode-settable-p)
; System 102 defines these as stubs. How useless! Suppress redefinition warnings.
#+LMI (remprop 'com-c-mode ':source-file-name)
#+LMI (remprop 'c-mode-hook ':source-file-name)
; New name in LMI 102, may as well use it in other systems.
#-LMI (defmacro zwei-search (&rest etc) `(search . ,etc))
(defmajor com-c-mode c-mode "C"
"Set things up for editing C programs.
Makes comment delimiters //* and *//, Tab is Indent-for-C,
and anything else I think of." ()
(set-char-syntax word-alphabetic *mode-word-syntax-table* #/_)
(set-comtab *mode-comtab*
'(#\Tab com-Indent-for-C ; #\Line calls this automatically!
#\c-m-Q com-Indent-Region-for-C ; in lieu of -Block-
#\c-m-A com-Beginning-of-C-Function-or-Declaration
#\c-m-E com-End-of-C-Function-or-Declaration
#\c-m-H com-Mark-C-Function-or-Declaration
#\c-m-R com-Reposition-Window-for-C
;; Hyper-control and control-shift aren't synonymous
;; in LMI system 102, TI Rel 2.
#\h-c-C com-C-Compile-Region
#\c-sh-C com-C-Compile-Region
#\h-m-C com-C-Compile-Buffer-Changed-Sections
#\m-sh-C com-C-Compile-Buffer-Changed-Sections
#\m-/; com-End-Comment
#\Break com-Break-for-C
#\f4 com-Break-Lisp-in-C
#\h-tab COM-C-LAST-OPEN-PAREN ;?? for debug only
#\s-tab COM-JHB-INDENT ;?? for debug only
#\f1 COM-PARSE-FROM-DEFUN
)
'(("C Compile Buffer" . com-C-compile-buffer)
("C Syntax Check Region" . com-C-syntax-check-region)
("C Syntax Check Buffer" . com-C-syntax-check-buffer)))
(setq *space-indent-flag* t)
(setq *paragraph-delimiter-list* nil)
(setq *comment-start* "//*")
(setq *comment-begin* "//*")
(setq *comment-end* "*//")
(setq *flash-matching-paren* nil) ; tries to parse Lisp!
;; Try to make at least some of the existing Lisp parsing work.
;; This appears to be sufficient to get matching brackets and braces to
;; work correctly, most of the time anyway.
;; There may be full-blown C parsing someday...
; (aset list-alphabetic *mode-list-syntax-table* #/_) we do not want this.
(aset list-alphabetic *mode-list-syntax-table* #//)
(aset list-alphabetic *mode-list-syntax-table* #/|) ;??
(aset list-slash *mode-list-syntax-table* #/\) ;??
(aset list-double-quote *mode-list-syntax-table* #/')
(aset list-delimiter *mode-list-syntax-table* #/,)
(aset list-delimiter *mode-list-syntax-table* #/;)
(aset list-open *mode-list-syntax-table* #/[)
(aset list-close *mode-list-syntax-table* #/])
(aset list-open *mode-list-syntax-table* #/{)
(aset list-close *mode-list-syntax-table* #/}))
(defprop c-mode :c editing-type)
(set-comtab *standard-comtab*
'()
'(("C Mode" . com-C-mode)))
(let ((pair '(:c . :c)))
(unless (memq pair fs:*file-type-mode-alist*)
(push pair fs:*file-type-mode-alist*)
(push '(:h . :c) fs:*file-type-mode-alist*)))
; ================================================================
; Some utility functions.
; These were taken from ZCPARSE.LISP so that one could at least invoke C mode
; without having the rest of ZETA-C loaded.
(defun c-symbol-start-char-p (c)
(or (and (>= c #/A) (<= c #/Z))
(and (>= c #/a) (<= c #/z))
(= c #/_) (= c #/$)))
(defun c-symbol-char-p (c)
(or (c-symbol-start-char-p c)
(and (>= c #/0) (<= c #/9))))
(defun c-symbol-from-string (string &optional (start 0) (end nil))
"Extracts and interns a C symbol from a string, starting at START, and ending at
END, the first non-symbol character, or the end of the string, whichever comes
first. NIL if there is no symbol starting at START. Returns two values: the
symbol, and the index of the next character after it."
(and (c-symbol-start-char-p (aref string start))
(do ((index (1+ start) (1+ index))
(length (string-length string)))
((or (and end (>= index end))
(>= index length)
(not (c-symbol-char-p (aref string index))))
(values (c-intern-symbol (nsubstring string start index))
index)))))
; This started as a copy of zeta-c:zclex>intern.
(defun c-intern-symbol (name &rest options)
"Interns a symbol in the current package. Meaningful OPTIONS include :UPCASE,
which causes conversion to upper case, and :SOFT, which causes the symbol not
to be interned if not present. '$' is interpreted as the package
prefix delimiter."
(when (memq ':upcase options)
(dotimes (i (string-length name))
(aset (char-upcase (aref name i)) name i)))
(nlet (($pos (string-search-char #/$ name))
((pkg
(and $pos (pkg-find-package (string-upcase (nsubstring name 0 $pos))
:find *package*)))
((pkg name (if (and pkg (neq pkg *package*))
(values pkg (nsubstring name (1+ $pos)))
(values *package* name))))))
(if (memq :soft options)
(intern-soft name pkg)
(intern name pkg))))
; ================================================================
; Sectionization.
(defun (:c section-p) (line)
"Does it look like this line contains the beginning of a C section?"
(c-section-p line nil))
(defun c-section-p (line recursive-p)
"A line is likely to begin a section if it starts with a symbol in column 0, and
either the previous line does not start with a symbol or the previous line
contains a semicolon."
(and (plusp (string-length line))
(c-symbol-start-char-p (aref line 0))
(or recursive-p
(null (line-previous line))
(not (c-section-p (line-previous line) t))
(string-search-char #/; (line-previous line)))))
(defun (:c get-section-name) (line ignore)
"Gets the name of the section starting on LINE. Returns three values: the symbol
or function spec defined, or NIL; the string which appears in the line to
specify that symbol or spec; and T if the line doesn't begin a section after
all."
(declare (values symbol string error-p))
(if (not (c-section-p line nil))
(values nil nil t)
(do ((sline line)
(sidx 0 (1+ sidx))
(parendepth 0)
possible-func-name
probable-func-name)
(nil)
(or sline
(ferror "Sectionization failure on line: ~%~%~A~%~@
Lines that start in the middle of comments must be indented at least~@
one space; if this is such a line, indent it to prevent this error.~@
Otherwise, you have found a bug in the ZETA-C sectionizer; please~@
report it, including several lines of the text of your file above~@
and below where the error occurred." line))
(cond ((>= sidx (string-length sline))
(if (and probable-func-name (zerop parendepth))
(progn (setf (get probable-func-name 'function-section-p) t)
(return probable-func-name (string probable-func-name) nil))
(setq sline (line-next sline))
(setq sidx -1)))
((%string-equal sline sidx "//*" 0 2)
(nlet ((next-bp gave-up
(zwei-search (create-bp sline sidx) "*//" nil nil 2)))
(if gave-up
;; If couldn't find end of comment in 2 lines, give up
;; (?? is this a reasonable strategy?)
(setq sidx (string-length sline))
(setq sline (bp-line next-bp))
(setq sidx (1- (bp-index next-bp))))))
(t
(let ((c (ldb %%ch-char (aref sline sidx))))
(cond ((= #/( c)
(incf parendepth)
(setq probable-func-name possible-func-name))
((= #/) c)
(decf parendepth))
((= #/: c) ; Sigh, it's a label in column 0.
(return (values nil nil t)))
((and (= #/{ c)
probable-func-name
(zerop parendepth))
(setf (get probable-func-name 'function-section-p) t)
(return probable-func-name (string probable-func-name) nil))
((and (= #/{ c) ; check for struct/union tag.
(zerop parendepth)
(not (memq possible-func-name 'c:(|struct| |union|))))
(return possible-func-name (string possible-func-name) nil))
((and (or (= #/, c) (= #/; c) (= #/= c) (= #/[ c))
(zerop parendepth))
(let ((sec-name (or probable-func-name possible-func-name
(format nil "~A-declaration-~D"
(line-buffer-pathname-name line)
(incf *section-count*)))))
(return sec-name (string sec-name) nil)))
((c-symbol-start-char-p c)
(nlet ((sym next (c-symbol-from-string sline sidx)))
(setq sidx (1- next))
(setq possible-func-name sym))))))))))
; Extracted from (:lisp get-section-name) in SYS: ZWEI; SECTIO.
(defun line-buffer-pathname-name (line)
"Given a line, finds a string appropriate for naming the buffer the line appears
in."
(let ((buffer (node-top-level-node (line-node line))))
(if (buffer-pathname buffer)
(let ((name
(pathname-name (buffer-pathname buffer))))
(if (consp name)
(apply 'string-append
(mapcar #'(lambda (name-elt)
(if (consp name-elt)
(car name-elt) name-elt))
name))
(string name)))
(buffer-name buffer))))
; ================================================================
; Command support routines.
(defun forward-c-object (bp &optional (times 1) fixup-p)
"Return a bp which is forward across TIMES top-level C objects (declarations or
function definitions) from BP. If BP is within such an object, that is included
in the count. TIMES negative means move backwards. FIXUP-P non-NIL means if we
attempt to move over the beginning or end of the buffer, return a bp to there;
otherwise return NIL.
/Note this is intentionally /"stupid/": it does no brace counting or the like but
just goes on the simplest textual cues, so it will work (assuming the
conventions are followed) even when semicolons and braces are missing."
(if (zerop times)
(copy-bp bp)
(if (plusp times)
(or (forward-c-object-forward bp times)
(and fixup-p (copy-bp (interval-last-bp *interval*))))
(or (forward-c-object-backward bp (- times))
(and fixup-p (copy-bp (interval-first-bp *interval*)))))))
; Internal to forward-c-object.
(defun forward-c-object-forward (bp times)
(nlet ((next-start-after (find-c-object-start bp t 1 t))
((next-end (c-skip-backward-blank-and-comment-lines next-start-after))))
(if (bp-< bp next-end)
#| We were in the middle of an object. |#
(if (= times 1)
next-end
(let ((next-start-after-n (find-c-object-start next-start-after
t (1- times))))
(and next-start-after-n
(c-skip-backward-blank-and-comment-lines next-start-after-n))))
#| We were between objects. |#
(let ((next-start-after-n (find-c-object-start next-start-after t times)))
(and next-start-after-n
(c-skip-backward-blank-and-comment-lines next-start-after-n))))))
; Internal to forward-c-object.
(defun forward-c-object-backward (bp times)
(find-c-object-start bp nil
(if (and (not (zerop (bp-index bp)))
(c-section-p (bp-line bp) nil))
(1- times) times)))
(defun find-c-object-start (start-bp forwardp times &optional fixup-p)
"Searches forward or backward for a line on which a C object appears to start.
TIMES must be non-negative; FORWARDP controls the direction of search.
Returns NIL if it runs off the end of the buffer."
(do ((i 0 (1+ i))
(line (bp-line start-bp)))
((or (null line) (>= i times))
(if line (create-bp line 0)
(and fixup-p
(copy-bp (if forwardp (interval-last-bp *interval*)
(interval-first-bp *interval*))))))
(do ((this-start-line line))
((or (null line)
(and (neq line this-start-line) (c-section-p line nil))))
(setq line (if forwardp (line-next line) (line-previous line))))))
(defun c-skip-backward-blank-and-comment-lines (bp &optional comments-only)
"Skips backward to the beginning of the line just after the last non-blank,
non-comment line preceding BP. (BP is assumed not to be in a comment.) A
comment beginning on a line with other stuff on it is not skipped over. If
COMMENTS-ONLY, only goes back to the beginning of the first comment before BP.
A line containing a preprocessor command counts as a blank line."
(let ((prev-thing (backward-over *whitespace-chars* bp)))
(or (and (bp-= prev-thing (interval-first-bp *interval*))
prev-thing)
(and (looking-at-backward prev-thing "*//")
(nlet ((comment-start (or (zwei-search prev-thing "//*" t)
(barf "Can't find beginning of comment.")))
((prev-thing-on-line (backward-over '(#\Space #\Tab)
comment-start))))
(and (zerop (bp-index prev-thing-on-line))
(c-skip-backward-blank-and-comment-lines prev-thing-on-line
comments-only))))
; Then again, maybe preprocessor commands shouldn't count. (The bug is that only
; one of a matched pair, #if ... #endif or #lisp ... #endlisp, gets picked up.)
; (and (not comments-only)
; (let ((beg-line-bp (beg-line prev-thing 0 t)))
; (and (looking-at beg-line-bp "#")
; (c-skip-backward-blank-and-comment-lines beg-line-bp))))
(if comments-only bp
(beg-line prev-thing 1 t)))))
; Similar to DEFUN-INTERVAL (SYS: ZWEI; FOR), q.v.
(defun c-object-interval (bp &optional (times 1) fixup-p (comments-p t)
(top-blank-p nil))
"Return an interval surrounding the top-level C object that BP is within, or NIL.
If TIMES is > 1, includes additional objects after that one. COMMENTS-P non-NIL
means include comments before the object. TOP-BLANK-P non-NIL along with
COMMENTS-P means include one blank line (if any) before anything else.
The second value is the first line of the object proper (comments etc. not
included)."
(declare (values interval definition-line))
(nlet ((this-obj-end (forward-c-object bp 1 t))
((obj-start (forward-c-object this-obj-end -1 fixup-p)))
((end (forward-c-object this-obj-end (1- times) fixup-p))))
(and obj-start end
(let ((start (if (not comments-p) obj-start
(c-skip-backward-blank-and-comment-lines obj-start t))))
(let ((start (if (and top-blank-p
(line-previous (bp-line start))
(line-blank-p (line-previous (bp-line start))))
(beg-line start -1)
start)))
(values (create-interval start end)
obj-start))))))
; This is quite simple-minded compared to the Lisp version.
(defun indent-interval-for-C (bp1 &optional bp2 in-order-p point-line
(comments-p t))
"Indent all the lines in the specified interval for C. A line is in the interval
iff its beginning is included. If COMMENTS-P is NIL, comments are not
readjusted. Returns a BP to the end of the interval adjusted. Normally, blank
lines are left with no indentation; however, if POINT-LINE is supplied, that
line is indented even if blank (as the name suggests, this is typically the
preferred treatment for the line containing point)."
(get-interval bp1 bp2 in-order-p)
(interval-lines (bp1 bp2) (start-line stop-line)
(do ((line start-line (line-next line))
(tbp (create-bp start-line 0))
(indent-increment (if *C-block-indentation*
(* *C-block-indentation* (font-space-width))
(send (window-sheet *window*) ':editor-tab-width)))
;; Special case for empty line at end of buffer.
(stop-line (if (and (= (bp-index bp2) 0) (null (line-next (bp-line bp2)))
(bp-= bp1 bp2))
nil stop-line)))
((eq line stop-line)
(if line (move-bp tbp line 0) (interval-last-bp *interval*)))
(move-bp tbp line 0)
(indent-bp-adjustment tbp)
(if (or (null (line-previous line))
(and (neq line point-line) (line-blank-p line))
(looking-at tbp "#"))
(indent-line tbp 0)
(nlet ((prev-non-blank-line (line-previous-non-blank-or-comment line t))
((prev-line-ind (line-indentation prev-non-blank-line))
(last-thing-bp (end-of-real-text prev-non-blank-line))
(unmatched-open (c-last-open-paren prev-non-blank-line))
((goal-ind (if (not (and *C-indent-}-as-outside*
(looking-at tbp "}")))
prev-line-ind
(max 0 (- prev-line-ind indent-increment)))))))
(cond (unmatched-open
(indent-line tbp (+ (BP-INDENTATION unmatched-open) (font-space-width))))
((looking-at-backward last-thing-bp "{")
(indent-line tbp (+ goal-ind indent-increment)))
((and (not *C-indent-}-as-outside*)
(looking-at-backward last-thing-bp "}"))
(indent-line tbp (max 0 (- goal-ind indent-increment))))
(t (indent-line tbp goal-ind)))
(when comments-p (indent-for-comment tbp)))))))
(defun line-previous-non-blank-or-comment (line &optional fixup-p)
"Returns the first non-blank line before LINE which does not begin with a
comment (or #). FIXUP-P means, if we reach the first line of the buffer
and it's blank, return it anyway.
If we are already on the first line of the buffer, return NIL."
(do ((line (line-previous line) (line-previous line)))
((or (null line)
(let ((first-thing (forward-over *blanks* (create-bp line 0))))
(and (not (line-blank-p line))
(not (looking-at first-thing *comment-start*))
(not (looking-at first-thing "#"))))
(and fixup-p (null (line-previous line))))
line)))
(defun end-of-real-text (line)
"Returns a BP that points right after the last non-whitespace, non-comment
character on LINE."
;;Need to adjust this so we can have more than one comment on a line. ??
(nlet ((comment-start ignore inside-string
(c-find-next-comment-start line)))
(backward-over *blanks*
(if (and comment-start (not inside-string))
(create-bp line comment-start)
(create-bp line (string-length line))))))
; Similar to COMPILE-DEFUN-INTERNAL (SYS: ZWEI; COMC), q.v.
(defun c-compile-object-internal (compile-p mode-name echo-name
&optional use-typeout)
"C-compile a part of the current buffer. If COMPILE-P is NIL, the object is only
parsed (for syntax checking). MODE-NAME is a string containing a capitalized
present participle, such as /"Compiling/"; ECHO-NAME is a string containing a
lowercase past participle and period (/"compiled./"). USE-TYPEOUT is passed to
C-COMPILE-PRINT-INTERVAL and controls where information is printed."
(nlet ((bp1 bp2 object-name
(if (window-mark-p *window*)
(values (point) (mark) "region")
(let ((int (or (c-object-interval (point) 1 nil nil)
(barf "Don't see what to compile."))))
(values (interval-first-bp int) (interval-last-bp int) nil)))))
(c-compile-print-interval bp1 bp2 nil compile-p object-name
mode-name echo-name use-typeout)))
; Similar to COMPILE-BUFFER (SYS: ZWEI; COMC), q.v.
(defun c-compile-buffer (compile-p mode-name echo-name rest-of-buffer)
"C-compile or syntax check the current buffer. If COMPILE-P is NIL, the buffer
is only parsed (for syntax checking). MODE-NAME is a string containing a
capitalized present participle, such as /"Compiling/"; ECHO-NAME is a string
containing a lowercase past participle and period (/"compiled./"). If
REST-OF-BUFFER, starts compiling at point."
(nlet ((bp1 name (if rest-of-buffer (values (point) "rest of buffer")
(values (interval-first-bp *interval*) "buffer")))
(bp2 (interval-last-bp *interval*)))
(c-compile-print-interval bp1 bp2 t compile-p name mode-name echo-name nil)))
; Similar to COMPILE-PRINT-INTERVAL (SYS: ZWEI; COMC), q.v.
(defun c-compile-print-interval (bp1 bp2 in-order-p compile-p object-name mode-name
echo-name use-typeout
&optional already-sectionized)
"C-compile or parse (syntax check) the interval specified by BP1, BP2,
IN-ORDER-P. COMPILE-P is NIL for syntax checking only. OBJECT-NAME is a string
to print as the name of this whole object, or NIL to mention each object's name.
USE-TYPEOUT can be T (print in typeout window), NIL (print in echo area), or
:PROMPT (print in prompt line). MODE-NAME is a string containing a capitalized
present participle, such as /"Compiling/"; ECHO-NAME is a string containing a
lowercase past participle and period (/"compiled./")."
(get-interval bp1 bp2 in-order-p)
(when (not already-sectionized)
(check-interval-sections bp1 bp2 t))
(undo-save-current-range)
(let ((format-function
(selectq use-typeout
((t) #'(lambda (string &rest args)
(lexpr-funcall #'format t string args)))
(:prompt #'prompt-line-more)
((nil) #'(lambda (string &rest args)
(lexpr-funcall #'format query-io string args)))))
(success))
(if object-name
(funcall format-function "~&~A ~A" mode-name object-name)
(funcall format-function "~&~A ~S" mode-name
(section-node-name (bp-node bp1))))
(unwind-protect
(progn
(c-compile-interval compile-p (if (eq use-typeout 't) t query-io)
bp1 bp2 t)
(setq success t))
(or success (funcall format-function " -- aborted.")))
(funcall format-function " -- ~A" echo-name)
(update-interval-compile-tick bp1 bp2 t)))
; Similar to COMPILE-INTERVAL (SYS: ZWEI; COMC), q.v.
; Saving the location of the first read-error in a "q-register" is gross, but this
; is the way the LMITI system works, and (for the moment, at least) I might as well
; follow along.
(defun c-compile-interval (compile-p-arg print-results-stream bp1
&optional bp2 in-order-p)
"C-compile or parse (syntax check) the interval specified by BP1, BP2,
IN-ORDER-P. Does not print any sort of message saying what is being compiled;
does not know about sectionization. COMPILE-P-ARG is NIL for syntax checking
only."
(declare (special print-results-stream))
(get-interval bp1 bp2 in-order-p)
(nlet ((generic-pathname (send *interval* :send-if-handles :generic-pathname))
(whole-file (and (bp-= bp1 (interval-first-bp *interval*))
(bp-= bp2 (interval-last-bp *interval*))))
(interval-stream (interval-stream bp1 bp2))
(start-line (count-lines (interval-first-bp *interval*) bp1 t))
((stream (zeta-c:make-c-parser interval-stream generic-pathname
:start-line start-line
:c-package package
:whole-file whole-file)))
(attr-vars attr-vals (send *interval* ':attribute-bindings)))
(remprop (make-register-name #/.) 'point)
(let ((compile-processing-mode 'compiler:macro-compile)
(defvar-hack nil)
(compile-p (or compile-p-arg #'ignore)))
(declare (special compile-processing-mode defvar-hack compile-p))
(progv attr-vars attr-vals
(when fs:this-is-a-patch-file
(putprop generic-pathname t ':patch-file))
(flet ((do-it ()
(compiler:compile-stream stream generic-pathname nil
'compile-interval-process-fn
t nil package nil nil whole-file)))
(if compile-p
(compiler:locking-resources-no-qfasl (do-it))
(do-it)))))
(and generic-pathname
(si:record-file-definitions generic-pathname si:fdefine-file-definitions
whole-file))))
; Similar to COMPILE-BUFFER-CHANGED-FUNCTIONS (SYS: ZWEI; COMC), q.v.
(defun c-compile-buffer-changed-functions (buffer ask-p compile-p names)
"Re-C-compile or syntax-check all changed sections in BUFFER (that contain
function definitions). COMPILE-P is NIL for syntax-checking only. ASK-P says
whether to query user about each function to be compiled. NAMES has three
elements, like '(/"Compile/" /"Compiling/" /"compiled./")."
(let ((*interval* buffer))
(resectionize-buffer buffer)
(mapc #'(lambda (node)
(and (typep node 'section-node)
(not (stringp (section-node-name node)))
(not (bp-= (interval-first-bp node) (interval-last-bp node)))
(> (node-tick node) (section-node-compile-tick node))
(or (not ask-p)
(fquery '(:select t) "~A ~A? " (car names)
(section-node-name node)))
(c-compile-print-interval node nil t compile-p nil
(cadr names) (caddr names) t)))
(node-inferiors *interval*))))
; ================================================================
; Commands.
(defcom com-beginning-of-c-function-or-declaration
"Moves to the beginning of the current C function or declaration." (km)
(let ((bp (or (forward-c-object (point) (- *numeric-arg*)) (barf))))
(point-pdl-push (point) *window*)
(move-bp (point) bp))
dis-bps)
(defcom com-end-of-c-function-or-declaration
"Moves to the end of the current C function or declaration." (km)
(let ((bp (or (forward-c-object (point) *numeric-arg*) (barf))))
(point-pdl-push (point) *window*)
(move-bp (point) bp))
dis-bps)
(defcom com-mark-c-function-or-declaration
"Puts point and mark around the current C function or declaration." ()
(let ((int (or (c-object-interval (point) *numeric-arg* nil t t)
(barf))))
(setf (window-mark-p *window*) t)
(setq *mark-stays* t)
(point-pdl-push (point) *window* nil nil)
(move-bp (point) (interval-first-bp int))
(move-bp (mark) (interval-last-bp int)))
dis-bps)
(defcom com-indent-for-C "Indent this line in the current C style.
Numeric argument is the number of lines to indent.
Variables you can set to affect the style:
*C-block-indentation*: The distance, in spaces, to indent nested C blocks.
If NIL, defaults to the current tab width.
*C-indent-}-as-outside*: If T, a } is lined up with the statements *outside*
the block it closes; if NIL, with the *inside* of the block." ()
(let ((end (indent-interval-for-C (beg-line (point))
(beg-line (point) *numeric-arg* t)
nil (bp-line (point)) *numeric-arg-p*)))
(if *numeric-arg-p*
(move-bp (point) end)
(indent-bp-adjustment (point))))
dis-text)
(defcom com-indent-region-for-C
"Indents all lines in the region in the current C style.
Variables you can set to affect the style:
*C-block-indentation*: The distance in spaces to indent nested C blocks.
If NIL, defaults to the current tab width.
*C-indent-}-as-outside*: If T, a } is lined up with the statements *outside*
the block it closes; if NIL, with the *inside* of the block." ()
(region (bp1 bp2)
(indent-interval-for-C bp1 bp2 t))
dis-text)
(defcom com-C-compile-region
"C-compiles the current region or function//declaration.
If there is a region, it is compiled; otherwise, the current or next
function or declaration is compiled." ()
(c-compile-object-internal t "C-compiling" "compiled.")
dis-none)
(defcom com-C-syntax-check-region
"Checks the current region or function//declaration for correct C syntax.
If there is a region, it is checked; otherwise, the current or next function or
declaration is checked." ()
(c-compile-object-internal nil "C-syntax-checking" "syntax-checked.")
dis-none)
(defcom com-C-compile-buffer
"C-compiles the entire current buffer; or, with an argument, the rest of
/the buffer (starting at point)." ()
(c-compile-buffer t "C-compiling" "compiled." *numeric-arg-p*)
dis-none)
(defcom com-C-syntax-check-buffer
"Checks the entire current buffer for correct C syntax; or, with an
argument, the rest of the buffer (starting at point)." ()
(c-compile-buffer nil "C-syntax-checking" "syntax-checked." *numeric-arg-p*)
dis-none)
(defcom com-C-compile-buffer-changed-sections
"C-compile any sections in this buffer which have been edited.
A numeric arg means ask about each section individually." ()
(si:file-operation-with-warnings ((and (buffer-file-id *interval*)
(send (send *interval* ':generic-pathname)
':generic-pathname))
':compile nil)
(compiler:compiler-warnings-context-bind
(c-compile-buffer-changed-functions
*interval* *numeric-arg-p* t '("C-compile" "C-compiling" "compiled."))))
(format t "~&Done.~%")
dis-none)
; Similar to COM-REPOSITION-WINDOW in SYS:ZWEI;COME
; Should indirect through major mode!
(defcom com-Reposition-Window-for-C
"Try to get all of current C function//declaration in the window.
If function beginning is on the screen,
scrolls down to bring the end onto the screen.
If function beginning is off screen, scrolls up so beginning appears,
but will not push point off the bottom.
If function beginning is at the top of the screen,
tries omitting or including the comments before it.
If function is entirely on screen, positions it at the top
(or, with numeric arg, at the bottom) of the screen." (KM)
(let ((point (point))
(sheet (window-sheet *window*))
(n-plines (window-n-plines *window*))
(int (c-object-interval (point) 1 t t))
start-bp end-bp
recenter-bp)
(cond ((not (null int))
(setq start-bp (interval-first-bp int)
end-bp (interval-last-bp int))
;; Don't include the blank line after the defun
(and (zerop (bp-index end-bp)) (setq end-bp (end-line end-bp -1 t)))
(cond ((and (pline-of-point t *window* start-bp) ;If start is on screen
(null (pline-of-point t *window* end-bp)) ; but not end
(multiple-value-bind (line index)
(put-point-at-pline sheet (bp-line end-bp)
(bp-index end-bp) (1- n-plines)
(interval-first-bp *interval*)
(interval-last-bp *interval*))
(setq recenter-bp (create-bp line index))
;; And can fit bottom of the defun on as well
;; then start at the top of the function.
(not (bp-< start-bp recenter-bp)))))
((bp-< start-bp
(setq recenter-bp (multiple-value-bind (line index)
(put-point-at-pline
sheet (bp-line point)
(bp-index point) (1- n-plines)
(interval-first-bp *interval*)
(interval-last-bp *interval*))
(create-bp line index))))
;; If displaying from the start of the defun would push point off
;; the bottom, complain, and bring in as much as possible anyway.
(beep))
;; Start of defun thru point fits on the screen.
((and *numeric-arg-p* (pline-of-point t *window* end-bp))
;; If numeric arg, and end of function is on screen,
;; try putting end of function at bottom.
(multiple-value-bind (line index)
(put-point-at-pline sheet (bp-line end-bp) (bp-index end-bp)
(1- n-plines)
(interval-first-bp *interval*)
(interval-last-bp *interval*))
(setq recenter-bp (create-bp line index))))
(t
;; If already at default place, exclude comments above defun.
(and (bp-= (window-start-bp *window*) start-bp)
(setq start-bp
(interval-first-bp
(c-object-interval (point) 1 t nil))))
(setq recenter-bp start-bp)))
(recenter-window *window* ':start recenter-bp))
(t (barf "Can't find a C function or declaration here.")))
dis-none))
(defcom com-Break-for-C "Invokes a C listener on the typeout window." ()
(unwind-protect
(let ((*inside-break* t))
;; *inside-break* talks to (:method editor-typeout-window :more-exception).
(zeta-c:c-top-level *typeout-window* t
(if (typep *interval* 'file-buffer)
(send *interval* ':pathname)
(fs:default-pathname)))))
(send *typeout-window* ':make-complete)
dis-none)
; End of old ZCZWEI.LISP
;;@@@This is stuff from the now-defunct JHBMODE, to be slipped in above and used as time goes on.
;; The thing to do is make this file work for all A-machines, with conditional compilation.
;; Sadly, ZWEI on the the Symbolics machines is done incompatibly (with more methods instead
;; of traditional function calls), and so must be maintained separately.
(DEFGLOBAL *C-PARSE-PREPARSED-FLAG* NIL ;We may not need this, so be prepared to delete it.
"If this is T, C-PARSE-FROM-DEFUN assumes that the lines are already parsed.")
(defcom com-Break-Lisp-in-C "Invokes a Lisp listener on the typeout window. To be changed." ()
(UNWIND-PROTECT
(LET ((*INSIDE-BREAK* T))
(BREAK "ZMACS")))
(FUNCALL STANDARD-OUTPUT ':MAKE-COMPLETE)
DIS-NONE)
(defun jhbshobuf (&optional (firstline (bp-line (interval-first-bp *interval*))))
"Used to examine the LINE-CONTENTS-PLIST of all lines from FIRSTLINE onward."
(do ((x firstline (line-next x)))
((not x) :done)
(format t "~%~A ~A" (line-contents-plist x) x)))
(defcom COM-C-LAST-OPEN-PAREN "Move POINT to the last valid, unmatched open-parenthesis, if it exists." ()
(let* ((line (bp-line (point)))
(dest-bp (c-last-open-paren line)))
(when dest-bp (move-bp (point) dest-bp)))
dis-text)
(defcom COM-JHB-INDENT "My first try at the important issue of indentation." ()
;;Eventually we want to parse-from-defun first, then check to see if this line is in a string??
;; Be sure to go over the LISP-indent and make ours feels exactly the same??
(unless nil ;Check if we are in a string?? if so do nil
(let ((end (jhb-indent-interval (beg-line (point))
(beg-line (point) *numeric-arg* t)
nil (bp-line (point)) *numeric-arg-p*)))
(if *numeric-arg-p*
(move-bp (point) end)
(indent-bp-adjustment (point)))))
dis-text)
(defcom COM-PARSE-FROM-DEFUN "Experimental" ()
(C-PARSE-FROM-DEFUN (bp-line (point)))
dis-text)
#||
"BP1 can be an interval, in which case bp2 should be nil. Indentation for C. Returns a BP to the end of the indentation, usually the first printing char on the line. If COMMENTS-P is NIL, comments are not readjusted. If INDENT-BLANK-P is NIL, a blank line is left with no *BLANK* chars." ;replace below when done.
(defun JHB-INDENT-INTERVAL (bp1 &optional bp2 in-order-p point-line (comments-p t))
(GET-INTERVAL BP1 BP2 IN-ORDER-P)
(C-PARSE-FROM-DEFUN (BP-LINE BP2))
(interval-lines (bp1 bp2) (start-line stop-line)
(when (and (= (bp-index bp2) 0) ;Special case for blank line at EOB.
(null (line-next (bp-line bp2)))
(bp-= bp1 bp2))
(setq stop-line nil))
(do (model-line
(line start-line (line-next line))
(tbp (create-bp start-line 0))
(*C-PARSE-PREPARSED-FLAG* T)
(indent-increment (if *C-block-indentation*
(* *C-block-indentation* (font-space-width))
(send (window-sheet *window*) :editor-tab-width))))
((eq line stop-line)
(if line (move-bp tbp line 0) (interval-last-bp *interval*))) ;??Scrap this in favor of the Lisp mode way.
(indent-bp-adjustment (move-bp tbp line 0))
(if (or (null (line-previous line)) ;Never indent: (interval-first-bp ...),
(and (line-blank-p line) (neq line point-line)) ;blanks, except cursor line,
(looking-at tbp "#")) ;or preprocessor commands.
(indent-line tbp 0) ;THEN snuggle up to that left margin,
;; ELSE we have to do some real work...
(setq model-line (line-previous-non-blank-or-comment line t))
(end-line model-line)
***
(do* ((BP (end-of-line (line-previous line)) (dbp BP)) ;Start at end of prev-line.
(char (and BP (ldb %%ch-char (bp-char BP))) ;Strip font, checking for valid BP first.
(and BP (ldb %%ch-char (bp-char BP))))
(found-keyword (and (memq char '(#/f #/w #/i #/F #/W #/I)) ;;Efficiency- usually we
(or (looking-at BP "FOR")
(looking-at BP "WHILE")
(looking-at BP "IF")))
(and (memq char '(#/f #/w #/i #/F #/W #/I)) ;;report failure right here.
(or (looking-at BP "FOR")
(looking-at BP "WHILE")
(looking-at BP "IF")))))
((or (eq char #/;) ;Quit upon reaching a semi-colon,
(eq char #/() ; open-paren,
(not BP) ; the beg of buffer,
found-keyword) ; or a keyword.
(when found-keyword BP))
(when (= char #/)) ;Skip over any complete parenthetical expression.
(ibp BP) ;This puts us in position for (forwrd-sexp ...)
(move-bp BP (forward-sexp BP -1)))
(c-skip-string BP nil char) ;Likewise any string or comment.
))
***
(let* ((model-line (line-previous-non-blank-or-comment line t))
(model-pxl-indent (line-indentation model-line))
(last-thing-bp (end-of-real-text model-line))
(FWI (C-FWI-indent line)) ;For, While or If.
(unmatched-open (c-last-open-paren model-line))
(goal-pxl-indent (if (and *C-indent-}-as-outside*
(looking-at tbp "}"))
(max 0 (- model-pxl-indent indent-increment))
model-pxl-indent)))
(setq goal-pxl-indent
(cond (unmatched-open (+ (BP-INDENTATION unmatched-open) (font-space-width)))
(FWI (+ (BP-INDENTATION FWI) indent-increment))
((looking-at-backward last-thing-bp "{") ;This will change to account for many
(+ goal-pxl-indent indent-increment)) ;Push.
((and (not *C-indent-}-as-outside*)
(looking-at-backward last-thing-bp "}"))
(max 0 (- goal-pxl-indent indent-increment))) ;Pop.
(t goal-pxl-indent)))
(indent-line tbp goal-pxl-indent) ;Here is where the work actually gets done.
(when comments-p (indent-for-comment tbp)))))) ;Maybe write our own??
||#
(defun old-JHB-INDENT-INTERVAL (bp1 &optional bp2 in-order-p point-line (comments-p t)) ;for reference only
"Indent one line for C. Returns a BP to the end of the indentation,
usually the first printing char on the line.
If COMMENTS-P is NIL, comments are not readjusted.
If INDENT-BLANK-P is NIL, a blank line is left with no *BLANK* chars."
;;Strategy: An un-matched open-paren lying about comes first, and is final.
;;Next come those things which can push or pop us one or more levels: IF WHEN ELSE, {},
;;Last we just copy the indentation of the previous non-blank line.
(or in-order-p (order-bps bp1 bp2))
(interval-lines (bp1 bp2) (start-line stop-line)
(when (and (= (bp-index bp2) 0) ;Special case for blank line at EOB.
(null (line-next (bp-line bp2)))
(bp-= bp1 bp2))
(setq stop-line nil))
(do ((line start-line (line-next line))
(tbp (create-bp start-line 0))
(indent-increment (if *C-block-indentation*
(* *C-block-indentation* (font-space-width))
(send (window-sheet *window*) :editor-tab-width))))
((eq line stop-line)
(if line (move-bp tbp line 0) (interval-last-bp *interval*)))
(indent-bp-adjustment (move-bp tbp line 0))
(if (or (null (line-previous line)) ;Never indent: (interval-first-bp ...),
(and (line-blank-p line) (neq line point-line)) ;blanks, except cursor line,
(looking-at tbp "#")) ;or preprocessor commands.
(indent-line tbp 0) ;THEN snuggle up to that left margin,
;; ELSE we have to do some real work...
(let* ((model-line (line-previous-non-blank-or-comment line t))
(model-pxl-indent (line-indentation model-line))
(last-thing-bp (end-of-real-text model-line))
(FWI (C-FWI-indent line))
(unmatched-open (c-last-open-paren model-line))
(goal-pxl-indent (if (and *C-indent-}-as-outside*
(looking-at tbp "}")) ;??Ever stacked up??
(print (max 0 (- model-pxl-indent indent-increment)))
model-pxl-indent)))
(setq goal-pxl-indent
(cond (unmatched-open (print "UMO")
(+ (BP-INDENTATION unmatched-open) (font-space-width)))
(FWI (print "FWI")(+ (BP-INDENTATION FWI) indent-increment))
((looking-at-backward last-thing-bp "{") (print "{") ;Push.
(+ goal-pxl-indent indent-increment)) ; Many #\{s?? YES.
((and (not *C-indent-}-as-outside*)
(looking-at-backward last-thing-bp "}")) (print "}")
(max 0 (- goal-pxl-indent indent-increment))) ;Pop.
(t goal-pxl-indent)))
(print goal-pxl-indent)
(indent-line tbp goal-pxl-indent)
(when comments-p (indent-for-comment tbp)))))))
(defun c-last-open-paren (line)
"Return either NIL or a bp which points to the last valid
/(outside a string or comment), unmatched open-parenthesis in LINE."
;;Strategy:
;;
;;index <- 0.
;;LOOP
;;find the first valid open after index (0, at first).
;;IF ~, quit, returning last-valid-one (the last valid open, or NIL, reporting failure).
;; ELSE set index to (1+ pos).
;;find the matching close (not just any close).
;;IF , set index to (1+ pos), and go back to LOOP.
;; ELSE last-valid-one <- index, and go back to LOOP.
(do (next-close
last-valid-one
(ind 0)
(next-open (C-sensitive-string-search #/( line 0)
(C-sensitive-string-search #/( line (1+ ind))))
((not next-open)
(when last-valid-one
(create-bp line last-valid-one)))
(setq ind next-open
next-close (c-matching-close-paren-in-line line next-open))
(if next-close
(setq ind next-close)
(setq last-valid-one next-open))))
(defun c-matching-close-paren-in-line (line index)
"Like FORWARD-SEXP.
In LINE, find the next open-paren after INDEX (normally right at INDEX),
and return either the index of its mate, or NIL if it has no mate on this line."
;;Recursion is a good idea here cos we stay in one line.
;;Maybe we could assume index points to a #\(, but it is easy to make sure.
;;Maybe we can get rid of ndx, and just hack INDEX.
(setq index (C-sensitive-string-search #/( line index))
(when index
(do (open2 close (ndx index))
((not ndx)) ;If ndx shows up nil, we failed to find a match.
(setq open2 (C-sensitive-string-search #/( line (1+ ndx)))
(setq close (C-sensitive-string-search #/) line (1+ ndx)))
(cond ((not close) (return nil)) ;~ close, return NIL.
((not open2) (return close)) ; close, ~ open, return close.
(t ; close, and open:
(if (< close open2) ;If the close comes 1st, return it
(return close) ;else skip over the () and keep looking.
(setq ndx (c-matching-close-paren-in-line line open2))))
))))
(defun C-sensitive-string-search (KEY STRING &OPTIONAL (FROM 0) TO (KEY-FROM 0) KEY-TO
CONSIDER-CASE &AUX
(ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON CONSIDER-CASE)
KEY-LEN)
"Just like an ordinary STRING-SEARCH, but skips over
strings and comments without searching their contents.
Rules for nesting comments are found on the file's plist.
Obviously this function will not do the right thing if
you ask it to find a string or comment delimiter."
;;Should we do the same for SEARCH?
;;??Make this sensitive to the previous line.
;;??Make this deal with slashified chars!
;;??Are there any other conds under which we might find quotes (either kind)?
;;Look for BACKslash?? Ubique.
(si:COERCE-STRING-SEARCH-ARG STRING)
(si:COERCE-STRING-ARG KEY)
(UNLESS KEY-TO
(SETQ KEY-TO (ARRAY-ACTIVE-LENGTH KEY))) ;NB-- Have I failed to do this elsewhere??
(SETQ KEY-LEN (- KEY-TO KEY-FROM))
(OR TO (SETQ TO (1+ (- (ARRAY-ACTIVE-LENGTH STRING) ;Last position at which key may start +1
KEY-LEN)))) ;Key-Len will be 1.
(COND ((= KEY-FROM KEY-TO)
(AND ( FROM TO) FROM))
(T
(PROG (CH1)
(COND ((MINUSP TO) (RETURN NIL)))
(SETQ CH1 (AREF KEY KEY-FROM))
LOOP ;Find next place key might start
(OR (SETQ FROM
(do ((index FROM)
(next-ind (string-search-set (list #/' #/" #// CH1) STRING FROM)
(string-search-set (list #/' #/" #// CH1) STRING index)))
;;When ~ any more interesting chars on this line, we failed to find it.
((or (not next-ind) (> next-ind TO)))
(case (AREF STRING next-ind)
(#/" (setq index (1+ (or (%STRING-SEARCH-CHAR
#/" STRING (1+ next-ind) (1- TO))
(1- TO)))))
(#/' (setq index (1+ (or (%STRING-SEARCH-CHAR
#/' STRING (1+ next-ind) (1- TO))
(1- TO)))))
(#// (if (eq (AREF STRING (1+ next-ind)) #/*)
(setq index (+ 2 (or (string-search