suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

v4-ified preprocessor tools

Browse Source 
svn: r8785
This commit is contained in:
Eli Barzilay 2008-02-24 21:05:28 +00:00
parent 31a9f69df5
commit c2f1773ea2
6 changed files with 94 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
collects/preprocessor/mzpp-run.ss
View File

@ -1,34 +1,31 @@
(module mzpp-run mzscheme #lang scheme/base
(require preprocessor/mzpp preprocessor/pp-run mzlib/cmdline mzlib/process) (require preprocessor/mzpp preprocessor/pp-run scheme/cmdline)
(let ([output #f] [run-cmd #f]) (let ([output #f] [run-cmd #f])
(command-line (command-line
"mzpp" #:once-each
(current-command-line-arguments) [("-o" "--output") file "output file (defaults to standard output)"
(once-each (set! output file)]
[("-o" "--output") file "output file (defaults to standard output)" [("-b" "--begin-mark") beg "Scheme beginning marker (defaults to \"<<\")"
(set! output file)] (beg-mark beg)]
[("-b" "--begin-mark") beg "Scheme beginning marker (defaults to \"<<\")" [("-e" "--end-mark") end "Scheme ending marker (defaults to \">>\")"
(beg-mark beg)] (end-mark end)]
[("-e" "--end-mark") end "Scheme ending marker (defaults to \">>\")" [("-s" "--skip-to") skip "skip processing to a line with only this string"
(end-mark end)] (skip-to skip)]
[("-s" "--skip-to") skip "skip processing to a line with only this string" [("--no-spaces") "disable \"smart\" handling of spaces"
(skip-to skip)] (no-spaces? #t)]
[("--no-spaces") "disable \"smart\" handling of spaces" [("--run") cmd "run the command string on a single preprocessed input file"
(no-spaces? #t)] (set! run-cmd cmd)]
[("--run") cmd "run the command string on a single preprocessed input file" #:help-labels " (see the documentation for this option)"
(set! run-cmd cmd)]) #:multi
(help-labels " (see the documentation for this option)") [("-E" "--eval") expr "evaluates <expr> before processing starts"
(multi (parameterize ([read-case-sensitive #t])
[("-E" "--eval") expr "evaluates <expr> before processing starts" (add-eval (read (open-input-string expr))))]
(parameterize ([read-case-sensitive #t]) #:once-each
(add-eval (read (open-input-string expr))))]) [("--debug") "show preprocessed Scheme code (for debugging)"
(once-each (debug? #t)]
[("--debug") "show preprocessed Scheme code (for debugging)" #:handlers
(debug? #t)]) (lambda (_ . files) (run preprocess run-cmd output files))
(=> (lambda (_ . files) (run preprocess run-cmd output files)) '("input-file")
'("input-file") (more-help 'mzpp "a MzScheme-based preprocessor")))
(more-help 'mzpp "a MzScheme-based preprocessor"))))
)

13
collects/preprocessor/mzpp.ss
View File

@ -1,7 +1,7 @@
(module mzpp mzscheme #lang scheme/base
(require preprocessor/pp-utils) (require preprocessor/pp-utils scheme/promise)
(provide (all-from preprocessor/pp-utils)) (provide (all-from-out preprocessor/pp-utils))
(provide beg-mark end-mark skip-to no-spaces? debug?) (provide beg-mark end-mark skip-to no-spaces? debug?)
(define beg-mark (make-parameter "<<")) (define beg-mark (make-parameter "<<"))
@ -167,13 +167,10 @@
[cd (cd)]) [cd (cd)])
(run files))) (run files)))
(define-namespace-anchor nsa)
(provide preprocess) (provide preprocess)
(define (preprocess . files) (define (preprocess . files)
(read-case-sensitive #t) (read-case-sensitive #t)
(current-namespace (namespace-anchor->namespace nsa)) (namespace-require 'scheme/base)
(namespace-require 'preprocessor/mzpp)
(do-evals) (do-evals)
(run files)) (run files))
)

39
collects/preprocessor/mztext-run.ss
View File

@ -1,25 +1,22 @@
(module mztext-run mzscheme #lang scheme/base
(require preprocessor/mztext preprocessor/pp-run mzlib/cmdline) (require preprocessor/mztext preprocessor/pp-run scheme/cmdline)
(let ([output #f] [run-cmd #f]) (let ([output #f] [run-cmd #f])
(command-line (command-line
"mztext" #:once-each
(current-command-line-arguments) [("-o" "--output") file "output file (defaults to standard output)"
(once-each (set! output file)]
[("-o" "--output") file "output file (defaults to standard output)" [("-c" "--command-marker") marker "command marker (defaults to \"@\")"
(set! output file)] (command-marker marker)]
[("-c" "--command-marker") marker "command marker (defaults to \"@\")" [("--run") cmd "run the command string on a single preprocessed input file"
(command-marker marker)] (set! run-cmd cmd)]
[("--run") cmd "run the command string on a single preprocessed input file" #:help-labels " (see the documentation for this option)"
(set! run-cmd cmd)]) #:multi
(help-labels " (see the documentation for this option)") [("-E" "--eval") expr "evaluates <expr> before processing starts"
(multi (parameterize ([read-case-sensitive #t])
[("-E" "--eval") expr "evaluates <expr> before processing starts" (add-eval (read (open-input-string expr))))]
(parameterize ([read-case-sensitive #t]) #:handlers
(add-eval (read (open-input-string expr))))]) (lambda (_ . files) (run preprocess run-cmd output files))
(=> (lambda (_ . files) (run preprocess run-cmd output files)) '("input-file")
'("input-file") (more-help 'mztext "a MzScheme-based preprocessing language")))
(more-help 'mztext "a MzScheme-based preprocessing language"))))
)

24
collects/preprocessor/mztext.ss
View File

@ -1,7 +1,8 @@
(module mztext mzscheme #lang scheme/base
(require mzlib/string mzlib/port preprocessor/pp-utils) (require preprocessor/pp-utils scheme/port scheme/promise
(provide (all-from preprocessor/pp-utils)) (only-in mzlib/string read-from-string-all))
(provide (all-from-out preprocessor/pp-utils))
;;============================================================================= ;;=============================================================================
;; Composite port ;; Composite port
@ -113,7 +114,7 @@
(define (dispatch dispatcher continue failure . copy?) (define (dispatch dispatcher continue failure . copy?)
(let ([m (if (and (pair? copy?) (car copy?)) (let ([m (if (and (pair? copy?) (car copy?))
(regexp-match (car dispatcher) (stdin) 0 #f (stdout)) (regexp-match (car dispatcher) (stdin) 0 #f (stdout))
(regexp-match/fail-without-reading (car dispatcher) (stdin)))]) (regexp-try-match (car dispatcher) (stdin)))])
(if m (if m
(ormap (lambda (x y) (and x (y x continue))) (cdr m) (cdr dispatcher)) (ormap (lambda (x y) (and x (y x continue))) (cdr m) (cdr dispatcher))
(failure)))) (failure))))
@ -184,7 +185,7 @@
((if (andmap (lambda (x) (or (not x) (void? x))) vs) ((if (andmap (lambda (x) (or (not x) (void? x))) vs)
(begin (swallow-newline) cont) (begin (swallow-newline) cont)
(value->cont vs cont)))))) (value->cont vs cont))))))
(cond [(regexp-match/fail-without-reading (command-marker-here-re) (stdin)) (cond [(regexp-try-match (command-marker-here-re) (stdin))
=> (lambda (here) (display (car here)) (cont))] => (lambda (here) (display (car here)) (cont))]
[else (let ((r (read))) (do-thunk (lambda () (eval r))))])) [else (let ((r (read))) (do-thunk (lambda () (eval r))))]))
@ -232,11 +233,10 @@
(arg-dispatcher) (arg-dispatcher)
#f #f
(lambda () (lambda ()
(cond [(regexp-match/fail-without-reading (let ([m (regexp-try-match
(if (get-arg-reads-word?) #rx"[^ \t\r\n]+" #rx"[^ \t\r\n]") (if (get-arg-reads-word?) #rx"[^ \t\r\n]+" #rx"[^ \t\r\n]")
(stdin)) (stdin))])
=> car] (if m (car m) eof)))))
[else eof]))))
(provide get-arg*) (provide get-arg*)
(define (get-arg*) (define (get-arg*)
@ -254,7 +254,7 @@
(provide swallow-newline) (provide swallow-newline)
(define (swallow-newline) (define (swallow-newline)
;; careful: if there's no match, we don't want to consume the input ;; careful: if there's no match, we don't want to consume the input
(regexp-match/fail-without-reading #rx"^[ \t]*\r?\n" (stdin)) (regexp-try-match #rx"^[ \t]*\r?\n" (stdin))
(void)) (void))
(define (string->substlist args str) (define (string->substlist args str)
@ -346,5 +346,3 @@
(unless (null? files) (unless (null? files)
(parameterize ([stdin (make-composite-input)]) (parameterize ([stdin (make-composite-input)])
(apply include files)))) (apply include files))))
)

66
collects/preprocessor/pp-run.ss
View File

@ -1,4 +1,4 @@
(module pp-run mzscheme #lang scheme/base
(require mzlib/process) (require mzlib/process)
@ -21,37 +21,35 @@
(set! exit-code (system/exit-code (regexp-replace (set! exit-code (system/exit-code (regexp-replace
#rx"\\*" run-cmd (format "~s" f))))) #rx"\\*" run-cmd (format "~s" f)))))
(cond (cond
[(and run-cmd (not (regexp-match #rx"\\*" run-cmd))) [(and run-cmd (not (regexp-match #rx"\\*" run-cmd)))
(when output (when output
(error 'mzpp "cannot run a command with piped stdin when an ~a" (error 'mzpp "cannot run a command with piped stdin when an ~a"
"output name is specified")) "output name is specified"))
(let ([p (process/ports (current-output-port) #f (current-error-port) (let ([p (process/ports (current-output-port) #f (current-error-port)
run-cmd)]) run-cmd)])
(parameterize ([current-output-port (list-ref p 1)]) (parameterize ([current-output-port (list-ref p 1)])
(apply preprocess files)) (apply preprocess files))
(close-output-port (list-ref p 1)) (close-output-port (list-ref p 1))
((list-ref p 4) 'wait) ((list-ref p 4) 'wait)
(set! exit-code ((list-ref p 4) 'exit-code)))] (set! exit-code ((list-ref p 4) 'exit-code)))]
[(and run-cmd (not (or (= 1 (length files)) output))) [(and run-cmd (not (or (= 1 (length files)) output)))
(error 'mzpp "cannot run a command that expects a filename with ~a" (error 'mzpp "cannot run a command that expects a filename with ~a"
"multiple input files and no output name")] "multiple input files and no output name")]
[(and run-cmd (not output)) [(and run-cmd (not output))
(let* ([file (car files)] (let* ([file (car files)]
[temp (format "~a-mzpp-temporary" file)]) [temp (format "~a-mzpp-temporary" file)])
(when (file-exists? temp) (when (file-exists? temp)
(error 'mzpp "~s already exists!" temp)) (error 'mzpp "~s already exists!" temp))
(dynamic-wind (dynamic-wind
(lambda () (rename-file-or-directory file temp)) (lambda () (rename-file-or-directory file temp))
(lambda () (lambda ()
(with-output-to-file file (lambda () (preprocess temp))) (with-output-to-file file (lambda () (preprocess temp)))
(do-run-subst file)) (do-run-subst file))
(lambda () (lambda ()
(delete-file file) (delete-file file)
(rename-file-or-directory temp file))))] (rename-file-or-directory temp file))))]
[output [output
(with-output-to-file output (lambda () (apply preprocess files)) 'replace) (with-output-to-file output (lambda () (apply preprocess files)) 'replace)
(when run-cmd (do-run-subst output))] (when run-cmd (do-run-subst output))]
[else (apply preprocess files)]) [else (apply preprocess files)])
(exit exit-code))) (exit exit-code)))
)

3
collects/preprocessor/pp-utils.ss
View File

@ -1,4 +1,4 @@
(module pp-utils mzscheme #lang scheme/base
(provide stdin stdout stderr cd) (provide stdin stdout stderr cd)
(define stdin current-input-port) (define stdin current-input-port)
@ -13,4 +13,3 @@
(define evals (make-parameter '())) (define evals (make-parameter '()))
(define (add-eval expr) (evals (cons expr (evals)))) (define (add-eval expr) (evals (cons expr (evals))))
(define (do-evals) (for-each eval (reverse (evals)))) (define (do-evals) (for-each eval (reverse (evals))))
)