642 lines
23 KiB
Scheme
642 lines
23 KiB
Scheme
;;; m4.ss
|
|
;;; Copyright (C) 1988 R. Kent Dybvig
|
|
|
|
;;; Permission is hereby granted, free of charge, to any person obtaining a
|
|
;;; copy of this software and associated documentation files (the "Software"),
|
|
;;; to deal in the Software without restriction, including without limitation
|
|
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
|
|
;;; and/or sell copies of the Software, and to permit persons to whom the
|
|
;;; Software is furnished to do so, subject to the following conditions:
|
|
;;;
|
|
;;; The above copyright notice and this permission notice shall be included in
|
|
;;; all copies or substantial portions of the Software.
|
|
;;;
|
|
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
|
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
|
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
|
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
|
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
|
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
|
;;; DEALINGS IN THE SOFTWARE.
|
|
|
|
;;; speed improvement ideas:
|
|
;;; use hash table rather than assoc for macro lookup
|
|
;;; use extensible string buffer in place of lists
|
|
;;; collect multiple characters when scanning text, arguments
|
|
;;; use fixnum arithmetic where appropriate
|
|
|
|
(eval-when (compile) (optimize-level 3))
|
|
|
|
(define lexeme-type car)
|
|
(define lexeme-value cdr)
|
|
|
|
(define-structure (ibuf ip) ([pb '()]))
|
|
|
|
(define oparen #\()
|
|
(define cparen #\))
|
|
|
|
(define m4-get-char
|
|
(lambda (ib)
|
|
(let ([pb (ibuf-pb ib)])
|
|
(if (null? pb)
|
|
(read-char (ibuf-ip ib))
|
|
(begin (set-ibuf-pb! ib (cdr pb))
|
|
(car pb))))))
|
|
|
|
(define m4-unget-char
|
|
(lambda (c ib)
|
|
(set-ibuf-pb! ib (cons c (ibuf-pb ib)))))
|
|
|
|
(define unget-string
|
|
(lambda (s ib)
|
|
(set-ibuf-pb! ib (append (string->list s) (ibuf-pb ib)))))
|
|
|
|
(define int->str
|
|
(lambda (num)
|
|
(format "~s" num)))
|
|
|
|
(define char->digit
|
|
(let ([zero (char->integer #\0)])
|
|
(lambda (c)
|
|
(- (char->integer c) zero))))
|
|
|
|
(define str->int
|
|
(let ([ustr->int
|
|
(lambda (s i n)
|
|
(let f ([a 0] [i i])
|
|
(if (= i n)
|
|
a
|
|
(f (+ (* a 10) (char->digit (string-ref s i)))
|
|
(+ i 1)))))])
|
|
(lambda (s)
|
|
(let ([n (string-length s)])
|
|
(if (= n 0)
|
|
0
|
|
(if (char=? (string-ref s 0) #\-)
|
|
(- (ustr->int s 1 n))
|
|
(ustr->int s 0 n)))))))
|
|
|
|
(define eval-string
|
|
(let ([str #f] [port #f] [token #f] [value #f])
|
|
(define eval-error
|
|
(lambda ()
|
|
(error 'm4 "invalid arithmetic expression ~s" str)))
|
|
(define next-token!
|
|
(lambda ()
|
|
(let ([c (read-char port)])
|
|
(cond
|
|
[(eof-object? c) (set! token 'eof)]
|
|
[(char-whitespace? c) (next-token!)]
|
|
[(char-numeric? c)
|
|
(let loop ([a (char->digit c)])
|
|
(let ([c (read-char port)])
|
|
(cond
|
|
[(eof-object? c)
|
|
(set! token 'integer)
|
|
(set! value a)]
|
|
[(char-numeric? c)
|
|
(loop (+ (* a 10) (char->digit c)))]
|
|
[else
|
|
(unread-char c port)
|
|
(set! token 'integer)
|
|
(set! value a)])))]
|
|
[(char=? c oparen) (set! token 'oparen)]
|
|
[(char=? c cparen) (set! token 'cparen)]
|
|
[(char=? c #\-) (set! token '-)]
|
|
[(char=? c #\*)
|
|
(let ([c (read-char port)])
|
|
(cond
|
|
[(eof-object? c) (set! token '*)]
|
|
[(char=? c #\*) (set! token '**)]
|
|
[else (unread-char c port) (set! token '*)]))]
|
|
[(char=? c #\+) (set! token '+)]
|
|
[(char=? c #\-) (set! token '+)]
|
|
[(char=? c #\/) (set! token '/)]
|
|
[(char=? c #\%) (set! token '%)]
|
|
[(char=? c #\!)
|
|
(let ([c (read-char port)])
|
|
(cond
|
|
[(eof-object? c) (set! token '!)]
|
|
[(char=? c #\=) (set! token '!=)]
|
|
[else (unread-char c port) (set! token '!)]))]
|
|
[(char=? c #\|)
|
|
(let ([c (read-char port)])
|
|
(cond
|
|
[(eof-object? c) (eval-error)]
|
|
[(char=? c #\|) (set! token 'or)]
|
|
[else (unread-char c port) (eval-error)]))]
|
|
[(char=? c #\&)
|
|
(let ([c (read-char port)])
|
|
(cond
|
|
[(eof-object? c) (eval-error)]
|
|
[(char=? c #\&) (set! token 'and)]
|
|
[else (unread-char c port) (eval-error)]))]
|
|
[(char=? c #\=)
|
|
(let ([c (read-char port)])
|
|
(cond
|
|
[(eof-object? c) (eval-error)]
|
|
[(char=? c #\=) (set! token '==)]
|
|
[else (unread-char c port) (eval-error)]))]
|
|
[(char=? c #\<)
|
|
(let ([c (read-char port)])
|
|
(cond
|
|
[(eof-object? c) (set! token '<)]
|
|
[(char=? c #\=) (set! token '<=)]
|
|
[else (unread-char c port) (set! token '<)]))]
|
|
[(char=? c #\>)
|
|
(let ([c (read-char port)])
|
|
(cond
|
|
[(eof-object? c) (set! token '>)]
|
|
[(char=? c #\=) (set! token '>=)]
|
|
[else (unread-char c port) (set! token '>)]))]))))
|
|
(define E0 ; or
|
|
(lambda ()
|
|
(E0* (E1))))
|
|
(define E0*
|
|
(lambda (v)
|
|
(case token
|
|
[or (next-token!) (E0* (if (= (+ v (E1)) 0) 0 1))]
|
|
[else v])))
|
|
(define E1 ; and
|
|
(lambda ()
|
|
(E1* (E2))))
|
|
(define E1*
|
|
(lambda (v)
|
|
(case token
|
|
[and (next-token!) (E1* (if (= (* v (E2)) 0) 0 1))]
|
|
[else v])))
|
|
(define E2 ; ==, !=
|
|
(lambda ()
|
|
(E2* (E3))))
|
|
(define E2*
|
|
(lambda (v)
|
|
(case token
|
|
[== (next-token!) (E2* (if (= v (E3)) 1 0))]
|
|
[!= (next-token!) (E2* (if (= v (E3)) 0 1))]
|
|
[else v])))
|
|
(define E3 ; <, <=, >, >=
|
|
(lambda ()
|
|
(E3* (E4))))
|
|
(define E3*
|
|
(lambda (v)
|
|
(case token
|
|
[< (next-token!) (E3* (if (< v (E4)) 1 0))]
|
|
[<= (next-token!) (E3* (if (<= v (E4)) 1 0))]
|
|
[> (next-token!) (E3* (if (> v (E4)) 1 0))]
|
|
[>= (next-token!) (E3* (if (>= v (E4)) 1 0))]
|
|
[else v])))
|
|
(define E4 ; +, -
|
|
(lambda ()
|
|
(E4* (E5))))
|
|
(define E4*
|
|
(lambda (v)
|
|
(case token
|
|
[+ (next-token!) (E4* (+ v (E5)))]
|
|
[- (next-token!) (E4* (- v (E5)))]
|
|
[else v])))
|
|
(define E5 ; *, /, %
|
|
(lambda ()
|
|
(E5* (E6))))
|
|
(define E5*
|
|
(lambda (v)
|
|
(case token
|
|
[* (next-token!) (E5* (* v (E6)))]
|
|
[/ (next-token!) (E5* (quotient v (E6)))]
|
|
[% (next-token!) (E5* (modulo v (E6)))]
|
|
[else v])))
|
|
(define E6 ; **
|
|
(lambda ()
|
|
(E6* (E7))))
|
|
(define E6*
|
|
(lambda (v)
|
|
(case token
|
|
[** (next-token!) (E6* (expt v (E7)))]
|
|
[else v])))
|
|
(define E7 ; -, integer, paren
|
|
(lambda ()
|
|
(case token
|
|
[- (next-token!) (- (E7))]
|
|
[! (next-token!) (if (= (E7) 0) 1 0)]
|
|
[oparen
|
|
(next-token!)
|
|
(let ([v (E0)])
|
|
(unless (eq? token 'cparen) (eval-error))
|
|
(next-token!)
|
|
v)]
|
|
[integer (next-token!) value]
|
|
[else (eval-error)])))
|
|
(lambda (s)
|
|
(fluid-let ([str s] [port (open-input-string s)] [token #f] [value #f])
|
|
(next-token!)
|
|
(let ([v (E0)])
|
|
(unless (eq? token 'eof) (eval-error))
|
|
v)))))
|
|
|
|
(define *divnum* #f)
|
|
(define *diversions* #f)
|
|
|
|
(define m4-put-string
|
|
(lambda (s)
|
|
(unless (= *divnum* -1)
|
|
(display s (vector-ref *diversions* *divnum*)))))
|
|
|
|
(define *open-quote* #f)
|
|
(define *close-quote* #f)
|
|
|
|
(define *macros* #f)
|
|
(define builtin-macros '())
|
|
|
|
(define *translit-table* #f)
|
|
|
|
(define define-builtin-macro
|
|
(lambda (name proc)
|
|
(set! builtin-macros (cons (cons name proc) builtin-macros))))
|
|
|
|
(define m4
|
|
(lambda (ofn ifn . rest)
|
|
(let ([op (open-output-file ofn 'replace)])
|
|
(fluid-let ([*macros* builtin-macros]
|
|
[*open-quote* #\`]
|
|
[*close-quote* #\']
|
|
[*translit-table* #f]
|
|
[*divnum* 0]
|
|
[*diversions* (vector op #f #f #f #f #f #f #f #f #f)])
|
|
(let loop ([ip (open-input-file ifn)] [rest rest])
|
|
(m4-process (make-ibuf ip) op)
|
|
(close-input-port ip)
|
|
(unless (null? rest)
|
|
(loop (open-input-file (car rest)) (cdr rest))))
|
|
(for-each undivert '(1 2 3 4 5 6 7 8 9)))
|
|
(close-output-port op))))
|
|
|
|
(define m4-process
|
|
(lambda (ib op)
|
|
(let ([lexeme (read-lexeme ib)])
|
|
(case (lexeme-type lexeme)
|
|
[(comment literal)
|
|
(m4-put-string (lexeme-value lexeme))
|
|
(m4-process ib op)]
|
|
[macro
|
|
((cdr (lexeme-value lexeme)) (read-args ib) ib)
|
|
(m4-process ib op)]
|
|
[eof #t]
|
|
[else (error 'm4-internal "unexpected lexeme ~s" lexeme)]))))
|
|
|
|
(define name-start-char?
|
|
(lambda (c)
|
|
(or (char-alphabetic? c)
|
|
(char=? c #\_))))
|
|
|
|
(define name-char?
|
|
(lambda (c)
|
|
(or (name-start-char? c)
|
|
(char-numeric? c))))
|
|
|
|
(define read-lexeme
|
|
(lambda (ib)
|
|
(let ([c (m4-get-char ib)])
|
|
(cond
|
|
[(eof-object? c) (cons 'eof c)]
|
|
[(char=? c #\#) (cons 'comment (read-comment ib))]
|
|
[(char=? c *open-quote*) (cons 'literal (read-quoted ib))]
|
|
[(name-start-char? c) (lookup-macro (cons c (read-alpha ib)))]
|
|
[else (cons 'literal (string c))]))))
|
|
|
|
(define read-comment
|
|
(lambda (ib)
|
|
(let loop ([ls '(#\#)])
|
|
(let ([c (m4-get-char ib)])
|
|
(cond
|
|
[(eof-object? c) (list->string (reverse ls))]
|
|
[(char=? c #\newline) (list->string (reverse (cons c ls)))]
|
|
[else (loop (cons c ls))])))))
|
|
|
|
(define read-quoted
|
|
(lambda (ib)
|
|
(let loop ([ls '()] [n 0])
|
|
(let ([c (m4-get-char ib)])
|
|
(cond
|
|
[(eof-object? c)
|
|
(error 'm4 "end-of-file detected at quote level ~s" n)]
|
|
[(char=? c *close-quote*)
|
|
(if (= n 0)
|
|
(list->string (reverse ls))
|
|
(loop (cons c ls) (- n 1)))]
|
|
[(char=? c *open-quote*) (loop (cons c ls) (+ n 1))]
|
|
[else (loop (cons c ls) n)])))))
|
|
|
|
(define read-alpha
|
|
(lambda (ib)
|
|
(let ([c (m4-get-char ib)])
|
|
(cond
|
|
[(eof-object? c) '()]
|
|
[(name-char? c) (cons c (read-alpha ib))]
|
|
[else (m4-unget-char c ib) '()]))))
|
|
|
|
(define lookup-macro
|
|
(lambda (ls)
|
|
(let ([s (list->string ls)])
|
|
(let ([a (assoc s *macros*)])
|
|
(if a
|
|
(cons 'macro a)
|
|
(cons 'literal s))))))
|
|
|
|
(define read-args
|
|
(lambda (ib)
|
|
(let ([c (m4-get-char ib)])
|
|
(cond
|
|
[(eof-object? c) '()]
|
|
[(char=? c oparen)
|
|
(let next-arg ()
|
|
(let skip-white ()
|
|
(let ([c (m4-get-char ib)])
|
|
(cond
|
|
[(eof-object? c) '()]
|
|
[(char-whitespace? c) (skip-white)]
|
|
[else (m4-unget-char c ib)])))
|
|
(let this-arg ([strings '()])
|
|
(let ([c (m4-get-char ib)])
|
|
(cond
|
|
[(or (eof-object? c) (char=? c cparen))
|
|
(if (null? strings)
|
|
'()
|
|
(cons (apply string-append (reverse strings))
|
|
'()))]
|
|
[(char=? c oparen)
|
|
(let nest ([strings (cons (string oparen)
|
|
strings)]
|
|
[k this-arg])
|
|
(let ([c (m4-get-char ib)])
|
|
(cond
|
|
[(eof-object? c) (this-arg strings)]
|
|
[(char=? c cparen)
|
|
(k (cons (string cparen) strings))]
|
|
[(char=? c oparen)
|
|
(nest (cons (string oparen) strings)
|
|
(lambda (strings)
|
|
(nest strings k)))]
|
|
[else
|
|
(m4-unget-char c ib)
|
|
(let ([lexeme (read-lexeme ib)])
|
|
(case (lexeme-type lexeme)
|
|
[comment (nest strings k)]
|
|
[literal
|
|
(nest (cons (lexeme-value lexeme)
|
|
strings)
|
|
k)]
|
|
[macro
|
|
((cdr (lexeme-value lexeme))
|
|
(read-args ib)
|
|
ib)
|
|
(nest strings k)]
|
|
[else
|
|
(error 'm4-internal
|
|
"unexpected lexeme ~s"
|
|
lexeme)]))])))]
|
|
[(char=? c #\,)
|
|
(cons (apply string-append (reverse strings))
|
|
(next-arg))]
|
|
|
|
[else
|
|
(m4-unget-char c ib)
|
|
(let ([lexeme (read-lexeme ib)])
|
|
(case (lexeme-type lexeme)
|
|
[comment (this-arg strings)]
|
|
[literal
|
|
(this-arg
|
|
(cons (lexeme-value lexeme) strings))]
|
|
[macro
|
|
((cdr (lexeme-value lexeme)) (read-args ib) ib)
|
|
(this-arg strings)]
|
|
[else
|
|
(error 'm4-internal
|
|
"unexpected lexeme ~s"
|
|
lexeme)]))]))))]
|
|
[else (m4-unget-char c ib) '()]))))
|
|
|
|
;;; builtin macros
|
|
|
|
(define $$ (lambda (ls) (if (null? ls) ls (cdr ls))))
|
|
(define $1 (lambda (ls) (if (null? ls) "" (car ls))))
|
|
(define $2 (lambda (ls) ($1 ($$ ls))))
|
|
(define $3 (lambda (ls) ($2 ($$ ls))))
|
|
(define $4 (lambda (ls) ($3 ($$ ls))))
|
|
(define $5 (lambda (ls) ($4 ($$ ls))))
|
|
(define $6 (lambda (ls) ($5 ($$ ls))))
|
|
(define $7 (lambda (ls) ($6 ($$ ls))))
|
|
(define $8 (lambda (ls) ($7 ($$ ls))))
|
|
(define $9 (lambda (ls) ($8 ($$ ls))))
|
|
|
|
(define-builtin-macro "changequote"
|
|
(lambda (args ib)
|
|
(set! *open-quote*
|
|
(if (string=? ($1 args) "") #\` (string-ref ($1 args) 0)))
|
|
(set! *close-quote*
|
|
(if (string=? ($2 args) "") #\' (string-ref ($2 args) 0)))))
|
|
|
|
(define-builtin-macro "define"
|
|
(lambda (args ib)
|
|
(let ([name ($1 args)])
|
|
(unless (let ([n (string-length name)])
|
|
(and (fx> n 0)
|
|
(name-start-char? (string-ref name 0))
|
|
(let ok? ([i 1])
|
|
(or (fx= i n)
|
|
(and (name-char? (string-ref name i))
|
|
(ok? (fx+ i 1)))))))
|
|
(error 'm4-define "invalid macro name ~s" name))
|
|
(let ([proc (make-macro ($2 args))])
|
|
(let ([a (assoc name *macros*)])
|
|
(if a
|
|
(set-cdr! a proc)
|
|
(set! *macros* (cons (cons name proc) *macros*))))))))
|
|
|
|
(define make-macro
|
|
(lambda (s)
|
|
(let ([ls (string->list s)])
|
|
(lambda (args ib)
|
|
(let loop ([ls ls])
|
|
(unless (null? ls)
|
|
(case (and (char=? (car ls) #\$)
|
|
(not (null? (cdr ls)))
|
|
(cadr ls))
|
|
[#\1 (loop (cddr ls)) (unget-string ($1 args) ib)]
|
|
[#\2 (loop (cddr ls)) (unget-string ($2 args) ib)]
|
|
[#\3 (loop (cddr ls)) (unget-string ($3 args) ib)]
|
|
[#\4 (loop (cddr ls)) (unget-string ($4 args) ib)]
|
|
[#\5 (loop (cddr ls)) (unget-string ($5 args) ib)]
|
|
[#\6 (loop (cddr ls)) (unget-string ($6 args) ib)]
|
|
[#\7 (loop (cddr ls)) (unget-string ($7 args) ib)]
|
|
[#\8 (loop (cddr ls)) (unget-string ($8 args) ib)]
|
|
[#\9 (loop (cddr ls)) (unget-string ($9 args) ib)]
|
|
[else (loop (cdr ls)) (m4-unget-char (car ls) ib)])))))))
|
|
|
|
(define-builtin-macro "divert"
|
|
(lambda (args ib)
|
|
(set! *divnum*
|
|
(if (string=? ($1 args) "")
|
|
0
|
|
(case (string-ref ($1 args) 0)
|
|
[#\0 0]
|
|
[#\1 1]
|
|
[#\2 2]
|
|
[#\3 3]
|
|
[#\4 4]
|
|
[#\5 5]
|
|
[#\6 6]
|
|
[#\7 7]
|
|
[#\8 8]
|
|
[#\9 9]
|
|
[else -1])))
|
|
(when (and (<= 1 *divnum* 9) (not (vector-ref *diversions* *divnum*)))
|
|
(vector-set! *diversions* *divnum* (open-output-string)))))
|
|
|
|
(define-builtin-macro "divnum"
|
|
(lambda (args ib)
|
|
(unget-string (format "~a" *divnum*) ib)))
|
|
|
|
(define-builtin-macro "dnl"
|
|
(lambda (args ib)
|
|
(let loop ()
|
|
(let ([c (m4-get-char ib)])
|
|
(cond
|
|
[(eof-object? c) '()]
|
|
[(char=? c #\newline) '()]
|
|
[else (loop)])))))
|
|
|
|
(define-builtin-macro "dumpdef"
|
|
(lambda (args ib)
|
|
(printf "m4 warning: no dumpdef yet~%")))
|
|
|
|
(define-builtin-macro "errprint"
|
|
(lambda (args ib)
|
|
(display ($1 args) *error-output*)
|
|
(newline *error-output*)))
|
|
|
|
(define-builtin-macro "eval"
|
|
(lambda (args ib)
|
|
(unget-string (int->str (eval-string ($1 args))) ib)))
|
|
|
|
(define-builtin-macro "ifdef"
|
|
(lambda (args ib)
|
|
(unget-string ((if (assoc ($1 args) *macros*) $2 $3) args) ib)))
|
|
|
|
(define-builtin-macro "ifelse"
|
|
(rec ifelse
|
|
(lambda (args ib)
|
|
(if (string=? ($1 args) ($2 args))
|
|
(unget-string ($3 args) ib)
|
|
(if (> (length args) 4)
|
|
(ifelse ($$ ($$ ($$ args))) ib)
|
|
(unget-string ($4 args) ib))))))
|
|
|
|
(define-builtin-macro "include"
|
|
(lambda (args ib)
|
|
(printf "m4 warning: no include yet~%")))
|
|
|
|
(define-builtin-macro "incr"
|
|
(lambda (args ib)
|
|
(unget-string (int->str (+ (str->int ($1 args)) 1)) ib)))
|
|
|
|
(define-builtin-macro "index"
|
|
(lambda (args ib)
|
|
(let ([s1 ($1 args)] [s2 ($2 args)])
|
|
(let ([n1 (string-length s1)] [n2 (string-length s2)])
|
|
(let find ([i 0])
|
|
(if (fx> n2 (fx- n1 i))
|
|
(unget-string "-1" ib)
|
|
(let try ([i1 i] [i2 0])
|
|
(if (fx= i2 n2)
|
|
(unget-string (int->str i) ib)
|
|
(if (char=? (string-ref s1 i1) (string-ref s2 i2))
|
|
(try (fx+ i1 1) (fx+ i2 1))
|
|
(find (fx+ i 1)))))))))))
|
|
|
|
(define-builtin-macro "len"
|
|
(lambda (args ib)
|
|
(unget-string (int->str (string-length ($1 args))) ib)))
|
|
|
|
(define-builtin-macro "maketemp"
|
|
(lambda (args ib)
|
|
(printf "m4 warning: no maketemp yet~%")))
|
|
|
|
(define-builtin-macro "shift"
|
|
(lambda (args ib)
|
|
(printf "m4 warning: no shift yet~%")))
|
|
|
|
(define-builtin-macro "sinclude"
|
|
(lambda (args ib)
|
|
(printf "m4 warning: no sinclude yet~%")))
|
|
|
|
(define-builtin-macro "substr"
|
|
(lambda (args ib)
|
|
(let ([s ($1 args)] [start ($2 args)] [count ($3 args)])
|
|
(let ([n (string-length s)])
|
|
(let ([start (min (max (str->int start) 0) n)])
|
|
(let ([end (if (string=? count "")
|
|
n
|
|
(min (max (+ (str->int count) start) start) n))])
|
|
(unget-string (substring s start end) ib)))))))
|
|
|
|
(define-builtin-macro "syscmd"
|
|
;;; cannot be written in Scheme---needs something more powerful than
|
|
;;; "system" or "process"
|
|
(lambda (args ib)
|
|
(printf "m4 warning: no syscmd yet~%")))
|
|
|
|
(define-builtin-macro "translit"
|
|
(lambda (args ib)
|
|
(let ([s1 ($1 args)] [s2 ($2 args)] [s3 ($3 args)])
|
|
(let ([n1 (string-length s1)] [n2 (string-length s2)])
|
|
(unless (= n2 (string-length s3))
|
|
(error 'm4 "translit arguments ~s and ~s are not of same length"
|
|
s2 s3))
|
|
(when (null? *translit-table*)
|
|
(set! *translit-table* (make-string 256)))
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i 256))
|
|
(string-set! *translit-table* i (integer->char i)))
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i n2))
|
|
(string-set! *translit-table*
|
|
(char->integer (string-ref s2 i))
|
|
(string-ref s3 i)))
|
|
(let ([s4 (make-string n1)])
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i n1))
|
|
(string-set! s4 i
|
|
(string-ref *translit-table*
|
|
(char->integer (string-ref s1 i)))))
|
|
(unget-string s4 ib))))))
|
|
|
|
(define-builtin-macro "undefine"
|
|
(lambda (args ib)
|
|
(let ([a (assoc ($1 args) *macros*)])
|
|
(unless a (error 'm4 "cannot undefine ~s (not defined)" ($1 args)))
|
|
(set-car! a #f))))
|
|
|
|
(define-builtin-macro "undivert"
|
|
(rec myself
|
|
(lambda (args ib)
|
|
(if (null? args)
|
|
(myself '("1" "2" "3" "4" "5" "6" "7" "8" "9") ib)
|
|
(for-each
|
|
(lambda (x)
|
|
(case (and (not (string=? x "")) (string-ref x 0))
|
|
[#\1 (undivert 1)]
|
|
[#\2 (undivert 2)]
|
|
[#\3 (undivert 3)]
|
|
[#\4 (undivert 4)]
|
|
[#\5 (undivert 5)]
|
|
[#\6 (undivert 6)]
|
|
[#\7 (undivert 7)]
|
|
[#\8 (undivert 8)]
|
|
[#\9 (undivert 9)]))
|
|
args)))))
|
|
|
|
(define undivert
|
|
(lambda (n)
|
|
(let ([op (vector-ref *diversions* n)])
|
|
(when op
|
|
(display (get-output-string op) (vector-ref *diversions* 0))))))
|