kreyren/pman
1
0
Fork 0
Code Issues 16 Pull Requests 2 Releases Activity

mostly working

Browse Source
This commit is contained in:
Michael Gran 2021-02-14 15:28:12 -08:00
parent f75e5e8f4b
commit cbee22e2de
9 changed files with 1095 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
CHEATSHEET.md
View File

@ -26,16 +26,21 @@ are syntax that add quotation marks around `key`, so you call them without the q
($ KEY) -> "VAL" ($ KEY) -> "VAL"
($ key [transformer]) ($ key [transformer])
Look up `key` in the `%makevars` hash table and return the result Look up `key` in the `%makevars` hash table and return the
as a string. If `key` is not found, return an empty string. result as a string. If `key` is not found, return an empty
If a string-to-string transformer procedure is provided, apply it to each string. If a string-to-string transformer procedure is
space-separated token in the result. provided, apply it to each space-separated token in the
result.
(?= key val) (?= key val)
Assign `val` to `key` in the `%makevars` hash table. If `val` is a procedure, Assign `val` to `key` in the `%makevars` hash table. If `val`
assign its output to `key` the first time that `key` is referenced. is a procedure, assign its output to `key` the first time that
`key` is referenced.
(:= key val) (:= key val)
Assign `val` to `key` in the `%makevars` hash table. If `val` is a procedure, Assign `val` to `key` in the `%makevars` hash table. If `val`
evaluate it and assign its output to `key` immediately. is a procedure, evaluate it and assign its output to `key`
immediately.
## Rules ## Rules
@ -47,8 +52,8 @@ have filenames or phony names.
recipe-2 recipe-2
...) ...)
`target-name` is a string which is either a filename to be created `target-name` is a string which is either a filename to be
or an phony name like "all" or "clean". created or an phony name like "all" or "clean".
Recipe as a string to be evaluated by the system Recipe as a string to be evaluated by the system
@ -88,8 +93,21 @@ have filenames or phony names.
(: "foo.c" '() #t) (: "foo.c" '() #t)
The *suffix rule* is a generic rule to convert one source file to If there is no recipe at all, it is shorthand for the recipe #t,
a target file, based on the filename extensions. indicating a recipe that always passes. This is used
in prerequisite-only target rules, such as below, which passes
so long as the prerequisites
pass. These two rules are the same.
(: "all" '("foo.exe"))
(: "all" '("foo.exe") #t)
Lastly, if the recipe is #f, this target will always fail.
(: "fail" '() #f)
The *suffix rule* is a generic rule to convert one source file to a
target file, based on the filename extensions.
(-> ".c" ".o" (-> ".c" ".o"
(~ ($ CC) ($ CFLAGS) "-c" $< "-o" $@)) (~ ($ CC) ($ CFLAGS) "-c" $< "-o" $@))

3
potato/make.scm
View File

@ -4,6 +4,7 @@
#:use-module (ice-9 optargs) #:use-module (ice-9 optargs)
#:use-module (ice-9 getopt-long) #:use-module (ice-9 getopt-long)
#:use-module (ice-9 receive) #:use-module (ice-9 receive)
#:use-module (system vm trace)
#:use-module (potato exceptions) #:use-module (potato exceptions)
#:use-module (potato makevars) #:use-module (potato makevars)
#:use-module (potato rules) #:use-module (potato rules)
@ -278,8 +279,6 @@ targets listed on the parsed command-line are used."
(when (not (null? targets)) (when (not (null? targets))
(let loop ((target (car targets)) (let loop ((target (car targets))
(rest (cdr targets))) (rest (cdr targets)))
(when (>= %verbosity 3)
(format #t "Considering target file ~A~A~A.~%" (lquo) target (rquo)))
(if (not (build target)) (if (not (build target))
(begin (begin
(print "The recipe for “~A” has failed.~%" target) (print "The recipe for “~A” has failed.~%" target)

493
potato/rules.scm
View File

@ -1,5 +1,6 @@
(define-module (potato rules) (define-module (potato rules)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
#:use-module (ice-9 optargs)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (potato exceptions) #:use-module (potato exceptions)
@ -14,8 +15,8 @@
initialize-rules initialize-rules
first-target-rule-name first-target-rule-name
install-alternate-system-driver install-alternate-system-driver
target-rule : target-rule :
suffix-rule -> suffix-rule ->
target-name $@ target-name $@
newer-prerequisites $? $$? newer-prerequisites $? $$?
primary-prerequisite $< primary-prerequisite $<
@ -42,8 +43,12 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPER FUNCTIONS ;; HELPER FUNCTIONS
(define (basename str) (define (basename str)
"Strip off the '.ext' part of a filename string." "Strip off the '.ext' part of a filename string."
(unless (string? str)
(scm-error 'wrong-type-arg "basename" "Not a string: ~S" (list str) #f))
(let ((idx (string-index-right str #\.))) (let ((idx (string-index-right str #\.)))
(if idx (if idx
(substring str 0 idx) (substring str 0 idx)
@ -69,8 +74,8 @@ it is evaluated."
(set! effective-arg (arg)) (set! effective-arg (arg))
(unless (string? effective-arg) (unless (string? effective-arg)
(bad-proc-output "~" arg)) (bad-proc-output "~" arg)))
)
((string? arg) ((string? arg)
(set! effective-arg arg)) (set! effective-arg arg))
(else (else
@ -111,10 +116,16 @@ it is evaluated."
(define ~+ always-execute-compose) (define ~+ always-execute-compose)
(define (regular-file? filename) (define (regular-file? filename)
(unless (string? filename)
(scm-error 'wrong-type-arg "regular-file?" "Not a string: ~S" (list filename) #f))
(let ((st (stat filename #f))) (let ((st (stat filename #f)))
(eq? (stat:type st) 'regular))) (eq? (stat:type st) 'regular)))
(define (compute-mtime filename) (define (compute-mtime filename)
(unless (string? filename)
(scm-error 'wrong-type-arg "regular-file?" "Not a string: ~S" (list filename) #f))
(let ((st (stat filename #f))) (let ((st (stat filename #f)))
(+ (* 1000000000 (stat:mtime st)) (+ (* 1000000000 (stat:mtime st))
(stat:mtimensec st)))) (stat:mtimensec st))))
@ -122,11 +133,13 @@ it is evaluated."
(define %system-proc system) (define %system-proc system)
(define (install-alternate-system-driver proc) (define (install-alternate-system-driver proc)
"Give a procure to use rather than the standard "Give a procure to use rather than the standard 'system' procedure,
'system' procedure." installs it as the system driver. Returns the old system driver."
(unless (procedure? proc) (unless (procedure? proc)
(not-a-procedure "install-alternate-system-driver" proc)) (scm-error 'wrong-type-arg "install-alternate-system-driver" "Not a procedure: ~S" (list proc) #f))
(set! %system-proc proc)) (let ((old-proc %system-proc))
(set! %system-proc proc)
old-proc))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TARGET STRUCT AND METHODS ;; TARGET STRUCT AND METHODS
@ -152,8 +165,17 @@ it is evaluated."
(define* (target-rule name #:optional (prerequisites '()) #:rest recipes) (define* (target-rule name #:optional (prerequisites '()) #:rest recipes)
"Register a new target rule" "Register a new target rule"
(when (>= %verbosity 3) (format #t "BLAMMO!! ~S~%" recipes)
(format #t "Defining target rule: ~A ~A ~A~%" prerequisites (right-arrow) name))
(when (>= %verbosity 0)
(if (null? prerequisites)
(format #t "Defining target rule: ~a~A~a~%" (lquo) name (rquo))
(format #t "Defining target rule: ~a~A~a ~A ~A~%" (lquo) name (rquo) (left-arrow) prerequisites)))
;; Empty recipes is shorthand for a recipe that always passes.
(when (null? recipes)
(set! recipes (list #t)))
;; If any recipes are raw strings, we need to make them into ;; If any recipes are raw strings, we need to make them into
;; (cons 'default string) ;; (cons 'default string)
(let ((recipes2 (let ((recipes2
@ -161,10 +183,8 @@ it is evaluated."
(cond (cond
((pair? recipe) ((pair? recipe)
recipe) recipe)
((string? recipe) (else
(cons 'default recipe)) (cons 'default recipe))))
(else
(error "bad recipe for target rule"))))
recipes))) recipes)))
(let ((rule (make-target-rule name prerequisites recipes2 1))) (let ((rule (make-target-rule name prerequisites recipes2 1)))
@ -178,7 +198,7 @@ it is evaluated."
(if (null? %target-rules) (if (null? %target-rules)
#f #f
;; else ;; else
(target-rule-get-name (car %target-rules)))) (target-rule-get-name (last %target-rules))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SUFFIX STRUCT AND METHODS ;; SUFFIX STRUCT AND METHODS
@ -206,7 +226,7 @@ it is evaluated."
"Register a suffix rule" "Register a suffix rule"
;; FIXME: Typecheck ;; FIXME: Typecheck
(when (>= %verbosity 3) (when (>= %verbosity 0)
(format #t "Defining suffix rule: ~A ~A ~A~%" source (right-arrow) target)) (format #t "Defining suffix rule: ~A ~A ~A~%" source (right-arrow) target))
;; If any recipes are raw strings, we need to make them into ;; If any recipes are raw strings, we need to make them into
;; (cons 'default string) ;; (cons 'default string)
@ -242,16 +262,19 @@ it is evaluated."
(mtime node-get-mtime node-set-mtime!) (mtime node-get-mtime node-set-mtime!)
;; One of 'pass, 'fail, or 'undetermined ;; One of 'pass, 'fail, or 'undetermined
(status node-get-status node-set-status!) (status node-get-status node-set-status!)
;; Either 'target or 'suffix or 'default
(rule-type node-get-rule-type node-set-rule-type!)
;; A list of rules ;; A list of rules
(rules node-get-rules node-set-rules!) (rules node-get-rules node-set-rules!)
(children node-get-children node-set-children!) (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!)
) )
(define (has-rules? node) (define (using-target-rule? node)
(not (null? (node-get-rules node)))) (eq? 'target (node-get-rule-type node)))
(define (using-suffix-rules? node)
(eq? 'suffix (node-get-rule-type node)))
(define (using-default-rule? node)
(eq? 'default (node-get-rule-type node)))
(define (set-fail! node) (define (set-fail! node)
(node-set-status! node 'fail)) (node-set-status! node 'fail))
@ -272,37 +295,53 @@ it is evaluated."
(eq? (node-get-status node) 'undetermined)) (eq? (node-get-status node) 'undetermined))
(define (any-child-has-passed? node) (define (any-child-has-passed? node)
(unless (node? node)
(scm-error 'wrong-type-arg "any-child-has-passed?" "Not a node: ~S" (list node) #f))
(when (null? (node-get-children node))
(scm-error 'misc-error "any-child-has-passed?" "Node ~a has no children"
(list (node-get-name node)) #t))
(let ((children (node-get-children node))) (let ((children (node-get-children node)))
(if (null? children) (any passed? children)))
#f
(any passed? children))))
(define (every-child-has-passed? node) (define (every-child-has-passed? node)
(unless (node? node)
(scm-error 'wrong-type-arg "every-child-has-passed?" "Not a node: ~S" (list node) #f))
(when (null? (node-get-children node))
(scm-error 'misc-error "every-child-has-passed?" "Node ~a has no children"
(list (node-get-name node)) #t))
(let ((children (node-get-children node))) (let ((children (node-get-children node)))
(if (null? children) (every passed? children)))
#f
(every passed? children))))
(define (any-child-has-failed? node) (define (any-child-has-failed? node)
(unless (node? node)
(scm-error 'wrong-type-arg "any-child-has-failed?" "Not a node: ~S" (list node) #f))
(when (null? (node-get-children node))
(scm-error 'misc-error "any-child-has-failed?" "Node ~a has no children"
(list (node-get-name node)) #t))
(let ((children (node-get-children node))) (let ((children (node-get-children node)))
(if (null? children) (any failed? children)))
#f
(any failed? children))))
(define (every-child-has-failed? node) (define (every-child-has-failed? node)
(unless (node? node)
(scm-error 'wrong-type-arg "every-child-has-failed?" "Not a node: ~S" (list node) #f))
(when (null? (node-get-children node))
(scm-error 'misc-error "every-child-has-failed?" "Node ~a has no children"
(list (node-get-name node)) #t))
(let ((children (node-get-children node))) (let ((children (node-get-children node)))
(if (null? children) (every failed? children)))
#f
(every failed? children))))
(define (children-complete? node) (define (children-complete? node)
(cond (cond
((leaf-node? node) ((leaf-node? node)
#t) #t)
((eqv? 'and (node-get-logic node)) ((eqv? 'target (node-get-rule-type node))
(or (every-child-has-passed? node) (or (every-child-has-passed? node)
(any-child-has-failed? node))) (any-child-has-failed? node)))
((eqv? 'or (node-get-logic node)) ((eqv? 'suffix (node-get-rule-type node))
(or (every-child-has-failed? node) (or (every-child-has-failed? node)
(any-child-has-passed? node))) (any-child-has-passed? node)))
(else (else
@ -312,9 +351,9 @@ it is evaluated."
(cond (cond
((null? (node-get-children node)) ((null? (node-get-children node))
#t) #t)
((eqv? 'and (node-get-logic node)) ((eq? 'target (node-get-rule-type node))
(every-child-has-passed? node)) (every-child-has-passed? node))
((eqv? 'or (node-get-logic node)) ((eq? 'suffix (node-get-rule-type node))
(any-child-has-passed? node)) (any-child-has-passed? node))
(else (else
#f))) #f)))
@ -322,14 +361,15 @@ it is evaluated."
(define (get-next-child node) (define (get-next-child node)
"Return the first child node that is not yet PASS or FAIL" "Return the first child node that is not yet PASS or FAIL"
(let ((children (node-get-children node))) (let ((children (node-get-children node)))
(if (null? children) (cond
#f ((null? children)
#f)
(any (lambda (child) (else
(if (eqv? (node-get-status child) 'undetermined) (any (lambda (child)
child (if (eqv? (node-get-status child) 'undetermined)
#f)) child
children)))) #f))
children)))))
(define (has-parent? node) (define (has-parent? node)
(if (node-get-parent node) (if (node-get-parent node)
@ -358,6 +398,14 @@ it is evaluated."
#t #t
#f))))) #f)))))
(define (node-depth-string node)
(let loop ((depth 0)
(cur node))
(if (has-parent? cur)
(loop (1+ depth) (get-parent cur))
;;
(make-string (* 2 depth) #\space))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; AUTOMATIC VARIABLES ;; AUTOMATIC VARIABLES
@ -440,7 +488,7 @@ it is evaluated."
(-> ".c" "" (-> ".c" ""
(~ ($ CC) ($ CFLAGS) ($ LDFLAGS) "-o" $@ $<)) (~ ($ CC) ($ CFLAGS) ($ LDFLAGS) "-o" $@ $<))
(-> ".f" "" (-> ".f" ""
(~ ($ FC) ($ FFLAGS) ($ LDFLAGS) "-o" $@ %<)) (~ ($ FC) ($ FFLAGS) ($ LDFLAGS) "-o" $@ $<))
(-> ".sh" "" (-> ".sh" ""
(~ "cp" $< $@) (~ "cp" $< $@)
(~ "chmod a+x" $< $@)) (~ "chmod a+x" $< $@))
@ -464,108 +512,156 @@ it is evaluated."
(-> ".scm" ".go" (-> ".scm" ".go"
(~ ($ GUILD) "compile" ($ GFLAGS) $<))) (~ ($ GUILD) "compile" ($ GFLAGS) $<)))
(define (run-rules! node) (define (run-target-rule! node)
"Runs the rules associated with this node. If this node has *and* "Runs the (singular) target rule associated with this node."
logic, it runs the recipes one by one, quitting on the first failure. (unless (node? node)
If this rule has *or* logic, it runs them quitting on the first (scm-error 'wrong-type-arg "run-target-rule!" "Not a node: ~S" (list node) #f))
success."
(let ((rules (node-get-rules node))) (let ((rules (node-get-rules node)))
(when (null? rules) (when (null? rules)
(error "no rules")) (scm-error 'misc-error "run-target-rule!" "Node ~S has no target rules"
(list (node-get-name node)) #f))
(unless (= 1 (length rules))
(scm-error 'misc-error "run-target-rule!" "Node ~S has ~A target rules"
(list (node-get-name node) (length rules)) #f))
(unless (or (leaf-node? node) (every-child-has-passed? node))
(scm-error 'misc-error "run-target-rule!" "Node ~S: not all children have passed"
(list (node-get-name node)) #f))
(let ((logic (node-get-logic node))) (let ((rule (car rules)))
(let loop ((rule (car rules)) (target-rule-prep-automatic-variables node rule)
(rest (cdr rules))) (run-recipes! node (target-rule-get-recipes rule))
(cond (let ((status (node-get-status node)))
((target-rule? rule) status))))
(target-rule-prep-automatic-variables node rule)
(run-recipes! node (target-rule-get-recipes rule)))
((suffix-rule? rule)
(suffix-rule-prep-automatic-variables node rule)
(run-recipes! node (suffix-rule-get-recipes rule)))
(else
(error "bad rule")))
(let ((status (node-get-status node))) (define (run-suffix-rules! node)
(cond "Runs the one-or-more suffix rules associated with this node. It
((or (and (eq? 'and logic) runs them one-by-one, quitting on the first success."
(eq? 'fail status)) (unless (node? node)
(and (eq? 'or logic) (scm-error 'wrong-type'arg "run-suffix-rules!" "Not a node: ~S" (list node) #f))
(eq? 'pass status))
(null? rest)) (let ((rules (node-get-rules node))
;; We're done (children (node-get-children node)))
status) (when (null? rules)
(else (scm-error 'misc-error "run-suffix-rules!" "Node ~S has no rules"
(loop (car rest) (cdr rest))))))))) (list (node-get-name node)) #f))
(when (null? children)
(scm-error 'misc-error "run-suffix-rule!" "Node ~S has no children"
(list (node-get-name node)) #f))
(unless (any-child-has-passed? node)
(scm-error 'misc-error "run-suffix-rule!" "Node ~S: not child has passed"
(list (node-get-name node)) #f))
(unless (= (length rules) (length children))
(scm-error 'misc-error "run-suffix-rule!" "Node ~S: must have as many children as rules"
(list (node-get-name node)) #f))
(let ((i 0)
(len (length children)))
(while (< i len)
(let ((rule (list-ref rules i))
(child (list-ref children i)))
(when (passed? child)
(when (>= %verbosity 3)
(format #t "~A: attempting to make using ~a~A~a ~a ~a~A~a rule"
(node-get-name node)
(lquo) (suffix-rule-get-source rule) (rquo)
(right-arrow)
(lquo) (suffix-rule-get-target rule) (rquo)))
(suffix-rule-prep-automatic-variables node rule)
(run-recipes! node (suffix-rule-get-recipes rule)))
(when (passed? node)
(break))
(set! i (1+ i)))))
(when (>= %verbosity 3)
(if (passed? node)
(format #t "PASS: ~a~%" (node-get-name node))
(format #t "FAIL: ~a~%" (node-get-name node))))
(node-get-status node)))
(define (run-recipes! node recipes) (define (run-recipes! node recipes)
"Runs the recipes on this node, one by one. Recipes are either "Runs the recipes on this node, one by one. Recipes are either
strings, procedures that return strings, or generic procedures. If a strings, procedures that return strings, or generic procedures. If a
failure condition happens, mark the node as having failed." failure condition happens, mark the node as having failed."
(when (null? recipes) (unless (node? node)
(error "no recipe")) (scm-error 'wrong-type-arg "run-recipes!" "Not a node: ~S" (list node) #f))
(let loop ((opt/recipe (car recipes)) ;;(unless (and (list? recipes) (not (null? recipes)))
(rest (cdr recipes))) ;; (scm-error 'wrong-type-arg "run-recipes!" "Not a non-null list: ~S" (list recipes) #f))
(let ((opt (car opt/recipe))
(recipe (cdr opt/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)
(format #t "[SYSTEM] ~A~%" recipe)
(let ((retval (%system-proc recipe)))
(format #t " --> ~S~%" retval)
(unless (zero? retval)
(set-fail! node))))
((procedure? recipe) (let ((i 0)
(if (procedure-name recipe) (len (length recipes)))
(format #t "[PROC] ~A~%" (procedure-name recipe)) (while (< i len)
(format #t "[PROC] ~%")) (let* ((opt/recipe (list-ref recipes i))
(let ((retval (recipe))) (opt (car opt/recipe))
(format #t " --> ~S~%" retval) (recipe (cdr opt/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 (cond
((eqv? retval #f) ((eq? recipe #t)
(set-fail! node)) (set-pass! node))
;; If a procedure returns a string, that string gets ((eq? recipe #f)
;; processed by system. (set-fail! node))
((string=? retval)
(format #t "[SYSTEM] ~A~%" retval)
(let ((retval2 (%system-proc retval)))
(format #t " --> ~S~%" retval2)
(unless (zero? retval2)
(set-fail! node)))))))
(else ((string? recipe)
;; Not a string or procedure (when (= %verbosity 1)
(error "bad rule"))) (format #t "~a~%" (node-get-name node)))
(when (or (and (= %verbosity 2) (not (eq? 'silent opt)))
(= %verbosity 3))
(format #t "~A~%" recipe))
(let ((retval (%system-proc recipe)))
(if (zero? retval)
(set-pass! node)
(set-fail! node))))
((procedure? recipe)
(let ((retval (recipe)))
(cond
;; If a procedure returns a string, that string gets
;; processed by system.
((string? retval)
(when (= %verbosity 1)
(format #t "~a~%" (node-get-name node)))
(when (or (and (= %verbosity 2) (not (eq? 'silent opt)))
(= %verbosity 3))
(format #t "~A~%" retval))
(let ((retval2 (%system-proc retval)))
(if (zero? retval2)
(set-pass! node)
(set-fail! node))))
(cond ;; A scheme procedure recipe that returns false.
((failed? node) ((eqv? retval #f)
;; quit (set-fail! node))
)
((null? rest)
(set-pass! node))
(else
((loop (car rest)
(cdr rest)))))))
(when (passed? node) (else
(let ((name (node-get-name node))) ;; Otherwise, this was a procedure that didn't return
(when (and (file-exists? name) ;; #f or a string, so it gets a pass.
(regular-file? name)) (set-pass! node)))))
(node-set-mtime! node (compute-mtime name))))))
(define (run-default-recipe! node) (else
"The default recipe passes if the file exists" ;; Can't be converted to a viable string or procedure
(scm-error 'misc-error "run-recipes!" "bad recipe: ~S" (list recipe) #f)))
(when (failed? node) (break))
(set! i (1+ i))))
(when (passed? 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-rule! node)
"The default rule if not other rule exists. It just passes if the
file exists."
(let ((name (node-get-name node))) (let ((name (node-get-name node)))
(if (and (file-exists? name) (if (and (file-exists? name)
(regular-file? name)) (regular-file? name))
@ -627,7 +723,8 @@ failure condition happens, mark the node as having failed."
"Constructs a tree of nodes, with name as the root node." "Constructs a tree of nodes, with name as the root node."
(let ((node (make-node name parent 'undetermined))) (let ((node (make-node name parent 'undetermined)))
(node-set-children! node '()) (node-set-children! node '())
;; FIXME: here check that this name differs from all ancenstor's (node-set-rule-type! node 'default)
;; FIXME: here check that this name differs from all ancestor's
;; names ;; names
;; Try to the file's modification time. ;; Try to the file's modification time.
@ -649,7 +746,7 @@ failure condition happens, mark the node as having failed."
(begin (begin
;; OK we have a matching rule ;; OK we have a matching rule
(node-set-rules! node (list rule)) (node-set-rules! node (list rule))
(node-set-logic! node 'and) (node-set-rule-type! node 'target)
;; For target-rules, the prerequisites comes from the ;; For target-rules, the prerequisites comes from the
;; rule itself. ;; rule itself.
@ -669,13 +766,12 @@ failure condition happens, mark the node as having failed."
(for-each (for-each
(lambda (rule) (lambda (rule)
(let ((targ (suffix-rule-get-target rule))) (let ((targ (suffix-rule-get-target rule)))
(format #t "possible suffix rule ~S~%" rule)
(when (string-suffix? targ name) (when (string-suffix? targ name)
;; For suffix rules, there will be exactly one child per ;; For suffix rules, there will be exactly one child per
;; rule and the name of the child is constructed from a ;; rule and the name of the child is constructed from a
;; suffix and the parent's name. ;; suffix and the parent's name.
(node-set-rules! node (cons rule (node-get-rules node))) (node-set-rules! node (cons rule (node-get-rules node)))
(node-set-logic! node 'or) (node-set-rule-type! node 'suffix)
(let* ((src (suffix-rule-get-source rule)) (let* ((src (suffix-rule-get-source rule))
(prereq (prereq
(string-append (string-append
@ -698,39 +794,116 @@ failure condition happens, mark the node as having failed."
node)) node))
(define (build root) (define (build root)
"Give a tree of <node>, this executes the recipes therein." "Give a tree of <node>, this executes the recipes therein.
(format #t "BLAMMO 1 ~S~%" root) This is where the magic happens."
(let ((tree (create-node root #f))) (let ((tree (create-node root #f)))
(let ((node tree)) (let ((node tree))
(format #t "~ABegin building target ~a~A~a.~%"
(node-depth-string node) (lquo) (node-get-name node) (rquo))
(while #t (while #t
(when (>= %verbosity 2) (format #t "PRocessing ~S~%" (node-get-name node))) (format #t "~AConsidering target ~a~A~a.~%"
(node-depth-string node) (lquo) (node-get-name node) (rquo))
(if (undetermined? node) (if (undetermined? node)
(begin (begin
(when (>= %verbosity 3) (format #t "~S is undetermined~%" (node-get-name node))) (format #t "~ATarget file ~a~A~a is undetermined.~%"
(node-depth-string node) (lquo) (node-get-name node) (rquo))
(unless (node-get-mtime node)
(format #t "~AFile ~a~A~a does not exist.~%"
(node-depth-string node) (lquo) (node-get-name node) (rquo)))
(if (children-complete? node) (if (children-complete? node)
(if (children-passed? node) (begin
(if (up-to-date? node) (format #t "~AFinished prerequisites of target file ~a~A~a.~%"
(set-pass! node) (node-depth-string node) (lquo) (node-get-name node) (rquo))
;; else, not up to date (if (children-passed? node)
(if (has-rules? node) (begin
(run-rules! node) (format #t "~AThe prerequisites of target file ~a~A~a have passed.~%"
;; else, no recipe exists (node-depth-string node) (lquo) (node-get-name node) (rquo))
(run-default-recipe! node))) (if (up-to-date? node)
;; else, children have failed (begin
(set-fail! node)) (when (node-get-mtime node)
(format #t "~ATarget file ~a~A~a is up to date.~%"
(node-depth-string node)
(lquo) (node-get-name node) (rquo)))
(set-pass! node))
;; else, not up to date
(begin
(format #t "~ATarget file ~a~A~a is not up to date.~%"
(node-depth-string node)
(lquo) (node-get-name node) (rquo))
(cond
((using-target-rule? node)
(format #t "~ATarget file ~a~A~a has a target rule.~%"
(node-depth-string node)
(lquo) (node-get-name node) (rquo))
(run-target-rule! node))
((using-suffix-rules? node)
(format #t "~ATarget file ~a~A~a has a suffix rule.~%"
(node-depth-string node)
(lquo) (node-get-name node) (rquo))
(run-suffix-rules! node))
((using-default-rule? node)
(format #t "~ATarget file ~a~A~a is using the default rule.~%"
(node-depth-string node)
(lquo) (node-get-name node) (rquo))
(run-default-rule! node))
(else
(error "bad rules")))
(if (passed? node)
(format #t "~A[PASS] target file ~a~A~a.~%"
(node-depth-string node)
(lquo) (node-get-name node) (rquo))
(format #t "~A[FAIL] target file ~a~A~a.~%"
(node-depth-string node)
(lquo) (node-get-name node) (rquo))))))
;; else, children have failed
(begin
(format #t "~AThe prerequisites of target file ~a~A~a have failed.~%"
(node-depth-string node) (lquo) (node-get-name node) (rquo))
(set-fail! node))))
;; else, children aren't complete ;; else, children aren't complete
(set! node (get-next-child node)))) (begin
(format #t "~AThe prerequisites of target file ~a~A~a are incomplete.~%"
(node-depth-string node) (lquo) (node-get-name node) (rquo))
(let ((next (get-next-child node)))
(format #t "~ANew node ~a~A~a ~a ~a~A~a.~%"
(node-depth-string node)
(lquo) (node-get-name node) (rquo)
(right-arrow)
(lquo) (node-get-name next) (rquo))
(set! node (get-next-child node))
(format #t "~ATarget is now ~a~A~a.~%~!"
(node-depth-string node)
(lquo) (node-get-name node) (rquo)))
)))
;; else, this node is determined ;; else, this node is determined
(begin (begin
(when (>= %verbosity 2) (format #t "~S is determined ~S~%" (node-get-name node) (node-get-status node))) (if (passed? node)
#| (if (and (not %ignore-errors?) (failed? node)) (format #t "~ATarget file ~a~A~a is passed.~%"
(break)|# (node-depth-string node) (lquo) (node-get-name node) (rquo))
;; else not failed (format #t "~ATarget file ~a~A~a has failed.~%"
(if (has-parent? node) (node-depth-string node) (lquo) (node-get-name node) (rquo)))
(set! node (get-parent node)) (if (has-parent? node)
;; else, there is no parent to this node (begin
(break)) (format #t "~ANew node ~a~A~a ~a ~a~A~a.~%"
;; ) (node-depth-string node)
)))) (lquo) (node-get-name node) (rquo)
(right-arrow)
(lquo) (node-get-name (node-get-parent node)) (rquo))
(set! node (get-parent node)))
;; else, there is no parent to this node
(begin
(format #t "~ATarget file ~a~A~a has no parent.~%"
(node-depth-string node)
(lquo) (node-get-name node) (rquo))
(if (passed? node)
(format #t "~A[COMPLETE] [PASS] target file ~a~A~a.~%"
(node-depth-string node)
(lquo) (node-get-name node) (rquo))
(format #t "~A[COMPLETE] [FAIL] target file ~a~A~a.~%"
(node-depth-string node)
(lquo) (node-get-name node) (rquo)))
(break)))))))
;; Return the command output of the root node ;; Return the command output of the root node
(passed? tree))) (passed? tree)))

4
potato/text.scm
View File

@ -58,6 +58,10 @@
(if %fancy (if %fancy
"→" "->")) "→" "->"))
(define (left-arrow)
(if %fancy
"←" "<-"))
(define (ellipses) (define (ellipses)
(if %fancy "…" "...")) (if %fancy "…" "..."))

285
tests/automatic-variables Executable file
View File

@ -0,0 +1,285 @@
#!/usr/bin/env sh
exec guile -L . -s "$0" "$@"
!#
(use-modules (potato make)
(srfi srfi-1)
(srfi srfi-64))
(test-begin "automatic-variables")
(test-equal "A phony target rule with no prerequisites defines $@."
#t
(begin
(initialize)
(: "clean" '()
(lambda ()
(string=? ($@) "clean")))
(execute)))
(test-equal "A phony target rule with no prerequisites defines $*."
#t
(begin
(initialize)
(: "clean" '()
(lambda ()
(string=? ($*) "clean")))
(execute)))
(test-equal "A phony target rule with no prerequisites has empty string $<."
#t
(begin
(initialize)
(: "clean" '()
(lambda ()
(string-null? ($<))))
(execute)))
(test-equal "A phony target rule with no prerequisites has null list $$?."
#t
(begin
(initialize)
(: "clean" '()
(lambda ()
(null? ($$?))))
(execute)))
(test-equal "A phony target rule with no prerequisites has empty string $?."
#t
(begin
(initialize)
(: "clean" '()
(lambda ()
(string-null? ($?))))
(execute)))
(test-equal "A phony target rule with no prerequisites has null list $$^."
#t
(begin
(initialize)
(: "clean" '()
(lambda ()
(null? ($$^))))
(execute)))
(test-equal "A phony target rule with no prerequisites has empty string $^."
#t
(begin
(initialize)
(: "clean" '()
(lambda ()
(string-null? ($^))))
(execute)))
;;;;;;;;;;;;;;;;
(test-equal "A target rule with a prerequisite defines $@."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x")
(lambda ()
(string=? ($@) "foo.exe")))
(: "foo.x" '() #t)
(execute)))
(test-equal "A target rule with a prerequisite defines $*."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x")
(lambda ()
(string=? ($*) "foo")))
(: "foo.x" '() #t)
(execute)))
(test-equal "A target rule with a prerequisite defines $<."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x")
(lambda ()
(string=? ($<) "foo.x")))
(: "foo.x" '() #t)
(execute)))
(test-equal "A target rule with a prerequisite defines $$?."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x")
(lambda ()
(equal? ($$?) (list "foo.x"))))
(: "foo.x" '() #t)
(execute)))
(test-equal "A target rule with a prerequisite defines $?."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x")
(lambda ()
(string=? ($?) "foo.x")))
(: "foo.x" '() #t)
(execute)))
(test-equal "A target rule with a prerequisite defines $$^."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x")
(lambda ()
(equal? ($$?) (list "foo.x"))))
(: "foo.x" '() #t)
(execute)))
(test-equal "A target rule with a prerequisite defines $^."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x")
(lambda ()
(string=? ($?) "foo.x")))
(: "foo.x" '() #t)
(execute)))
;;;;;;;;;;;;;;;;
(test-equal "A target rule with multiple prerequisites defines $@."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x" "foo.y")
(lambda ()
(string=? ($@) "foo.exe")))
(: "foo.x" '() #t)
(: "foo.y" '() #t)
(execute)))
(test-equal "A target rule with multiple prerequisites defines $*."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x" "foo.y")
(lambda ()
(string=? ($*) "foo")))
(: "foo.x" '() #t)
(: "foo.y" '() #t)
(execute)))
(test-equal "A target rule with multiple prerequisites defines $<."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x" "foo.y")
(lambda ()
(string=? ($<) "foo.x")))
(: "foo.x" '() #t)
(: "foo.y" '() #t)
(execute)))
(test-equal "A target rule with multiple prerequisites defines $$?."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x" "foo.y")
(lambda ()
(equal? ($$?) (list "foo.x" "foo.y"))))
(: "foo.x" '() #t)
(: "foo.y" '() #t)
(execute)))
(test-equal "A target rule with multiple prerequisites defines $?."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x" "foo.y")
(lambda ()
(string=? ($?) "foo.x foo.y")))
(: "foo.x" '() #t)
(: "foo.y" '() #t)
(execute)))
(test-equal "A target rule with multiple prerequisites defines $$^."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x" "foo.y")
(lambda ()
(equal? ($$?) (list "foo.x" "foo.y"))))
(: "foo.x" '() #t)
(: "foo.y" '() #t)
(execute)))
(test-equal "A target rule with multiple prerequisites defines $^."
#t
(begin
(initialize)
(: "foo.exe" '("foo.x" "foo.y")
(lambda ()
(string=? ($?) "foo.x foo.y")))
(: "foo.x" '() #t)
(: "foo.y" '() #t)
(execute)))
;;;;;;;;;;;;;;;;
(test-equal "A suffix rule with a prerequisite defines $@."
#t
(begin
(initialize '("test" "foo.y"))
(-> ".x" ".y"
(lambda ()
(format #t "BLAMMO ~A~%" ($@))
(string=? ($@) "foo.y")))
(: "foo.x" '() #t)
(execute)))
(test-equal "A suffix rule with a prerequisite defines $*."
#t
(begin
(initialize '("test" "foo.y"))
(-> ".x" ".y"
(lambda ()
(format #t "BLAMMO ~A~%" ($*))
(string=? ($*) "foo")))
(: "foo.x" '() #t)
(execute)))
(test-equal "A suffix rule with a prerequisite defines $<."
#t
(begin
(initialize '("test" "foo.y"))
(-> ".x" ".y"
(lambda ()
(format #t "BLAMMO ~A~%" ($<))
(string=? ($<) "foo.x")))
(: "foo.x" '() #t)
(execute)))
(test-equal "A suffix rule with a prerequisite defines $$^."
#t
(begin
(initialize '("test" "foo.y"))
(-> ".x" ".y"
(lambda ()
(format #t "BLAMMO ~A~%" ($$^))
(equal? ($$^) (list "foo.x"))))
(: "foo.x" '() #t)
(execute)))
(test-equal "A suffix rule with a prerequisite defines $^."
#t
(begin
(initialize '("test" "foo.y"))
(-> ".x" ".y"
(lambda ()
(format #t "BLAMMO ~A~%" ($^))
(equal? ($^) "foo.x")))
(: "foo.x" '() #t)
(execute)))
(test-end "automatic-variables")
;; Local Variables:
;; mode: scheme
;; End:

135
tests/makevars Executable file
View File

@ -0,0 +1,135 @@
#!/usr/bin/env sh
exec guile -L . -s "$0" "$@"
!#
(use-modules (potato make)
(srfi srfi-1)
(srfi srfi-64))
(test-begin "makevars")
(test-equal "Makevars can be set in the environment with the --environment flag."
"BAR1"
(begin
(setenv "FOO1" "BAR1")
(initialize '("test" "--environment"))
(let ((result ($ FOO1)))
(unsetenv "FOO1")
result)))
(test-equal "Makevars can be set in the MAKEFLAGS environment variable with the --environment flag."
"BAR2"
(begin
(setenv "MAKEFLAGS" "FOO2=BAR2")
(initialize '("test" "--environment"))
(let ((result ($ FOO2)))
(unsetenv "MAKEFLAGS")
result)))
(test-equal "Makevars can be set with initialize."
"BAR3"
(begin
(initialize '("test" "FOO3=BAR3"))
($ FOO3)))
(test-equal "Makevars can be set in the script."
"BAR4"
(begin
(:= FOO4 "BAR4")
($ FOO4)))
(test-equal "Makevars can be set lazily in the script."
"BAR5"
(begin
(?= FOO5 "BAR5")
($ FOO5)))
(test-assert "A lazy makevar of a procedure is a promise before it is referenced."
(begin
(?= FOO6 (lambda () "BAR6"))
(let ((val (hash-ref (@@ (potato makevars) %makevars) "FOO6")))
(promise? (car val)))))
(test-equal "A lazy makevar of a procedure is a string after it is referenced."
"BAR7"
(begin
(?= FOO7 (lambda () "BAR7"))
($ FOO7)
(let ((val (hash-ref (@@ (potato makevars) %makevars) "FOO7")))
(car val))))
(test-equal "Referencing an unset makevar returns an empty string."
""
($ FOO8))
(test-error "Referencing an unset makevar throws an error in strict mode."
#t
(begin
(initialize '("test" "--strict"))
($ FOO9)))
(test-equal "Assigning an integer to a makevar converts it into a string."
"100"
(begin
(:= FOO10 100)
($ FOO10)))
(test-equal "Assigning a character to a makevar converts it into a string."
"x"
(begin
(:= FOO11 #\x)
($ FOO11)))
(test-equal "Makevar script assignment overrides command-line assignment."
"BAZ14"
(begin
(initialize '("test" "FOO14=BAR14"))
(:= FOO14 "BAZ14")
($ FOO14)))
(test-equal "Makevar script assignment overrides MAKEFLAGS assignment."
"BAZ15"
(begin
(setenv "MAKEFLAGS" "FOO15=BAR15")
(initialize '("test" "--environment"))
(:= FOO15 "BAZ15")
($ FOO15)))
(test-equal "Makevar script assignment overrides environment assignment."
"BAZ16"
(begin
(setenv "FOO16" "BAR16")
(initialize '("test" "--environment"))
(unsetenv "FOO16")
(:= FOO16 "BAZ16")
($ FOO16)))
(test-equal "Makevar command-line assignment overrides script assignment in elevate mode."
"BAR14"
(begin
(initialize '("test" "FOO14=BAR14" "--elevate-environment"))
(:= FOO14 "BAZ14")
($ FOO14)))
(test-equal "MAKEFLAGS assignment overrides script assignment in elevate mode."
"BAR15"
(begin
(setenv "MAKEFLAGS" "FOO15=BAR15")
(initialize '("test" "--elevate-environment"))
(unsetenv "MAKEFLAGS")
(:= FOO15 "BAZ15")
($ FOO15)))
(test-equal "Environment assignment overrides script assignment in elevate mode."
"BAR16"
(begin
(setenv "FOO16" "BAR16")
(initialize '("test" "--elevate-environment"))
(:= FOO16 "BAZ16")
($ FOO16)))
(test-end "makevars")
;; Local Variables:
;; mode: scheme
;; End:

97
tests/recipe-helpers Executable file
View File

@ -0,0 +1,97 @@
#!/usr/bin/env sh
exec guile -L . -s "$0" "$@"
!#
(use-modules (potato make)
(srfi srfi-1)
(srfi srfi-64))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RECIPE HELPERS
(test-begin "recipe_helpers")
(test-assert "initialize"
(initialize))
(test-assert "String-compose returns 'default and procedure."
(let ((ret (~ "hello")))
(and
(eq? (car ret) 'default)
(procedure? (cdr ret)))))
(test-assert "Silent-compose returns 'silent and procedure."
(let ((ret (~@ "hello")))
(and
(eq? (car ret) 'silent)
(procedure? (cdr ret)))))
(test-assert "Always-execute-compose returns 'always-execute and procedure."
(let ((ret (~+ "hello")))
(and
(eq? (car ret) 'always-execute)
(procedure? (cdr ret)))))
(test-assert "Ignore-error-compose returns 'ignore-error and procedure."
(let ((ret (~- "hello")))
(and
(eq? (car ret) 'ignore-error)
(procedure? (cdr ret)))))
(test-equal "String-compose passes through strings."
"hello"
(let ((ret (~ "hello")))
((cdr ret))))
(test-equal "String-compose concatenates strings with an added space."
"hello world"
(let ((ret (~ "hello" "world")))
((cdr ret))))
(test-equal "String-compose doesn't add a space after a null string."
"world"
(let ((ret (~ "" "world")))
((cdr ret))))
(test-equal "String-compose doesn't add a space before a null string."
"hello"
(let ((ret (~ "hello" "")))
((cdr ret))))
(test-equal "String-compose adds a space in lieu of a null medial string."
"hello world"
(let ((ret (~ "hello" "" "world")))
((cdr ret))))
(test-equal "String-compose handles procedure elements."
"hello world"
(let ((ret (~ "hello" (lambda () "world"))))
((cdr ret))))
(test-equal "String-compose handles integer elements."
"hello 123"
(let ((ret (~ "hello" 123)))
((cdr ret))))
(test-equal "String-compose handles character elements."
"hello w"
(let ((ret (~ "hello" #\w)))
((cdr ret))))
(test-equal "String-compose handles makevar elements."
"hello BAR"
(begin
(:= FOO "BAR")
(let ((ret (~ "hello" ($ FOO))))
((cdr ret)))))
(test-equal "An empty string-compose returns a null string."
""
(let ((ret (~)))
((cdr ret))))
(test-end "recipe_helpers")
;; Local Variables:
;; mode: scheme
;; End:

87
tests/suffix-rules Executable file
View File

@ -0,0 +1,87 @@
#!/usr/bin/env sh
exec guile -L . -s "$0" "$@"
!#
(use-modules (potato make)
(srfi srfi-1)
(srfi srfi-64))
(test-begin "suffix_rules")
;; These stubs override the driver that calls
;; 'system' so we can instead just investigate
;; what string it was passed.
(define %cmd #f)
(define (stub-system-pass cmd)
(set! %cmd cmd)
0)
(define (stub-system-fail cmd)
(set! %cmd cmd)
1)
(test-assert "install alternate system driver"
(false-if-exception (install-alternate-system-driver stub-system-pass)))
#|
(test-equal "Suffix rule using recipe helper and automatic variable."
"cc -c foo.c"
(begin
(initialize '("test" "foo.o"))
(-> ".c" ".o"
(~ "cc -c" $<))
(: "foo.c" '() #t)
(execute)
%cmd))
(test-equal "Suffix rule using procedure returning #t."
#t
(begin
(initialize '("test" "foo.o"))
(-> ".c" ".o"
(lambda ()
#t))
(: "foo.c" '() #t)
(execute)))
(test-equal "Suffix rule using procedure returning #f."
#f
(begin
(initialize '("test" "foo.o"))
(-> ".c" ".o"
(lambda ()
#f))
(: "foo.c" '() #t)
(execute)))
(test-equal "Suffix rule using procedure returning string."
"cc -o foo.o foo.c"
(begin
(initialize '("test" "foo.o"))
(-> ".c" ".o"
(lambda ()
"cc -o foo.o foo.c"))
(: "foo.c" '() #t)
(execute)
%cmd))
|#
(test-equal "Multiple possible suffix rules using procedure returning string."
"dc -o foo.o foo.d"
(begin
(initialize '("test"))
(: "all" '("foo.o"))
(-> ".e" ".o"
(lambda ()
"ec -o foo.o foo.e"))
(-> ".d" ".o"
(lambda ()
"dc -o foo.o foo.d"))
(-> ".c" ".o"
(lambda ()
"cc -o foo.o foo.c"))
(: "foo.c" '() #f)
(: "foo.d" '() #t)
(: "foo.e" '() #f)
(execute)
%cmd))
(test-end "suffix_rules")

109
tests/target-rules Executable file
View File

@ -0,0 +1,109 @@
#!/usr/bin/env sh
exec guile -L . -s "$0" "$@"
!#
(use-modules (potato make)
(srfi srfi-1)
(srfi srfi-64))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TARGET RULES
(test-begin "target_rules")
;; These stubs override the driver that calls
;; 'system' so we can instead just investigate
;; what string it was passed.
(define %cmd #f)
(define (stub-system-pass cmd)
(format #t "stub-system-pass receive command ~S~%" cmd)
(set! %cmd cmd)
0)
(define (stub-system-fail cmd)
(set! %cmd cmd)
1)
(test-assert "Install alternate system driver."
(false-if-exception (install-alternate-system-driver stub-system-pass)))
(test-equal "A string target rule is sent to system driver."
"cc -o foo.exe foo.c"
(begin
(initialize)
(: "foo.exe" '("foo.c")
"cc -o foo.exe foo.c")
(: "foo.c" '() #t)
(execute)
%cmd))
(test-assert "target rule is a procedure"
(begin
(let ((tmpvar #f))
(initialize '("test" "foo.exe"))
(: "foo.exe" '("foo.c")
(lambda ()
(set! tmpvar #t)))
(: "foo.c" '() #t)
(execute)
tmpvar)))
(test-equal "target rule is a procedure returning a string"
"cc -o foo.exe foo.c"
(begin
(initialize '("test" "foo.exe"))
(: "foo.exe" '("foo.c")
(lambda ()
("cc -o foo.exe foo.c")))
(execute)
%cmd))
(test-equal "target rule using string-compose on a string"
"cc -o foo.exe foo.c"
(begin
(initialize '("test" "foo.exe"))
(: "foo.exe" '("foo.c")
(~ "cc -o foo.exe foo.c"))
(execute)
%cmd))
(test-equal "target rule using string-compose on special variables"
"cc -o foo.exe foo.c"
(begin
(initialize '("test" "foo.exe"))
(: "foo.exe" '("foo.c")
(~ "cc -o" $@ $<))
(execute)
%cmd))
(test-equal "target rule check success"
#t
(begin
(initialize '("test" "foo.exe"))
(: "foo.exe" '("foo.c")
(~ "cc -o" $@ $<))
(: "foo.c" '() #t)
(execute)))
(test-assert "install failing alternate system driver"
(false-if-exception (install-alternate-system-driver stub-system-fail)))
(test-equal "target rule check failure of system call"
#f
(begin
(initialize '("test" "foo.exe"))
(: "foo.exe" '("foo.c")
(~ "cc -o" $@ $<))
(execute)))
(test-equal "target rule check failure of scheme procedure"
#f
(begin
(initialize '("test" "foo.exe"))
(: "foo.exe" '("foo.c")
(lambda ()
#f))
(execute)))
(test-end "target_rules")