checkman.txr


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

@(name file)
@;;
@;; Check syntax block after function
@;;
@(define check-synb ())
.synb
@  (assert bad ln `bad .synb block`)
@  (repeat :gap 0 :min 1)
.mets @(skip)
@    (maybe)
@      (repeat :gap 0 :mintimes 1)
.mets \ \ @(skip)
@      (last :mandatory)

@      (trailer)
.mets @(skip)
@      (end)
@    (end)
@  (last :mandatory)
.syne
@  (end)
@  (assert bad ln `missing .desc`)
.desc
@  (assert bad ln `blank line after .desc`)
@/..*/
@(end)
@;;
@;; Check variable description headings
@;;
@(define check-var ())
@  (cases)
@;   exception
.coNP Variables @@, s-ifmt @(skip)
@    (or)
@;   exception
.coNP Variables @@, *0 @(skip)
@    (or)
.coNP Variables@(assert bad ln `bad Variables heading`)@(rep :gap 0) @@, @{x /\S+/}@(last :mandatory) @@ @y and @@ @{z /\S+/}@(end)
@      (assert bad ln `no .desc after variables heading`)
.desc
@    (or)
.coNP Variable@(assert bad ln `bad Variable heading`) @{x /\S+/}
@      (assert bad ln `no .desc after variable heading`)
.desc
@  (end)
@(end)
@;;
@;; Check function/macro/operator headings
@;;
@(define check-func ())
@  (cases)
.coNP Operator/function @(skip)
@    (or)
.coNP @{type /Function|Operator|Macro/}s@(assert bad ln `bad @{type}s heading`)@(rep :gap 0) @@, @{x /\S+/}@(last :mandatory) @@ @y and @@ @{z /\S+/}@(end)
@      (assert bad ln `no .synb after @{type}s heading`)
@      (check-synb)
@    (or)
.coNP @{type /Function|Operator|Macro/}@(assert bad ln `bad @type heading`) @@ @{x /\S+/}
@      (assert bad ln `no .synb after @type heading`)
@      (check-synb)
@  (end)
@(end)
@;;
@;; check .code, .codn, .cod2, .cod3, .meta and .metn.
@;;
@(define check-code ())
@  (cases)
.@{type /code|meta/} "@(assert bad ln `.@type needs one argument`)@x"@(eol)
@  (or)
.@{type /code|meta/}@(assert bad ln `.@type needs one argument`) @{x /\S+/}@(eol)
@  (or)
.cod3 @(assert bad ln `.cod3 needs three arguments`)@x @y @{z /\S+/}@(eol)
@  (or)
.@{type /codn|cod2|metn/} @(assert bad ln `.@type needs two arguments`)@(cases)"@x"@(or)@{x /\S+/}@(end) @{y /\S+/}@(eol)
@    (assert bad ln `.codn second argument doesn't begin with punctuation`)
@    (require (or (not (memqual type '("codn" "metn")))
                  (chr-ispunct [y 0])))
@  (end)
@(end)
@;;
@;; Check .cblk/.cble pairing
@;;
@(define check-cblk ())
.cblk
@  (assert bad ln `.cblk not closed`)
@  (repeat :gap 0)
@    (none)
.cblk
@    (end)
@  (until :mandatory)
.cble
@  (end)
@(end)
@;;
@;; Main
@;;
@(bind errors 0)
@(repeat)
@  (line ln)
@  (try)
@    (cases)
@      (check-var)
@    (or)
@      (check-func)
@    (or)
@      (check-code)
@    (or)
@      (check-cblk)
@    (end)
@  (catch bad (line msg))
@    (do (inc errors)
         (put-line `@file:@line:@msg`))
@  (end)
@(end)
@(do (exit (zerop errors)))