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
(build)
(execute)
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))
(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
> returned.
> found, VALUE is returned as a string.
> *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

6
doodle.txt
View File

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

11
potato/exceptions.scm
View File

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

97
potato/make.scm
View File

@ -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 " -V, --verbose print maximum output~%")
(format #t " -q, --terse use terse 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)
(set! %opt-quiet #t)
(when (member "terse" tokens)
(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)
(set! %opt-quiet #t)
(when (option-ref options 'terse #f)
(set! %opt-terse #t)
(set! %opt-verbose #f))
(when (option-ref options 'verbose #f)
(set! %opt-verbose #t)
(set! %opt-quiet #f))
(set! %opt-builtins
(option-ref options 'builtins #f))
(set! %opt-elevate-environment
(option-ref options 'elevate-environment #f))
(set! %opt-ignore-errors
(option-ref options 'ignore-errors #f))
(set! %opt-continue-on-error
(option-ref options 'continue-on-error #f))
(set! %opt-no-execution
(option-ref options 'no-execution #f))
(set! %opt-ascii
(option-ref options 'ascii #f))
(set! %opt-terse #f))
(when (option-ref options 'builtins #f)
(set! %opt-builtins #t))
(when (option-ref options 'elevate-environment #f)
(set! %opt-elevate-environment #t))
(when (option-ref options 'ignore-errors #f)
(set! %opt-ignore-errors #t))
(when (option-ref options 'continue-on-error #f)
(set! %opt-continue-on-error #t))
(when (option-ref options 'no-execution #f)
(set! %opt-no-execution #t))
(when (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))

104
potato/makevars.scm
View File

@ -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))
(not (procedure? key)))
(bad-key-type "lazy-assign" (list key)))
(when (and (not (string? val))
(not (procedure? val)))
(bad-value-type "lazy-assign" (list val)))
(let ((KEY (if (string? key) key (key)))
(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))))
(when (procedure? key)
(set! key (key)))
(unless (string? key)
(set! key (format #f "~a" key)))
(makevars-set key (delay val))
(when %verbose?
(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))
(not (procedure? key)))
(bad-key-type "assign" (list key)))
(when (and (not (string? val))
(not (procedure? val)))
(bad-value-type "assign" (list val)))
(let ((KEY (if (string? key) key (key)))
(VAL (if (string? val) val (val))))
(unless (string? KEY)
(bad-proc-output "assign" KEY))
(unless (string? VAL)
(bad-proc-output "assign" VAL))
(makevars-set KEY VAL)
(when (procedure? key)
(set! key (key)))
(unless (string? key)
(set! key (format #f "~a" key)))
(when (procedure? val)
(set! val (val)))
(unless (string? val)
(set! val (format #f "~a" val)))
(makevars-set key val)
(when %verbose?
(format #t "~A=~A~%" KEY VAL))))
(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 #:optional (transformer #f))
(define* (reference key quoted? #: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)
(bad-proc-output "reference" val))
(cond
((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))
(when %verbose?
(format #t "~A=~A~%" key val)))
(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)
#'(reference (symbol->string (syntax->datum #'key)) transformer))
((_ 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)))))))

427
potato/rules.scm
View File

@ -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,9 +67,10 @@ 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))
)
((string? 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?
(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
(set! %target-rules (cons rule %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
(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)))
(set! %suffix-rules (cons rule %suffix-rules))))
(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))))
;;;;;;;;;
;; Automatic variables
;; target-name $@
;; target-basename $*
;; newer-prerequisites $?
;; prerequisites $^
;; primary-prerequisite $<
(define (set-fail! node)
(node-set-status! node 'fail))
(define (set-pass! node)
(node-set-status! node 'pass))
;; This is set in the builder to make automatic variables work.
(define %node-cur #f)
(define (failed? node)
(eqv? (node-get-status node) 'fail))
(define target-name
(lambda ()
(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 (passed? node)
(eqv? (node-get-status node) 'pass))
(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)))
(if (null? children)
#f
(any (lambda (child)
(if (eqv? (node-get-status child) 'undetermined)
child
#f))
children)))
(define (failed? node)
(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,88 +358,211 @@ it is evaluated."
#t
#f)))
(define (get-parent node)
(node-get-parent node))
#|
(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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; AUTOMATIC VARIABLES
(define target-name 'unspecified)
(define target-basename 'unspecified)
(define prerequisites '())
(define primary-prerequisite 'unspecified)
(define newer-prerequisites '())
(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)
(error "no recipe"))
(let loop ((opt/recipe (car recipes))
(rest (cdr recipes)))
(let ((opt ((car recipe/opt))
(recipe (cdr recipe)))
(let ((opt (car opt/recipe))
(recipe (cdr opt/recipe)))
;; Recipes are either
;; - strings to pass to system
;; - procedures that return a string which is passed
;; to system
;; - procedures (that don't return a string) that are executed
;; that pass unless they return #f
; OPT is one of 'default, 'ignore, 'silent
;; 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))))
((string? recipe)
(format #t "[SYSTEM] ~A~%" recipe)
(let ((retval (%system-proc recipe)))
(format #t " --> ~S~%" retval)
(unless (zero? retval)
(set-fail! node))))
((procedure? recipe)
(unless (or quiet (eq? opt 'silent))
(if (procedure-name recipe)
(format #t "[PROC] ~A~%" (procedure-name recipe))
(format #t "[PROC] ~%")))
(format #t "[PROC] ~%"))
(let ((retval (recipe)))
(unless (or quiet (eq? opt 'silent))
(format #t " --> ~S~%" (status:exit-val retval2)))
(format #t " --> ~S~%" retval)
(cond
((eqv? retval #f)
(unless (eqv? opt 'ignore)
(node-set-status node 'fail)))
(set-fail! node))
;; If a procedure returns a string, that string gets
;; processed by system.
((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))))))))
(format #t "[SYSTEM] ~A~%" retval)
(let ((retval2 (%system-proc retval)))
(format #t " --> ~S~%" retval2)
(unless (zero? retval2)
(set-fail! node)))))))
(else
;; Not a string or procedure
(error "bad rule")))
(cond
((eqv? (node-get-status node) 'fail)
((failed? node)
;; quit
)
((null? rest)
(node-set-status! node) 'pass)
(set-pass! node))
(else
((loop (car rest)
(cdr rest))))))))))
(cdr rest)))))))
(when (eq? 'pass (node-get-status node))
(when (passed? node)
(let ((name (node-get-name node)))
(when (and (file-exists? name)
(regular-file? name))
(node-set-mtime! node (compute-mtime name))))))
(define (run-default-recipe! node)
"The default recipe passes if the file exists"
(let ((name (node-get-name node)))
(if (and (file-exists? name)
(regular-file? name))
(begin
(node-set-status! node 'pass)
(set-pass! node)
(node-set-mtime! node (compute-mtime name)))
;; else
(node-set-status! node 'fail))))
(set-fail! node))))
;; Start at root
@ -436,26 +600,23 @@ failed."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LET'S GO!
(define %debug? #f)
(define (initialize-rules no-builtins? debug?)
(define (initialize-rules targets builtins? ignore-errors? continue-on-error? no-execution? terse? verbose? ascii?)
(set! %target-rules '())
(set! %suffix-rules '())
(set! %debug? debug?)
(unless no-builtins?
;; Set up initial suffix rules
(suffix-rule ".c" ".o"
(string-compose
(reference "CC")
(reference "CFLAGS")
"-c"
primary-prerequisite)))
)
(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 'untested)))
(let ((node (make-node name parent 'undetermined)))
(node-set-children! node '())
;; FIXME: here check that this name differs from all ancenstor's
;; names
@ -535,29 +696,31 @@ failed."
(define (build root)
"Give a tree of <node>, this executes the recipes therein."
(let ((tree (create-node root #f)))
(let ((node root))
(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)
(run-recipe! node)
(if (has-rules? 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
(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)))))))))
|#

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

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

342
tests.scm
View File

@ -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)
(not (%opt-verbose?))))
(setenv "FOO1" "BAR1")
(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")