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

stash

Browse Source
This commit is contained in:
Michael Gran 2021-02-12 16:34:18 -08:00
parent a42fef03b9
commit 0a30f1d23a
9 changed files with 957 additions and 380 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CHEATSHEET.md
View File

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

27
README.md
View File

@ -41,8 +41,7 @@ is named `makefile.scm`; however, you may choose any name.
!# !#
(use-modules (potato make)) (use-modules (potato make))
(setup (command-line)) (initialize)
This boilerplate loads the library functions and it parses the This boilerplate loads the library functions and it parses the
command-line arguments. The command-line arguments are the following, 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' 'always execute'
-a, --ascii -a, --ascii
use ASCII-only output and no colors use ASCII-only output and no colors
-W, --warn
enable warning messages
[var=value...] [var=value...]
set the value of makevars 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 and built-in rules. This is to make this tool more appropriate for
generating *reproducible builds*. 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 ## Environment Variables
Certain environment variables affect the execution of the makefile 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 key [transformer]
> `reference` looks up KEY in the `%makevar` hash table. If it is > `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 > 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 > procedure is *forced* to return a string. Also, the value in the

6
doodle.txt
View File

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

11
potato/exceptions.scm
View File

@ -5,6 +5,7 @@
bad-proc-output bad-proc-output
invalid-macro invalid-macro
not-a-regular-file not-a-regular-file
not-a-procedure
no-read-access-to-file no-read-access-to-file
)) ))
@ -58,6 +59,16 @@
(define (not-a-regular-file origin irritant) (define (not-a-regular-file origin irritant)
(raise-exception (make-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) (define (make-no-read-access-to-file origin irritants)
(make-exception (make-exception
(make-programming-error) (make-programming-error)

97
potato/make.scm
View File

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

104
potato/makevars.scm
View File

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

485
potato/rules.scm
View File

@ -1,9 +1,11 @@
(define-module (potato rules) (define-module (potato rules)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (potato exceptions) #:use-module (potato exceptions)
#:use-module (potato builtins) #:use-module (potato builtins)
#:use-module (potato makevars) #:use-module (potato makevars)
#:use-module (potato text)
#:export(<target-rule> #:export(<target-rule>
<suffix-rule> <suffix-rule>
<node> <node>
@ -11,6 +13,7 @@
%suffix-rules %suffix-rules
initialize-rules initialize-rules
first-target-rule-name first-target-rule-name
install-alternate-system-driver
target-rule : target-rule :
suffix-rule -> suffix-rule ->
target-name $@ target-name $@
@ -25,6 +28,18 @@
ignore-error-compose ~- 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 ;; HELPER FUNCTIONS
@ -52,9 +67,10 @@ it is evaluated."
(effective-arg #f)) (effective-arg #f))
(cond (cond
((procedure? arg) ((procedure? arg)
(format #t "BLAMMO ~s ~s ~%" arg (arg))
(set! effective-arg (arg)) (set! effective-arg (arg))
#;(unless (string? effective-arg) (unless (string? effective-arg)
(bad-proc-output "~" arg)) (bad-proc-output "~" arg))
) )
((string? arg) ((string? arg)
@ -94,7 +110,7 @@ it is evaluated."
(define (always-execute-compose . args) (define (always-execute-compose . args)
(cons 'always-execute (apply base-compose args))) (cons 'always-execute (apply base-compose args)))
(define ~@ always-execute-compose) (define ~+ always-execute-compose)
(define (regular-file? filename) (define (regular-file? filename)
(let ((st (stat filename #f))) (let ((st (stat filename #f)))
@ -105,6 +121,15 @@ it is evaluated."
(+ (* 1000000000 (stat:mtime st)) (+ (* 1000000000 (stat:mtime st))
(stat:mtimensec 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 ;; TARGET STRUCT AND METHODS
@ -128,10 +153,25 @@ it is evaluated."
(define* (target-rule name #:optional (prerequisites '()) #:rest recipes) (define* (target-rule name #:optional (prerequisites '()) #:rest recipes)
"Register a new target rule" "Register a new target rule"
;; FIXME: Typecheck
(let ((rule (make-target-rule name prerequisites recipes 1))) (when %verbose?
(format #t "Defining target rule: ~A ~A ~A~%" prerequisites (right-arrow) name))
;; 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 ;; Add to %target-rules
(set! %target-rules (cons rule %target-rules)))) (set! %target-rules (cons rule %target-rules)))))
;; Alias ;; Alias
(define : target-rule) (define : target-rule)
@ -166,9 +206,25 @@ it is evaluated."
(define (suffix-rule source target . recipes) (define (suffix-rule source target . recipes)
"Register a suffix rule" "Register a suffix rule"
;; FIXME: Typecheck ;; FIXME: Typecheck
(when %verbose?
(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))) (let ((rule (make-suffix-rule source target recipes 1)))
(set! %suffix-rules (cons rule %suffix-rules)))) (set! %suffix-rules (cons rule %suffix-rules)))))
;; Alias ;; Alias
(define -> suffix-rule) (define -> suffix-rule)
@ -183,14 +239,14 @@ it is evaluated."
;; just a label. ;; just a label.
(name node-get-name node-set-name!) (name node-get-name node-set-name!)
;; A <node> which is the parent of this node, or #f. ;; 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 ;; If 'name' is a regular file, mtime holds its last modification
;; time in nanoseconds since the epoch. If 'name' does not exist, ;; time in nanoseconds since the epoch. If 'name' does not exist,
;; _mtime is #f. ;; _mtime is #f.
(mtime node-get-mtime node-set-mtime!) (mtime node-get-mtime node-set-mtime!)
;; One of 'pass, 'fail, or 'undetermined ;; One of 'pass, 'fail, or 'undetermined
(status node-get-status node-set-status!) (status node-get-status node-set-status!)
;; A list of rules to evaluate to try to c ;; A list of rules
(rules node-get-rules node-set-rules!) (rules node-get-rules node-set-rules!)
(children node-get-children node-set-children!) (children node-get-children node-set-children!)
;; Determines how many children must pass for the parent ;; Determines how many children must pass for the parent
@ -198,60 +254,51 @@ it is evaluated."
(logic node-get-logic node-set-logic!) (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) (define (undetermined? node)
(eq? (node-get-status node) 'undetermined)) (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) (define (children-complete? node)
(cond (cond
((leaf-node? node) ((leaf-node? node)
@ -276,32 +323,26 @@ it is evaluated."
(else (else
#f))) #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) (define (get-next-child node)
"Return the first child node that is not yet PASS or FAIL" "Return the first child node that is not yet PASS or FAIL"
(let ((children (node-get-children node))) (let ((children (node-get-children node)))
(if (null? children)
#f
(any (lambda (child) (any (lambda (child)
(if (eqv? (node-get-status child) 'undetermined) (if (eqv? (node-get-status child) 'undetermined)
child child
#f)) #f))
children))) children))))
(define (failed? node)
(eqv? (node-get-status node) 'fail))
(define (has-parent? node) (define (has-parent? node)
(if (node-get-parent node) (if (node-get-parent node)
#t #t
#f)) #f))
(define (get-parent node)
(node-get-parent node))
(define (up-to-date? node) (define (up-to-date? node)
"Checks if node is up to date: "Checks if node is up to date:
- it has an mtime - it has an mtime
@ -317,145 +358,265 @@ it is evaluated."
#t #t
#f))) #f)))
(define (get-parent node) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(node-get-parent node)) ;; AUTOMATIC VARIABLES
#|
(define (run-recipe! node quiet verbose) (define target-name 'unspecified)
"Runs the recipes associated with this node, one by one. Recipes (define target-basename 'unspecified)
are either strings, procedures that return strings, or generic (define prerequisites '())
procedures. If a failure condition happens, mark the node as having (define primary-prerequisite 'unspecified)
failed." (define newer-prerequisites '())
(let ((recipes (node-get-recipes node)))
(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)))
(define (target-rule-prep-automatic-variables node rule)
(set! target-name (node-get-name node))
(set! target-basename (basename target-name))
(set! prerequisites (target-rule-get-prerequisites rule))
(set! primary-prerequisite (if (null? prerequisites) #f (car prerequisites)))
(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))))
(define (suffix-rule-prep-automatic-variables node rule)
(set! target-name (node-get-name node))
(set! target-basename (basename target-name))
(set! primary-prerequisite (string-append target-basename (suffix-rule-get-source rule)))
(set! prerequisites (list primary-prerequisite))
(set! newer-prerequisites
;; If this node doesn't have a real file attached, then the
;; prerequisite is newer.
(if (not (node-get-mtime node))
(list primary-prerequisite)
;; Prerequisites that have no mtime or a higher mtime are
;; "newer".
(cond
((and (file-exists? primary-prerequisite)
(regular-file? primary-prerequisite)
(> (node-get-mtime node) (compute-mtime primary-prerequisite)))
(list primary-prerequisite))
(else
'())))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MIXED METHODS
;; requiring more than one of node, automatic variables, suffix rules
;; and target rules
(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 (run-rules! node)
"Runs the rules associated with this node. If this node has *and*
logic, it runs the recipes one by one, quitting on the first failure.
If this rule has *or* logic, it runs them quitting on the first
success."
(let ((rules (node-get-rules node)))
(when (null? rules)
(error "no rules"))
(let ((logic (node-get-logic node)))
(let loop ((rule (car rules))
(rest (cdr rules)))
(cond
((target-rule? rule)
(target-rule-prep-automatic-variables node rule)
(run-recipes! node (target-rule-get-recipes rule)))
((suffix-rule? rule)
(suffix-rule-prep-automatic-variables node rule)
(run-recipes! node (suffix-rule-get-recipes rule)))
(else
(error "bad rule")))
(let ((status (node-get-status node)))
(cond
((or (and (eq? 'and logic)
(eq? 'fail status))
(and (eq? 'or logic)
(eq? 'pass status))
(null? rest))
;; We're done
status)
(else
(loop (car rest) (cdr rest)))))))))
(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) (when (null? recipes)
(error "no recipe")) (error "no recipe"))
(let loop ((opt/recipe (car recipes)) (let loop ((opt/recipe (car recipes))
(rest (cdr recipes))) (rest (cdr recipes)))
(let ((opt ((car recipe/opt)) (let ((opt (car opt/recipe))
(recipe (cdr recipe))) (recipe (cdr opt/recipe)))
;; Recipes are either ;; Recipes are either
;; - strings to pass to system ;; - strings to pass to system
;; - procedures that return a string which is passed ;; - procedures that return a string which is passed
;; to system ;; to system
;; - procedures (that don't return a string) that are executed ;; - procedures (that don't return a string) that are executed
;; that pass unless they return #f ;; that pass unless they return #f
; OPT is one of 'default, 'ignore, 'silent ;; OPT is one of 'default, 'ignore, 'silent
(cond (cond
((string=? recipe) ((string? recipe)
(unless (or quiet (eq? opt 'silent)) (format #t "[SYSTEM] ~A~%" recipe)
(format #t "[SYSTEM] ~A~$" recipe) (let ((retval (%system-proc recipe)))
(let ((retval (system recipe))) (format #t " --> ~S~%" retval)
(unless (or quiet (eq? opt 'silent)) (unless (zero? retval)
(format #t " --> ~S~%" (status:exit-val retval))) (set-fail! node))))
(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) ((procedure? recipe)
(unless (or quiet (eq? opt 'silent))
(if (procedure-name recipe) (if (procedure-name recipe)
(format #t "[PROC] ~A~%" (procedure-name recipe)) (format #t "[PROC] ~A~%" (procedure-name recipe))
(format #t "[PROC] ~%"))) (format #t "[PROC] ~%"))
(let ((retval (recipe))) (let ((retval (recipe)))
(unless (or quiet (eq? opt 'silent)) (format #t " --> ~S~%" retval)
(format #t " --> ~S~%" (status:exit-val retval2)))
(cond (cond
((eqv? retval #f) ((eqv? retval #f)
(unless (eqv? opt 'ignore) (set-fail! node))
(node-set-status node 'fail)))
;; If a procedure returns a string, that string gets
;; processed by system.
((string=? retval) ((string=? retval)
(unless (or quiet (eq? opt 'silent)) (format #t "[SYSTEM] ~A~%" retval)
(format #t "[SYSTEM] ~A~$" retval) (let ((retval2 (%system-proc retval)))
(let ((retval2 (system retval))) (format #t " --> ~S~%" retval2)
(unless (or quiet (eq? opt 'silent)) (unless (zero? retval2)
(format #t " --> ~S~%" (status:exit-val retval2))) (set-fail! node)))))))
(when (and (not (eqv? opt 'ignore))
(or (eqv? #f (status:exit-val retval)) (else
(not (zero? (status:exit-val retval))))) ;; Not a string or procedure
(node-set-status! node 'fail)))))))) (error "bad rule")))
(cond (cond
((eqv? (node-get-status node) 'fail) ((failed? node)
;; quit ;; quit
) )
((null? rest) ((null? rest)
(node-set-status! node) 'pass) (set-pass! node))
(else (else
((loop (car rest) ((loop (car rest)
(cdr rest)))))))))) (cdr rest)))))))
(when (eq? 'pass (node-get-status node)) (when (passed? node)
(let ((name (node-get-name node))) (let ((name (node-get-name node)))
(when (and (file-exists? name) (when (and (file-exists? name)
(regular-file? name)) (regular-file? name))
(node-set-mtime! node (compute-mtime name)))))) (node-set-mtime! node (compute-mtime name))))))
(define (run-default-recipe! node)
(define (run-default-recipe! node)
"The default recipe passes if the file exists" "The default recipe passes if the file exists"
(let ((name (node-get-name node))) (let ((name (node-get-name node)))
(if (and (file-exists? name) (if (and (file-exists? name)
(regular-file? name)) (regular-file? name))
(begin (begin
(node-set-status! node 'pass) (set-pass! node)
(node-set-mtime! node (compute-mtime name))) (node-set-mtime! node (compute-mtime name)))
;; else ;; else
(node-set-status! node 'fail)))) (set-fail! node))))
;; Start at root ;; Start at root
;; If cur is UNDETERMINED, find a leaf that is UNDETERMINED. ;; If cur is UNDETERMINED, find a leaf that is UNDETERMINED.
;; Descent to first leaf. ;; Descent to first leaf.
;; If self's mtime is earlier than parent's mtime, mark self as PASS. ;; If self's mtime is earlier than parent's mtime, mark self as PASS.
;; Elif self has rules, run rules and mark self PASS/FAIL. ;; Elif self has rules, run rules and mark self PASS/FAIL.
;; Else self has no mtime or rules, so mark self FAIL. ;; Else self has no mtime or rules, so mark self FAIL.
;; Go to parent. ;; Go to parent.
;; IF PASS or FAIL, go to parent ;; IF PASS or FAIL, go to parent
;; IF UNDETERMINED do these... ;; IF UNDETERMINED do these...
;; Are we done with the children? ;; Are we done with the children?
;; If AND rule and one child is FAIL, stop ;; If AND rule and one child is FAIL, stop
;; If OR rule and one child is PASS, stop ;; If OR rule and one child is PASS, stop
;; If no children left, stop ;; If no children left, stop
;; Else keep going ;; Else keep going
;; Did the children pass? ;; Did the children pass?
;; IF AND rule and all children are PASS, true ;; IF AND rule and all children are PASS, true
;; IF OR rule an one child is PASS, true ;; IF OR rule an one child is PASS, true
;; Otherwise, false ;; Otherwise, false
;; If the children FAIL, cur is FAIL ;; If the children FAIL, cur is FAIL
;; If the children PASS, run rules and mark self PASS/FAIL ;; If the children PASS, run rules and mark self PASS/FAIL
;; Go to parent ;; Go to parent
;; 3 failures ;; 3 failures
;; - If anything fails, stop immediately ;; - If anything fails, stop immediately
;; - If anything fails, searching through tree ;; - If anything fails, searching through tree
;; - Ignore errors ;; - Ignore errors
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LET'S GO! ;; LET'S GO!
(define %debug? #f) (define (initialize-rules targets builtins? ignore-errors? continue-on-error? no-execution? terse? verbose? ascii?)
(define (initialize-rules no-builtins? debug?)
(set! %target-rules '()) (set! %target-rules '())
(set! %suffix-rules '()) (set! %suffix-rules '())
(set! %debug? debug?) (set! %top-level-targets targets)
(unless no-builtins? (set! %ignore-errors? ignore-errors?)
;; Set up initial suffix rules (set! %continue-on-error? continue-on-error?)
(suffix-rule ".c" ".o" (set! %no-execution? no-execution?)
(string-compose (set! %terse? terse?)
(reference "CC") (set! %verbose? verbose?)
(reference "CFLAGS") (set! %ascii? ascii?)
"-c" (when builtins?
primary-prerequisite))) (add-builtins)))
)
(define (create-node name parent) (define (create-node name parent)
"Constructs a tree of nodes, with name as the root node." "Constructs a tree of nodes, with name as the root node."
(let ((node (make-node name parent 'untested))) (let ((node (make-node name parent 'undetermined)))
(node-set-children! node '())
;; FIXME: here check that this name differs from all ancenstor's ;; FIXME: here check that this name differs from all ancenstor's
;; names ;; names
@ -532,32 +693,34 @@ failed."
;; And node is ready to go ;; And node is ready to go
node)) node))
(define (build root) (define (build root)
"Give a tree of <node>, this executes the recipes therein." "Give a tree of <node>, this executes the recipes therein."
(let ((tree (create-node root #f))) (let ((tree (create-node root #f)))
(let ((node root)) (let ((node tree))
(while #t (while #t
(if (undetermined? node) (if (undetermined? node)
(begin
(if (children-complete? node) (if (children-complete? node)
(if (children-passed? node) (if (children-passed? node)
(if (up-to-date? node) (if (up-to-date? node)
(set-pass! node) (set-pass! node)
;; else, not up to date ;; else, not up to date
(if (has-recipe? node) (if (has-rules? node)
(run-recipe! node) (run-rules! node)
;; else, no recipe exists ;; else, no recipe exists
(run-default-recipe! node))) (run-default-recipe! node)))
;; else, children have failed ;; else, children have failed
(set-fail! node)) (set-fail! node))
;; else, children aren't complete ;; 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) (break)
;; else not failed ;; else not failed
(if (has-parent? node) (if (has-parent? node)
(set! node (get-parent node)) (set! node (get-parent node))
;; else, there is no parent to this node ;; else, there is no parent to this node
(break)))))))) (break)))))))))
|#

7
raw-tests.scm Normal file → Executable file
View File

@ -5,8 +5,9 @@ exec guile -L . -s "$0" "$@"
(use-modules (potato make) (use-modules (potato make)
(srfi srfi-1)) (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)

342
tests.scm
View File

@ -6,12 +6,344 @@ exec guile -L . -s "$0" "$@"
(srfi srfi-1) (srfi srfi-1)
(srfi srfi-64)) (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 (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")