zilch/lang/rust/src/cfg.sld

(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))))))
   (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))

   (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))))))