pmacros.scm from Gdb at Krugle
Show pmacros.scm syntax highlighted
; Preprocessor-like macro support.
; Copyright (C) 2000 Red Hat, Inc.
; This file is part of CGEN.
; See file COPYING.CGEN for details.
; TODO:
; - Like C preprocessor macros, there is no scoping [one can argue
; there should be]. Maybe in time (??? Hmmm... done?)
; On the other hand these macros aren't intended for use outside
; the cpu description file.
; - Support for multiple macro tables.
; - Comments for .pmacros.
; Required routines:
; make-hash-table, hashq-ref, hashq-set!
; string-append, symbol-append, map, apply, number?, number->string,
; eval, num-args-ok?, *UNSPECIFIED*.
; `num-args-ok?' and `*UNSPECIFIED*' are defined in cgen's utils.scm.
; The convention we use says `-' begins "local" objects.
; At some point this might also use the Guile module system.
; Exported routines:
;
; pmacro-init! - initialize the pmacro system
;
; define-pmacro - define a symbolic or procedural macro
;
; (define-pmacro symbol "comment" expansion)
; (define-pmacro (symbol [args]) "comment" (expansion))
;
; ARGS is a list of `symbol' or `(symbol default-value)' elements.
;
; pmacro-expand - expand all macros in an expression
;
; (pmacro-expand expression)
;
; pmacro-trace - same as pmacro-expand, but print debugging messages
;
; (pmacro-trace expression)
; Builtin macros:
;
; (.sym symbol1 symbol2 ...) - symbolstr-append
; (.str string1 string2 ...) - stringsym-append
; (.hex number) - convert to hex string
; (.upcase string) - convert to uppercase
; (.downcase string) - convert to lowercase
; (.substring string start end) - get part of a string
; (.splice a b (.unsplice c) d e ...) - quasi-quote/unquote-splicing
; (.iota count [start [increment]]) - number generator
; (.map macro-name arg1 ...) - map
; (.apply macro-name arg) - apply
; (.pmacro (arg-list) expansion) - lambda (??? call it .lambda?)
; (.eval (expr)) - eval (experimental)
;
; .sym and .str convert numbers to symbols/strings as necessary (base 10).
;
; .pmacro is for constructing pmacros on-the-fly, like lambda, and is currently
; only valid as arguments to other macros.
; ??? Nested pmacros don't bind their arguments the way nested lambda's do.
; Should they?
;
; .eval is an experiment. Ports that consider themselves to be of beta
; quality or better don't use it.
;
; ??? Methinks .foo isn't a valid R5RS symbol. May need to change
; to something else. Where's Quad when you need it?! :-)
(define -pmacro-trace? #f)
(define -pmacro-table #f)
(define (-pmacro-lookup name) (hashq-ref -pmacro-table name))
(define (-pmacro-set! name val) (hashq-set! -pmacro-table name val))
; Marker to indicate a value is a pmacro.
(define -pmacro-marker '<pmacro>)
; Utilities to create and access pmacros.
(define (-pmacro-make name arg-spec default-values transformer comment)
(vector -pmacro-marker name arg-spec default-values transformer comment)
)
(define (-pmacro? x) (and (vector? x) (eq? (vector-ref x 0) -pmacro-marker)))
(define (-pmacro-name pmac) (vector-ref pmac 1))
(define (-pmacro-arg-spec pmac) (vector-ref pmac 2))
(define (-pmacro-default-values pmac) (vector-ref pmac 3))
(define (-pmacro-transformer pmac) (vector-ref pmac 4))
(define (-pmacro-comment pmac) (vector-ref pmac 5))
; Cover functions to manage an "environment" in case a need or desire for
; another method arises.
(define (-pmacro-env-make names values) (map cons names values))
(define (-pmacro-env-ref env name) (assq name env))
; Error message generator.
(define (-pmacro-error msg expr)
(error (string-append
(or (port-filename (current-input-port)) "<input>")
":"
(number->string (port-line (current-input-port)))
":"
msg
":")
expr)
)
; Process list of keyword/value specified arguments.
(define (-pmacro-process-keyworded-args arg-spec default-values args)
; Build a list of default values, then override ones specified in ARGS,
(let ((result-alist (alist-copy default-values)))
(let loop ((args args))
(cond ((null? args)
#f) ; done
((and (pair? args) (keyword? (car args)))
(let ((elm (assq (car args) result-alist)))
(if (not elm)
(-pmacro-error "not an argument name" (car args)))
(if (null? (cdr args))
(-pmacro-error "missing argument to #:keyword" (car args)))
(set-cdr! elm (cadr args))
(loop (cddr args))))
(else
(-pmacro-error "bad keyword/value argument list" args))))
; Ensure each element has a value.
(let loop ((to-scan result-alist))
(if (null? to-scan)
#f ; done
(begin
(if (not (cdar to-scan))
(-pmacro-error "argument value not specified" (caar to-scan)))
(loop (cdr to-scan)))))
; If varargs pmacro, adjust result.
(if (list? arg-spec)
(map cdr result-alist) ; not varargs
(let ((nr-args (length (result-alist))))
(append! (map cdr (list-head result-alist (- nr-args 1)))
(cdr (list-tail result-alist (- nr-args 1)))))))
)
; Process a pmacro argument list.
; ARGS is either a fully specified position dependent argument list,
; or is a list of keyword/value pairs with missing values coming from
; DEFAULT-VALUES.
(define (-pmacro-process-args arg-spec default-values args)
(if (and (pair? args) (keyword? (car args)))
(-pmacro-process-keyworded-args arg-spec default-values args)
args)
)
; Invoke a procedural macro.
; ??? A better name might be -pmacro-apply but that is taken by the
; .apply handler.
(define (-pmacro-invoke macro args)
(let ((arg-spec (-pmacro-arg-spec macro))
(default-values (-pmacro-default-values macro)))
(let ((processed-args (-pmacro-process-args arg-spec default-values args)))
(if (not (num-args-ok? (length processed-args) arg-spec))
(-pmacro-error (string-append
"wrong number of arguments to pmacro "
(with-output-to-string
(lambda ()
(write (cons (-pmacro-name macro)
(-pmacro-arg-spec macro))))))
args))
(apply (-pmacro-transformer macro) processed-args)))
)
; Expand expression EXP using ENV, an alist of variable assignments.
(define (-pmacro-expand exp env)
(define cep (current-error-port))
; If the symbol is in `env', return its value.
; Otherwise see if symbol is a globally defined pmacro.
; Otherwise return the symbol unchanged.
(define (scan-symbol sym)
(let ((val (-pmacro-env-ref env sym)))
(if val
(cdr val) ; cdr is value of (name . value) pair
(let ((val (-pmacro-lookup sym)))
(if val
; Symbol is a macro.
; If this is a procedural macro, let caller perform expansion.
; Otherwise, return the macro's value.
(if (procedure? (-pmacro-transformer val))
val
(-pmacro-transformer val))
; Return symbol unchanged.
sym)))))
; See if (car exp) is a macro.
; Return macro or #f.
(define (check-macro exp)
(if -pmacro-trace?
(begin
(display "macro? " cep)
(write exp cep)
(newline cep)))
(and (-pmacro? (car exp)) (car exp)))
; Scan each element in EXP and see if the result is a macro invocation.
(define (scan-list exp)
; Check for syntactic forms.
(case (car exp)
((.pmacro)
(if (not (= (length exp) 3))
(-pmacro-error "wrong number of arguments to .pmacro" exp))
(-pmacro-pmacro (cadr exp) (caddr exp)))
(else
(let ((scanned-exp (map scan exp)))
(let ((macro (check-macro scanned-exp)))
(if macro
(if (procedure? (-pmacro-transformer macro))
(-pmacro-invoke macro (cdr scanned-exp))
(cons (-pmacro-transformer macro) (cdr scanned-exp)))
scanned-exp))))))
; Scan EXP, an arbitrary value.
(define (scan exp)
(let ((result (cond ((symbol? exp) (scan-symbol exp))
((and (list? exp) (not (null? exp))) (scan-list exp))
; Not a symbol or expression, return unchanged.
(else exp))))
; Re-examining `result' to see if it is another pmacro invocation
; allows doing things like ((.sym a b c) arg1 arg2)
; where `abc' is a pmacro. Scheme doesn't work this way, but then
; this is CGEN.
(if (symbol? result) (scan-symbol result) result)))
(if -pmacro-trace?
(begin
; We use `write' to display `exp' to see strings quoted.
(display "expand: " cep) (write exp cep) (newline cep)
(display " env: " cep) (display env cep) (newline cep)))
(let ((result (scan exp)))
(if -pmacro-trace?
(begin
(display "result: " cep) (write result cep) (newline cep)))
result)
)
; Return the argument spec from ARGS.
; ARGS is a [possibly improper] list of `symbol' or `(symbol default-value)'
; elements. For varargs pmacros, ARGS must be an improper list
; (e.g. (a b . c)) with the last element being a symbol.
(define (-pmacro-get-arg-spec args)
(let ((parse-arg
(lambda (arg)
(cond ((symbol? arg)
arg)
((and (pair? arg) (symbol? (car arg)))
(car arg))
(else
(-pmacro-error "argument not `symbol' or `(symbol . default-value)'"
arg))))))
(if (list? args)
(map parse-arg args)
(letrec ((parse-improper-list
(lambda (args)
(cond ((symbol? args)
args)
((pair? args)
(cons (parse-arg (car args))
(parse-improper-list (cdr args))))
(else
(-pmacro-error "argument not `symbol' or `(symbol . default-value)'"
args))))))
(parse-improper-list args))))
)
; Return the default values specified in ARGS.
; The result is an alist of (#:arg-name . default-value) elements.
; ARGS is a [possibly improper] list of `symbol' or `(symbol . default-value)'
; elements. For varargs pmacros, ARGS must be an improper list
; (e.g. (a b . c)) with the last element being a symbol.
; Unspecified default values are recorded as #f.
(define (-pmacro-get-default-values args)
(let ((parse-arg
(lambda (arg)
(cond ((symbol? arg)
(cons (symbol->keyword arg) #f))
((and (pair? arg) (symbol? (car arg)))
(cons (symbol->keyword (car arg)) (cdr arg)))
(else
(-pmacro-error "argument not `symbol' or `(symbol . default-value)'"
arg))))))
(if (list? args)
(map parse-arg args)
(letrec ((parse-improper-list
(lambda (args)
(cond ((symbol? args)
(cons (parse-arg args) nil))
((pair? args)
(cons (parse-arg (car args))
(parse-improper-list (cdr args))))
(else
(-pmacro-error "argument not `symbol' or `(symbol . default-value)'"
args))))))
(parse-improper-list args))))
)
; Build a procedure that performs a pmacro expansion.
(define (-pmacro-build-lambda params expansion)
(eval1 `(lambda ,params
(-pmacro-expand ',expansion (-pmacro-env-make ',params (list ,@params)))))
)
; ??? I'd prefer to use `define-macro', but boot-9.scm uses it and
; I'd rather not risk a collision. I could of course make the association
; during parsing, maybe later.
; ??? On the other hand, calling them pmacros removes all ambiguity.
;
; The syntax is one of:
; (define (name args ...) expansion)
; (define (name args ...) "documentation" expansion)
;
; If `expansion' is the name of a pmacro, its value is used (rather than its
; name).
; ??? The goal here is to follow Scheme's define/lambda, but not all variants
; are supported yet. There's also the difference that we treat undefined
; symbols as being themselves.
(define (define-pmacro header arg1 . arg-rest)
(let ((name (if (symbol? header) header (car header)))
(arg-spec (if (symbol? header) #f (-pmacro-get-arg-spec (cdr header))))
(default-values (if (symbol? header) #f (-pmacro-get-default-values (cdr header))))
(comment (if (null? arg-rest) "" arg1))
(expansion (if (null? arg-rest) arg1 (car arg-rest))))
(if (symbol? header)
(if (symbol? expansion)
(let ((maybe-pmacro (-pmacro-lookup expansion)))
(if maybe-pmacro
(-pmacro-set! name
(-pmacro-make name
(-pmacro-arg-spec maybe-pmacro)
(-pmacro-default-values maybe-pmacro)
(-pmacro-transformer maybe-pmacro)
comment))
(-pmacro-set! name (-pmacro-make name #f #f expansion comment))))
(-pmacro-set! name (-pmacro-make name #f #f expansion comment)))
(-pmacro-set! name
(-pmacro-make name arg-spec default-values
(-pmacro-build-lambda arg-spec expansion)
comment))))
*UNSPECIFIED*
)
; Expand any pmacros in EXPR.
(define (pmacro-expand expr)
(-pmacro-expand expr '())
)
; Debugging routine to trace macro expansion.
(define (pmacro-trace expr)
; ??? Need unwind protection.
(let ((old -pmacro-trace?))
(set! -pmacro-trace? #t)
(let ((result (-pmacro-expand expr '())))
(set! -pmacro-trace? old)
result))
)
; Builtin macros.
; .sym - symbol-append, auto-convert numbers
(define -pmacro-sym
(lambda args
(string->symbol
(apply string-append
(map (lambda (elm)
(cond ((number? elm) (number->string elm))
((symbol? elm) (symbol->string elm))
((string? elm) elm)
(else
(-pmacro-error "invalid argument to .str" elm))))
args))))
)
; .str - string-append, auto-convert numbers
(define -pmacro-str
(lambda args
(apply string-append
(map (lambda (elm)
(cond ((number? elm) (number->string elm))
((symbol? elm) (symbol->string elm))
((string? elm) elm)
(else
(-pmacro-error "invalid argument to .str" elm))))
args)))
)
; .hex - convert number to hex string
; WIDTH, if present, is the number of characters in the result, beginning
; from the least significant digit.
(define (-pmacro-hex num . width)
(if (> (length width) 1)
(-pmacro-error "wrong number of arguments to .hex"
(cons '.hex (cons num width))))
(let ((str (number->string num 16)))
(if (null? width)
str
(let ((len (string-length str)))
(substring (string-append (make-string (car width) #\0) str)
len (+ len (car width))))))
)
; .upcase - convert a string to uppercase
(define (-pmacro-upcase str)
(cond
((string? str) (string-upcase str))
((symbol? str) (string->symbol (string-upcase (symbol->string str))))
(else (-pmacro-error "invalid argument to .upcase" str)))
)
; .downcase - convert a string to lowercase
(define (-pmacro-downcase str)
(cond
((string? str) (string-downcase str))
((symbol? str) (string->symbol (string-downcase (symbol->string str))))
(else (-pmacro-error "invalid argument to .downcase" str)))
)
; .substring - get part of a string
(define (-pmacro-substring str start end)
(substring str start end)
)
; .splice - splicing support
; Splice lists into the outer list.
;
; E.g. (define-pmacro '(splice-test a b c) '(.splice a (.unsplice b) c))
; (pmacro-expand '(splice-test (1 (2) 3))) --> (1 2 3)
;
; Similar to `(1 ,@'(2) 3) in Scheme, though the terminology is slightly
; different (??? may need to revisit). In Scheme we have quasi-quote,
; unquote, unquote-splicing. Here we have splice, unsplice.
(define -pmacro-splice
(lambda arg-list
; ??? Not the most efficient implementation, but will the difference
; ever be measureable?
(let loop ((arg-list arg-list) (result '()))
(cond ((null? arg-list) result)
((and (pair? (car arg-list)) (eq? '.unsplice (caar arg-list)))
(if (= (length (car arg-list)) 2)
(if (list? (cadar arg-list))
(loop (cdr arg-list) (append result (cadar arg-list)))
(-pmacro-error "argument to .unsplice must be a list"
(car arg-list)))
(-pmacro-error "wrong number of arguments to .unsplice"
(car arg-list))))
(else
(loop (cdr arg-list) (append result (list (car arg-list))))))))
)
; .iota
; Usage:
; (.iota count) ; start=0, incr=1
; (.iota count start) ; incr=1
; (.iota count start incr)
(define (-pmacro-iota count . start-incr)
(if (> (length start-incr) 2)
(-pmacro-error "wrong number of arguments to .iota"
(cons '.iota (cons count start-incr))))
(if (< count 0)
(-pmacro-error "count must be non-negative"
(cons '.iota (cons count start-incr))))
(let ((start (if (pair? start-incr) (car start-incr) 0))
(incr (if (= (length start-incr) 2) (cadr start-incr) 1)))
(let loop ((i start) (count count) (result '()))
(if (= count 0)
(reverse! result)
(loop (+ i incr) (- count 1) (cons i result)))))
)
; .map
(define (-pmacro-map pmacro arg1 . arg-rest)
(if (not (-pmacro? pmacro))
(-pmacro-error "not a pmacro" pmacro))
(let ((transformer (-pmacro-transformer pmacro)))
(if (not (procedure? transformer))
(-pmacro-error "not a procedural macro" pmacro))
(apply map (cons transformer (cons arg1 arg-rest))))
)
; .apply
(define (-pmacro-apply pmacro arg-list)
(if (not (-pmacro? pmacro))
(-pmacro-error "not a pmacro" pmacro))
(let ((transformer (-pmacro-transformer pmacro)))
(if (not (procedure? transformer))
(-pmacro-error "not a procedural macro" pmacro))
(apply transformer arg-list))
)
; .pmacro
(define (-pmacro-pmacro params expansion)
(if (not (list? params))
(-pmacro-error "bad parameter list" params))
(-pmacro-make '.anonymous params #f (-pmacro-build-lambda params expansion) "")
)
; Initialization.
(define (pmacros-init!)
(set! -pmacro-table (make-hash-table 127))
; Some "predefined" macros.
(-pmacro-set! '.sym
(-pmacro-make '.sym 'symbols #f -pmacro-sym "symbol-append"))
(-pmacro-set! '.str
(-pmacro-make '.str 'strings #f -pmacro-str "string-append"))
(-pmacro-set! '.hex
(-pmacro-make '.hex '(number . width) #f -pmacro-hex
"convert to hex, with optional width"))
(-pmacro-set! '.upcase
(-pmacro-make '.upcase '(string) #f
-pmacro-upcase "string-upcase"))
(-pmacro-set! '.downcase
(-pmacro-make '.downcase '(string) #f
-pmacro-downcase "string-downcase"))
(-pmacro-set! '.substring
(-pmacro-make '.substring '(string start end) #f
-pmacro-substring "get part of a string"))
(-pmacro-set! '.splice
(-pmacro-make '.splice 'arg-list #f -pmacro-splice
"splice lists into the outer list"))
(-pmacro-set! '.iota
(-pmacro-make '.iota '(count . start-incr) #f -pmacro-iota
"iota number generator"))
(-pmacro-set! '.map
(-pmacro-make '.map '(macro-name arg1 . arg-rest) #f
-pmacro-map
"map a macro over a list of arguments"))
(-pmacro-set! '.apply
(-pmacro-make '.apply '(macro-name arg-list) #f -pmacro-apply
"apply a macro, taking arguments from a list"))
(-pmacro-set! '.pmacro
(-pmacro-make '.pmacro '(params expansion) #f -pmacro-pmacro
"create a pmacro on-the-fly"))
; doesn't work, Hobbit creates "eval" variable
;(-pmacro-set! '.eval (-pmacro-make '.eval '(expr) #f eval "eval"))
(-pmacro-set! '.eval (-pmacro-make '.eval '(expr) #f (eval1 'eval1) "eval"))
)
; Initialize so we're ready to use after loading.
(pmacros-init!)
See more files for this project here