(zilch lang rust): initial commit

lang/rust/src/cfg.sld

@@ -0,0 +1,124 @@
+(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))))))