stash

CHEATSHEET.md

@@ -13,7 +13,7 @@ Add this at the top of your build script.
 
 Add this at the bottom of your build script
 
-    (build)
+    (execute)
     
 The rules go in between `initialize` and `build`
 

README.md

@@ -41,8 +41,7 @@ is named `makefile.scm`; however, you may choose any name.
     !#
 
     (use-modules (potato make))
-    (setup (command-line))
+    (initialize)
-
 
 This boilerplate loads the library functions and it parses the
 command-line arguments.  The command-line arguments are the following,
@@ -72,6 +71,8 @@ command-line arguments.  The command-line arguments are the following,
                  'always execute'
              -a, --ascii
                  use ASCII-only output and no colors
+             -W, --warn
+                 enable warning messages
              
              [var=value...]
                set the value of makevars
@@ -85,6 +86,20 @@ command-line arguments to be enabled to pick up environment variables
 and built-in rules.  This is to make this tool more appropriate for
 generating *reproducible builds*.
 
+If you don't want `initialize` to parse the command line, you may call
+it with specific command line arguments, like the example below.  The
+first string is the name of the script, and then any combination of
+flags, macro assignments and targets may follow.
+
+    (initialize '("makefile.scm" "--verbose" "CC=gcc" "all"))
+
+If you call initialize with an empty list as below, it will guess the
+script name from the command-line arguements, but, will ignore all
+other flags and options.
+
+    ;; ignore all command line arguments except the script name
+    (initialize '())
+
 ## Environment Variables
 
 Certain environment variables affect the execution of the makefile
@@ -375,8 +390,12 @@ The library provides the following procedures for makevars
     reference key [transformer]
 
 > `reference` looks up KEY in the `%makevar` hash table.  If it is
-> found, VALUE is returned as a string.  If it is not found, `#f` is
+> found, VALUE is returned as a string.
-> returned.
+
+> *IMPORTANT!* If it is not found, an empty string is returned.  This
+> is because it is a common practice in makefiles to use makevars that
+> may or may not be defined by environment variables. In `--verbose`
+> mode, a warning will be printed when a key cannot be found.
         
 > If the value was stored using `lazy-assign` and is a *promise*, this
 > procedure is *forced* to return a string.  Also, the value in the

doodle.txt

@@ -2,3 +2,9 @@
 U+220E END OF PROOF
 U+227A PRECEDES
 U+227B SUCCEEDS
+
+a.out
+→ foo.o [PASS]
+-> bar.o [PASS]
+
+a.out ≺

potato/exceptions.scm

@@ -5,6 +5,7 @@
             bad-proc-output
             invalid-macro
             not-a-regular-file
+            not-a-procedure
             no-read-access-to-file
             ))
 
@@ -58,6 +59,16 @@
 (define (not-a-regular-file origin irritant)
   (raise-exception (make-not-a-regular-file origin irritant)))
 
+(define (make-not-a-procedure origin irritants)
+  (make-exception
+   (make-programming-error)
+   (make-exception-with-origin origin)
+   (make-exception-with-message "Not a procedure")
+   (make-exception-with-irritants irritants)))
+
+(define (not-a-procedure origin irritant)
+  (raise-exception (make-not-a-procedure origin irritant)))
+
 (define (make-no-read-access-to-file origin irritants)
   (make-exception
    (make-programming-error)

potato/make.scm

@@ -9,12 +9,11 @@
   #:use-module (potato rules)
   #:use-module (potato text)
   #:export (initialize
-            execute
+            execute)
-            )
   #:re-export (%suffix-rules
                lazy-assign    ?=
                assign         :=
-               reference      $
+               reference      $    Q
                reference-func $$
                target-rule    :
                suffix-rule    ->
@@ -23,10 +22,15 @@
                newer-prerequisites  $?
                prerequisites        $^
                primary-prerequisite $<
-               compose              ~               
+               string-compose       ~
+               silent-compose       ~@
+               always-execute-compose ~+
+               ignore-error-compose ~-
+               install-alternate-system-driver
                               ))
 
 (define %version "1.0")
