mostly working

CHEATSHEET.md

@@ -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
+        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)
-        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)
-        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
 
@@ -47,8 +52,8 @@ have filenames or phony names.
        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
 
@@ -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
+     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"
        (~ ($ CC) ($ CFLAGS) "-c" $< "-o" $@))

potato/make.scm

@@ -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)

potato/rules.scm

@@ -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 :
+           target-rule         :
-           suffix-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
+  "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)
-    (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
@@ -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 "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
   ;; (cons 'default string)
   (let ((recipes2
@@ -161,10 +183,8 @@ it is evaluated."
                 (cond
                  ((pair? recipe)
                   recipe)
-                 ((string? recipe)
+                     (else
-                  (cons 'default recipe))
+                      (cons 'default recipe))))
-                 (else
-                  (error "bad recipe for target rule"))))
               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)
+(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)
   (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)
+    (any passed? children)))
-        #f
-        (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)
+    (every passed? children)))
-        #f
-        (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)
+    (any failed? children)))
-        #f
-        (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)
+    (every failed? children)))
-        #f
-        (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)
+    (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)
   (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)
+(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)))
     (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)))
+(define (run-suffix-rules! node)
-         ((suffix-rule? rule)
+  "Runs the one-or-more suffix rules associated with this node.  It
-        (suffix-rule-prep-automatic-variables node rule)
+runs them one-by-one, quitting on the first success."
-        (run-recipes! node (suffix-rule-get-recipes rule)))
+  (unless (node? node)
-         (else
+    (scm-error 'wrong-type'arg "run-suffix-rules!" "Not a node: ~S" (list node) #f))
-          (error "bad rule")))
+
-        
+  (let ((rules (node-get-rules node))
-        (let ((status (node-get-status node)))
+        (children (node-get-children node)))
-          (cond
+    (when (null? rules)
-           ((or (and (eq? 'and logic)
+      (scm-error 'misc-error "run-suffix-rules!" "Node ~S has no rules"
-                     (eq? 'fail status))
+                 (list (node-get-name node)) #f))
-                (and (eq? 'or logic)
+    (when (null? children)
-                     (eq? 'pass status))
+      (scm-error 'misc-error "run-suffix-rule!" "Node ~S has no children"
-                (null? rest))
+                 (list (node-get-name node)) #f))
-            ;; We're done
+    (unless (any-child-has-passed? node)
-            status)
+      (scm-error 'misc-error "run-suffix-rule!" "Node ~S: not child has passed"
-           (else
+                 (list (node-get-name node)) #f))
-            (loop (car rest) (cdr rest)))))))))
+    (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)
+  (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)
-        (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))))))
 
-(define (run-default-recipe! node)
+  (let ((i 0)
-  "The default recipe passes if the file exists"
+        (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."
+  "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 ((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)
+                  (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
-                  (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 (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
     (passed? tree)))

potato/text.scm

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

tests/automatic-variables

@@ -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:

tests/makevars

@@ -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:

tests/recipe-helpers

@@ -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:

tests/suffix-rules

@@ -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")

tests/target-rules

@@ -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")