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

44
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 [transformer])
Look up `key` in the `%makevars` hash table and return the result
as a string. If `key` is not found, return an empty string.
If a string-to-string transformer procedure is provided, apply it to each
space-separated token in the result.
Look up `key` in the `%makevars` hash table and return the
result as a string. If `key` is not found, return an empty
string. If a string-to-string transformer procedure is
provided, apply it to each space-separated token in the
result.
(?= key val)
Assign `val` to `key` in the `%makevars` hash table. If `val` is a procedure,
assign its output to `key` the first time that `key` is referenced.
Assign `val` to `key` in the `%makevars` hash table. If `val`
is a procedure, assign its output to `key` the first time that
`key` is referenced.
(:= key val)
Assign `val` to `key` in the `%makevars` hash table. If `val` is a procedure,
evaluate it and assign its output to `key` immediately.
Assign `val` to `key` in the `%makevars` hash table. If `val`
is a procedure, evaluate it and assign its output to `key`
immediately.
## Rules
@ -47,8 +52,8 @@ have filenames or phony names.
recipe-2
...)
`target-name` is a string which is either a filename to be created
or an phony name like "all" or "clean".
`target-name` is a string which is either a filename to be
created or an phony name like "all" or "clean".
Recipe as a string to be evaluated by the system
@ -85,11 +90,24 @@ have filenames or phony names.
Recipe as a boolean to indicate pass or failure without doing any
processing. For example, the rule below tells Potato Make that
the file "foo.c" exists without actually testing for it.
(: "foo.c" '() #t)
The *suffix rule* is a generic rule to convert one source file to
a target file, based on the filename extensions.
If there is no recipe at all, it is shorthand for the recipe #t,
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"
(~ ($ CC) ($ CFLAGS) "-c" $< "-o" $@))

3
potato/make.scm
View File

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

519
potato/rules.scm
View File

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

4
potato/text.scm
View File

@ -58,6 +58,10 @@
(if %fancy
"→" "->"))
(define (left-arrow)
(if %fancy
"←" "<-"))
(define (ellipses)
(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")