461 lines
21 KiB
Scheme
461 lines
21 KiB
Scheme
(define-library (zilch lang ninja)
|
|
(import
|
|
(scheme base) (scheme write) (scheme process-context) (scheme lazy)
|
|
(zilch file) (zilch magic) (zilch nix drv) (zilch nix path) (scheme char)
|
|
(zilch nixpkgs) (zilch zexpr) (zilch semver)
|
|
json
|
|
(chicken process)
|
|
(chicken base) (chicken format)
|
|
(chicken foreign)
|
|
(srfi 4) (srfi 128) (srfi 146) (srfi 152) (srfi 207))
|
|
|
|
(export
|
|
<build-file> make-build-file build-file?
|
|
build-file-global-variables build-file-default-targets build-file-rules build-file-build-edges
|
|
build-file-pools
|
|
|
|
<build-rule> make-build-rule build-rule?
|
|
build-rule-name build-rule-command build-rule-depfile build-rule-deps build-rule-description
|
|
build-rule-restat build-rule-rspfile build-rule-rspfile-content
|
|
|
|
<build-edge> make-build-edge build-edge?
|
|
build-edge-rule build-edge-outputs build-edge-inputs
|
|
build-edge-implicit-dependencies build-edge-order-only-dependencies build-edge-validations
|
|
build-edge-implicit-outputs build-edge-variables build-edge-resolved
|
|
|
|
read-ninja-file)
|
|
|
|
(begin
|
|
;; Write a properly escaped string to the provided port.
|
|
(define (write-variable-string port var as-path)
|
|
(string-for-each
|
|
(lambda (c)
|
|
(cond
|
|
((and as-path (member c '(#\space #\: #\$))) (write-char #\$ port))
|
|
((char=? c #\newline) (write-char #\$ port)))
|
|
(write-char c port)
|
|
(when (char=? c #\newline) (write-string " " port)))
|
|
var))
|
|
|
|
;; Writes a variable, prefixed with $ and curly-bracketed, to a port.
|
|
(define (write-variable port var)
|
|
(write-string (string-append "${" var "}") port))
|
|
|
|
;; Returns a string containing the contents of the evalstring, properly escaped.
|
|
(define (render-evalstring var as-path)
|
|
(define out (open-output-string))
|
|
(for-each
|
|
(lambda (chunk)
|
|
(cond
|
|
((string? chunk) (write-variable-string out chunk as-path))
|
|
((pair? chunk) (write-variable out (cdr chunk))))) (if (string? var) (list var) var))
|
|
(define str (get-output-string out))
|
|
(close-output-port out)
|
|
str)
|
|
|
|
(define (is-valid-varname-char ch simple)
|
|
(or
|
|
(and (char>=? ch #\a) (char<=? ch #\z))
|
|
(and (char>=? ch #\A) (char<=? ch #\Z))
|
|
(and (char>=? ch #\0) (char<=? ch #\9))
|
|
(char=? ch #\_) (char=? ch #\-)
|
|
(and (not simple) (char=? ch #\.))))
|
|
(define (is-valid-varname-byte ch simple)
|
|
(or
|
|
(and (>= ch #x61) (<= ch #x7A))
|
|
(and (>= ch #x41) (<= ch #x5A))
|
|
(and (>= ch #x30) (<= ch #x39))
|
|
(= ch #x5F) (= ch #x2D)
|
|
(and (not simple) (= ch #x2E))))
|
|
|
|
(define (is-valid-eval-string-char ch path)
|
|
(not
|
|
(or
|
|
(char=? ch #\null)
|
|
(char=? ch #\newline)
|
|
(char=? ch #\return)
|
|
(char=? ch #\$)
|
|
(and path
|
|
(or
|
|
(char=? ch #\space)
|
|
(char=? ch #\:)
|
|
(char=? ch #\|))))))
|
|
|
|
(define (is-valid-eval-string-byte ch path)
|
|
(not
|
|
(or
|
|
(= ch 0)
|
|
(= ch #x0A)
|
|
(= ch #x0D)
|
|
(= ch #x24)
|
|
(and path
|
|
(or
|
|
(= ch #x20)
|
|
(= ch #x3A)
|
|
(= ch #x7C))))))
|
|
|
|
(define (resolve-evalstring evalstr file rule edge is-command)
|
|
(define (find-value val)
|
|
(define res #f)
|
|
(when edge
|
|
(cond
|
|
((string=? val "in") (set! res (string-join (build-edge-inputs edge))))
|
|
((string=? val "in_newline") (set! res (string-join (build-edge-inputs edge) "\n")))
|
|
((string=? val "out") (set! res (string-join (build-edge-outputs edge))))
|
|
(else (set! res (mapping-ref/default (build-edge-variables edge) val #f)))))
|
|
(when rule
|
|
(cond
|
|
((member val '("command" "depfile" "deps" "msvc_deps_prefix" "description" "dyndep" "generator" "restat" "rspfile" "rspfile_content") string=?) (error "ambiguity in how to process build rules depending on build rules!"))))
|
|
(unless res
|
|
(set! res
|
|
(mapping-ref/default (build-file-global-variables file) val "")))
|
|
res)
|
|
(apply string-append
|
|
(map
|
|
(lambda (part)
|
|
(if (string? part)
|
|
part
|
|
(find-value (cdr part))))
|
|
evalstr)))
|
|
|
|
(define (pr out name value) (unless (eq? value #f) (fprintf out " ~A = ~A\n" name (render-evalstring value #f))))
|
|
|
|
;; Represents a Ninja build file.
|
|
(define-record-type <build-file>
|
|
(make-build-file global-variables default-targets rules build-edges pools)
|
|
build-file?
|
|
(global-variables build-file-global-variables set-build-file-global-variables!)
|
|
(default-targets build-file-default-targets set-build-file-default-targets!)
|
|
(rules build-file-rules set-build-file-rules!)
|
|
(build-edges build-file-build-edges set-build-file-build-edges!)
|
|
(pools build-file-pools set-build-file-pools!))
|
|
|
|
(define-record-printer (<build-file> file out)
|
|
(fprintf out "# debug build file\n")
|
|
(mapping-for-each (lambda (k v) (fprintf out "~A = ~A\n" k (render-evalstring v #f))) (build-file-global-variables file))
|
|
(unless (null? (build-file-default-targets file))
|
|
(fprintf out "default")
|
|
(for-each (lambda (v) (fprintf out " ~A" (render-evalstring v #t))) (build-file-default-targets file))
|
|
(fprintf out "\n"))
|
|
(mapping-for-each (lambda (k rule) (fprintf out "~S" rule)) (build-file-rules file))
|
|
(for-each (lambda (edge) (fprintf out "~S" edge)) (build-file-build-edges file)))
|
|
|
|
;; Represents a Ninja build rule.
|
|
; variables that are ignored for now: dyndep, generator, pool, msvc_deps_prefix
|
|
(define-record-type <build-rule>
|
|
(make-build-rule name command depfile deps description restat rspfile rspfile-content)
|
|
build-rule?
|
|
(name build-rule-name set-build-rule-name!)
|
|
(command build-rule-command set-build-rule-command!)
|
|
(depfile build-rule-depfile set-build-rule-depfile!)
|
|
(deps build-rule-deps set-build-rule-deps!)
|
|
(description build-rule-description set-build-rule-description!)
|
|
(restat build-rule-restat set-build-rule-restat!)
|
|
(rspfile build-rule-rspfile set-build-rule-rspfile!)
|
|
(rspfile-content build-rule-rspfile-content set-build-rule-rspfile-content!))
|
|
|
|
(define-record-printer (<build-rule> rule out)
|
|
(fprintf out "rule ~A\n" (build-rule-name rule))
|
|
(pr out "command" (build-rule-command rule))
|
|
(pr out "depfile" (build-rule-depfile rule))
|
|
(pr out "deps" (build-rule-deps rule))
|
|
(pr out "description" (build-rule-description rule))
|
|
(pr out "restat" (build-rule-restat rule))
|
|
(pr out "rspfile" (build-rule-rspfile rule))
|
|
(pr out "rspfile-content" (build-rule-rspfile-content rule))
|
|
(fprintf out "\n"))
|
|
|
|
;; Represents a Ninja build edge (aka one or more files built by this Ninja file)
|
|
(define-record-type <build-edge>
|
|
(make-build-edge rule outputs inputs implicit-dependencies order-only-dependencies validations implicit-outputs variables resolved)
|
|
build-edge?
|
|
(rule build-edge-rule)
|
|
(outputs build-edge-outputs)
|
|
(inputs build-edge-inputs)
|
|
(implicit-dependencies build-edge-implicit-dependencies)
|
|
(order-only-dependencies build-edge-order-only-dependencies)
|
|
(validations build-edge-validations)
|
|
(implicit-outputs build-edge-implicit-outputs)
|
|
(variables build-edge-variables set-build-edge-variables!)
|
|
(resolved build-edge-resolved set-build-edge-resolved!))
|
|
(define-record-printer (<build-edge> edge out)
|
|
(fprintf out "build")
|
|
(for-each (lambda (var) (fprintf out " ~A" (render-evalstring var #t))) (build-edge-outputs edge))
|
|
(fprintf out ": ~A" (build-edge-rule edge))
|
|
(for-each (lambda (var) (fprintf out " ~A" (render-evalstring var #t))) (build-edge-inputs edge))
|
|
(unless (null? (build-edge-implicit-dependencies edge))
|
|
(fprintf out " |")
|
|
(for-each (lambda (var) (fprintf out " ~A" (render-evalstring var #t))) (build-edge-implicit-dependencies edge)))
|
|
(unless (null? (build-edge-order-only-dependencies edge))
|
|
(fprintf out " ||")
|
|
(for-each (lambda (var) (fprintf out " ~A" (render-evalstring var #t))) (build-edge-order-only-dependencies edge)))
|
|
(unless (null? (build-edge-validations edge))
|
|
(fprintf out " |@")
|
|
(for-each (lambda (var) (fprintf out " ~A" (render-evalstring var #t))) (build-edge-validations edge)))
|
|
(fprintf out "\n")
|
|
(mapping-for-each (lambda (k v) (pr out k v)) (build-edge-variables edge))
|
|
(define rule (build-edge-resolved edge))
|
|
(when rule
|
|
(fprintf out " resolved rule ~A\n" (build-rule-name rule))
|
|
(pr out " command" (build-rule-command rule))
|
|
(pr out " depfile" (build-rule-depfile rule))
|
|
(pr out " deps" (build-rule-deps rule))
|
|
(pr out " description" (build-rule-description rule))
|
|
(pr out " restat" (build-rule-restat rule))
|
|
(pr out " rspfile" (build-rule-rspfile rule))
|
|
(pr out " rspfile-content" (build-rule-rspfile-content rule))
|
|
(fprintf out "\n"))
|
|
(fprintf out "\n"))
|
|
(define (build-rule-resolve rule edge file)
|
|
(define (try-resolve v is-command)
|
|
(and v (resolve-evalstring v file rule edge is-command)))
|
|
(make-build-rule #f
|
|
(try-resolve (build-rule-command rule) #t)
|
|
(try-resolve (build-rule-depfile rule) #f)
|
|
(try-resolve (build-rule-deps rule) #f)
|
|
(try-resolve (build-rule-description rule) #f)
|
|
(try-resolve (build-rule-restat rule) #f)
|
|
(try-resolve (build-rule-rspfile rule) #f)
|
|
(try-resolve (build-rule-rspfile-content rule) #f)))
|
|
|
|
(define (bytevector-prefix? bv in-bv index)
|
|
(define bv-len (bytevector-length bv))
|
|
(define (inner-loop j)
|
|
(cond
|
|
((>= j bv-len) #t)
|
|
((= (bytevector-u8-ref bv j) (bytevector-u8-ref in-bv (+ index j)))
|
|
(inner-loop (+ j 1)))
|
|
(else #f)))
|
|
(if (>= (+ index bv-len) (bytevector-length in-bv))
|
|
#f
|
|
(inner-loop 0)))
|
|
|
|
;; Reads a full Ninja file, returning a <build-file> record.
|
|
(define (read-ninja-file strval)
|
|
(define i 0)
|
|
(define (eat-whitespace)
|
|
(cond
|
|
((>= i (bytevector-length strval)))
|
|
((bytevector-prefix? #u8(#x24 #x0D #x0A) strval i) (set! i (+ i 3)) (eat-whitespace))
|
|
((bytevector-prefix? #u8(#x24 #x0A) strval i) (set! i (+ i 2)) (eat-whitespace))
|
|
((= (bytevector-u8-ref strval i) #x20) (set! i (bytestring-index strval (lambda (ch) (not (= ch #x20))) i)) (eat-whitespace))))
|
|
(define (read-eval-string-text path)
|
|
(define collected '())
|
|
(define start-i i)
|
|
(define (tick)
|
|
(cond
|
|
((>= i (bytevector-length strval)) (error "unexpected EOF"))
|
|
((is-valid-eval-string-byte (bytevector-u8-ref strval i) path)
|
|
(let ((start-i i))
|
|
(do () ((or (>= i (bytevector-length strval)) (not (is-valid-eval-string-byte (bytevector-u8-ref strval i) path))))
|
|
(set! i (+ i 1)))
|
|
(set! collected (cons (utf8->string strval start-i i) collected)))
|
|
(tick))
|
|
((and path (member (bytevector-u8-ref strval i) '(#x20 #x3A #x7C #x0A))))
|
|
((and (not path) (= #x0A (bytevector-u8-ref strval i)))
|
|
(set! i (+ i 1)))
|
|
((bytevector-prefix? #u8(#x0D #x0A) strval i)
|
|
(unless path
|
|
(set! i (+ i 2))))
|
|
((bytevector-prefix? #u8(#x24 #x0D #x0A) strval i)
|
|
(set! i (bytestring-index strval (lambda (ch) (not (= ch #x20))) (+ i 3)))
|
|
(tick))
|
|
((bytevector-prefix? #u8(#x24 #x0A) strval i)
|
|
(set! i (bytestring-index strval (lambda (ch) (not (= ch #x20))) (+ i 2)))
|
|
(tick))
|
|
((bytevector-prefix? #u8(#x24 #x7B) strval i)
|
|
(let ((end-of-varname (bytestring-index strval (lambda (ch) (not (is-valid-varname-byte ch #f))) (+ i 2))))
|
|
(unless (= (bytevector-u8-ref strval end-of-varname) #x7D) (error "unexpected non-varname character at index" end-of-varname))
|
|
(set! collected (cons (cons 'varname (utf8->string strval (+ i 2) end-of-varname)) collected))
|
|
(set! i (+ end-of-varname 1)))
|
|
(tick))
|
|
((or (bytevector-prefix? #u8(#x24 #x24) strval i) (bytevector-prefix? #u8(#x24 #x3A) strval i) (bytevector-prefix? #u8(#x24 #x20) strval i))
|
|
(set! collected (cons (utf8->string strval (+ i 1) (+ i 2)) collected))
|
|
(set! i (+ i 2))
|
|
(tick))
|
|
((and (= (bytevector-u8-ref strval i) #x24) (is-valid-varname-byte (bytevector-u8-ref strval (+ i 1)) #t))
|
|
(let ((end-of-varname (bytestring-index strval (lambda (ch) (not (is-valid-varname-byte ch #t))) (+ i 1))))
|
|
(set! collected (cons (cons 'varname (utf8->string strval (+ i 1) end-of-varname)) collected))
|
|
(set! i end-of-varname))
|
|
(tick))
|
|
((= (bytevector-u8-ref strval i) #x24)
|
|
(error "bad $-escape at index" i))
|
|
(else (error "Unknown character at index" i))))
|
|
(tick)
|
|
(when path (eat-whitespace))
|
|
(if (= i start-i) #f (reverse collected)))
|
|
|
|
(define (try-read-eval-string-text path)
|
|
(define start-i i)
|
|
(call/cc
|
|
(lambda (cc)
|
|
(with-exception-handler
|
|
(lambda (h) (set! i start-i) (cc #f))
|
|
(lambda () (read-eval-string-text path))))))
|
|
|
|
(define (read-token)
|
|
(define start-i i)
|
|
(define post-space (or (bytestring-index strval (lambda (ch) (not (= ch #x20))) i) i))
|
|
(define token
|
|
(cond
|
|
((>= i (bytevector-length strval))
|
|
'eof)
|
|
((bytevector-prefix? #u8(#x23) strval post-space)
|
|
(let ((end-of-comment (or (bytestring-index strval (lambda (ch) (= ch #x0A)) post-space) (bytevector-length strval))))
|
|
(set! i end-of-comment)
|
|
(read-token)))
|
|
((bytevector-prefix? #u8(#x0D #x0A) strval post-space)
|
|
(set! i (+ post-space 2))
|
|
'newline)
|
|
((bytevector-prefix? #u8(#x0A) strval post-space)
|
|
(set! i (+ post-space 1))
|
|
'newline)
|
|
((> post-space i)
|
|
'indent)
|
|
((= (bytevector-u8-ref strval i) #x3D)
|
|
(set! i (+ i 1))
|
|
'equals)
|
|
((= (bytevector-u8-ref strval i) #x3A)
|
|
(set! i (+ i 1))
|
|
'colon)
|
|
((bytevector-prefix? #u8(#x7C #x40) strval i)
|
|
(set! i (+ i 2))
|
|
'pipe-at)
|
|
((bytevector-prefix? #u8(#x7C #x7C) strval i)
|
|
(set! i (+ i 2))
|
|
'pipe-pipe)
|
|
((= (bytevector-u8-ref strval i) #x7C)
|
|
(set! i (+ i 1))
|
|
'pipe)
|
|
((is-valid-varname-byte (bytevector-u8-ref strval i) #f)
|
|
(let* ((token-end (bytestring-index strval (lambda (ch) (not (is-valid-varname-byte ch #f))) i))
|
|
(token (utf8->string strval i token-end)))
|
|
(set! i token-end)
|
|
(cond
|
|
((string=? token "build") 'build)
|
|
((string=? token "pool") 'pool)
|
|
((string=? token "rule") 'rule)
|
|
((string=? token "default") 'default)
|
|
((string=? token "include") 'include)
|
|
((string=? token "subninja") 'subninja)
|
|
(else token))))
|
|
(else #f)))
|
|
(unless (member token '(newline eof #f)) (eat-whitespace))
|
|
token)
|
|
(define (expect-token expected)
|
|
(define prev-i i)
|
|
(define token (read-token))
|
|
(if (eqv? expected token)
|
|
token
|
|
(begin (set! i prev-i) #f)))
|
|
|
|
(define (read-rule)
|
|
(define name (read-token))
|
|
(unless (string? name) (error "reading rule: expected valid ident, found" name))
|
|
(unless (expect-token 'newline) (error "reading rule: expected name to be followed by newline"))
|
|
(define rule (make-build-rule name #f #f #f #f #f #f #f))
|
|
(define (parse-variable)
|
|
(define name #f)
|
|
(define contents #f)
|
|
(when (expect-token 'indent)
|
|
(set! name (read-token))
|
|
(unless (string? name) (error "reading rule: expected name, found" name))
|
|
(unless (expect-token 'equals) (error "reading rule: expected equals, found" (read-token)))
|
|
(set! contents (read-eval-string-text #f))
|
|
(cond
|
|
((string=? name "command") (set-build-rule-command! rule contents))
|
|
((string=? name "depfile") (set-build-rule-depfile! rule contents))
|
|
((string=? name "deps") (set-build-rule-deps! rule contents))
|
|
((string=? name "description") (set-build-rule-description! rule contents))
|
|
((string=? name "restat") (set-build-rule-restat! rule contents))
|
|
((string=? name "rspfile") (set-build-rule-rspfile! rule contents))
|
|
((string=? name "rspfile_content") (set-build-rule-rspfile-content! rule contents))
|
|
((member name '("dyndep" "generator" "pool" "msvc_deps_prefix") string=?))
|
|
(else (error "reading rule: unexpected rule" name)))
|
|
(parse-variable)))
|
|
(parse-variable)
|
|
rule)
|
|
|
|
(define (read-pool)
|
|
(define name (read-token))
|
|
(unless (string? name) (error "reading pool: expected valid ident, found" name))
|
|
(unless (expect-token 'newline) (error "reading pool: expected name to be followed by newline"))
|
|
(define (parse-variable)
|
|
(define name #f)
|
|
(define contents #f)
|
|
(when (expect-token 'indent)
|
|
(set! name (read-token))
|
|
(unless (string? name) (error "reading pool: expected name, found" name))
|
|
(unless (expect-token 'equals) (error "reading poolo: expected equals, found" (read-token)))
|
|
(set! contents (read-eval-string-text #f))
|
|
(parse-variable)))
|
|
(parse-variable))
|
|
|
|
(define (read-build-edge file)
|
|
(define (read-list tail)
|
|
(define eval-string (try-read-eval-string-text #t))
|
|
(if eval-string
|
|
(read-list (cons (resolve-evalstring eval-string file #f #f #f) tail))
|
|
(reverse tail)))
|
|
|
|
(define outputs (read-list '()))
|
|
(define implicit-outputs '())
|
|
(when (expect-token 'pipe)
|
|
(set! implicit-outputs (read-list '())))
|
|
(unless (expect-token 'colon)
|
|
(error "reading build edge: expected colon, found" (read-token)))
|
|
(define rule-name (read-token))
|
|
(unless (string? rule-name)
|
|
(error "reading build edge: expected rule name, found" rule-name))
|
|
(define inputs (read-list '()))
|
|
(define implicit-dependencies '())
|
|
(when (expect-token 'pipe)
|
|
(set! implicit-dependencies (read-list '())))
|
|
(define order-only-dependencies '())
|
|
(when (expect-token 'pipe-pipe)
|
|
(set! order-only-dependencies (read-list '())))
|
|
(define validations '())
|
|
(when (expect-token 'pipe-at)
|
|
(set! validations (read-list '())))
|
|
(unless (expect-token 'newline) (error "reading build edge: expected rule name / dependencies to be followed by newline"))
|
|
(define edge (make-build-edge rule-name outputs inputs implicit-dependencies order-only-dependencies validations implicit-outputs (mapping (make-default-comparator)) #f))
|
|
(define (parse-variable)
|
|
(define name #f)
|
|
(define contents #f)
|
|
(when (expect-token 'indent)
|
|
(set! name (read-token))
|
|
(when (eq? name 'pool) (set! name "pool")) ; uh. how is this supposed to work
|
|
|
|
(unless (string? name) (error "reading build edge var: expected name, found" name))
|
|
(unless (expect-token 'equals) (error "reading build edge var: expected equals, found" (read-token)))
|
|
(set! contents (resolve-evalstring (read-eval-string-text #f) file #f #f #f))
|
|
(set-build-edge-variables! edge (mapping-set! (build-edge-variables edge) name contents))
|
|
(parse-variable)))
|
|
(parse-variable)
|
|
edge)
|
|
|
|
(define (read-toplevel file)
|
|
(define token (read-token))
|
|
(case token
|
|
((eof) #f)
|
|
((rule)
|
|
(let ((rule (read-rule))) (set-build-file-rules! file (mapping-set! (build-file-rules file) (build-rule-name rule) rule)))
|
|
(read-toplevel file))
|
|
((build)
|
|
(let ((edge (read-build-edge file))) (set-build-file-build-edges! file (cons edge (build-file-build-edges file))))
|
|
(read-toplevel file))
|
|
((default)
|
|
(do () ((expect-token 'newline)) (set-build-file-default-targets! file (cons (resolve-evalstring (read-eval-string-text #t) file #f #f #f) (build-file-default-targets file)))))
|
|
((subninja include) (error "todo: includes"))
|
|
((pool) (read-pool) (read-toplevel file))
|
|
((newline) (read-toplevel file))
|
|
(else
|
|
(unless (string? token) (error "unexpected" (list token i)))
|
|
(unless (expect-token 'equals) (error "expected =, found" (read-token)))
|
|
(let* ((value (read-eval-string-text #f)) (resolved (resolve-evalstring value file #f #f #f)))
|
|
(set-build-file-global-variables! file (mapping-set! (build-file-global-variables file) token resolved)))
|
|
(read-toplevel file)))
|
|
file)
|
|
(define out-file (read-toplevel (make-build-file (mapping (make-default-comparator)) '() (mapping (make-default-comparator)) '() (mapping (make-default-comparator)))))
|
|
(for-each (lambda (f) (unless (string=? (build-edge-rule f) "phony") (set-build-edge-resolved! f (build-rule-resolve (mapping-ref (build-file-rules out-file) (build-edge-rule f)) f out-file)))) (build-file-build-edges out-file))
|
|
out-file)))
|