diff options
author | cvs2svn <admin@example.com> | 2002-08-04 00:18:34 +0000 |
---|---|---|
committer | cvs2svn <admin@example.com> | 2002-08-04 00:18:34 +0000 |
commit | 2f4c89c4f475d3b2c718cbd4332c650214488ff9 (patch) | |
tree | 5abd57b1ace53b0c6970da9395f15d80d5f79430 /scripts/read-scheme-source | |
parent | c7743d027a335eae585335b959e483c5a6c38d36 (diff) | |
download | guile-after-hanwen-gc-change.tar.gz |
This commit was manufactured by cvs2svn to create tagafter-hanwen-gc-change
'after-hanwen-gc-change'.
Diffstat (limited to 'scripts/read-scheme-source')
-rwxr-xr-x | scripts/read-scheme-source | 284 |
1 files changed, 0 insertions, 284 deletions
diff --git a/scripts/read-scheme-source b/scripts/read-scheme-source deleted file mode 100755 index 31d851bd2..000000000 --- a/scripts/read-scheme-source +++ /dev/null @@ -1,284 +0,0 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts read-scheme-source)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# -;;; read-scheme-source --- Read a file, recognizing scheme forms and comments - -;; Copyright (C) 2001 Free Software Foundation, Inc. -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;; Boston, MA 02111-1307 USA - -;;; Author: Thien-Thi Nguyen - -;;; Commentary: - -;; Usage: read-scheme-source FILE1 FILE2 ... -;; -;; This program parses each FILE and writes to stdout sexps that describe the -;; top-level structures of the file: scheme forms, single-line comments, and -;; hash-bang comments. You can further process these (to associate comments -;; w/ scheme forms as a kind of documentation, for example). -;; -;; The output sexps have one of these forms: -;; -;; (quote (filename FILENAME)) -;; -;; (quote (comment :leading-semicolons N -;; :text LINE)) -;; -;; (quote (whitespace :text LINE)) -;; -;; (quote (hash-bang-comment :line LINUM -;; :line-count N -;; :text-list (LINE1 LINE2 ...))) -;; -;; (quote (following-form-properties :line LINUM -;; :line-count N) -;; :type TYPE -;; :signature SIGNATURE -;; :std-int-doc DOCSTRING)) -;; -;; SEXP -;; -;; The first four are straightforward (both FILENAME and LINE are strings sans -;; newline, while LINUM and N are integers). The last two always go together, -;; in that order. SEXP is scheme code processed only by `read' and then -;; `write'. -;; -;; The :type field may be omitted if the form is not recognized. Otherwise, -;; TYPE may be one of: procedure, alias, define-module, variable. -;; -;; The :signature field may be omitted if the form is not a procedure. -;; Otherwise, SIGNATURE is a list showing the procedure's signature. -;; -;; If the type is `procedure' and the form has a standard internal docstring -;; (first body form a string), that is extracted in full -- including any -;; embedded newlines -- and recorded by field :std-int-doc. -;; -;; -;; Usage from a program: The output list of sexps can be retrieved by scheme -;; programs w/o having to capture stdout, like so: -;; -;; (use-modules (scripts read-scheme-source)) -;; (define source-forms (read-scheme-source-silently "FILE1" "FILE2" ...)) -;; -;; There are also two convenience procs exported for use by Scheme programs: -;; -;; (clump FORMS) --- filter FORMS combining contiguous comment forms that -;; have the same number of leading semicolons. -;; -;; (quoted? SYM FORM) --- see if FORM looks like: "(quote (SYM ...))", parse -;; the ":tags", and return alist of (TAG . VAL) elems. -;; -;; TODO: Add option "--clump-comments", maybe w/ different clumping styles. -;; Make `annotate!' extensible. - -;;; Code: - -(define-module (scripts read-scheme-source) - :use-module (ice-9 rdelim) - :export (read-scheme-source - read-scheme-source-silently - quoted? - clump)) - -;; Try to figure out what FORM is and its various attributes. -;; Call proc NOTE! with key (a symbol) and value. -;; -(define (annotate! form note!) - (cond ((and (list? form) - (< 2 (length form)) - (eq? 'define (car form)) - (pair? (cadr form)) - (symbol? (caadr form))) - (note! ':type 'procedure) - (note! ':signature (cadr form)) - (and (< 3 (length form)) - (string? (caddr form)) - (note! ':std-int-doc (caddr form)))) - ((and (list? form) - (< 2 (length form)) - (eq? 'define (car form)) - (symbol? (cadr form)) - (list? (caddr form)) - (< 3 (length (caddr form))) - (eq? 'lambda (car (caddr form))) - (string? (caddr (caddr form)))) - (note! ':type 'procedure) - (note! ':signature (cons (cadr form) (cadr (caddr form)))) - (note! ':std-int-doc (caddr (caddr form)))) - ((and (list? form) - (= 3 (length form)) - (eq? 'define (car form)) - (symbol? (cadr form)) - (symbol? (caddr form))) - (note! ':type 'alias)) - ((and (list? form) - (eq? 'define-module (car form))) - (note! ':type 'define-module)) - ;; Add other types here. - (else (note! ':type 'variable)))) - -;; Process FILE, calling NB! on parsed top-level elements. -;; Recognized: #!-!# and regular comments in addition to normal forms. -;; -(define (process file nb!) - (nb! `'(filename ,file)) - (let ((hash-bang-rx (make-regexp "^#!")) - (bang-hash-rx (make-regexp "^!#")) - (all-comment-rx (make-regexp "^[ \t]*(;+)")) - (all-whitespace-rx (make-regexp "^[ \t]*$")) - (p (open-input-file file))) - (let loop ((n (1+ (port-line p))) (line (read-line p))) - (or (not n) - (eof-object? line) - (begin - (cond ((regexp-exec hash-bang-rx line) - (let loop ((line (read-line p)) - (text (list line))) - (if (or (eof-object? line) - (regexp-exec bang-hash-rx line)) - (nb! `'(hash-bang-comment - :line ,n - :line-count ,(1+ (length text)) - :text-list ,(reverse - (cons line text)))) - (loop (read-line p) - (cons line text))))) - ((regexp-exec all-whitespace-rx line) - (nb! `'(whitespace :text ,line))) - ((regexp-exec all-comment-rx line) - => (lambda (m) - (nb! `'(comment - :leading-semicolons - ,(let ((m1 (vector-ref m 1))) - (- (cdr m1) (car m1))) - :text ,line)))) - (else - (unread-string line p) - (let* ((form (read p)) - (count (- (port-line p) n)) - (props (let* ((props '()) - (prop+ (lambda args - (set! props - (append props args))))) - (annotate! form prop+) - props))) - (or (= count 1) ; ugh - (begin - (read-line p) - (set! count (1+ count)))) - (nb! `'(following-form-properties - :line ,n - :line-count ,count - ,@props)) - (nb! form)))) - (loop (1+ (port-line p)) (read-line p))))))) - -;;; entry points - -(define (read-scheme-source-silently . files) - "See commentary in module (scripts read-scheme-source)." - (let* ((res '())) - (for-each (lambda (file) - (process file (lambda (e) (set! res (cons e res))))) - files) - (reverse res))) - -(define (read-scheme-source . files) - "See commentary in module (scripts read-scheme-source)." - (for-each (lambda (file) - (process file (lambda (e) (write e) (newline)))) - files)) - -;; Recognize: (quote (SYM :TAG1 VAL1 :TAG2 VAL2 ...)) -;; and return alist: ((TAG1 . VAL1) (TAG2 . VAL2) ...) -;; where the tags are symbols. -;; -(define (quoted? sym form) - (and (list? form) - (= 2 (length form)) - (eq? 'quote (car form)) - (let ((inside (cadr form))) - (and (list? inside) - (< 0 (length inside)) - (eq? sym (car inside)) - (let loop ((ls (cdr inside)) (alist '())) - (if (null? ls) - alist ; retval - (let ((first (car ls))) - (or (symbol? first) - (error "bad list!")) - (loop (cddr ls) - (acons (string->symbol - (substring (symbol->string first) 1)) - (cadr ls) - alist))))))))) - -;; Filter FORMS, combining contiguous comment forms that have the same number -;; of leading semicolons. Do not include in them whitespace lines. -;; Whitespace lines outside of such comment groupings are ignored, as are -;; hash-bang comments. All other forms are passed through unchanged. -;; -(define (clump forms) - (let loop ((forms forms) (acc '()) (pass-this-one-through? #f)) - (if (null? forms) - (reverse acc) ; retval - (let ((form (car forms))) - (cond (pass-this-one-through? - (loop (cdr forms) (cons form acc) #f)) - ((quoted? 'following-form-properties form) - (loop (cdr forms) (cons form acc) #t)) - ((quoted? 'whitespace form) ;;; ignore - (loop (cdr forms) acc #f)) - ((quoted? 'hash-bang-comment form) ;;; ignore for now - (loop (cdr forms) acc #f)) - ((quoted? 'comment form) - => (lambda (alist) - (let cloop ((inner-forms (cdr forms)) - (level (assq-ref alist 'leading-semicolons)) - (text (list (assq-ref alist 'text)))) - (let ((up (lambda () - (loop inner-forms - (cons (cons level (reverse text)) - acc) - #f)))) - (if (null? inner-forms) - (up) - (let ((inner-form (car inner-forms))) - (cond ((quoted? 'comment inner-form) - => (lambda (inner-alist) - (let ((new-level - (assq-ref - inner-alist - 'leading-semicolons))) - (if (= new-level level) - (cloop (cdr inner-forms) - level - (cons (assq-ref - inner-alist - 'text) - text)) - (up))))) - (else (up))))))))) - (else (loop (cdr forms) (cons form acc) #f))))))) - -;;; script entry point - -(define main read-scheme-source) - -;;; read-scheme-source ends here |