karttu@walrus.megabaud.fi (Antti Karttunen) wrote in message
news:<a657d0$o97$1@walrus.megabaud.fi>...
Actually, R5RS macros are more powerful than they may appear. The
present article implements your example using only hygienic macros.
> (define-convform (NUKE_CRS (I infile) (O outfile))
> (run (tr -d '\015') (< ,infile) (> ,outfile))
> )
> and that macro define-convform would do two things:
> A) define a function
> (define (NUKE_CRS_fun *STEP* *DEFS* *IO_BINDINGS* infile outfile)
> (let ((infile (assq infile *IO_BINDINGS*))
> (outfile (some_code_for_creating_new_temporary_file_name
> outfile and_destructively_adding_it_to *IO_BINDINGS*))
> )
> (some_catcher_and_thrower_for_possibly_ruined_execution_here?
> (run (tr -d `\015`) (< ,infile) (> ,outfile))
> )
> )
> )
> B) define a macro called NUKE_CRS
> which would expand something like (NUKE_CRS (I file1) (O file2))
> to call: (NUKE_CRS_fun *STEP* *DEFS* *IO_BINDINGS* 'file1 'file2)
> and these all invocations would occur
> inside some begin-form or such with *DEFS* and *IO_BINDINGS*
> bound as appropriate association-lists.
You don't seem to need to define any macros defining macros. Most of
the things can be done with procedures.
; An assoc list of (TAG . conv-proc)
; where conv-proc is a procedure
; STEP DEFS IO-BINDINGS FILE-NAME FILE-NAME ...
; where FILE-NAME is a symbol.
(define *convforms* '())
Now,
(define-convform (NUKE_CRS (I infile) (O outfile))
(run (tr -d "\015") (< ,infile) (> ,outfile))
)
will expand into the following:
(begin
(set! *convforms*
(cons
(cons 'NUKE_CRS
(lambda (step defs io-bindings infile outfile)
(let ((file1 (locate file1 io-bindings)))
(let ((file2 (store! file2 io-bindings)))
(run (tr -d '\015') (< ,file1) (> ,file2))))))
*convforms*))
(define (NUKE_CRS file1 file2)
(cond
((assq 'NUKE_CRS *convforms*) =>
(lambda (ass)
((cdr ass) *STEP* *DEFS* *IO-BINDINGS* file1 file2)))
(else (error "can't find procedure: " 'NUKE_CRS))))
)
To be more precise, the lambda form associated with NUKE_CRS has
actually the form:
(lambda (step defs io-bindings infile outfile)
((lambda (file1 file2)
(run (tr -d '\015') (< ,file1) (> ,file2)))
(locate infile io-bindings #t)
(locate outfile io-bindings #f)))
where (locate file io-bindings input-file?) locates the file in
io-bindings (if it is an input file). Otherwise, it creates the file
and destructively modifies the bindings.
The only non-trivial part is converting
(run (tr -d '\015') (< ,infile) (> ,outfile))
into
(lambda (file1 file2)
(run (tr -d '\015') (< ,file1) (> ,file2)))
That is, renaming of variables in the body of define-convform. Well,
it all can be done with hygienic macros. Given the code in appendix,
(define-convform (NUKE_CRS (I infile) (O outfile))
(run (tr -d "\\015") (< ,infile) (> ,outfile))
)
indeed expands into:
(begin (set! *convforms*
(cons (cons 'NUKE_CRS
(lambda
(step~10~11
defs~10~11
io-bindings~10~11
infile~11
outfile~11)
((lambda
(fname~1~6~13 fname~1~5~13)
(run (tr -d "\\015")
(< ,fname~1~6~13)
(> ,fname~1~5~13)))
(locate-file io-bindings~10~11 infile~11 #t)
(locate-file io-bindings~10~11 outfile~11 #f))))
*convforms*))
(define
(NUKE_CRS fname~1~6~20 fname~1~5~20)
((lambda
(temp~21~23)
(if temp~21~23
((lambda
(ass~19~24)
((cdr ass~19~24)
*STEP*
*DEFS*
*IO-BINDINGS*
fname~1~6~20
fname~1~5~20))
temp~21~23)
(begin (error "can't find procedure: " 'NUKE_CRS))))
(assq 'NUKE_CRS *convforms*))))
Note how all macroexpander-generated names match each other in all the
right places.
Given the dummy definitions for the 'run' macro and other procedures,
(NUKE_CRS (I myinfile1) (O myofile2))
indeed runs and prints the correct result. The complete code follows:
; An assoc list of (TAG . conv-proc)
; where conv-proc is a procedure
; STEP DEFS IO-BINDINGS FILE-NAME FILE-NAME ...
; where FILE-NAME is a symbol.
(define *convforms* '())
; This is for debugging purposes only
(define-syntax run
(syntax-rules ()
((_ . forms) (begin
(display "Runnning: ") (display (quasiquote forms)) (newline)))
))
; the main dispatch macro
(define-syntax define-convform
(syntax-rules ()
((_ (_tag . file-args) _body)
(letrec-syntax
((partition-file-args ; partition into ifiles and ofiles args
(syntax-rules (I O)
((_ () ifiles ofiles all-files tag body)
(make-arglist () () (ifiles ofiles) all-files tag body))
((_ ((I file) . other-args) ifiles ofiles all-files tag body)
(partition-file-args other-args
(file . ifiles) ofiles (file . all-files)
tag body))
((_ ((O file) . other-args) ifiles ofiles all-files tag body)
(partition-file-args other-args
ifiles (file . ofiles) (file . all-files)
tag body)))
)
(make-arglist ; generate tempnames for each of the arglist
(syntax-rules ()
((_ arglist argtemps iofiles () tag body)
(gen arglist argtemps iofiles tag body))
((_ arglist argtemps iofiles (file . files) tag body)
(make-arglist (file . arglist) (fname . argtemps)
iofiles files tag body))))
(gen
(syntax-rules ()
((_ arglist argtemps iofiles tag body)
(begin
(set! *convforms*
(cons
(cons (quote tag)
(gen-body arglist argtemps iofiles body))
*convforms*))
(gen-def argtemps tag)))))
)
(partition-file-args file-args () () () _tag _body)))))
; The renamer:
; any mentioning of one of the arglist in the body is replaced with argtemp
(define-syntax gen-body
(syntax-rules ()
((_ arglist _argtemps iofiles body)
(gen-outer arglist iofiles
(let-syntax
((ren (syntax-rules ()
((_ argtemps arglist) (lambda argtemps body)))))
(ren _argtemps _argtemps))))))
; generate the outer conv procedure, which is to be associated with
; with the tag
(define-syntax gen-outer
(syntax-rules ()
((_ (file ...) (ifiles ofiles) inner-lambda)
(lambda (step defs io-bindings file ...)
(inner-lambda
(locate-file io-bindings file (?memq? file ifiles)) ...)))))
(define-syntax ?memq?
(syntax-rules ()
((_ x xs)
(letrec-syntax
((so?
(syntax-rules (x)
((_ x . others) #t)
((_) #f)
((_ y . others)
(so? . others)))))
(so? . xs)))))
(define-syntax gen-def
(syntax-rules ()
((_ (file ...) tag)
(define (tag file ...)
(cond
((assq (quote tag) *convforms*) =>
(lambda (ass)
((cdr ass) *STEP* *DEFS* *IO-BINDINGS* file ...)))
(else (error "can't find procedure: " (quote tag))))))))
(define-syntax I
(syntax-rules ()
((_ sym) (quote sym))))
(define-syntax O
(syntax-rules ()
((_ sym) (quote sym))))
; A sample definition
(define-convform (NUKE_CRS (I infile) (O outfile))
(run (tr -d "\\015") (< ,infile) (> ,outfile))
)
; The following is a set of stubs to make the example run
(define (locate-file io-bindings file input?)
(if input?
(cond
((assq file io-bindings) => cdr)
(else (error "unknown input file: " file-symb #f))))
(store! file io-bindings))
(define *STEP* #f)
(define *DEFS* '())
(define *IO-BINDINGS* '((#f . #f) ; header
(myinfile1 . "infile-1")))
(define (store! file io-bindings)
(let ((file-name (symbol->string file)))
(set-cdr! io-bindings (cons (cons file file-name) (cdr io-bindings)))
file-name))
(NUKE_CRS (I myinfile1) (O myofile2)) ; and it surely runs
; it prints: Runnning: ((tr -d \015) (< myinfile1) (> myofile2))
|