+(define %debug-argv0 #f)
 
 ;; #:re-export (
 ;;              lazy-assign ?=
@@ -58,7 +62,7 @@
 ;; If the -t option was specified, make shall write to standard
 ;; output a message for each file that was touched.
 
-(define %opt-quiet #f)
+(define %opt-terse #f)
 (define %opt-verbose #f)
 (define %opt-ignore-errors #f)
 (define %opt-continue-on-error #f)
@@ -68,7 +72,7 @@
 (define (critical spec . args)
   (apply format (append (list #t spec) args)))
 (define (print spec . args)
-  (unless %opt-quiet
+  (unless %opt-terse
     (apply format (append (list #t spec) args))))
 (define (debug spec . args)
   (when %opt-verbose
@@ -77,7 +81,7 @@
 (define option-spec
   '((help              (single-char #\h) (value #f))
     (version           (single-char #\v) (value #f))
-    (quiet             (single-char #\q) (value #f))
+    (terse             (single-char #\q) (value #f))
     (verbose           (single-char #\V) (value #f))
     (environment       (single-char #\e) (value #f))
     (elevate-environment (single-char #\E) (value #f))
@@ -86,14 +90,15 @@
     (continue-on-error (single-char #\k) (value #f))
     (no-execution      (single-char #\n) (value #f))
     (ascii             (single-char #\A) (value #f))
+    (strict            (single-char #\S) (value #f))
     ))
 
 (define (display-help-and-exit argv0)
   (format #t "~A [-hvqVeEbn] [KEY=VALUE ...] [targets ...]~%" argv0)
   (format #t "    -h, --help                     print help and exit~%")
   (format #t "    -v, --version               print version and exit~%")
-  (format #t "    -q, --quiet                   print minimal output~%")
+  (format #t "    -q, --terse                       use terse output~%")
-  (format #t "    -V, --verbose                 print maximum output~%")
+  (format #t "    -V, --verbose                   use verbose output~%")
   (format #t "    -e, --environment        use environment variables~%")
   (format #t "    -E, --elevate-environment~%")
   (format #t "                     use environment variables and let~%")
@@ -101,13 +106,15 @@
   (format #t "    -b, --builtins~%")
   (format #t "        include some common variables and suffix rules~%")
   (format #t "    --ignore-errors~%")
-  (format #t "                   keep building even if commands fail~%")
+  (format #t "                                     ignore all errors~%")
   (format #t "    -k, --continue-on-error~%")
-  (format #t "                   keep building even if commands fail~%")
+  (format #t "           after an error, keep building other targets~%")
   (format #t "    -n, --no-execution~%")
   (format #t "         only execute rules marked as 'always execute'~%")
   (format #t "    -a, --ascii~%")
   (format #t "                       ASCII only output and no colors~%")
+  (format #t "    -S, --strict~%")
+  (format #t "                causes some behaviours to throw errors~%")
   (exit 0))
 
 (define (display-version-and-exit argv0)
@@ -120,7 +127,7 @@
 of pairs of KEY VAL"
   (filter-map
    (lambda (str)
-     (let ((tok (string-split str #\x)))
+     (let ((tok (string-split str #\=)))
        (cond
         ((= 1 (length tok))
          #f)
@@ -141,15 +148,20 @@ return them in a list."
    lst))
 
 (define* (initialize #:optional
-                     (arguments '()))
+                     (arguments #f))
   "Set up the options, rules, and makevars. If ARGUMENTS
 is not set, it will use options, makevars, and targets as
 specified by the command line.  If it is set, it is
 expected to be a list of strings that are command-line
 arguments."
 
+  ;; If left unset, assume user want all the command line arguments.
+  (when (not arguments)
+    (set! arguments (command-line)))
+  ;; If the user has set it to '(), expecting a null environment, add
+  ;; back in a filename, which is required.
   (when (null? arguments)
-    (set! arguments (program-arguments)))
+    (set! arguments (list (car (program-arguments)))))
 
   ;; We start of with the --help and --version command-line arguments.
   (let ((options (getopt-long arguments option-spec))
@@ -159,7 +171,8 @@ arguments."
         (%opt-no-errors #f)
         (%opt-continue-on-error #f)
         (%opt-no-execution #f)
-        (%opt-ascii #f))
+        (%opt-ascii #f)
+        (%opt-strict #f))
     (when (option-ref options 'help #f)
       (display-help-and-exit (car arguments)))
     (when (option-ref options 'version #f)
@@ -176,12 +189,12 @@ arguments."
       (let ((mf (getenv "MAKEFLAGS")))
         (when mf
           (let ((tokens (string-tokenize mf)))
-            (when (member "quiet" tokens)
+            (when (member "terse" tokens)
-              (set! %opt-quiet #t)
+              (set! %opt-terse #t)
               (set! %opt-verbose #f))
             (when (member "verbose" tokens)
               (set! %opt-verbose #t)
-              (set! %opt-quiet #f))
+              (set! %opt-terse #f))
             (when (member "builtins" tokens)
               (set! %opt-builtins #t))
             (when (member "ascii" tokens)
@@ -190,28 +203,32 @@ arguments."
               (set! %opt-ignore-errors #t))
             (when (member "continue-on-error" tokens)
               (set! %opt-continue-on-error #t))
+            (when (member "strict" tokens)
+              (set! %opt-strict #t))
             (when (member "no-execution" tokens)
               (set! %opt-no-execution #t))))))
 
     ;; Now the bulk of the command-line options.
-    (when (option-ref options 'quiet #f)
+    (when (option-ref options 'terse #f)
-      (set! %opt-quiet #t)
+      (set! %opt-terse #t)
       (set! %opt-verbose #f))
     (when (option-ref options 'verbose #f)
       (set! %opt-verbose #t)
-      (set! %opt-quiet #f))
+      (set! %opt-terse #f))
-    (set! %opt-builtins
+    (when (option-ref options 'builtins #f)
-      (option-ref options 'builtins #f))
+      (set! %opt-builtins #t))
-    (set! %opt-elevate-environment
+    (when (option-ref options 'elevate-environment #f)
-      (option-ref options 'elevate-environment #f))
+      (set! %opt-elevate-environment #t))
-    (set! %opt-ignore-errors
+    (when (option-ref options 'ignore-errors #f)
-      (option-ref options 'ignore-errors #f))
+      (set! %opt-ignore-errors #t))
-    (set! %opt-continue-on-error
+    (when (option-ref options 'continue-on-error #f)
-      (option-ref options 'continue-on-error #f))
+      (set! %opt-continue-on-error #t))
-    (set! %opt-no-execution
+    (when (option-ref options 'no-execution #f)
-      (option-ref options 'no-execution #f))
+      (set! %opt-no-execution #t))
-    (set! %opt-ascii
+    (when (option-ref options 'ascii #f)
-      (option-ref options 'ascii #f))
+      (set! %opt-ascii #t))
+    (when (option-ref options 'strict #f)
+      (set! %opt-strict #t))
 
     ;; Now that all the options are set, we can set up
     ;; the build environment.
@@ -221,14 +238,20 @@ arguments."
                            %opt-environment
                            %opt-elevate-environment
                            %opt-builtins
+                           %opt-strict
                            %opt-verbose
                            %opt-ascii)
-      #;(initialize-rules %opt-no-builtins
-                        %opt-verbose)
-      
       ;; The remaining command-line words are the build targets that
       ;; we're going to tackle.
       (set! %targets (parse-targets extra))
+      (initialize-rules %targets
+                        %opt-builtins
+                        %opt-ignore-errors
+                        %opt-continue-on-error
+                        %opt-no-execution
+                        %opt-terse
+                        %opt-verbose
+                        %opt-ascii)
       (set! %initialized #t)
       %targets
       )))
@@ -262,7 +285,7 @@ targets listed on the parsed command-line are used."
       (if (not (build target))
                       ;; %opt-ignore-errors
                       ;; %opt-continue-on-error
-                      ;; %opt-quiet
+                      ;; %opt-terse
                       ;; %opt-verbose))
           (begin
             (print "The recipe for “~A” has failed.~%" target))

potato/makevars.scm

@@ -9,7 +9,7 @@
             %elevate-environment?
             lazy-assign    ?=
             assign         :=
-            reference      $
+            reference      $    Q
             reference-func $$
             dump-makevars
             ))
@@ -27,6 +27,7 @@
 (define %ascii? #f)
 (define %makevars #f)
 (define %elevate-environment? #f)
+(define %strict #f)
 (define %verbose? #t)
 (define (debug spec . args)
   (when %verbose?
@@ -55,7 +56,7 @@ later equals signs."
   "The logic of whether which makemacro priority levels can override
 others."
   (if %elevate-environment?
-      (if (and (or (= old-priority) (= old-priority 3) (= old-priority 4))
+      (if (and (or (= old-priority 2) (= old-priority 3) (= old-priority 4))
                (= new-priority 1))
           #f
           ;; else
@@ -185,15 +186,17 @@ the value of MAKEFLAGS or SHELL."
                              environment?
                              elevate-environment?
                              builtins?
+                             strict?
                              verbose?
                              ascii?)
   (set! %elevate-environment? elevate-environment?)
   (set! %makevars (make-hash-table))
+  (set! %strict strict?)
   (set! %verbose? verbose?)
   (set! %ascii? ascii?)
   (when builtins?
     (makevars-add-builtins))
-  (when environment?
+  (when (or environment? elevate-environment?)
     (makevars-add-environment)
     (makevars-add-makeflags))
   (makevars-add-keyvals keyvals)
@@ -211,19 +214,13 @@ the key in the hash table entry.
 later. The promise will be evaluated the first time this key is
 referenced.
     If VAL is not given, the empty string will be used."
-  (when (and (not (string? key))
+  (when (procedure? key)
-             (not (procedure? key)))
+    (set! key (key)))
-    (bad-key-type "lazy-assign" (list key)))
+  (unless (string? key)
-  (when (and (not (string? val))
+    (set! key (format #f "~a" key)))
-             (not (procedure? val)))
+  (makevars-set key (delay val))
-    (bad-value-type "lazy-assign" (list val)))
+  (when %verbose?
-  (let ((KEY (if (string? key) key (key)))
+    (format #t "~A=~A~%" key val)))
-        (VAL (if (string? val) val (delay val))))
-    (unless (string? KEY)
-      (bad-proc-output "lazy-assign" key))
-    (makevars-set KEY VAL)
-    (when (and %verbose? (string? VAL))
-      (format #t "~A=~A~%" KEY VAL))))
 
 (define-syntax ?=
   (lambda (stx)
@@ -240,21 +237,17 @@ VAL.
     If KEY and/or VAL is a thunk, it is immediately evaluated to a
 string to use as the key in the hash table entry.
     If VAL is not given, the empty string will be used."
-  (when (and (not (string? key))
+  (when (procedure? key)
-             (not (procedure? key)))
+    (set! key (key)))
-    (bad-key-type "assign" (list key)))
+  (unless (string? key)
-  (when (and (not (string? val))
+    (set! key (format #f "~a" key)))
-             (not (procedure? val)))
+  (when (procedure? val)
-    (bad-value-type "assign" (list val)))
+    (set! val (val)))
-  (let ((KEY (if (string? key) key (key)))
+  (unless (string? val)
-        (VAL (if (string? val) val (val))))
+    (set! val (format #f "~a" val)))
-    (unless (string? KEY)
+  (makevars-set key val)
-      (bad-proc-output "assign" KEY))
+  (when %verbose?
-    (unless (string? VAL)
+    (format #t "~A=~A~%" key val)))
-      (bad-proc-output "assign" VAL))
-    (makevars-set KEY VAL)
-    (when %verbose?
-      (format #t "~A=~A~%" KEY VAL))))
 
 (define-syntax :=
   (lambda (stx)
@@ -264,8 +257,7 @@ string to use as the key in the hash table entry.
       ((_ key)
        #'(assign (symbol->string (syntax->datum #'key)))))))
 
-
+(define* (reference key quoted? #:optional (transformer #f))
-(define* (reference key #:optional (transformer #f))
   "Looks up KEY in the %makevars hash table. KEY may be a string
 or a procedure that evaluates to a string.
      If the value of the key
@@ -284,33 +276,62 @@ space-separated token in the looked-up value."
     (set! key (key))
     (unless (string? key)
       (bad-proc-output "reference" key)))
+  (when (not (string? key))
+    (set! key (format #t "~a" key)))
   (let* ((val&priority (hash-ref %makevars key))
          (val (if (pair? val&priority) (car val&priority) #f))
          (priority (if (pair? val&priority) (cdr val&priority) #f)))
     (if (not val)
-        #f
+        (if %strict
+            (error (format #t "There is no makevar for key ~a~%" key))
+            ;; else
+            (if quoted?
+                "\"\""
+                ""))
         ;; else
         (begin
-          (when (promise? val)
+          (cond
+           ((promise? val)
             (set! val (force val))
-            (unless (string? val)
+            (cond
-              (bad-proc-output "reference" val))
+             ((string? val)
-            (hash-set! %makevars key (cons val priority))
+              ;; noop
-            (when %verbose?
+              #t)
-              (format #t "~A=~A~%" key val)))
+             ((procedure? val)
+              (set! val (val)))
+             (else
+              (set! val (format #f "~a" val)))))
+           ((string? val)
+            ;; noop
+            #f)
+           (else
+            (set! val (format #f "~a" val))))
+          (hash-set! %makevars key (cons val priority))
+          (when %verbose?
+            (format #t "~A=~A~%" key val))
           (when (procedure? transformer)
             (set! val (string-append-with-spaces
                        (map transformer
                             (string-tokenize val)))))
-          val))))
+          (if quoted?
+              (string-append "\"" val "\"")
+              val)))))
 
 (define-syntax $
   (lambda (stx)
     (syntax-case stx ()
-      ((_ key val)
+      ((_ key transformer)
-       #'(reference (symbol->string (syntax->datum #'key)) transformer))
+       #'(reference (symbol->string (syntax->datum #'key)) #f transformer))
       ((_ key)
-       #'(reference (symbol->string (syntax->datum #'key)))))))
+       #'(reference (symbol->string (syntax->datum #'key)) #f)))))
+
+(define-syntax Q
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ key transformer)
+       #'(reference (symbol->string (syntax->datum #'key)) #t transformer))
+      ((_ key)
+       #'(reference (symbol->string (syntax->datum #'key)) #t)))))
 
 (define (reference-func key)
   "Looks up KEY in the %makevars hash table. KEY shall be a string
@@ -347,3 +368,4 @@ that string."
     (syntax-case stx ()
       ((_ key)
        #'(reference-func (symbol->string (syntax->datum #'key)))))))
+

potato/rules.scm

@@ -1,9 +1,11 @@
 (define-module (potato rules)
   #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (potato exceptions)
   #:use-module (potato builtins)
   #:use-module (potato makevars)
+  #:use-module (potato text)
   #:export(<target-rule>
            <suffix-rule>
            <node>
@@ -11,6 +13,7 @@
            %suffix-rules
            initialize-rules
            first-target-rule-name
+           install-alternate-system-driver
            target-rule :
            suffix-rule ->
            target-name         $@
@@ -25,6 +28,18 @@
            ignore-error-compose   ~-
            ))
 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GLOBALS
+
+(define %ignore-errors? #f)
+(define %continue-on-error? #f)
+(define %no-execution? #f)
+(define %terse? #f)
+(define %verbose? #f)
+(define %ascii? #f)
+(define %top-level-targets '())
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; HELPER FUNCTIONS
 
@@ -52,10 +67,11 @@ it is evaluated."
               (effective-arg #f))
           (cond
            ((procedure? arg)
+            (format #t "BLAMMO ~s ~s ~%" arg (arg))
             (set! effective-arg (arg))
             
-            #;(unless (string? effective-arg)
+            (unless (string? effective-arg)
-            (bad-proc-output "~" arg))
+              (bad-proc-output "~" arg))
             )
            ((string? arg)
             (set! effective-arg arg))
@@ -94,7 +110,7 @@ it is evaluated."
 (define (always-execute-compose . args)
   (cons 'always-execute (apply base-compose args)))
 
-(define ~@ always-execute-compose)
+(define ~+ always-execute-compose)
 
 (define (regular-file? filename)
   (let ((st (stat filename #f)))
@@ -105,6 +121,15 @@ it is evaluated."
     (+ (* 1000000000 (stat:mtime st))
        (stat:mtimensec st))))
 
+(define %system-proc system)
+
+(define (install-alternate-system-driver proc)
+  "Give a procure to use rather than the standard
+'system' procedure."
+  (unless (procedure? proc)
+    (not-a-procedure "install-alternate-system-driver" proc))
+  (set! %system-proc proc))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; TARGET STRUCT AND METHODS
 
@@ -128,10 +153,25 @@ it is evaluated."
 
 (define* (target-rule name #:optional (prerequisites '()) #:rest recipes)
   "Register a new target rule"
-  ;; FIXME: Typecheck
+
-  (let ((rule (make-target-rule name prerequisites recipes 1)))
+  (when %verbose?
-    ;; Add to %target-rules
+    (format #t "Defining target rule: ~A ~A ~A~%" prerequisites (right-arrow) name))
-    (set! %target-rules (cons rule %target-rules))))
+  ;; If any recipes are raw strings, we need to make them into
+  ;; (cons 'default string)
+  (let ((recipes2
+         (map (lambda (recipe)
+                (cond
+                 ((pair? recipe)
+                  recipe)
+                 ((string? recipe)
+                  (cons 'default recipe))
+                 (else
+                  (error "bad recipe for target rule"))))
+              recipes)))
+
+    (let ((rule (make-target-rule name prerequisites recipes2 1)))
+      ;; Add to %target-rules
+      (set! %target-rules (cons rule %target-rules)))))
 
 ;; Alias
 (define : target-rule)
@@ -166,9 +206,25 @@ it is evaluated."
 
 (define (suffix-rule source target . recipes)
   "Register a suffix rule"
+  
   ;; FIXME: Typecheck
-  (let ((rule (make-suffix-rule source target recipes 1)))
+  (when %verbose?
-    (set! %suffix-rules (cons rule %suffix-rules))))
+    (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)
+  (let ((recipes2
+         (map (lambda (recipe)
+                (cond
+                 ((pair? recipe)
+                  recipe)
+                 ((string? recipe)
+                  (cons 'default recipe))
+                 (else
+                  (error "bad recipe for target rule"))))
+              recipes)))
+  
+    (let ((rule (make-suffix-rule source target recipes 1)))
+      (set! %suffix-rules (cons rule %suffix-rules)))))
 
 ;; Alias
 (define -> suffix-rule)
@@ -183,14 +239,14 @@ it is evaluated."
   ;; just a label.
   (name      node-get-name node-set-name!)
   ;; A <node> which is the parent of this node, or #f.
-  (parent    note-get-parent note-set-parent!)
+  (parent    node-get-parent node-set-parent!)
   ;; If 'name' is a regular file, mtime holds its last modification
   ;; time in nanoseconds since the epoch. If 'name' does not exist,
   ;; _mtime is #f.
   (mtime     node-get-mtime node-set-mtime!)
   ;; One of 'pass, 'fail, or 'undetermined
   (status    node-get-status node-set-status!)
-  ;; A list of rules to evaluate to try to c
+  ;; 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
@@ -198,60 +254,51 @@ it is evaluated."
   (logic     node-get-logic node-set-logic!)
   )
 
+(define (has-rules? node)
+  (not (null? (node-get-rules node))))
 
-;;;;;;;;;
+(define (set-fail! node)
-;; Automatic variables
+  (node-set-status! node 'fail))
-;;              target-name          $@
-;;              target-basename      $*
-;;              newer-prerequisites  $?
-;;              prerequisites        $^
-;;              primary-prerequisite $<
 
+(define (set-pass! node)
+  (node-set-status! node 'pass))
 
-;; This is set in the builder to make automatic variables work.
+(define (failed? node)
-(define %node-cur #f)
+  (eqv? (node-get-status node) 'fail))
 
-(define target-name
+(define (passed? node)
-  (lambda ()
+  (eqv? (node-get-status node) 'pass))
-    (if %node-cur
-        (node-get-name %node-cur)
-        #f)))
-
-(define $@ target-name)
-
-(define target-basename
-  (lambda ()
-    (if %node-cur
-        (basename (node-get-name %node-cur)))))
-
-(define $* target-basename)
-
-(define primary-prerequisite
-  (lambda ()
-    (if %node-cur
-        (let ((prereq (node-get-children %node-cur)))
-          (if (null? prereq)
-              ""
-              (car prereq))))))
-
-(define $< primary-prerequisite)
-
-(define newer-prerequisites
-  (lambda ()
-    (error "FIXME")))
-
-(define $? newer-prerequisites)
-
-(define prerequisites
-  (lambda ()
-    (error "FIXME")))
-
-(define $^ prerequisites)
 
+(define (leaf-node? node)
+  (null? (node-get-children node)))
 
 (define (undetermined? node)
   (eq? (node-get-status node) 'undetermined))
 
+(define (any-child-has-passed? node)
+  (let ((children (node-get-children node)))
+    (if (null? children)
+        #f
+        (any passed? children))))
+
+(define (every-child-has-passed? node)
+  (let ((children (node-get-children node)))
+    (if (null? children)
+        #f
+        (every passed? children))))
+
+(define (any-child-has-failed? node)
+  (let ((children (node-get-children node)))
+    (if (null? children)
+        #f
+        (any failed? children))))
+
+(define (every-child-has-failed? node)
+  (let ((children (node-get-children node)))
+    (if (null? children)
+        #f
+        (every failed? children))))
+
 (define (children-complete? node)
   (cond
    ((leaf-node? node)
@@ -276,32 +323,26 @@ it is evaluated."
    (else
     #f)))
 
-(define (has-recipe? node)
-  (not (null? (node-get-recipe node))))
-
-(define (set-fail! node)
-  (node-set-status! node 'fail))
-
-(define (set-pass! node)
-  (node-set-status! node 'fail))
-
 (define (get-next-child node)
   "Return the first child node that is not yet PASS or FAIL"
   (let ((children (node-get-children node)))
-    (any (lambda (child)
+    (if (null? children)
-           (if (eqv? (node-get-status child) 'undetermined)
+        #f
-               child
+    
-               #f))
+        (any (lambda (child)
-         children)))
+               (if (eqv? (node-get-status child) 'undetermined)
-
+                   child
-(define (failed? node)
+                   #f))
-  (eqv? (node-get-status node) 'fail))
+             children))))
 
 (define (has-parent? node)
   (if (node-get-parent node)
       #t
       #f))
 
+(define (get-parent node)
+  (node-get-parent node))
+
 (define (up-to-date? node)
   "Checks if node is up to date:
 - it has an mtime
@@ -317,247 +358,369 @@ it is evaluated."
         #t
         #f)))
 
-(define (get-parent node)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  (node-get-parent node))
+;; AUTOMATIC VARIABLES
-#|
-(define (run-recipe! node quiet verbose)
-  "Runs the recipes associated with this node, one by one.  Recipes
-are either strings, procedures that return strings, or generic
-procedures.  If a failure condition happens, mark the node as having
-failed."
-  (let ((recipes (node-get-recipes node)))
-    (when (null? recipes)
-      (error "no recipe"))
-    (let loop ((opt/recipe (car recipes))
-               (rest (cdr recipes)))
-      (let ((opt ((car recipe/opt))
-                 (recipe (cdr recipe)))
-            ;; Recipes are either
-            ;; - strings to pass to system
-            ;; - procedures that return a string which is passed
-            ;;   to system
-            ;; - procedures (that don't return a string) that are executed
-            ;;   that pass unless they return #f
-                                        ; OPT is one of 'default, 'ignore, 'silent
-            (cond
-             ((string=? recipe)
-              (unless (or quiet (eq? opt 'silent))
-                (format #t "[SYSTEM] ~A~$" recipe)
-                (let ((retval (system recipe)))
-                  (unless (or quiet (eq? opt 'silent))
-                    (format #t " --> ~S~%" (status:exit-val retval)))
-                  (when (and (not (eqv? opt 'ignore))
-                             (or (eqv? #f (status:exit-val retval))
-                                 (not (zero? (status:exit-val retval)))))
-                    (node-set-status! node 'fail))))
-              ((procedure? recipe)
-               (unless (or quiet (eq? opt 'silent))
-                 (if (procedure-name recipe)
-                     (format #t "[PROC] ~A~%" (procedure-name recipe))
-                     (format #t "[PROC] ~%")))
-               (let ((retval (recipe)))
-                 (unless (or quiet (eq? opt 'silent))
-                   (format #t " --> ~S~%" (status:exit-val retval2)))
-                 (cond
-                  ((eqv? retval #f)
-                   (unless (eqv? opt 'ignore)
-                     (node-set-status node 'fail)))
-                  ((string=? retval)
-                   (unless (or quiet (eq? opt 'silent))
-                     (format #t "[SYSTEM] ~A~$" retval)
-                     (let ((retval2 (system retval)))
-                       (unless (or quiet (eq? opt 'silent))
-                         (format #t " --> ~S~%" (status:exit-val retval2)))
-                       (when  (and (not (eqv? opt 'ignore))
-                                   (or (eqv? #f (status:exit-val retval))
-                                       (not (zero? (status:exit-val retval)))))
-                         (node-set-status! node 'fail))))))))
-              (cond
-               ((eqv? (node-get-status node) 'fail)
-                ;; quit
-                )
-               ((null? rest)
-                (node-set-status! node) 'pass)
-               (else
-                ((loop (car rest)
-                       (cdr rest))))))))))
-    
-    (when (eq? 'pass (node-get-status node))
-      (let ((name (node-get-name node)))
-        (when (and (file-exists? name)
-                   (regular-file? name))
-          (node-set-mtime! node (compute-mtime name))))))
-  
 
-  (define (run-default-recipe! node)
+(define target-name 'unspecified)
-    "The default recipe passes if the file exists"
+(define target-basename 'unspecified)
-    (let ((name (node-get-name node)))
+(define prerequisites '())
-      (if (and (file-exists? name)
+(define primary-prerequisite 'unspecified)
-               (regular-file? name))
+(define newer-prerequisites '())
-          (begin
-            (node-set-status! node 'pass)
-            (node-set-mtime! node (compute-mtime name)))
-          ;; else
-          (node-set-status! node 'fail))))
 
-  ;; Start at root
+(define $@  (lambda () target-name))
+(define $*  (lambda () target-basename))
+(define $<  (lambda () primary-prerequisite))
+(define $$? (lambda () newer-prerequisites))
+(define $?  (lambda () (apply string-compose newer-prerequisites)))
+(define $$^ (lambda () prerequisites))
+(define $^  (lambda () (apply string-compose prerequisites)))
 
-  ;; If cur is UNDETERMINED, find a leaf that is UNDETERMINED.
+(define (target-rule-prep-automatic-variables node rule)
-  ;; Descent to first leaf.
+  (set! target-name (node-get-name node))
-  ;; If self's mtime is earlier than parent's mtime, mark self as PASS.
+  (set! target-basename (basename target-name))
-  ;; Elif self has rules, run rules and mark self PASS/FAIL.
+  (set! prerequisites (target-rule-get-prerequisites rule))
-  ;; Else self has no mtime or rules, so mark self FAIL.
+  (set! primary-prerequisite (if (null? prerequisites) #f (car prerequisites)))
-  ;; Go to parent.
+  (set! newer-prerequisites
+    ;; If this node doesn't have a real file attached, then all
+    ;; prerequistes are "newer".
+    (if (not (node-get-mtime node))
+        prerequisites
+        ;; Prerequisites that have no mtime or a higher mtime are
+        ;; "newer".
+        (filter-map
+         (lambda (name)
+           (cond
+            ((and (file-exists? name)
+                  (regular-file? name)
+                  (>= (node-get-mtime node) (compute-mtime name)))
+             name)
+            ((not (file-exists? name))
+             name)
+            (else
+             #f)))
+         prerequisites))))
 
-  ;; IF PASS or FAIL, go to parent
+(define (suffix-rule-prep-automatic-variables node rule)
-
+  (set! target-name (node-get-name node))
-  ;; IF UNDETERMINED do these...
+  (set! target-basename (basename target-name))
-
+  (set! primary-prerequisite (string-append target-basename (suffix-rule-get-source rule)))
-  ;; Are we done with the children?
+  (set! prerequisites (list primary-prerequisite))
-  ;; If AND rule and one child is FAIL, stop
+  (set! newer-prerequisites
-  ;; If OR rule and one child is PASS, stop
+    ;; If this node doesn't have a real file attached, then the
-  ;; If no children left, stop
+    ;; prerequisite is newer.
-  ;; Else keep going
+    (if (not (node-get-mtime node))
-
+        (list primary-prerequisite)
-  ;; Did the children pass?
+        ;; Prerequisites that have no mtime or a higher mtime are
-  ;; IF AND rule and all children are PASS, true
+        ;; "newer".
-  ;; IF OR rule an one child is PASS, true
+        (cond
-  ;; Otherwise, false
+         ((and (file-exists?  primary-prerequisite)
-
+               (regular-file? primary-prerequisite)
-  ;; If the children FAIL, cur is FAIL
+               (> (node-get-mtime node) (compute-mtime primary-prerequisite)))
-  ;; If the children PASS, run rules and mark self PASS/FAIL
+          (list primary-prerequisite))
-  ;; Go to parent
+         (else
-
+          '())))))
-  ;; 3 failures
-  ;; - If anything fails, stop immediately
-  ;; - If anything fails, searching through tree
-  ;; - Ignore errors
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  ;; LET'S GO! 
+;; MIXED METHODS
+;; requiring more than one of node, automatic variables, suffix rules
+;; and target rules
 
-  (define %debug? #f)
+(define (add-builtins)
+  (-> ".c" ""
+      (~ ($ CC) ($ CFLAGS) ($ LDFLAGS) "-o" $@ $<))
+  (-> ".f" ""
+      (~ ($ FC) ($ FFLAGS) ($ LDFLAGS) "-o" $@ %<))
+  (-> ".sh" ""
+      (~ "cp" $< $@)
+      (~ "chmod a+x" $< $@))
+  (-> ".c" ".o"
+      (~ ($ CC) ($ CFLAGS) "-c" $<))
+  (-> ".f" ".o"
+      (~ ($ FC) ($ FFLAGS) ",c" $<))
+  (-> ".y" ".o"
+      (~ ($ YACC) ($ YFLAGS) $<))
+  (-> ".l" ".o"
+      (~ ($ LEX) ($ LFLAGS) $<)
+      (~ ($ CC) ($ CFLAGS) "-c lex.yy.c")
+      "rm -f lex.yy.c"
+      (~ "mv lex.yy.o" $@))
+  (-> ".y" ".c"
+      (~ ($ YACC) ($ YFLAGS) $<)
+      (~ "mv y.tab.c" $@))
+  (-> ".l" ".c"
+      (~ ($ LEX) ($ LDFLAGS) $<)
+      (~ "mv lex.yy.c" $@))
+  (-> ".scm" ".go"
+      (~ ($ GUILD) "compile" ($ GFLAGS) $<)))
 
-  (define (initialize-rules no-builtins? debug?)
+(define (run-rules! node)
-    (set! %target-rules '())
+  "Runs the rules associated with this node.  If this node has *and*
-    (set! %suffix-rules '())
+logic, it runs the recipes one by one, quitting on the first failure.
-    (set! %debug? debug?)
+If this rule has *or* logic, it runs them quitting on the first
-    (unless no-builtins?
+success."
-      ;; Set up initial suffix rules
+  (let ((rules (node-get-rules node)))
-      (suffix-rule ".c" ".o"
+    (when (null? rules)
-                   (string-compose
+      (error "no rules"))
-                    (reference "CC")
-                    (reference "CFLAGS")
-                    "-c"
-                    primary-prerequisite)))
-    )
 
-  (define (create-node name parent)
+    (let ((logic (node-get-logic node)))
-    "Constructs a tree of nodes, with name as the root node."
+      (let loop ((rule (car rules))
-    (let ((node (make-node name parent 'untested)))
+                 (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)))))))))
 
-      ;; FIXME: here check that this name differs from all ancenstor's
+(define (run-recipes! node recipes)
-      ;; names
+  "Runs the recipes on this node, one by one.  Recipes are either
-
+strings, procedures that return strings, or generic procedures.  If a
-      ;; Try to the file's modification time.
+failure condition happens, mark the node as having failed."
-      (when (file-exists? name)
+  (when (null? recipes)
-        (when (not (regular-file? name))
+    (error "no recipe"))
-          (not-a-regular-file "create-node" name))
+  (let loop ((opt/recipe (car recipes))
-        (when (not (access? name R_OK))
+             (rest (cdr recipes)))
-          (no-read-access-to-file "create-node" name))
+    (let ((opt (car opt/recipe))
-        (node-set-mtime! node (compute-mtime name)))
+          (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")))
       
-      ;; Search for matching target rule.
+      
-      (when (not (null? %target-rules))
+      (cond
-        (let loop ((rule (car %target-rules))
+       ((failed? node)
-                   (rest (cdr %target-rules)))
+        ;; 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))))))
 
-          ;; N.B: here we assume target rule names and
+(define (run-default-recipe! node)
-          ;; predicates are exclusively strings.
+  "The default recipe passes if the file exists"
-          (if (string=? name (target-rule-get-name rule))
+  (let ((name (node-get-name node)))
-              (begin
+    (if (and (file-exists? name)
-                ;; OK we have a matching rule
+             (regular-file? name))
-                (node-set-rules! node (list rule))
+        (begin
-                (node-set-logic! node 'and)
+          (set-pass! node)
-                ;; For target-rules, the prerequisites comes from the
+          (node-set-mtime! node (compute-mtime name)))
-                ;; rule itself.
+        ;; else
+        (set-fail! node))))
 
-                ;; Oooh, recursion!
+;; Start at root
-                (node-set-children! node
-                                    (map (lambda (prereq)
-                                           (create-node prereq node))
-                                         (target-rule-get-prerequisites rule))))
-              ;; else
-              (if (not (null? rest))
-                  (loop (car rest) (cdr rest))
-                  ;; else, no matching rule found
-                  (node-set-rules! node '())))))
 
-      #|
+;; If cur is UNDETERMINED, find a leaf that is UNDETERMINED.
-      ;; If no rule found so far, search for suffix rules.
+;; Descent to first leaf.
-      (when (null? (node-get-rules node))
+;; If self's mtime is earlier than parent's mtime, mark self as PASS.
-      (for-each
+;; Elif self has rules, run rules and mark self PASS/FAIL.
-      (lambda (rule)
+;; Else self has no mtime or rules, so mark self FAIL.
-      (let ((targ (suffix-rule-get-target rule)))
+;; Go to parent.
-      (when (or
-      ;; string suffix
-      (and (string? targ)
-      (string-suffix? targ name))
-      ;; procedure suffix
-      (and (procedure? targ)
-      (targ name)))
-      ;; For suffix rules, there will be exactly one child per
-      ;; rule and the name of the child is constructed from a
-      ;; suffix and the parent's name.
-      (node-set-rules! node (cons rule (node-get-rules node)))
-      (node-set-logic! node 'or)
-      (let* ((src (suffix-rule-get-source rule))
-      (prereq
-      (if (string? src)
-      (string-append
-      (string-drop-right name (string-length src))
-      src)
-      ;; else, src is a conversion func.
-      (src name))))
-      ;; Note the recursion here.
-      (node-set-children! node
-      (cons (create-node prereq node)
-      (node-get-children node)))))))
-      %suffix-rules))
 
-      ;; First matching rule has highest priority
+;; IF PASS or FAIL, go to parent
-      (node-set-rules! node (reverse (node-get-rules node)))
-      (node-set-children! node (reverse (node-get-children node)))
-      |#
-      ;; And node is ready to go
-      node))
 
-  (define (build root)
+;; IF UNDETERMINED do these...
-    "Give a tree of <node>, this executes the recipes therein."
+
-    (let ((tree (create-node root #f)))
+;; Are we done with the children?
-      (let ((node root))
+;; If AND rule and one child is FAIL, stop
-        (while #t
+;; If OR rule and one child is PASS, stop
-          (if (undetermined? node)
+;; If no children left, stop
+;; Else keep going
+
+;; Did the children pass?
+;; IF AND rule and all children are PASS, true
+;; IF OR rule an one child is PASS, true
+;; Otherwise, false
+
+;; If the children FAIL, cur is FAIL
+;; If the children PASS, run rules and mark self PASS/FAIL
+;; Go to parent
+
+;; 3 failures
+;; - If anything fails, stop immediately
+;; - If anything fails, searching through tree
+;; - Ignore errors
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; LET'S GO! 
+
+(define (initialize-rules targets builtins? ignore-errors? continue-on-error? no-execution? terse? verbose? ascii?)
+  (set! %target-rules '())
+  (set! %suffix-rules '())
+  (set! %top-level-targets targets)
+  (set! %ignore-errors? ignore-errors?)
+  (set! %continue-on-error? continue-on-error?)
+  (set! %no-execution? no-execution?)
+  (set! %terse? terse?)
+  (set! %verbose? verbose?)
+  (set! %ascii? ascii?)
+  (when builtins?
+    (add-builtins)))
+
+(define (create-node name parent)
+  "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
+    ;; names
+    
+    ;; Try to the file's modification time.
+    (when (file-exists? name)
+      (when (not (regular-file? name))
+        (not-a-regular-file "create-node" name))
+      (when (not (access? name R_OK))
+        (no-read-access-to-file "create-node" name))
+      (node-set-mtime! node (compute-mtime name)))
+    
+    ;; Search for matching target rule.
+    (when (not (null? %target-rules))
+      (let loop ((rule (car %target-rules))
+                 (rest (cdr %target-rules)))
+        
+        ;; N.B: here we assume target rule names and
+        ;; predicates are exclusively strings.
+        (if (string=? name (target-rule-get-name rule))
+            (begin
+              ;; OK we have a matching rule
+              (node-set-rules! node (list rule))
+              (node-set-logic! node 'and)
+              ;; For target-rules, the prerequisites comes from the
+              ;; rule itself.
+              
+              ;; Oooh, recursion!
+              (node-set-children! node
+                                  (map (lambda (prereq)
+                                         (create-node prereq node))
+                                       (target-rule-get-prerequisites rule))))
+            ;; else
+            (if (not (null? rest))
+                (loop (car rest) (cdr rest))
+                ;; else, no matching rule found
+                (node-set-rules! node '())))))
+
+    #|
+    ;; If no rule found so far, search for suffix rules.
+    (when (null? (node-get-rules node))
+    (for-each
+    (lambda (rule)
+    (let ((targ (suffix-rule-get-target rule)))
+    (when (or
+    ;; string suffix
+    (and (string? targ)
+    (string-suffix? targ name))
+    ;; procedure suffix
+    (and (procedure? targ)
+    (targ name)))
+    ;; For suffix rules, there will be exactly one child per
+    ;; rule and the name of the child is constructed from a
+    ;; suffix and the parent's name.
+    (node-set-rules! node (cons rule (node-get-rules node)))
+    (node-set-logic! node 'or)
+    (let* ((src (suffix-rule-get-source rule))
+    (prereq
+    (if (string? src)
+    (string-append
+    (string-drop-right name (string-length src))
+    src)
+    ;; else, src is a conversion func.
+    (src name))))
+    ;; Note the recursion here.
+    (node-set-children! node
+    (cons (create-node prereq node)
+    (node-get-children node)))))))
+    %suffix-rules))
+
+    ;; First matching rule has highest priority
+    (node-set-rules! node (reverse (node-get-rules node)))
+    (node-set-children! node (reverse (node-get-children node)))
+    |#
+    ;; And node is ready to go
+    node))
+
+(define (build root)
+  "Give a tree of <node>, this executes the recipes therein."
+  (let ((tree (create-node root #f)))
+    (let ((node tree))
+      (while #t
+        (if (undetermined? node)
+            (begin
               (if (children-complete? node)
                   (if (children-passed? node)
                       (if (up-to-date? node)
                           (set-pass! node)
                           ;; else, not up to date
-                          (if (has-recipe? node)
+                          (if (has-rules? node)
-                              (run-recipe! node)
+                              (run-rules! node)
                               ;; else, no recipe exists
                               (run-default-recipe! node)))
                       ;; else, children have failed
                       (set-fail! node))
                   ;; else, children aren't complete
-                  (set! node (get-next-child node)))
+                  (set! node (get-next-child node))))
-              ;; else, this node is determined
+            ;; else, this node is determined
-              (if (and abort-on-error (failed? node))
+            (begin
+              (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))))))))
+                      (break)))))))))
-  
+
-|#
+

raw-tests.scm

@@ -5,8 +5,9 @@ exec guile -L . -s "$0" "$@"
 (use-modules (potato make)
              (srfi srfi-1))
 
+(initialize '("test" "foo.exe" "--verbose"))
+(: "foo.exe" '("foo.c")
+   "cc -o foo.exe foo.c")
+(execute)
 
-(initialize #:arguments (command-line))
-(write %opt-verbose) (newline)
-(write %opt-quiet) (newline)
 

tests.scm

@@ -6,12 +6,344 @@ exec guile -L . -s "$0" "$@"
              (srfi srfi-1)
              (srfi srfi-64))
 
-(test-begin "initialization")
 
-(test-assert "initialize doesn't set verbose flag"
+;; 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)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; MAKEVARS
+
+(test-begin "makevars")
+
+(test-equal "can set makevar with environment"
+  "BAR1"
   (begin
-    (initialize #:arguments '() #:environ #f)
+    (setenv "FOO1" "BAR1")
-    (not (%opt-verbose?))))
+    (initialize '("test" "--environment"))
+    (let ((result ($ FOO1)))
+      (unsetenv "FOO1")
+      result)))
 
-(test-end "initialization")
+(test-equal "can set makevar with MAKEFLAGS"
+  "BAR2"
+  (begin
+    (setenv "MAKEFLAGS" "FOO2=BAR2")
+    (initialize '("test" "--environment"))
+    (let ((result ($ FOO2)))
+      (unsetenv "MAKEFLAGS")
+      result)))
 
+(test-equal "can set makevar with initialize"
+  "BAR3"
+  (begin
+    (initialize '("test" "FOO3=BAR3"))
+    ($ FOO3)))
+
+(test-equal "can set makevar in script"
+  "BAR4"
+  (begin
+    (:= FOO4 "BAR4")
+    ($ FOO4)))
+
+(test-equal "can set makevar lazily in 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 "assign converts integers to strings"
+  "100"
+  (begin
+    (:= FOO10 100)
+    ($ FOO10)))
+
+(test-equal "assign converts characters to strings"
+  "x"
+  (begin
+    (:= FOO11 #\x)
+    ($ FOO11)))
+
+(test-equal "quote-reference adds quotation marks"
+  "\"BAR 12\""
+  (begin
+    (:= FOO12 "BAR 12")
+    (Q FOO12)))
+
+(test-equal "quote-reference of an unassigned makevar returns empty quotation marks in non-strict mode"
+  "\"\""
+  (begin
+    (initialize '("test"))
+    (Q FOO13)))
+
+(test-error "quote-reference of an unassigned makevar throws an error in strict mode"
+  #t
+  (begin
+    (initialize '("test" "--strict"))
+    (Q FOO13)))
+
+(test-equal "script assignment overrides command-line assignment"
+  "BAZ14"
+  (begin
+    (initialize '("test" "FOO14=BAR14"))
+    (:= FOO14 "BAZ14")
+    ($ FOO14)))
+
+(test-equal "script assignment overrides MAKEFLAGS assignment"
+  "BAZ15"
+  (begin
+    (setenv "MAKEFLAGS" "FOO15=BAR15")
+    (initialize '("test" "--environment"))
+    (:= FOO15 "BAZ15")
+    ($ FOO15)))
+
+(test-equal "script assignment overrides environment assignment"
+  "BAZ16"
+  (begin
+    (setenv "FOO16" "BAR16")
+    (initialize '("test" "--environment"))
+    (unsetenv "FOO16")
+    (:= FOO16 "BAZ16")
+    ($ FOO16)))
+
+(test-equal "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")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; RECIPE HELPERS
+
+(test-begin "recipe_helpers")
+
+(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 string passthrough"
+  "hello"
+  (let ((ret (~ "hello")))
+    ((cdr ret))))
+
+(test-equal "string-compose two strings passthrough"
+  "hello world"
+  (let ((ret (~ "hello" "world")))
+    ((cdr ret))))
+
+(test-equal "string-compose empty initial string"
+  "world"
+  (let ((ret (~ "" "world")))
+    ((cdr ret))))
+
+(test-equal "string-compose empty terminal string"
+  "hello"
+  (let ((ret (~ "hello" "")))
+    ((cdr ret))))
+
+(test-equal "string-compose empty medial string"
+  "hello world"
+  (let ((ret (~ "hello" "" "world")))
+    ((cdr ret))))
+
+(test-equal "string-compose handles procedure"
+  "hello world"
+  (let ((ret (~ "hello" (lambda () "world"))))
+    ((cdr ret))))
+
+(test-equal "string-compose handles integer"
+  "hello 123"
+  (let ((ret (~ "hello" 123)))
+    ((cdr ret))))
+
+(test-equal "string-compose handles character"
+  "hello w"
+  (let ((ret (~ "hello" #\w)))
+    ((cdr ret))))
+
+(test-equal "string-compose handles makevar"
+  "hello BAR"
+  (begin
+    (:= FOO "BAR")
+    (let ((ret (~ "hello" ($ FOO))))
+      ((cdr ret)))))
+
+(test-equal "empty string-compose"
+  ""
+  (let ((ret (~)))
+    ((cdr ret))))
+
+(test-end "recipe_helpers")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; TARGET RULES
+
+(test-begin "target_rules")
+
+(test-assert "install alternate system driver"
+  (false-if-exception (install-alternate-system-driver stub-system-pass)))
+
+(test-equal "target rule is 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-assert "target rule is a procedure"
+  (begin
+    (let ((tmpvar #f))
+      (initialize '("test" "foo.exe"))
+      (: "foo.exe" '("foo.c")
+         (lambda ()
+           (set! tmpvar #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" $@ $<))
+    (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")
+
+(test-begin "suffix_rules")
+
+(test-assert "install alternate system driver"
+  (false-if-exception (install-alternate-system-driver stub-system-pass)))
+
+(test-equal "suffix rule simple"
+  "cc -c foo.c"
+  (begin
+    (initialize '("test" "foo.o"))
+    (-> ".c" ".o"
+        (~ "cc -c" $<))
+    (execute)
+    %cmd))
+
+(test-end "suffix_rules")