Commit | Line | Data |
---|---|---|
bff56cdf TTN |
1 | #!/bin/sh |
2 | # aside from this initial boilerplate, this is actually -*- scheme -*- code | |
3 | main='(module-ref (resolve-module '\''(scripts read-scheme-source)) '\'main')' | |
8c914f6b | 4 | exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" |
bff56cdf TTN |
5 | !# |
6 | ;;; read-scheme-source --- Read a file, recognizing scheme forms and comments | |
7 | ||
8 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
9 | ;; | |
10 | ;; This program is free software; you can redistribute it and/or | |
11 | ;; modify it under the terms of the GNU General Public License as | |
12 | ;; published by the Free Software Foundation; either version 2, or | |
13 | ;; (at your option) any later version. | |
14 | ;; | |
15 | ;; This program is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
18 | ;; General Public License for more details. | |
19 | ;; | |
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with this software; see the file COPYING. If not, write to | |
92205699 MV |
22 | ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
23 | ;; Boston, MA 02110-1301 USA | |
bff56cdf | 24 | |
61897afe TTN |
25 | ;;; Author: Thien-Thi Nguyen |
26 | ||
bff56cdf TTN |
27 | ;;; Commentary: |
28 | ||
29 | ;; Usage: read-scheme-source FILE1 FILE2 ... | |
30 | ;; | |
31 | ;; This program parses each FILE and writes to stdout sexps that describe the | |
32 | ;; top-level structures of the file: scheme forms, single-line comments, and | |
33 | ;; hash-bang comments. You can further process these (to associate comments | |
34 | ;; w/ scheme forms as a kind of documentation, for example). | |
35 | ;; | |
36 | ;; The output sexps have one of these forms: | |
37 | ;; | |
38 | ;; (quote (filename FILENAME)) | |
39 | ;; | |
e8cd769d | 40 | ;; (quote (comment :leading-semicolons N |
bff56cdf TTN |
41 | ;; :text LINE)) |
42 | ;; | |
43 | ;; (quote (whitespace :text LINE)) | |
44 | ;; | |
45 | ;; (quote (hash-bang-comment :line LINUM | |
46 | ;; :line-count N | |
47 | ;; :text-list (LINE1 LINE2 ...))) | |
48 | ;; | |
49 | ;; (quote (following-form-properties :line LINUM | |
50 | ;; :line-count N) | |
51 | ;; :type TYPE | |
52 | ;; :signature SIGNATURE | |
53 | ;; :std-int-doc DOCSTRING)) | |
54 | ;; | |
55 | ;; SEXP | |
56 | ;; | |
57 | ;; The first four are straightforward (both FILENAME and LINE are strings sans | |
58 | ;; newline, while LINUM and N are integers). The last two always go together, | |
59 | ;; in that order. SEXP is scheme code processed only by `read' and then | |
60 | ;; `write'. | |
61 | ;; | |
62 | ;; The :type field may be omitted if the form is not recognized. Otherwise, | |
63 | ;; TYPE may be one of: procedure, alias, define-module, variable. | |
64 | ;; | |
65 | ;; The :signature field may be omitted if the form is not a procedure. | |
66 | ;; Otherwise, SIGNATURE is a list showing the procedure's signature. | |
67 | ;; | |
68 | ;; If the type is `procedure' and the form has a standard internal docstring | |
69 | ;; (first body form a string), that is extracted in full -- including any | |
70 | ;; embedded newlines -- and recorded by field :std-int-doc. | |
71 | ;; | |
72 | ;; | |
73 | ;; Usage from a program: The output list of sexps can be retrieved by scheme | |
74 | ;; programs w/o having to capture stdout, like so: | |
75 | ;; | |
76 | ;; (use-modules (scripts read-scheme-source)) | |
77 | ;; (define source-forms (read-scheme-source-silently "FILE1" "FILE2" ...)) | |
78 | ;; | |
6f2ec1d1 TTN |
79 | ;; There are also two convenience procs exported for use by Scheme programs: |
80 | ;; | |
81 | ;; (clump FORMS) --- filter FORMS combining contiguous comment forms that | |
82 | ;; have the same number of leading semicolons. | |
83 | ;; | |
84 | ;; (quoted? SYM FORM) --- see if FORM looks like: "(quote (SYM ...))", parse | |
85 | ;; the ":tags", and return alist of (TAG . VAL) elems. | |
bff56cdf TTN |
86 | ;; |
87 | ;; TODO: Add option "--clump-comments", maybe w/ different clumping styles. | |
88 | ;; Make `annotate!' extensible. | |
bff56cdf TTN |
89 | |
90 | ;;; Code: | |
91 | ||
92 | (define-module (scripts read-scheme-source) | |
93 | :use-module (ice-9 rdelim) | |
6f2ec1d1 TTN |
94 | :export (read-scheme-source |
95 | read-scheme-source-silently | |
96 | quoted? | |
97 | clump)) | |
bff56cdf TTN |
98 | |
99 | ;; Try to figure out what FORM is and its various attributes. | |
100 | ;; Call proc NOTE! with key (a symbol) and value. | |
101 | ;; | |
102 | (define (annotate! form note!) | |
103 | (cond ((and (list? form) | |
104 | (< 2 (length form)) | |
105 | (eq? 'define (car form)) | |
106 | (pair? (cadr form)) | |
107 | (symbol? (caadr form))) | |
108 | (note! ':type 'procedure) | |
109 | (note! ':signature (cadr form)) | |
110 | (and (< 3 (length form)) | |
111 | (string? (caddr form)) | |
112 | (note! ':std-int-doc (caddr form)))) | |
113 | ((and (list? form) | |
114 | (< 2 (length form)) | |
115 | (eq? 'define (car form)) | |
116 | (symbol? (cadr form)) | |
117 | (list? (caddr form)) | |
118 | (< 3 (length (caddr form))) | |
119 | (eq? 'lambda (car (caddr form))) | |
120 | (string? (caddr (caddr form)))) | |
121 | (note! ':type 'procedure) | |
122 | (note! ':signature (cons (cadr form) (cadr (caddr form)))) | |
123 | (note! ':std-int-doc (caddr (caddr form)))) | |
124 | ((and (list? form) | |
125 | (= 3 (length form)) | |
126 | (eq? 'define (car form)) | |
127 | (symbol? (cadr form)) | |
128 | (symbol? (caddr form))) | |
129 | (note! ':type 'alias)) | |
130 | ((and (list? form) | |
131 | (eq? 'define-module (car form))) | |
132 | (note! ':type 'define-module)) | |
133 | ;; Add other types here. | |
134 | (else (note! ':type 'variable)))) | |
135 | ||
136 | ;; Process FILE, calling NB! on parsed top-level elements. | |
137 | ;; Recognized: #!-!# and regular comments in addition to normal forms. | |
138 | ;; | |
139 | (define (process file nb!) | |
140 | (nb! `'(filename ,file)) | |
141 | (let ((hash-bang-rx (make-regexp "^#!")) | |
142 | (bang-hash-rx (make-regexp "^!#")) | |
143 | (all-comment-rx (make-regexp "^[ \t]*(;+)")) | |
144 | (all-whitespace-rx (make-regexp "^[ \t]*$")) | |
145 | (p (open-input-file file))) | |
146 | (let loop ((n (1+ (port-line p))) (line (read-line p))) | |
147 | (or (not n) | |
148 | (eof-object? line) | |
149 | (begin | |
150 | (cond ((regexp-exec hash-bang-rx line) | |
151 | (let loop ((line (read-line p)) | |
152 | (text (list line))) | |
153 | (if (or (eof-object? line) | |
154 | (regexp-exec bang-hash-rx line)) | |
155 | (nb! `'(hash-bang-comment | |
156 | :line ,n | |
157 | :line-count ,(1+ (length text)) | |
158 | :text-list ,(reverse | |
159 | (cons line text)))) | |
160 | (loop (read-line p) | |
161 | (cons line text))))) | |
162 | ((regexp-exec all-whitespace-rx line) | |
163 | (nb! `'(whitespace :text ,line))) | |
164 | ((regexp-exec all-comment-rx line) | |
165 | => (lambda (m) | |
166 | (nb! `'(comment | |
e8cd769d TTN |
167 | :leading-semicolons |
168 | ,(let ((m1 (vector-ref m 1))) | |
169 | (- (cdr m1) (car m1))) | |
bff56cdf TTN |
170 | :text ,line)))) |
171 | (else | |
172 | (unread-string line p) | |
173 | (let* ((form (read p)) | |
174 | (count (- (port-line p) n)) | |
175 | (props (let* ((props '()) | |
176 | (prop+ (lambda args | |
177 | (set! props | |
178 | (append props args))))) | |
179 | (annotate! form prop+) | |
180 | props))) | |
181 | (or (= count 1) ; ugh | |
182 | (begin | |
183 | (read-line p) | |
184 | (set! count (1+ count)))) | |
185 | (nb! `'(following-form-properties | |
186 | :line ,n | |
187 | :line-count ,count | |
188 | ,@props)) | |
189 | (nb! form)))) | |
190 | (loop (1+ (port-line p)) (read-line p))))))) | |
191 | ||
6f2ec1d1 TTN |
192 | ;;; entry points |
193 | ||
bff56cdf TTN |
194 | (define (read-scheme-source-silently . files) |
195 | "See commentary in module (scripts read-scheme-source)." | |
196 | (let* ((res '())) | |
197 | (for-each (lambda (file) | |
198 | (process file (lambda (e) (set! res (cons e res))))) | |
199 | files) | |
200 | (reverse res))) | |
201 | ||
202 | (define (read-scheme-source . files) | |
203 | "See commentary in module (scripts read-scheme-source)." | |
204 | (for-each (lambda (file) | |
205 | (process file (lambda (e) (write e) (newline)))) | |
206 | files)) | |
207 | ||
6f2ec1d1 TTN |
208 | ;; Recognize: (quote (SYM :TAG1 VAL1 :TAG2 VAL2 ...)) |
209 | ;; and return alist: ((TAG1 . VAL1) (TAG2 . VAL2) ...) | |
210 | ;; where the tags are symbols. | |
211 | ;; | |
212 | (define (quoted? sym form) | |
213 | (and (list? form) | |
214 | (= 2 (length form)) | |
215 | (eq? 'quote (car form)) | |
216 | (let ((inside (cadr form))) | |
217 | (and (list? inside) | |
218 | (< 0 (length inside)) | |
219 | (eq? sym (car inside)) | |
220 | (let loop ((ls (cdr inside)) (alist '())) | |
221 | (if (null? ls) | |
222 | alist ; retval | |
223 | (let ((first (car ls))) | |
224 | (or (symbol? first) | |
225 | (error "bad list!")) | |
226 | (loop (cddr ls) | |
227 | (acons (string->symbol | |
228 | (substring (symbol->string first) 1)) | |
229 | (cadr ls) | |
230 | alist))))))))) | |
231 | ||
232 | ;; Filter FORMS, combining contiguous comment forms that have the same number | |
233 | ;; of leading semicolons. Do not include in them whitespace lines. | |
234 | ;; Whitespace lines outside of such comment groupings are ignored, as are | |
235 | ;; hash-bang comments. All other forms are passed through unchanged. | |
236 | ;; | |
237 | (define (clump forms) | |
238 | (let loop ((forms forms) (acc '()) (pass-this-one-through? #f)) | |
239 | (if (null? forms) | |
240 | (reverse acc) ; retval | |
241 | (let ((form (car forms))) | |
242 | (cond (pass-this-one-through? | |
243 | (loop (cdr forms) (cons form acc) #f)) | |
244 | ((quoted? 'following-form-properties form) | |
245 | (loop (cdr forms) (cons form acc) #t)) | |
246 | ((quoted? 'whitespace form) ;;; ignore | |
247 | (loop (cdr forms) acc #f)) | |
248 | ((quoted? 'hash-bang-comment form) ;;; ignore for now | |
249 | (loop (cdr forms) acc #f)) | |
250 | ((quoted? 'comment form) | |
251 | => (lambda (alist) | |
252 | (let cloop ((inner-forms (cdr forms)) | |
253 | (level (assq-ref alist 'leading-semicolons)) | |
254 | (text (list (assq-ref alist 'text)))) | |
255 | (let ((up (lambda () | |
256 | (loop inner-forms | |
257 | (cons (cons level (reverse text)) | |
258 | acc) | |
259 | #f)))) | |
260 | (if (null? inner-forms) | |
261 | (up) | |
262 | (let ((inner-form (car inner-forms))) | |
263 | (cond ((quoted? 'comment inner-form) | |
264 | => (lambda (inner-alist) | |
265 | (let ((new-level | |
266 | (assq-ref | |
267 | inner-alist | |
268 | 'leading-semicolons))) | |
269 | (if (= new-level level) | |
270 | (cloop (cdr inner-forms) | |
271 | level | |
272 | (cons (assq-ref | |
273 | inner-alist | |
274 | 'text) | |
275 | text)) | |
276 | (up))))) | |
277 | (else (up))))))))) | |
278 | (else (loop (cdr forms) (cons form acc) #f))))))) | |
279 | ||
280 | ;;; script entry point | |
281 | ||
bff56cdf TTN |
282 | (define main read-scheme-source) |
283 | ||
284 | ;;; read-scheme-source ends here |