564 lines
18 KiB
Scheme
564 lines
18 KiB
Scheme
(define-module (potato rules)
|
|
#:use-module (ice-9 pretty-print)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (potato exceptions)
|
|
#:use-module (potato builtins)
|
|
#:use-module (potato makevars)
|
|
#:export(<target-rule>
|
|
<suffix-rule>
|
|
<node>
|
|
%target-rules
|
|
%suffix-rules
|
|
initialize-rules
|
|
first-target-rule-name
|
|
target-rule :
|
|
suffix-rule ->
|
|
target-name $@
|
|
newer-prerequisites $?
|
|
primary-prerequisite $<
|
|
target-basename $*
|
|
prerequisites $^
|
|
build
|
|
string-compose ~
|
|
silent-compose ~@
|
|
always-execute-compose ~+
|
|
ignore-error-compose ~-
|
|
))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; HELPER FUNCTIONS
|
|
|
|
(define (basename str)
|
|
"Strip off the '.ext' part of a filename string."
|
|
(let ((idx (string-index-right str #\.)))
|
|
(if idx
|
|
(substring str 0 idx)
|
|
str)))
|
|
|
|
(define (base-compose . args)
|
|
"Returns a lambda that appends args together as a string,
|
|
adding intermediate spaces. If an arg is a procedure,
|
|
it is evaluated."
|
|
(lambda ()
|
|
;; Loop over all the args, appending them together as a
|
|
;; string. Try to be smart about the types of args.
|
|
(let loop ((args args)
|
|
(result ""))
|
|
(cond
|
|
((null? args)
|
|
result)
|
|
(else
|
|
(let ((arg (car args))
|
|
(effective-arg #f))
|
|
(cond
|
|
((procedure? arg)
|
|
(set! effective-arg (arg))
|
|
|
|
#;(unless (string? effective-arg)
|
|
(bad-proc-output "~" arg))
|
|
)
|
|
((string? arg)
|
|
(set! effective-arg arg))
|
|
(else
|
|
;; Not a string or procedure?
|
|
;; Let's just write it, I guess. YOLO!
|
|
(set! effective-arg
|
|
(format #f "~a" arg))))
|
|
|
|
;; Loop, only adding spaces as necessary
|
|
(let ((need-a-space?
|
|
(and (not (string-null? result))
|
|
(not (string-null? effective-arg)))))
|
|
(loop
|
|
(cdr args)
|
|
(string-append
|
|
result
|
|
(if need-a-space? " " "")
|
|
effective-arg)))))))))
|
|
|
|
(define (string-compose . args)
|
|
(cons 'default (apply base-compose args)))
|
|
|
|
(define ~ string-compose)
|
|
|
|
(define (ignore-error-compose . args)
|
|
(cons 'ignore-error (apply base-compose args)))
|
|
|
|
(define ~- ignore-error-compose)
|
|
|
|
(define (silent-compose . args)
|
|
(cons 'silent (apply base-compose args)))
|
|
|
|
(define ~@ silent-compose)
|
|
|
|
(define (always-execute-compose . args)
|
|
(cons 'always-execute (apply base-compose args)))
|
|
|
|
(define ~@ always-execute-compose)
|
|
|
|
(define (regular-file? filename)
|
|
(let ((st (stat filename #f)))
|
|
(eq? (stat:type st) 'regular)))
|
|
|
|
(define (compute-mtime filename)
|
|
(let ((st (stat filename #f)))
|
|
(+ (* 1000000000 (stat:mtime st))
|
|
(stat:mtimensec st))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; TARGET STRUCT AND METHODS
|
|
|
|
(define-record-type <target-rule>
|
|
(make-target-rule name prerequisites recipes priority)
|
|
target-rule?
|
|
;; A filename, for real targets, or just a name for phony targets
|
|
(name target-rule-get-name target-rule-set-name!)
|
|
;; A list of filenames and/or phony targets that have target rules
|
|
(prerequisites target-rule-get-prerequisites
|
|
target-rule-set-prerequisites!)
|
|
;; A list of strings or procedures
|
|
(recipes target-rule-get-recipes
|
|
target-rule-set-recipes!)
|
|
;; 1 = script-defined. 2 = built-in
|
|
(priority target-rule-get-priority
|
|
target-rule-set-priority!))
|
|
|
|
;; List of all target rules in order of importance
|
|
(define %target-rules '())
|
|
|
|
(define* (target-rule name #:optional (prerequisites '()) #:rest recipes)
|
|
"Register a new target rule"
|
|
;; FIXME: Typecheck
|
|
(let ((rule (make-target-rule name prerequisites recipes 1)))
|
|
;; Add to %target-rules
|
|
(set! %target-rules (cons rule %target-rules))))
|
|
|
|
;; Alias
|
|
(define : target-rule)
|
|
|
|
(define (first-target-rule-name)
|
|
(if (null? %target-rules)
|
|
#f
|
|
;; else
|
|
(target-rule-get-name (car %target-rules))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; SUFFIX STRUCT AND METHODS
|
|
|
|
(define-record-type <suffix-rule>
|
|
(make-suffix-rule source-suffix target-suffix recipes priority)
|
|
suffix-rule?
|
|
;; A string, usually like ".c". Or a string->string proc.
|
|
(source-suffix suffix-rule-get-source
|
|
suffix-rule-set-source)
|
|
;; A string, usually like ".o". Or a string->bool proc.
|
|
(target-suffix suffix-rule-get-target
|
|
suffix-rule-set-suffix!)
|
|
;; A list of strings or procedures
|
|
(recipes suffix-rule-get-recipes
|
|
suffix-rule-set-recipes!)
|
|
;; 1 = script-defined. 2 = built-in
|
|
(priority suffix-rule-get-priority
|
|
suffix-rule-set-priority!))
|
|
|
|
;; The list of all registered suffix rules in order of importance
|
|
(define %suffix-rules '())
|
|
|
|
(define (suffix-rule source target . recipes)
|
|
"Register a suffix rule"
|
|
;; FIXME: Typecheck
|
|
(let ((rule (make-suffix-rule source target recipes 1)))
|
|
(set! %suffix-rules (cons rule %suffix-rules))))
|
|
|
|
;; Alias
|
|
(define -> suffix-rule)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; NODE STRUCT AND METHODS
|
|
|
|
(define-record-type <node>
|
|
(make-node name parent status)
|
|
node?
|
|
;; For a real target, this is a filename. For a phony target it is
|
|
;; just a label.
|
|
(name node-get-name node-set-name!)
|
|
;; A <node> which is the parent of this node, or #f.
|
|
(parent note-get-parent note-set-parent!)
|
|
;; If 'name' is a regular file, mtime holds its last modification
|
|
;; time in nanoseconds since the epoch. If 'name' does not exist,
|
|
;; _mtime is #f.
|
|
(mtime node-get-mtime node-set-mtime!)
|
|
;; One of 'pass, 'fail, or 'undetermined
|
|
(status node-get-status node-set-status!)
|
|
;; A list of rules to evaluate to try to c
|
|
(rules node-get-rules node-set-rules!)
|
|
(children node-get-children node-set-children!)
|
|
;; Determines how many children must pass for the parent
|
|
;; to be evaluated. Either 'or or 'and.
|
|
(logic node-get-logic node-set-logic!)
|
|
)
|
|
|
|
|
|
;;;;;;;;;
|
|
;; Automatic variables
|
|
;; target-name $@
|
|
;; target-basename $*
|
|
;; newer-prerequisites $?
|
|
;; prerequisites $^
|
|
;; primary-prerequisite $<
|
|
|
|
|
|
;; This is set in the builder to make automatic variables work.
|
|
(define %node-cur #f)
|
|
|
|
(define target-name
|
|
(lambda ()
|
|
(if %node-cur
|
|
(node-get-name %node-cur)
|
|
#f)))
|
|
|
|
(define $@ target-name)
|
|
|
|
(define target-basename
|
|
(lambda ()
|
|
(if %node-cur
|
|
(basename (node-get-name %node-cur)))))
|
|
|
|
(define $* target-basename)
|
|
|
|
(define primary-prerequisite
|
|
(lambda ()
|
|
(if %node-cur
|
|
(let ((prereq (node-get-children %node-cur)))
|
|
(if (null? prereq)
|
|
""
|
|
(car prereq))))))
|
|
|
|
(define $< primary-prerequisite)
|
|
|
|
(define newer-prerequisites
|
|
(lambda ()
|
|
(error "FIXME")))
|
|
|
|
(define $? newer-prerequisites)
|
|
|
|
(define prerequisites
|
|
(lambda ()
|
|
(error "FIXME")))
|
|
|
|
(define $^ prerequisites)
|
|
|
|
|
|
(define (undetermined? node)
|
|
(eq? (node-get-status node) 'undetermined))
|
|
|
|
(define (children-complete? node)
|
|
(cond
|
|
((leaf-node? node)
|
|
#t)
|
|
((eqv? 'and (node-get-logic node))
|
|
(or (every-child-has-passed? node)
|
|
(any-child-has-failed? node)))
|
|
((eqv? 'or (node-get-logic node))
|
|
(or (every-child-has-failed? node)
|
|
(any-child-has-passed? node)))
|
|
(else
|
|
#f)))
|
|
|
|
(define (children-passed? node)
|
|
(cond
|
|
((null? (node-get-children node))
|
|
#t)
|
|
((eqv? 'and (node-get-logic node))
|
|
(every-child-has-passed? node))
|
|
((eqv? 'or (node-get-logic node))
|
|
(any-child-has-passed? node))
|
|
(else
|
|
#f)))
|
|
|
|
(define (has-recipe? node)
|
|
(not (null? (node-get-recipe node))))
|
|
|
|
(define (set-fail! node)
|
|
(node-set-status! node 'fail))
|
|
|
|
(define (set-pass! node)
|
|
(node-set-status! node 'fail))
|
|
|
|
(define (get-next-child node)
|
|
"Return the first child node that is not yet PASS or FAIL"
|
|
(let ((children (node-get-children node)))
|
|
(any (lambda (child)
|
|
(if (eqv? (node-get-status child) 'undetermined)
|
|
child
|
|
#f))
|
|
children)))
|
|
|
|
(define (failed? node)
|
|
(eqv? (node-get-status node) 'fail))
|
|
|
|
(define (has-parent? node)
|
|
(if (node-get-parent node)
|
|
#t
|
|
#f))
|
|
|
|
(define (up-to-date? node)
|
|
"Checks if node is up to date:
|
|
- it has an mtime
|
|
- all its children have mtimes
|
|
- its mtime is older than the mtime of its children"
|
|
(let ((children (map node-get-mtime (node-get-children node)))
|
|
(parent (node-get-mtime node)))
|
|
(if (every (lambda (child)
|
|
(and (integer? parent)
|
|
(integer? child)
|
|
(>= parent child)))
|
|
children)
|
|
#t
|
|
#f)))
|
|
|
|
(define (get-parent node)
|
|
(node-get-parent node))
|
|
#|
|
|
(define (run-recipe! node quiet verbose)
|
|
"Runs the recipes associated with this node, one by one. Recipes
|
|
are either strings, procedures that return strings, or generic
|
|
procedures. If a failure condition happens, mark the node as having
|
|
failed."
|
|
(let ((recipes (node-get-recipes node)))
|
|
(when (null? recipes)
|
|
(error "no recipe"))
|
|
(let loop ((opt/recipe (car recipes))
|
|
(rest (cdr recipes)))
|
|
(let ((opt ((car recipe/opt))
|
|
(recipe (cdr recipe)))
|
|
;; Recipes are either
|
|
;; - strings to pass to system
|
|
;; - procedures that return a string which is passed
|
|
;; to system
|
|
;; - procedures (that don't return a string) that are executed
|
|
;; that pass unless they return #f
|
|
; OPT is one of 'default, 'ignore, 'silent
|
|
(cond
|
|
((string=? recipe)
|
|
(unless (or quiet (eq? opt 'silent))
|
|
(format #t "[SYSTEM] ~A~$" recipe)
|
|
(let ((retval (system recipe)))
|
|
(unless (or quiet (eq? opt 'silent))
|
|
(format #t " --> ~S~%" (status:exit-val retval)))
|
|
(when (and (not (eqv? opt 'ignore))
|
|
(or (eqv? #f (status:exit-val retval))
|
|
(not (zero? (status:exit-val retval)))))
|
|
(node-set-status! node 'fail))))
|
|
((procedure? recipe)
|
|
(unless (or quiet (eq? opt 'silent))
|
|
(if (procedure-name recipe)
|
|
(format #t "[PROC] ~A~%" (procedure-name recipe))
|
|
(format #t "[PROC] ~%")))
|
|
(let ((retval (recipe)))
|
|
(unless (or quiet (eq? opt 'silent))
|
|
(format #t " --> ~S~%" (status:exit-val retval2)))
|
|
(cond
|
|
((eqv? retval #f)
|
|
(unless (eqv? opt 'ignore)
|
|
(node-set-status node 'fail)))
|
|
((string=? retval)
|
|
(unless (or quiet (eq? opt 'silent))
|
|
(format #t "[SYSTEM] ~A~$" retval)
|
|
(let ((retval2 (system retval)))
|
|
(unless (or quiet (eq? opt 'silent))
|
|
(format #t " --> ~S~%" (status:exit-val retval2)))
|
|
(when (and (not (eqv? opt 'ignore))
|
|
(or (eqv? #f (status:exit-val retval))
|
|
(not (zero? (status:exit-val retval)))))
|
|
(node-set-status! node 'fail))))))))
|
|
(cond
|
|
((eqv? (node-get-status node) 'fail)
|
|
;; quit
|
|
)
|
|
((null? rest)
|
|
(node-set-status! node) 'pass)
|
|
(else
|
|
((loop (car rest)
|
|
(cdr rest))))))))))
|
|
|
|
(when (eq? 'pass (node-get-status node))
|
|
(let ((name (node-get-name node)))
|
|
(when (and (file-exists? name)
|
|
(regular-file? name))
|
|
(node-set-mtime! node (compute-mtime name))))))
|
|
|
|
|
|
(define (run-default-recipe! node)
|
|
"The default recipe passes if the file exists"
|
|
(let ((name (node-get-name node)))
|
|
(if (and (file-exists? name)
|
|
(regular-file? name))
|
|
(begin
|
|
(node-set-status! node 'pass)
|
|
(node-set-mtime! node (compute-mtime name)))
|
|
;; else
|
|
(node-set-status! node 'fail))))
|
|
|
|
;; Start at root
|
|
|
|
;; If cur is UNDETERMINED, find a leaf that is UNDETERMINED.
|
|
;; Descent to first leaf.
|
|
;; If self's mtime is earlier than parent's mtime, mark self as PASS.
|
|
;; Elif self has rules, run rules and mark self PASS/FAIL.
|
|
;; Else self has no mtime or rules, so mark self FAIL.
|
|
;; Go to parent.
|
|
|
|
;; IF PASS or FAIL, go to parent
|
|
|
|
;; IF UNDETERMINED do these...
|
|
|
|
;; Are we done with the children?
|
|
;; If AND rule and one child is FAIL, stop
|
|
;; If OR rule and one child is PASS, stop
|
|
;; If no children left, stop
|
|
;; Else keep going
|
|
|
|
;; Did the children pass?
|
|
;; IF AND rule and all children are PASS, true
|
|
;; IF OR rule an one child is PASS, true
|
|
;; Otherwise, false
|
|
|
|
;; If the children FAIL, cur is FAIL
|
|
;; If the children PASS, run rules and mark self PASS/FAIL
|
|
;; Go to parent
|
|
|
|
;; 3 failures
|
|
;; - If anything fails, stop immediately
|
|
;; - If anything fails, searching through tree
|
|
;; - Ignore errors
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; LET'S GO!
|
|
|
|
(define %debug? #f)
|
|
|
|
(define (initialize-rules no-builtins? debug?)
|
|
(set! %target-rules '())
|
|
(set! %suffix-rules '())
|
|
(set! %debug? debug?)
|
|
(unless no-builtins?
|
|
;; Set up initial suffix rules
|
|
(suffix-rule ".c" ".o"
|
|
(string-compose
|
|
(reference "CC")
|
|
(reference "CFLAGS")
|
|
"-c"
|
|
primary-prerequisite)))
|
|
)
|
|
|
|
(define (create-node name parent)
|
|
"Constructs a tree of nodes, with name as the root node."
|
|
(let ((node (make-node name parent 'untested)))
|
|
|
|
;; FIXME: here check that this name differs from all ancenstor's
|
|
;; names
|
|
|
|
;; Try to the file's modification time.
|
|
(when (file-exists? name)
|
|
(when (not (regular-file? name))
|
|
(not-a-regular-file "create-node" name))
|
|
(when (not (access? name R_OK))
|
|
(no-read-access-to-file "create-node" name))
|
|
(node-set-mtime! node (compute-mtime name)))
|
|
|
|
;; Search for matching target rule.
|
|
(when (not (null? %target-rules))
|
|
(let loop ((rule (car %target-rules))
|
|
(rest (cdr %target-rules)))
|
|
|
|
;; N.B: here we assume target rule names and
|
|
;; predicates are exclusively strings.
|
|
(if (string=? name (target-rule-get-name rule))
|
|
(begin
|
|
;; OK we have a matching rule
|
|
(node-set-rules! node (list rule))
|
|
(node-set-logic! node 'and)
|
|
;; For target-rules, the prerequisites comes from the
|
|
;; rule itself.
|
|
|
|
;; Oooh, recursion!
|
|
(node-set-children! node
|
|
(map (lambda (prereq)
|
|
(create-node prereq node))
|
|
(target-rule-get-prerequisites rule))))
|
|
;; else
|
|
(if (not (null? rest))
|
|
(loop (car rest) (cdr rest))
|
|
;; else, no matching rule found
|
|
(node-set-rules! node '())))))
|
|
|
|
#|
|
|
;; If no rule found so far, search for suffix rules.
|
|
(when (null? (node-get-rules node))
|
|
(for-each
|
|
(lambda (rule)
|
|
(let ((targ (suffix-rule-get-target rule)))
|
|
(when (or
|
|
;; string suffix
|
|
(and (string? targ)
|
|
(string-suffix? targ name))
|
|
;; procedure suffix
|
|
(and (procedure? targ)
|
|
(targ name)))
|
|
;; For suffix rules, there will be exactly one child per
|
|
;; rule and the name of the child is constructed from a
|
|
;; suffix and the parent's name.
|
|
(node-set-rules! node (cons rule (node-get-rules node)))
|
|
(node-set-logic! node 'or)
|
|
(let* ((src (suffix-rule-get-source rule))
|
|
(prereq
|
|
(if (string? src)
|
|
(string-append
|
|
(string-drop-right name (string-length src))
|
|
src)
|
|
;; else, src is a conversion func.
|
|
(src name))))
|
|
;; Note the recursion here.
|
|
(node-set-children! node
|
|
(cons (create-node prereq node)
|
|
(node-get-children node)))))))
|
|
%suffix-rules))
|
|
|
|
;; First matching rule has highest priority
|
|
(node-set-rules! node (reverse (node-get-rules node)))
|
|
(node-set-children! node (reverse (node-get-children node)))
|
|
|#
|
|
;; And node is ready to go
|
|
node))
|
|
|
|
(define (build root)
|
|
"Give a tree of <node>, this executes the recipes therein."
|
|
(let ((tree (create-node root #f)))
|
|
(let ((node root))
|
|
(while #t
|
|
(if (undetermined? node)
|
|
(if (children-complete? node)
|
|
(if (children-passed? node)
|
|
(if (up-to-date? node)
|
|
(set-pass! node)
|
|
;; else, not up to date
|
|
(if (has-recipe? node)
|
|
(run-recipe! node)
|
|
;; else, no recipe exists
|
|
(run-default-recipe! node)))
|
|
;; else, children have failed
|
|
(set-fail! node))
|
|
;; else, children aren't complete
|
|
(set! node (get-next-child node)))
|
|
;; else, this node is determined
|
|
(if (and abort-on-error (failed? node))
|
|
(break)
|
|
;; else not failed
|
|
(if (has-parent? node)
|
|
(set! node (get-parent node))
|
|
;; else, there is no parent to this node
|
|
(break))))))))
|
|
|
|
|#
|