134 lines
5.3 KiB
Scheme
134 lines
5.3 KiB
Scheme
;; Procedures to parse `cfg` attributes, as well as match them against
|
|
;; conditionals found in crate definitions.
|
|
(define-library (zilch lang rust cfg)
|
|
(import
|
|
(scheme base)
|
|
(srfi 152))
|
|
|
|
(export cfg-parse cfg-matches)
|
|
|
|
(begin
|
|
(define (is-ident-start ch)
|
|
(or
|
|
(char=? ch #\_)
|
|
(and (char>=? ch #\A) (char<=? ch #\Z))
|
|
(and (char>=? ch #\a) (char<=? ch #\z))))
|
|
|
|
(define (is-ident-rest ch)
|
|
(or
|
|
(is-ident-start ch)
|
|
(and (char>=? ch #\0) (char<=? ch #\9))))
|
|
|
|
(define (tokenize-cfg strval index tail)
|
|
(if (>= index (string-length strval))
|
|
(reverse tail)
|
|
(case (string-ref strval index)
|
|
((#\space) (tokenize-cfg strval (+ index 1) tail))
|
|
((#\x28) (tokenize-cfg strval (+ index 1) (cons 'left-paren tail)))
|
|
((#\x29) (tokenize-cfg strval (+ index 1) (cons 'right-paren tail)))
|
|
((#\,) (tokenize-cfg strval (+ index 1) (cons 'comma tail)))
|
|
((#\=) (tokenize-cfg strval (+ index 1) (cons 'equals tail)))
|
|
((#\")
|
|
(let ((end (string-index strval (lambda (f) (char=? f #\")) (+ index 1))))
|
|
(unless end (error "Unterminated string in cfg() string" strval))
|
|
(tokenize-cfg strval (+ end 1) (cons (string-copy strval (+ index 1) end) tail))))
|
|
(else
|
|
(if (is-ident-start (string-ref strval index))
|
|
(let ((end (or (string-skip strval is-ident-rest (+ index 1)) (string-length strval))))
|
|
(tokenize-cfg strval end (cons (cons 'ident (string-copy strval index end)) tail)))
|
|
(error "Unexpected character in cfg() string" strval))))))
|
|
|
|
;; Parses a configuration string or expression.
|
|
;;
|
|
;; - `key="value"` is represented as `('value . (key . value))`, where value can be `#f`.
|
|
;; - `all` and `any` are represented as `('all/'any . items)`, where `items` is a list of sub-expressions.
|
|
;; - `not(...)` is represented as `('not . value)`, where `value` is a sub-expression.
|
|
(define (cfg-parse str)
|
|
(define tokens (tokenize-cfg str 0 '()))
|
|
(define (expect token)
|
|
(when (null? tokens)
|
|
(error "Unexpected EOF parsing cfg() string"))
|
|
(unless (equal? token (car tokens))
|
|
(error "Unexpected token" (cons (car tokens) token)))
|
|
(set! tokens (cdr tokens)))
|
|
(define (next)
|
|
(define tok (car tokens))
|
|
(set! tokens (cdr tokens))
|
|
tok)
|
|
(define (parse-cfg)
|
|
(when (null? tokens)
|
|
(error "Unexpected EOF parsing cfg() string"))
|
|
(define token (next))
|
|
(unless (and (pair? token) (equal? (car token) 'ident))
|
|
(error "Unexpected token, expected identifier" token))
|
|
(if (and (not (null? tokens)) (equal? (car tokens) 'equals))
|
|
(begin
|
|
(next)
|
|
(let ((str-token (next)))
|
|
(unless (string? str-token)
|
|
(error "Unexpected token parsing cfg=, expected string" str-token))
|
|
(values (cdr token) str-token)))
|
|
(values (cdr token) #f)))
|
|
|
|
; Also consumes the right paren.
|
|
(define (parse-comma-separated-expr tail)
|
|
(when (null? tokens)
|
|
(error "Unexpected EOF parsing cfg() expression contents"))
|
|
(if (equal? (car tokens) 'right-paren)
|
|
(begin (next) (reverse tail))
|
|
(let ((parsed (parse-expr)))
|
|
(if (or (null? tokens) (equal? (car tokens) 'comma))
|
|
(begin (expect 'comma) (parse-comma-separated-expr (cons parsed tail)))
|
|
(begin (expect 'right-paren) (reverse (cons parsed tail)))))))
|
|
(define (parse-expr)
|
|
(when (null? tokens)
|
|
(error "Unexpected EOF parsing cfg() expression"))
|
|
(define token (car tokens))
|
|
(unless (and (pair? token) (equal? (car token) 'ident))
|
|
(error "Unexpected token, expected identifier" token))
|
|
(cond
|
|
((string=? (cdr token) "all")
|
|
(next)
|
|
(expect 'left-paren)
|
|
(let ((tokens (parse-comma-separated-expr '())))
|
|
(cons 'all tokens)))
|
|
((string=? (cdr token) "any")
|
|
(next)
|
|
(expect 'left-paren)
|
|
(let ((tokens (parse-comma-separated-expr '())))
|
|
(cons 'any tokens)))
|
|
((string=? (cdr token) "not")
|
|
(next)
|
|
(expect 'left-paren)
|
|
(let ((expr (parse-expr)))
|
|
(expect 'right-paren)
|
|
(cons 'not expr)))
|
|
(else
|
|
(let-values (((left right) (parse-cfg)))
|
|
(cons 'value (cons left right))))))
|
|
(parse-expr))
|
|
|
|
;; Checks whether the parsed expression `expr` matches against the list of
|
|
;; config value pairs in `cfgs`.
|
|
(define (cfg-matches expr cfgs)
|
|
(define (parse-any tail)
|
|
(cond
|
|
((null? tail) #f)
|
|
((cfg-matches (car tail) cfgs) #t)
|
|
(else (parse-any (cdr tail)))))
|
|
(define (parse-all tail)
|
|
(cond
|
|
((null? tail) #t)
|
|
((not (cfg-matches (car tail) cfgs)) #f)
|
|
(else (parse-all (cdr tail)))))
|
|
(define (has-match-in-cfg pair tail)
|
|
(cond
|
|
((null? tail) #f)
|
|
((equal? pair (car tail)) #t)
|
|
(else (has-match-in-cfg pair (cdr tail)))))
|
|
(case (car expr)
|
|
((value) (has-match-in-cfg (cdr expr) cfgs))
|
|
((any) (parse-any (cdr expr)))
|
|
((all) (parse-all (cdr expr)))
|
|
((not) (not (cfg-matches (cdr expr) cfgs)))
|
|
(else (error "unknown cfg expression" expr))))))
|