This is the mail archive of the guile@cygnus.com mailing list for the guile project.
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
Some benchmarking notes/results using extract.scm (appended below).
1. I moved almost all defines to the top level because I discovered
that they were being evaled for each fcn invocation.
2. Timing readline on all the C code in scwm gives ~1.8 seconds to read all the code:
guile> (define (test-read r p) (if (eof-object? (r p)) #t (test-read r p)))
guile> (define (test-read-f r f) (call-with-input-file f (lambda (p) (test-read r p))))
guile> (with-profiling (test-read-f) (for-each (lambda (f) (test-read-f read-line f)) testfilelist))
Function Called Time
------------------- ---------- ---------
test-read-f 45.0 1.770
3. Using %read-line instead shaves off about .7 seconds:
guile> (define (mrl p) (car (%read-line p)))
guile> (with-profiling (test-read-f) (for-each (lambda (f) (test-read-f mrl f)) testfilelist))
Function Called Time
------------------- ---------- ---------
test-read-f 45.0 1.060
4. gawk does it in .2 seconds:
hjstein@bacall:~/remote-cvs-pkgs/scwm/scwm$ time awk 'END {print NR}' *.c
26032
0.16user 0.05system 0:00.21elapsed 99%CPU (0avgtext+0avgdata 0maxresident)k
0inputs+0outputs (304major+243minor)pagefaults 0swaps
5. Perl takes .3 seconds:
hjstein@bacall:~/remote-cvs-pkgs/scwm/scwm$ time perl -e 'while (<>) { } ; print "$.\n";' *.c
26032
0.27user 0.02system 0:00.29elapsed 97%CPU (0avgtext+0avgdata 0maxresident)k
0inputs+0outputs (170major+63minor)pagefaults 0swaps
Thus, although %read-line would need to be ~7x faster to catch awk,
or ~3x faster to catch perl, it's still not horrible.
6. The extraction portion of extract.scm seems to be spending a large
chunk of it's time in regexp-exec. I'm effectively calling 2
regexps on each line - 1 to see if it's a SCWM_PROC & the 2nd when
the 1st fails (which is usually) to see if it's an embedded
document item. The calls to regexp-exec seem to be taking the bulk
of the processing time:
guile> (with-profiling (extract-docs-from-port) (define d (apply extract-docs-from-files testfilelist)))
Function Called Time
------------------- ---------- ---------
extract-docs-from-port 45.0 9.130
guile> (with-profiling (extract-docs-from-port regexp-exec) (define d (apply extract-docs-from-files testfilelist)))
Function Called Time
------------------- ---------- ---------
regexp-exec 51506.0 9.430
extract-docs-from-port 45.0 16.450
There's about 1 second of profiling overhead/10,000 calls in the
parent, & about .5 seconds/10,000 calls in the routine itself, so
about 6 second out of 9 are spent in regexp-exec.
7. Doing similar work with awk yields:
hjstein@bacall:~/remote-cvs-pkgs/scwm/scwm$ time awk '/^[ \t]*SCWM_PROC[ \t]*\(/ {print $0} /^[ \t]*SCWM_PROC[ \t]*\(/ {print $0}' *.c >/dev/null
0.65user 0.06system 0:00.70elapsed 100%CPU (0avgtext+0avgdata
0maxresident)k
0inputs+0outputs (309major+451minor)pagefaults 0swaps
According to this, guile regexps are >15x slower than awk's. Of
course, the scheme version is doing much more work, so:
8. Doing the same as the above awk gives:
guile> (define (for-each-line f p) (let loop ((l (car (%read-line p)))) (if (eof-object? l) #t (begin (f l) (loop (car (%read-line p)))))))
guile> (define (for-each-line-f f file) (call-with-input-file file (lambda (p) (for-each-line f p))))
guile> (with-profiling (for-each-line-f) (for-each (lambda (f) (for-each-line-f (lambda (l) (regexp-exec proc-start-match l)) f)) testfilelist))
Function Called Time
------------------- ---------- ---------
for-each-line-f 45.0 3.980
guile> (with-profiling (for-each-line-f) (for-each (lambda (f) (for-each-line-f (lambda (l) (regexp-exec proc-start-match l) (regexp-exec doc-start-match l)) f)) testfilelist))
Function Called Time
------------------- ---------- ---------
for-each-line-f 45.0 6.910
So, of the 9 seconds it's taking extract.scm to read & parse the
input files, about 7 seconds is devoted to reading each line (~1
second) and applying two regular expressions. This makes guile
about 10x slower than awk.
Putting the regexps together gives a decent improvement:
guile> (with-profiling (for-each-line-f) (for-each (lambda (f) (for-each-line-f (lambda (l) (regexp-exec proc-or-doc-start l)) f)) testfilelist))
Function Called Time
------------------- ---------- ---------
for-each-line-f 45.0 4.560
Can this be improved? Please?
Here's extract.scm:
#!/bin/sh
exec guile -l $0 -- --run-from-shell "$@"
!#
;;; extract.scm
;;; Copyright (C) 1998, Harvey J. Stein, hjstein@bfr.co.il
;;; 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.GPL. If not, write to
;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;; Boston, MA 02111-1307 USA
;;; Extracts doc strings from C code which follows scwm conventions:
;;; 1. Procs to document have declarations OTF:
;;; SCWM_PROC(c_name,
;;; "scheme_name",
;;; number_of_args,
;;; another_number,
;;; another_number,
;;; (SCM arg1, SCM arg2, ...))
;;; 2. The documentation for said proc starts on the line following it's
;;; definition, starting with /** & ending with */.
;;; 3. Additional documentation starts with /** spaces identifier: & ends with */, but is not
;;; preceeded by a SCWM_PROC.
;;; Usage:
;;; Parsing:
;;; (extract-docs-from-files f1.c f2.c ...)
;;; Returns a list of doc records extracted documentation from the listed
;;; files. Each record is either (DOC doclist-record filename linenumber)
;;; or (SCWM_PROC procdoc-record filename linenumber).
;;; A procdoc-record is a list otf:
;;; (proc-record doclist-record)
;;; A proc-record is a list otf:
;;; (c_name "scheme_name" number_of_args another_number another_number ((SCM arg1) (SCM arg2) ...))
;;; A doclist-record is a list of strings otf:
;;; (line1 line2 line3 ...)
;;;
;;; Checking docs are well formed:
;;; (check-docs doclist)
;;; Verifies stuff such as number of args = args
;;; in argslist, all args are SCM types, each arg is mentioned in
;;; the documentation, etc.
;;;
;;; Generating procedures-list documentation:
;;; (docs->proclist doclist)
;;; Output procedures-list stuff
;;;
;;; Generating sgml output:
;;; (docs->sgml doclist)
;;; Does various passes on the extract-docs-from-files output to
;;; generate the sgml output.
;;;
;;; Note:
;;; 1. Miscellaneous breaking of abstraction layers needs to be fixed
;;; - need make-proc-record, make-doc-record, ... & need to remove
;;; usage of car/list-ref/cdr/... on these things (if I'm doing this).
;;; 2. Too much hacking has lead to a need for some code cleanup.
;;; 3. Still can't load slib stuff without stupid hacks that should
;;; have been dealt with when guile installed.
;;;(debug-enable 'backtrace)
;;; Turn off debugging if run from the command line.
(or (null? (command-line))
(null? (cdr (command-line)))
(debug-disable 'debug))
(if (not (member "/usr/lib" %load-path))
(set! %load-path (cons "/usr/lib" %load-path))) ; HACK for guile to find slib!!!!!!!
(use-modules (ice-9 regex) ; For regexp-quote & substitute.
(ice-9 slib)) ; For sort.
(require 'sort)
(define proc-start-match-string "[ \t]*SCWM_PROC[ \t]*\\(")
(define proc-start-match
(make-regexp (string-append "^" proc-start-match-string)))
(define doc-start-match-string "[ \t]*/\\*\\*[ \t]*([^ \t:*]*:.*)") ; spaces /**[^space or *]
(define doc-start-match
(make-regexp (string-append "^" doc-start-match-string)))
(define proc-or-doc-start
(make-regexp (string-append "^(" proc-start-match-string "|" doc-start-match-string ")")))
(define post-proc-doc-start-match
(make-regexp "^[ \t]*/\\*\\*[ \t]+(.*)")) ; spaces /** space+
(define func-name-match
(make-regexp "^[ \t]*#[ \t]*define[ \t]+FUNC_NAME[ \t]+([^ \t]*)[ \t]*$"))
(define doc-end-match
(make-regexp "[ \t]*\\*/[ \t]*")) ; Strip off spaces */ spaces
(define sentence (make-regexp "\\."))
(define to-regexp (make-regexp "_to_"))
(define whitespace-line (make-regexp "^[ \t]*$"))
(define split (make-regexp "^([^.]*\\.)[ \t]*(.*)$"))
(define blank (make-regexp "^[ \t]*$"))
(define doc-parser-regexp (make-regexp "^[ \t]*([^ \t:]*):[ \t]*(.*[^ \t])[ \t]*$"))
(define parse-proc-regexp (make-regexp "^[ \t]*SCWM_PROC[ \t]*\\([ \t]*([^, \t]*)[ \t]*,[ \t]*\"([^, \t]*)\"[ \t]*,[ \t]*([^, \t]*)[ \t]*,[ \t]*([^, \t]*)[ \t]*,[ \t]*([^, \t]*)[ \t]*,[ \t]*(\\([^)]*\\)[ \t]*)\\)[ \t]*$"))
(define proc-regexp (make-regexp "`([^'` \t]*)'"))
(define tf-regexp (make-regexp "(#[tf])"))
(define (proc:c-name procrec)
(list-ref procrec 0))
(define (proc:scheme-name procrec)
(list-ref procrec 1))
(define (proc:required-args procrec)
(list-ref procrec 2))
(define (proc:optional-args procrec)
(list-ref procrec 3))
(define (proc:extra-var-args procrec)
(list-ref procrec 4))
(define (proc:args procrec)
(list-ref procrec 5))
(define (procdoc:decl procdocrec)
(list-ref procdocrec 0))
(define (procdoc:doc procdocrec)
(list-ref procdocrec 1))
(define (procdoc:funcname procdocrec)
(list-ref procdocrec 2))
(define (docitem:type rec)
(list-ref rec 0))
(define (docitem:data rec)
(list-ref rec 1))
(define (docitem:file rec)
(list-ref rec 2))
(define (vdocitem:decl rec)
(procdoc:decl (docitem:data rec)))
(define (vdocitem:scheme-name rec)
(proc:scheme-name (vdocitem:decl rec)))
(define (vdocitem:c-name rec)
(proc:c-name (vdocitem:decl rec)))
(define (vdocitem:args rec)
(proc:args (vdocitem:decl rec)))
(define (docitem:line rec)
(list-ref rec 3))
(define (doc:chapter rec)
(list-ref rec 0))
(define (doc:section rec)
(list-ref rec 1))
(define (doc:doc rec)
(list-ref rec 2))
(define (counting-read-line p)
(set-port-line! p (1+ (port-line p)))
(car (%read-line p)))
;;; Output procedures-list document.
(define (docs->proclist l)
(for-each proc->list
(sort (select-type 'SCWM_PROC l)
scheme-name-ci<?)))
(define (scheme-name-ci<? x y)
(string-ci<? (proc:scheme-name (procdoc:decl (docitem:data x)))
(proc:scheme-name (procdoc:decl (docitem:data y)))))
(define (scheme-name<? x y)
(string<? (proc:scheme-name (procdoc:decl (docitem:data x)))
(proc:scheme-name (procdoc:decl (docitem:data y)))))
(define (select-type type docitemlist)
(let loop ((l docitemlist)
(r '()))
(cond ((null? l) (reverse r))
((eq? (docitem:type (car l)) type)
(loop (cdr l) (cons (car l) r)))
(else (loop (cdr l) r)))))
(define (displayl . args)
(for-each display args))
(define (complain file line . complaints)
(apply displayl file ":" line ": " complaints)
(display ".\n"))
(define (check-docs docitemlist)
;; Do the per-item checks.
(for-each check-docitem docitemlist)
;; Now the global checks.
;; Check for >=2 identical scheme names.
(let loop ((spl (group (sort (select-type 'SCWM_PROC docitemlist)
scheme-name<?)
(lambda (x y)
(string=?
(vdocitem:scheme-name x)
(vdocitem:scheme-name y))))))
(for-each
(lambda (g)
(if (null? g)
(complain "" "" "Internal error - null group")
(for-each (lambda (r)
(complain (docitem:file r)
(docitem:line r)
"Scheme name " (vdocitem:scheme-name r) " redefined."
" First defined in " (docitem:file (car g)) " on line "
(docitem:line (car g))))
(cdr g))))
spl))
;; Don't need to check for >=2 identical proc names - compiler will catch it.
)
;;; Complains about docitem recs it doesn't like
(define (check-docitem procdocrec)
(let* ((data (docitem:data procdocrec))
(file (docitem:file procdocrec))
(line (docitem:line procdocrec)))
(case (docitem:type procdocrec)
((DOC)
;; Check that DOC has a nonempty chapter name.
(if (not (doc:chapter data))
(complain file line
"Untagged embedded documentation"))
;; Check that DOC has a nonempty section name.
(if (string=? "" (doc:section data))
(complain file line
"Empty section heading"))
;; Check that DOC doc has nonempty documentation.
(if (null? (doc:doc data))
(complain file line
"Empty documentation")))
;; Check that DOC doc identifier is HOOK or CONCEPT?
((SCWM_PROC)
(let ((procrec (procdoc:decl data))
(docrec (procdoc:doc data))
(funcname (procdoc:funcname data)))
;; What's this business about the 1st doc line being a "purpose" sentence?
;; What's this business about "leading spaces" being omitted?
;; Check c-name vs scheme-name.
(if (and (not (string=? (c-ident->scheme-ident (symbol->string (proc:c-name procrec)))
(proc:scheme-name procrec)))
(not (string=? (c-name->scheme-name (symbol->string (proc:c-name procrec)))
(proc:scheme-name procrec))))
(complain file line
"Scheme name of " (proc:scheme-name procrec) " doesn't match a C name of "
(proc:c-name procrec)))
;; Check that 1st doc sentence is a complete sentence (contains a ".")
(if (and (not (null? docrec))
(not (regexp-exec sentence (car docrec))))
(complain file line
"First documentation line is not a complete sentence"))
;; Check that arg 2+3+4 = length of arg5
(if (not (= (+ (proc:required-args procrec)
(proc:optional-args procrec)
(proc:extra-var-args procrec))
(length (proc:args procrec))))
(complain file line
"Argument count mismatch in "
(proc:scheme-name procrec)))
;; Warn about var param != 0 or 1.
(if (and (not (= (proc:extra-var-args procrec) 0))
(not (= (proc:extra-var-args procrec) 1)))
(complain file line
"Var count is (proc:extra-var-args procrec), but should be 0 or 1"))
;; Check that all args are of type SCM
(let loop ((i 1)
(args (proc:args procrec)))
(cond ((null? args))
((eq? (caar args) 'SCM)
(loop (1+ i) (cdr args)))
(else
(complain file line
"In the declaration for "
(proc:scheme-name procrec)
", argument " i " (" (cadar args) ") is not of type SCM"))))
;; Check that the proc is documented:
(if (null? docrec)
(complain file line
"Procedure " (proc:scheme-name procrec) " is not documented"))
;; Check that each arg appears in upper case in description.
(let next-arg ((argregexp (map (lambda (arg)
(delimited-regexp
(string-upcase! (c-name->scheme-name (symbol->string (cadr arg))))))
(proc:args procrec)))
(args (map cadr (proc:args procrec)))
(i 1))
(cond ((null? args))
(else
(let next-docline ((doc docrec))
(cond ((null? doc)
(complain file line
"Argument " i " (" (car args) ") of "
(proc:scheme-name procrec)
" is undocumented"))
((regexp-exec (car argregexp) (car doc)))
(else (next-docline (cdr doc)))))
(next-arg (cdr argregexp) (cdr args) (+ i 1)))))
;; Check for upper case words that don't match args.
(let ((args (map (lambda (arg) (string-upcase! (c-name->scheme-name (symbol->string (cadr arg)))))
(proc:args procrec))))
(for-each (lambda (word)
(if (and (upper-case? word)
(> (string-length word) 1)
(char-upper-case? (string-ref word 0))
(not (member word args)))
(complain file line "Documentation for procedure " (proc:scheme-name procrec)
" contains upper case word " word " which isn't an argument")))
(apply append (map (lambda (d) (extract-words d kw-delim?)) docrec))))
;; Check that there's a func_name & it matches the c-name
(if funcname
(if (not (string=? (string-append "s_" (symbol->string (proc:c-name procrec)))
funcname))
(complain file line
"Procedure " (proc:scheme-name procrec) " doesn't have a matching FUNC_NAME"))
(complain file line
"Procedure " (proc:scheme-name procrec) " doesn't have a FUNC_NAME"))))
(else (complain file line "Internal error - unrecognized doc record type.")))))
(define (upper-case? s)
(let loop ((i 0)
(l (string-length s)))
(cond ((>= i l) #t)
((and (not (char-upper-case? (string-ref s i)))
(char-lower-case? (string-ref s i)))
#f)
(else (loop (1+ i) l)))))
(define (all-special? s)
(let loop ((i 0)
(l (string-length s)))
(cond ((>= i l) #t)
((and (not (char-upper-case? (string-ref s i)))
(not (char-lower-case? (string-ref s i))))
(loop (1+ i) l))
(else #f))))
(define (extract-words s delimiter?)
(define (skip i l result)
(cond ((>= i l) result)
((delimiter? (string-ref s i))
(skip (1+ i) l result))
(else (grab i (1+ i) l result))))
(define (grab start end l result)
(cond ((>= end l) (cons (substring s start end) result))
((delimiter? (string-ref s end))
(skip (1+ end) l (cons (substring s start end) result)))
(else (grab start (1+ end) l result))))
(skip 0 (string-length s) '()))
(define (word-delimiter? c)
(case c
((#\: #\space #\tab #\+ #\= #\\ #\| #\{ #\} #\[ #\] #\' #\` #\" #\: #\; #\. #\/ #\< #\> #\@ #\# #\% #\^ #\& #\* #\( #\) #\,) #t)
(else #f)))
(define (kw-delim? c)
(case c
((#\: #\space #\tab #\+ #\= #\\ #\| #\{ #\} #\[ #\] #\' #\` #\: #\; #\. #\/ #\< #\> #\@ #\# #\% #\^ #\& #\* #\( #\) #\,) #t)
(else #f)))
(define (to->-> s)
(let ((match (regexp-exec to-regexp s)))
(if match
(regexp-substitute #f match 'pre "->" 'post)
s)))
(define (c-ident->scheme-ident s)
(c-name->scheme-name (to->-> s)))
(define (c-name->scheme-name s)
(let* ((normname (map (lambda (c)
(if (char=? c #\_) #\- c))
(string->list s)))
(revname (reverse normname)))
(cond ((or (null? revname)
(null? (cdr revname)))
(list->string normname))
((and (char=? (car revname) #\p)
(char=? (cadr revname) #\-))
(list->string (reverse (cons #\? (cddr revname)))))
((and (char=? (car revname) #\x)
(char=? (cadr revname) #\-))
(list->string (reverse (cons #\! (cddr revname)))))
(else
(list->string normname)))))
(define (delimited-case-insensitive-regexp s)
(let ((ci-name (regexp-quote s)))
(make-regexp
(string-append "[ \t'`.,:\"]" ci-name "[ \t'`.,:\"]|"
"^" ci-name "[ \t'`.,:\"]|"
"[ \t'`.,:\"]" ci-name "$|"
"^" ci-name "$")
regexp/icase)))
(define (delimited-regexp s)
(unsafe-delimited-regexp (regexp-quote s)))
(define (unsafe-delimited-regexp ci-name)
(make-regexp
(string-append "[ \t'`.,:\"]" ci-name "[ \t'`.,:\"]|"
"^" ci-name "[ \t'`.,:\"]|"
"[ \t'`.,:\"]" ci-name "$|"
"^" ci-name "$")))
;;; ispell crap
(define (ispell-start)
(system "rm /tmp/ispell-input 2>/dev/null")
(system "mkfifo /tmp/ispell-input 2>/dev/null")
(let ((ispell-out (open-input-pipe "ispell -a </tmp/ispell-input"))
(ispell-in (open-output-file "/tmp/ispell-input")))
(read-line ispell-out)
(cons ispell-in ispell-out)))
(define (ispell-ignore words ports)
(for-each (lambda (word)
(display "@" (car ports))
(display word (car ports))
(newline (car ports)))
words))
(define (ispell-send line ports)
(display (ispell-escape line) (car ports))
(newline (car ports))
(flush-all-ports)
(let loop ((resp (read-line (cdr ports))))
(flush-all-ports)
(cond ((string=? resp "") '())
(else (cons resp (loop (read-line (cdr ports))))))))
(define *scwm-ok-words*
'(scwm fvwm hilight viewport scwmexec scwmrepl menuitem
menuitems hotkey submenu colormap
pseudocolor staticgray staticcolor grayscale directcolor truecolor
scwmrc reallysmart smartplacement pposition mwm mwm alt meta hyper
broadcastinfo smartplacementisreallysmart randomplacement
super car cdr cadr titlebar unhover bg fg popup iconify
iconifying deiconify deiconifying unmap iconified desktop desktops
honoured lenience xproperty xored
shift control meta alt hyper super callbacks decors viewports))
(define (ispell-report io)
(cond ((null? io) '())
(else (case (string-ref (car io) 0)
((#\* #\+ #\-) (ispell-report (cdr io)))
((#\&) (cons (cons "Misspelling : "
(ispell-find-word (car io)))
(ispell-report (cdr io))))
((#\? #\#) (cons (cons "Unrecognized word : "
(ispell-find-word (car io)))
(ispell-report (cdr io))))
(else (cons (cons "Unrecognized ispell msg for : "
(ispell-find-word (car io)))
(ispell-report (cdr io))))))))
(define (ispell-find-word s)
(list->string (let loop ((s (cddr (string->list s))))
(cond ((null? s) '())
((char=? (car s) #\space)
'())
(else (cons (car s) (loop (cdr s))))))))
(define (ispell-stop ports)
(close-port (car ports))
(close-pipe (cdr ports))
(system "rm /tmp/ispell-input 2>/dev/null"))
(define (ispell-docs docs)
(let ((p '()))
(dynamic-wind
(lambda ()
(set! p (ispell-start))
(ispell-ignore *scwm-ok-words* p))
(lambda () (for-each (lambda (rec)
(ispell-complain rec p))
docs))
(lambda () (ispell-stop p)))))
(define (ispell-complain rec p)
(for-each (lambda (complaint)
(complain (docitem:file rec) (docitem:line rec)
(car complaint) (cdr complaint)))
(apply append (map (lambda (line)
(ispell-report (ispell-send line p)))
(docitem->plaintextlist rec)))))
(define (ispell-escape s)
(string-append "^" s))
;;; Outputs procdocrec in format suitable for a procedures-list document.
(define (proc->list procdocrec)
(if (eq? 'SCWM_PROC (docitem:type procdocrec))
(let ((procrec (procdoc:decl (docitem:data procdocrec)))
(docrec (procdoc:doc (docitem:data procdocrec))))
(display (function-call-decl procrec))
(newline)
(for-each (lambda (docline) (display docline) (newline))
docrec)
(displayl "[From " (docitem:file procdocrec) ":"
(docitem:line procdocrec) "]\n\n\f\n"))))
(define (function-call-decl procrec)
(apply string-append "("
(proc:scheme-name procrec)
(let loop ((args (map (lambda (a)
(c-name->scheme-name
(symbol->string (cadr a))))
(proc:args procrec)))
(req (proc:required-args procrec))
(opt (proc:optional-args procrec))
(rest (proc:extra-var-args procrec)))
(cond ((null? args)
'(")"))
((> req 0)
(cons " " (cons (car args)
(loop (cdr args) (- req 1) opt rest))))
((and (= req 0)
(> opt 0))
(cons " #&optional" (loop args (- req 1) opt rest)))
((and (< req 0)
(> opt 0))
(cons " " (cons (car args)
(loop (cdr args) req (- opt 1) rest))))
;; Now know req <= 0 & opt <= 0.
((> rest 0)
(cons " . " (cons (car args)
(loop (cdr args) req opt 0))))
(else
(cons " " (cons (car args)
(loop (cdr args) -1 0 0))))))))
;;; Output doc record in format suitable for ispell:
(define (docitem->plaintext procdocrec)
(let* ((file (docitem:file procdocrec))
(line (docitem:line procdocrec)))
(for-each (lambda (d) (complain file line d))
(docitem->plaintextlist procdocrec))))
(define (docitem->plaintextlist procdocrec)
(case (docitem:type procdocrec)
((SCWM_PROC) (procdoc:doc (docitem:data procdocrec)))
((DOC) (doc:doc (docitem:data procdocrec)))
(else (complain (docitem:file procdocrec) (docitem:line procdocrec)
"Internal error - unrecognized doc record type of " (docitem:type procdocrec))
'())))
(define (docs->text docs)
(for-each (lambda (rec) (for-each (lambda (d) (displayl d "\n"))
(docitem->plaintextlist rec)))
docs))
(define (docs->annotated-text docs)
(for-each docitem->plaintext
docs))
;;; Extract docs from specified files. Return list of procdoc
;;; records.
(define (extract-docs-from-files . files)
(let loop ((defs '())
(files files))
(cond ((null? files) (reverse defs))
(else (loop (call-with-input-file (car files)
(lambda (p) (extract-docs-from-port p defs)))
(cdr files))))))
;;; Extract docs from specified input port.
(define (extract-docs-from-port p . start)
(let ((filename (port-filename p)))
(let loop ((line (counting-read-line p))
(defs (if (null? start) '() (car start))))
(if (eof-object? line)
defs
(let* ((pd (regexp-exec proc-or-doc-start line))
(proc (if (and pd (match:start pd 2)) #f pd))
(docstart (if (and pd (match:start pd 2)) pd #f))
(linenum (port-line p)))
(cond (proc
(let ((doc (extract-proc-n-doc line p)))
(cond (doc
(loop (counting-read-line p)
(cons (list 'SCWM_PROC
doc
filename
linenum)
defs)))
(else
(complain filename linenum "SCWM_PROC not parsable")
(loop (counting-read-line p)
defs)))))
(docstart
(let ((doc (parse-doc (extract-doc p line))))
(loop (counting-read-line p)
(cons (list 'DOC
doc
filename
linenum)
defs))))
(else
(loop (counting-read-line p) defs))))))))
(define (next-non-whitespace-line p)
(let ((line (counting-read-line p)))
(cond ((eof-object? line)
line)
((regexp-exec whitespace-line line)
(next-non-whitespace-line p))
(else line))))
(define (extract-proc-n-doc line p)
(let* ((proc (parse-proc (match-parentheses line p)))
(next (counting-read-line p)))
(cond ((not proc) ; Proc not parsable
#f)
((eof-object? next) ; No doc & no func
(list proc '() #f))
((regexp-exec post-proc-doc-start-match next) ; Doc is first.
(let* ((doc (parse-proc-doc (extract-doc p next post-proc-doc-start-match)))
(next (next-non-whitespace-line p))
(match (if next (regexp-exec func-name-match next) #f)))
(if match
(list proc doc (substring (vector-ref match 0)
(car (vector-ref match 2))
(cdr (vector-ref match 2))))
(list proc doc #f))))
(else
(let* ((match (regexp-exec func-name-match next)) ; Func name must be next.
(next (next-non-whitespace-line p))
(doc (extract-doc p next post-proc-doc-start-match))) ; Then the docs.
(if match
(list proc doc (substring (vector-ref match 0)
(car (vector-ref match 2))
(cdr (vector-ref match 2))))
(list proc doc #f)))))))
(define (parse-proc-doc doc)
(cond ((null? doc) '())
(else (let ((m (regexp-exec split (car doc))))
(if m
(let ((s (match:substring m 1))
(e (match:substring m 2)))
(if (regexp-exec blank e)
doc
(cons s (cons e (cdr doc)))))
(let ((r (parse-proc-doc (cdr doc))))
(if (null? r)
doc
(cons (string-append (car doc) " " (car r))
(cdr r)))))))))
(define (doclist lines)
(reverse lines))
(define (extract-doc p . xargs)
(define (extract-to-end lines)
(if (eof-object? (car lines))
(doclist lines)
(let ((end (regexp-exec doc-end-match (car lines))))
(if end
(doclist (cons (substring (car lines) 0 (car (vector-ref end 1)))
(cdr lines)))
(extract-to-end (cons (counting-read-line p) lines))))))
(let ((line (if (null? xargs)
(counting-read-line p)
(car xargs)))
(doc-start-match (if (or (null? xargs)
(null? (cdr xargs)))
doc-start-match
(cadr xargs))))
(if (eof-object? line)
'()
(let ((start (regexp-exec doc-start-match line)))
(if start
(extract-to-end (list (substring line (car (vector-ref start 2)) (cdr (vector-ref start 2)))))
'())))))
;;; FIXME!!! This is dumb, but it probably works well enough.
(define (match-parentheses line p)
(dumb-match-parentheses line p))
(define (dumb-match-parentheses line p)
(let loop ((umc (unmatched-p-count line))
(lines (list line)))
(if (> umc 0)
(let ((line (counting-read-line p)))
(if (eof-object? line)
(apply string-append (reverse lines))
(loop (+ umc (unmatched-p-count line))
(cons line lines))))
(apply string-append (reverse lines)))))
(define (unmatched-p-count l)
(do ((c 0)
(ln (string-length l))
(i 0 (1+ i))
(keep #t))
((>= i ln) c)
(case (string-ref l i)
((#\() (if keep (set! c (1+ c))))
((#\)) (if keep (set! c (1- c))))
((#\") (set! keep (not keep))))))
(define (capitalize! s)
(do ((i 1 (1+ i))
(l (string-length s)))
((>= i l)
(if (>= l 1)
(string-set! s 0 (char-upcase (string-ref s 0))))
s)
(string-set! s i (char-downcase (string-ref s i)))))
(define (parse-doc doclist)
(cond ((null? doclist) '(#f '()))
(else (let ((match (regexp-exec doc-parser-regexp (car doclist))))
(list (capitalize! (string-copy (match:substring match 1)))
(match:substring match 2)
(cdr doclist))))))
(define (parse-proc defstring)
(let ((match (regexp-exec parse-proc-regexp defstring)))
(if match
(let ((args (list->vector (cdr (split-match match)))))
(list (string->symbol (vector-ref args 0))
(vector-ref args 1)
(string->number (vector-ref args 2))
(string->number (vector-ref args 3))
(string->number (vector-ref args 4))
(let ((args (with-input-from-string (string-append "(" (replace-occurrences (vector-ref args 5) #\, ")(") ")")
read)))
(if (equal? args '(()))
'()
args))))
#f)))
(define (my-repl start end char srepl)
(cond ((null? end) (list->string (reverse start)))
((char=? (car end) char)
(my-repl (append srepl start) (cdr end) char srepl))
(else
(my-repl (cons (car end) start) (cdr end) char srepl))))
(define (replace-occurrences string char repl)
(my-repl '() (string->list string) char (reverse (string->list repl))))
(define (split-match match)
(map (lambda (startnend)
(substring (vector-ref match 0)
(car startnend)
(cdr startnend)))
(cdr (vector->list match))))
(define (stringify value)
(with-output-to-string
(lambda () (write value))))
(define (regexp-orlist l)
(cond ((null? l) "")
((null? (cdr l)) (car l))
(else (string-append (car l) "|" (regexp-orlist (cdr l))))))
(define (arglist->argregexpstring l)
(let ((r (string-append "("
(regexp-orlist
(map (lambda (argspec)
(regexp-quote (string-upcase!
(c-name->scheme-name (cadr argspec)))))
l))
")")))
(string-append "([ \t'`.,:\"])" r "([ \t'`.,:\"])|"
"(^)" r "([ \t'`.,:\"])|"
"([ \t'`.,:\"])" r "($)|"
"(^)" r "($)")))
(define (arglist->argregexp l)
(make-regexp (arglist->argregexpstring l)))
(define (proc->primitives-ssgml docitem)
(let* ((data (docitem:data docitem))
(proc (procdoc:decl data))
(doc (procdoc:doc data))
(arglist (proc:args proc))
(argregexp (arglist->argregexp arglist)))
`((refentry (id ,(sgml-escape-xref (proc:scheme-name proc))))
((refnamediv)
((refname) ,(proc:scheme-name proc))
((refpurpose) ,(if (null? arglist) (car doc)
(markup-args argregexp (car doc)))))
((refsynopsisdiv)
((synopsis) ,(function-call-decl proc)))
((refsect1)
((title) "Description")
((para) ,@(if (null? arglist)
doc
(map (lambda (d) (markup-args argregexp d)) doc))))
((refsect1)
((title) "Implementation Notes")
((para) "Defined in "
((ulink (url ,(docitem:file docitem)))
((filename) ,(docitem:file docitem)))
,(string-append " at line " (stringify (docitem:line docitem))
"."))))))
(define (markup-args argregexp s)
(my-regexp-substitute/global #f argregexp s 'pre 1 "<parameter>"
(lambda (m) (string-downcase! (string-copy (match:good-substring m 2))))
"</parameter>" 3 'post))
(define (proclist->primitives-chapter l)
(make-chapter "Primitives in Alphabetical Order"
(map proc->primitives-ssgml l)))
(define (make-chapter name l)
`((chapter)
((title) ,name)
,@l))
(define (lexcmp selectors)
(lambda (x y)
(if (null? selectors)
#t
(let* ((selector (car selectors))
(sel (list-ref selector 0))
(less (list-ref selector 1))
(eq (list-ref selector 2))
(a (sel x))
(b (sel y)))
(or (less a b)
(and (eq a b)
((lexcmp (cdr selectors)) x y)))))))
(define (proclist->file-chapter procs)
(let ((procs (group (sort procs (lexcmp (list (list (lambda (x) (docitem:file x)) string<? string=?)
(list (lambda (x) (vdocitem:scheme-name x)) string<? string=?))))
(lambda (x y) (string=? (docitem:file x) (docitem:file y))))))
(make-chapter "Primitives by File"
(map gen-file-group procs))))
;;; Converts
;;; (1 1 1 1 2 2 3 3 3 3 ...) to:
;;; ((1 1 1 1) (2 2) (3 3 3 3) ...)
(define (group l eqcmp)
(define (grp l result)
(cond ((null? l) (list (reverse result)))
((null? result)
(grp (cdr l) (cons (car l) result)))
((eqcmp (car l) (car result))
(grp (cdr l) (cons (car l) result)))
(else
(cons result (grp l '())))))
(if (null? l) '()
(grp l '())))
(define (gen-file-group procs-from-file)
`((sect1)
((title) ,(docitem:file (car procs-from-file)))
((itemizedlist)
,@(map (lambda (rec)
(let* ((proc (vdocitem:decl rec))
(args (proc:args proc))
(doc (procdoc:doc (docitem:data rec))))
`((listitem)
((para)
((link (linkend ,(sgml-escape-xref (proc:scheme-name proc))))
((function) ,(proc:scheme-name proc)))
,(string-append "— "
(cond ((null? doc)
"")
((null? args)
(car doc))
(else (markup-args
(arglist->argregexp args)
(car doc)))))))))
procs-from-file))))
(define (emblist->ssgml docs)
(let ((docs (group (sort docs (lexcmp (list (list (lambda (x) (doc:chapter (docitem:data x))) string-ci<? string-ci=?)
(list (lambda (x) (doc:section (docitem:data x))) string-ci<? string-ci=?))))
(lambda (x y) (string-ci=? (doc:chapter (docitem:data x))
(doc:chapter (docitem:data y)))))))
(map embchapter->ssgml docs)))
(define (embchapter->ssgml group)
(make-chapter (doc:chapter (docitem:data (car group)))
(map embsect->ssgml group)))
(define (embsect->ssgml item)
`((sect1 (id ,(sgml-escape-xref (doc:section (docitem:data item)))))
((title) ,(doc:section (docitem:data item)))
((para) ,@(doc:doc (docitem:data item)))))
(define (docs->sgml frontpiece docs)
(display "<!DOCTYPE Book PUBLIC \"-//Davenport//DTD DocBook V3.0//EN\">\n")
(sgml (docs->ssgml frontpiece docs)))
(define (docs->ssgml frontpiece docs)
(let ((procs (sort (select-type 'SCWM_PROC docs) scheme-name-ci<?))
(embdocs (select-type 'DOC docs)))
`((book)
,frontpiece
,(proclist->primitives-chapter procs)
,(proclist->file-chapter procs)
,@(emblist->ssgml embdocs))))
(define sgml-escape-echars (make-regexp " ([<&]) "))
(define (sgml-excape-match m)
(case (string-ref (match:substring m 1) 0)
((#\<) " < ")
((#\&) " & ")))
(define (sgml-escape s)
(my-regexp-substitute/global #f sgml-escape-echars s 'pre sgml-escape-match 'post))
(define sgml-escape-xref-echars (make-regexp "->|_|!|\\?|% "))
(define (sgml-escape-xref-match m)
(case (string-ref (match:substring m 0) 0)
((#\-) "-to-")
((#\_) "-")
((#\!) "-p")
((#\?) "-x")
((#\%) "-pct-")
((#\space) "_")))
(define (sgml-escape-xref s)
(my-regexp-substitute/global #f sgml-escape-xref-echars s 'pre sgml-escape-xref-match 'post))
(define (my-regexp-substitute/global port rx string . items)
;; If `port' is #f, send output to a string.
(if (not port)
(call-with-output-string
(lambda (p)
(apply my-regexp-substitute/global p rx string items)))
;; Otherwise, compile the regexp and match it against the
;; string, looping if 'post is encountered in `items'.
(let next-match ((str string))
;; (displayl "My...: x" str "x\n")
(let ((match (regexp-exec rx str)))
;; (displayl "My...: match " match "\n")
(if (not match)
(display str port)
;; Process all of the items for this match.
(for-each
(lambda (obj)
(cond
((string? obj) (display obj port))
((integer? obj) (display (match:good-substring match obj) port))
((procedure? obj) (display (obj match) port))
((eq? 'pre obj) (display (match:prefix match) port))
((eq? 'post obj) (next-match (match:suffix match)))
(else (error 'wrong-type-arg obj))))
items))))))
(define (match:good-substring match n)
(do ((i 0 (1+ i)))
((< n 0)
(match:substring match (1- i)))
(if (not (equal? (vector-ref match (1+ i)) '(-1 . -1)))
(set! n (1- n)))))
(define (old-sgml-markup s)
(my-regexp-substitute/global
#f
tf-regexp
(my-regexp-substitute/global #f
proc-regexp
s
`pre
"<link linkend=\""
(lambda (m) (sgml-escape-xref (match:substring m 1)))
"\"><function>"
1
"</function></link>" `post)
`pre "<literal>" 1 "</literal>" `post))
(define (sgml-markup s)
(sgml-markup-literals (sgml-markup-fcns s)))
(define (sgml-markup-fcns s)
(let ((r (regexp-exec proc-regexp s)))
(if r
(let ((f (match:substring r 1)))
(string-append (match:prefix r)
"<link linkend=\""
(sgml-escape-xref f)
"\"><function>"
f
"</function></link>"
(sgml-markup-fcns (match:suffix r))))
s)))
(define (sgml-markup-literals s)
(let ((r (regexp-exec tf-regexp s)))
(if r
(string-append (match:prefix r)
"<literal>"
(match:substring r 1)
"</literal>"
(sgml-markup-literals (match:suffix r)))
s)))
;;; Convert ssgml to sgml:
(define (sgml form . depth)
(if (null? depth) (set! depth '(0)))
(cond ((string? form)
(display (make-string (car depth) #\space))
(display (sgml-markup form))
(newline))
((null? form)
'())
(else
(display (make-string (car depth) #\space))
(sgml-render-start (car form))
(for-each (lambda (f) (sgml f (+ (car depth) 3)))
(cdr form))
(display (make-string (car depth) #\space))
(sgml-render-end (car form)))))
(define (sgml-render-start tag)
(displayl "<" (car tag))
(for-each (lambda (args)
(displayl " " (car args) "=")
(write (cadr args)))
(cdr tag))
(display ">\n"))
(define (sgml-render-end tag)
(displayl "</" (car tag) ">\n"))
(define testfilelist
'("/home/hjstein/remote-cvs-pkgs/scwm/scwm/Grab.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/ICCCM.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/add_window.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/binding.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/borders.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/callbacks.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/color.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/colormaps.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/colors.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/complex.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/decor.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/decorations.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/deskpage.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/draw-pie-menu.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/drawmenu.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/errors.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/events.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/face.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/focus.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/font.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/getopt.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/getopt1.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/guile-compat.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/icons.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/image.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/init_scheme_string.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/menu.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/menuitem.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/miscprocs.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/module-interface.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/move.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/placement.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/resize.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/screen.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/scwm.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/scwmmenu.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/shutdown.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/string_token.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/syscompat.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/system.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/util.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/virtual.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/window.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/xmisc.c"
"/home/hjstein/remote-cvs-pkgs/scwm/scwm/xproperty.c"))
(define (testit . files)
(let ((start 0)
(ec 0)
(cc 0)
(pc 0)
(sc 0))
(set! start (profile:clock))
(displayl "Start time: " start "\n")
(let ((d (apply extract-docs-from-files
(if (null? files)
testfilelist
files))))
(set! ec (profile:clock))
(displayl "Extraction completed : " ec "\n")
(check-docs d)
(set! cc (profile:clock))
(displayl "Check completed : " cc "\n")
(with-output-to-file "hjs_scwm.txt" (lambda () (docs->proclist d)))
(set! pc (profile:clock))
(displayl "Proclist completed : " pc "\n")
(with-output-to-file "hjs_scwm.sgml" (lambda () (docs->sgml frontpiece d)))
(set! sc (profile:clock))
(displayl "sgml completed : " sc "\n")
(displayl "extract time : " (- ec start) "\n")
(displayl "check time : " (- cc ec) "\n")
(displayl "proc time : " (- pc cc) "\n")
(displayl "sgml time : " (- sc pc) "\n"))))
(define frontpiece
`((bookinfo)
((title)
((productname) "SCWM Reference Manual"))
((authorgroup)
((author)
((firstname) "Maciej")
((surname) "Stachowiak")
((affiliation)
((shortaffil) "MIT")
((jobtitle) "M.S. Degree Recipient")
((orgname) "Massachusetts Institute of Technology")
((orgdiv) "Department of Computer Science")
((address)
((city) "Cambridge")
((state) "Massachusetts")
((postcode) "12345")
((country) "U.S.A.")
((email) "mstachow@mit.edu"))))
((author)
((firstname) "Greg")
((surname) "Badros")
((affiliation)
((shortaffil) "UWashington")
((jobtitle) "Graduate Research Assistant")
((orgname) "University of Washington")
((orgdiv) "Department of Computer Science and Engineering")
((address)
((city) "Seattle")
((state) "Washington")
((postcode) "98195")
((country) "U.S.A.")
((email) "gjb@cs.washington.edu")))))
((releaseinfo) "Release pre-0.8")
((pubdate) "28 July 1998")
((copyright)
((year) "1997–1998")
((holder) "Maciej Stachowiak and Greg J. Badros"))))
(define (usage)
(displayl "Usage: extract.scm [options] file1.c file2.c ...
Extracts documentation from specified C source code files.
Documentation must be embedded according to SCWM conventions:
- Functions declared with the SCWM_PROC macro will be documented.
They can be immediately followed by comments of the form /**
... */, which will be assumed to document the preceeding
SCWM_PROC. Each SCWM_PROC should be followed by a FUNC_NAME
define which matches the C function name given by the SCWM_PROC.
- Comments of the form /** chapter_name : section_name ... */ will
also be extracted.
Options:
-nc, --nocheck Don't check documentation for reasonableness.
-s file, --sgml file Generate SGML and output to specified file.
-p file, --proc file Generate procedure listing and output to
specified file.
-t file, --text file Generate plain text output to specified
file.
-a, --annotated-text Output plain text with each line prefixed by
file:line_number:.
-l, --ispell Run ispell on documentation. Currently
hangs when given full SCWM source code set.
-w, --words 'word word ...' More words for ispell to ignore.
-h, -? --help Display this info.
If no flags are given, the default action is to check the files.
"))
;(define arglist
; '((("-nc" "--nocheck") 0)
; (("-s" "--sgml") 1)
; (("-p" "--proc") 1)
; (("-t" "--text") 1)
; (("-a" "--annotated-text") 0)
; (("-i" "--ispell") 0)
; (("-w" "--words") 1)
; (("-h" "-?" "--help" 0))))
;(define (alistmember arg arglist)
; (cond ((null? arglist) #f)
; ((member arg (caar arglist)) (car arglist))
; (else (alistmember arg (cdr arglist)))))
;(define (process-cmd-line args arglist)
; (cond ((null? args) '())
; ((and (option? (car args))
; (alistmember (car arg) arglist)
(define (process-arg n func arg rest files actions)
;; (displayl "process-arg\n"
;; "arg : " arg "\n"
;; "rest : " rest "\n"
;; "files : " files "\n"
;; "actions : " actions "\n")
(cond ((= n 0)
(process-cmd-line rest files (cons (lambda (docs) (func docs)) actions)))
((= n 1)
(cond ((null? rest)
(displayl arg
" flag given without arguments. Ignored.\n")
(process-cmd-line rest files actions))
(else (process-cmd-line (cdr rest)
files
(cons (lambda (docs) (with-output-to-file (car rest)
(lambda () (func docs))))
actions)))))
(else
(displayl "Internal error: process-arg only takes 0 or 1 as arg count\n"))))
(define check #t)
(define (process-cmd-line args files actions)
(call-with-current-continuation
(lambda (ret)
(cond ((null? args)
;;; (displayl "args : " args "\n" ;
;;; "files : " files "\n"
;;; "actions : " actions "\n")
(if (null? files)
(displayl "Error: You must specify at least one file.")
(let ((docs (apply extract-docs-from-files (reverse files))))
(if check (check-docs docs))
(for-each (lambda (act)
(act docs))
(reverse actions)))))
(else
;;; (displayl "process-cmd-line: processing '" (car args) "'\n")
(case (string->symbol (car args))
((-l --ispell)
(process-arg 0 ispell-docs (car args) (cdr args) files actions))
((-nc --nocheck)
(set! check #f)
(process-cmd-line (cdr args) files actions))
((-s --sgml)
(process-arg 1
(lambda (d) (docs->sgml frontpiece d))
(car args) (cdr args) files actions))
((-p --proc)
(process-arg 1 docs->proclist (car args) (cdr args) files actions))
((-t --text)
(process-arg 1 docs->text (car args) (cdr args) files actions))
((-a --annotated-text)
(process-arg 1 docs->annotated-text (car args) (cdr args) files actions))
((-w --words)
(cond ((null? (cdr args))
(displayl (car args)
" flag given without arguments. Ignored.\n")
(process-cmd-line (cdr args) files actions))
(else (set! *scwm-ok-words*
(append (extract-words (cadr args) word-delimiter?)
*scwm-ok-words*))
(process-cmd-line (cddr args) files actions))))
((-h -? --help)
(usage)
(ret '()))
(else
;;; (displayl "process-cmd-line: else. (car args) = '" (car args) "'\n")
;;; (displayl "(eq? (car args) '-i) = " (eq? (string->symbol (car args)) '-i) "\n")
(process-cmd-line (cdr args) (cons (car args) files) actions))))))))
;;; Arg processing.
(cond ((or (null? (command-line))
(null? (cdr (command-line)))))
((null? (cddr (command-line)))
(usage)
(exit))
(else
;;;(debug-enable 'backtrace)
(process-cmd-line (cddr (command-line)) '() '())
(exit)))
--
Harvey J. Stein
BFM Financial Research
hjstein@bfr.co.il