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-10 06:28:32 -08:00
parent 8aa578a241
commit 6af9c017ff
6 changed files with 728 additions and 394 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
README.md
View File

@ -47,19 +47,31 @@ is named `makefile.scm`; however, you may choose any name.
This boilerplate loads the library functions and it parses the
command-line arguments. The command-line arguments are the following,
makefile.scm [-efiknprs] [var=value...] [target_name...]
-e makevars from the environment override makefiles
in the script.
-f rebuild even if the prerequisite timestamps are
earlier than the target timestamps
-i ignore error codes return from system commands
-k continue to update other targets that don't depend
on a target that has reported a non-ignored error
-n write commands to be executed, but, do not execute
them
-p write debug output
-r do not use any built-in rules
-s use a terse output
makefile.scm [-hvqVeEbknB] [var=value...] [target_name...]
-h, --help
displays help
-v, --version
displays the version number of this script
-q, --quiet
use a terse output format
-V, --verbose
use a verbose output format
-e, --environment
environment variables are converted to makevars
-E, --elevate-environment
environment variables are converted to makevars
and will override makevars set in the script
-b, --builtins
adds some default makevars and suffix rules
--ignore-errors
keep building even if a command fails
-k, --continue-on-error
keep building some targets even if a command fails
-n, --no-execute
print rules, but only execute rules marked as
'always execute'
-B, --boring
use ASCII-only output and no colors
[var=value...]
set the value of makevars
@ -67,6 +79,11 @@ command-line arguments. The command-line arguments are the following,
Set one or more targets to be executed. If no target
is specified, the first target found will be executed.
Note that in POSIX `make`, it, by default, adds in environment
variables and built-in rules. With this library, these require
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*.
## Environment Variables
@ -125,7 +142,8 @@ list. There are 3 components
If the COMMAND recipe is a string, it will be passed to the `system`
procedure for execution by the shell. If any call to system returns a
non-zero return value, processing will end. (This behavior is modified
by the '-i' and '-k' command-line arguments.)
by the `--ignore-errors` and `--continue-on-error` command-line
arguments.)
If the COMMAND recipe is a procedure, it will be executed. If it
returns `#f` or a non-zero integer, failure is assumed. If the
@ -134,14 +152,14 @@ COMMAND recipe returns a string, the resulting string is passed to
If the COMMAND recipe is a pair, and the CAR of the pair is one of
`'ignore-error`, `'silent`, or `'always-execute`, it will have the
extra effect of ignoring errors, not printing the command line,
or always executing even when the `-n` option is enabled. The CDR
must be a string or procedure as above.
extra effect of ignoring errors, not printing the command line, or
always executing even when the `--no-execution` option is enabled.
The CDR must be a string or procedure as above.
There are a set of helper functions and variables that can be used to
construct recipes.
compose element ...
string-compose element ...
~ element ...
ignore-error-compose element ...
~- element ...
@ -150,21 +168,28 @@ construct recipes.
always-execute-compose element ...
~+ element ...
`compose` (aka `~`) takes as arguments one or more elements, each of which
is a string or a procedure of zero arguments that returns a string. It
executes any procedure arguments and concatenates the resulting
strings, appending spaces in between them.
`string-compose` (aka `~`) takes as arguments one or more elements. It
converts the elements to strings and concatenates the strings,
appending spaces between them. The conversion to strings happens as if
by `display`.
`ignore-error-compose` (aka `~-`) is like compose but returns a pair
with the first argument of `'ignore-error`. When passed as a recipe,
it causes the recipe not to end execution, even if an error is
For elements that are procedures, they are executed and their result
is used instead.
It is returned as a pair, where the `car` is the symbol `'default`.
That symbol is interpreted by the builder.
`ignore-error-compose` (aka `~-`) is like string-compose but returns a
pair with the first argument of `'ignore-error`. When passed as a
recipe, it causes the recipe not to end execution, even if an error is
signaled.
`silent-compose` (aka `~@`) is like compose, but, it does not print
the resulting string to the output port.
`silent-compose` (aka `~@`) is like string-compose, but, it does not
print the resulting string to the output port, except in verbose mode.
`always-execute-compose` (aka `~+`) is like compose, but, it forces the line
to always be executed, even if the `-n` option was chosen.
`always-execute-compose` (aka `~+`) is like compose, but, it forces
the line to always be executed, even if the `--no-execution` option
was chosen.
target-name
$@
@ -237,7 +262,7 @@ above.
suffix-rule source-suffix target-suffix [commands...]
-> source-suffix target-suffix [commands ...]
`suffix-rule` (aka `->`) adds a suffix rule to the suffix rule
`suffix-rule` (aka `->` or `→`) adds a suffix rule to the suffix rule
list. There are 3 components
- SOURCE-SUFFIX is a string that names the filename suffix of the file

10
potato/ecma48.scm
View File

@ -1,10 +0,0 @@
(define-module (potato ecma48)
#:export (underline
reset))
(define (underline)
(display (string #\escape #\[ #\4 #\m)))
(define (reset)
(display (string #\escape #\[ #\0 #\m)))

123
potato/makevars.scm
View File

@ -3,10 +3,10 @@
#:use-module (ice-9 format)
#:use-module (potato exceptions)
#:use-module (potato builtins)
#:use-module (potato ecma48)
#:use-module (potato text)
#:export (initialize-makevars
%makevars
%environment-overrides?
%elevate-environment?
lazy-assign ?=
assign :=
reference $
@ -24,11 +24,12 @@
;; The lower priority level always win, unless the '-e' flag was set
;; If the '-e' flag is set level 1 doesn't override level 3 and 4.
(define %ascii? #f)
(define %makevars #f)
(define %environment-overrides? #f)
(define %debug? #t)
(define %elevate-environment? #f)
(define %verbose? #t)
(define (debug spec . args)
(when %debug?
(when %verbose?
(apply format (append (list #t spec) args))))
@ -53,7 +54,7 @@ later equals signs."
(define (override? old-priority new-priority)
"The logic of whether which makemacro priority levels can override
others."
(if %environment-overrides?
(if %elevate-environment?
(if (and (or (= old-priority) (= old-priority 3) (= old-priority 4))
(= new-priority 1))
#f
@ -129,9 +130,9 @@ the value of MAKEFLAGS or SHELL."
(define (dump-makevars)
"Write out a list of the current makevars."
(when (not (zero? (hash-count (const #t) %makevars)))
(underline)
(display (underline))
(display "Makevars")
(reset)
(display (default))
(newline)
(let ((keyvals
(sort
@ -140,56 +141,64 @@ the value of MAKEFLAGS or SHELL."
(string<? (car a) (car b))))))
(for-each
(lambda (keyval)
(let* ((key (car keyval))
(val (cdr keyval))
(part1 (if (zero? (string-length (car val)))
(string-copy key)
(string-append key " → " (car val))))
(part1-trunc
(if (> (string-length part1) 50)
(string-append (substring part1 0 50) "…")
part1))
(part2 (make-string (- 54 (string-length part1-trunc))
#\space))
(priority (cdr val))
(part3 (list-ref '("unknown"
"script"
"command line"
"MAKEFLAGS"
"environment"
"built-in")
priority)))
(string-map!
(lambda (c)
(if (char<? c #\space)
;; Replace control codes with control pictures
(integer->char (+ #x2400 (char->integer c)))
c))
part1)
(display " ")
(display part1-trunc)
(display part2)
(display part3)
(newline)))
keyvals))))
(let ((key (car keyval))
(val (cdr keyval)))
(let ((keyval-string
(if (zero? (string-length (car val)))
(string-copy key)
(string-append key " " (right-arrow) " " (car val)))))
;; Replace any control characters in VAL, like newline or tab
(set! keyval-string
(string-fold
(lambda (c str)
(string-append str
(if (char<? c #\space)
(C0 c)
(string c))))
""
keyval-string))
;; Truncate
(if (> (string-length keyval-string) 60)
(if %ascii?
(set! keyval-string
(string-append (substring keyval-string 0 57) "..."))
(set! keyval-string
(string-append (substring keyval-string 0 59) "…"))))
(let* ((space (make-string (- 64 (string-length keyval-string))
#\space))
(priority (cdr val))
(source-string (list-ref '("unknown"
"script"
"command line"
"MAKEFLAGS"
"environment"
"built-in")
priority)))
(display " ")
(display keyval-string)
(display space)
(display source-string)
(newline)))))
keyvals))))
(define (initialize-makevars keyvals
elevate-env-vars?
ignore-environment?
no-builtins?
debug?)
(set! %environment-overrides? elevate-env-vars?)
environment?
elevate-environment?
builtins?
verbose?
ascii?)
(set! %elevate-environment? elevate-environment?)
(set! %makevars (make-hash-table))
(set! %debug? debug?)
(unless no-builtins?
(set! %verbose? verbose?)
(set! %ascii? ascii?)
(when builtins?
(makevars-add-builtins))
(makevars-add-environment)
(makevars-add-makeflags)
(when environment?
(makevars-add-environment)
(makevars-add-makeflags))
(makevars-add-keyvals keyvals)
(when %debug?
(dump-makevars))
)
(when %verbose?
(dump-makevars)))
;; API
(define* (lazy-assign key #:optional (val ""))
@ -213,7 +222,7 @@ referenced.
(unless (string? KEY)
(bad-proc-output "lazy-assign" key))
(makevars-set KEY VAL)
(when (and %debug? (string? VAL))
(when (and %verbose? (string? VAL))
(format #t "~A=~A~%" KEY VAL))))
(define-syntax ?=
@ -244,7 +253,7 @@ string to use as the key in the hash table entry.
(unless (string? VAL)
(bad-proc-output "assign" VAL))
(makevars-set KEY VAL)
(when %debug?
(when %verbose?
(format #t "~A=~A~%" KEY VAL))))
(define-syntax :=
@ -287,7 +296,7 @@ space-separated token in the looked-up value."
(unless (string? val)
(bad-proc-output "reference" val))
(hash-set! %makevars key (cons val priority))
(when %debug?
(when %verbose?
(format #t "~A=~A~%" key val)))
(when (procedure? transformer)
(set! val (string-append-with-spaces
@ -327,7 +336,7 @@ that string."
(if (promise? val)
(lambda ()
(let ((VAL (force val)))
;; FIXME: put debug print here?
;; FIXME: put verbose print here?
VAL))
;; else
(lambda ()

693
potato/rules.scm
View File

@ -19,118 +19,23 @@
target-basename $*
prerequisites $^
build
string-compose ~
string-compose ~
silent-compose ~@
always-execute-compose ~+
ignore-error-compose ~-
))
(define-record-type <target-rule>
(make-target-rule name prerequisites recipes priority)
target-rule?
;; A filename, for real targets, or just a name for phony targets
(name target-rule-get-name target-rule-set-name!)
;; A list of filenames and/or phony targets that have target rules
(prerequisites target-rule-get-prerequisites
target-rule-set-prerequisites!)
;; A list of strings or procedures
(recipes target-rule-get-recipes
target-rule-set-recipes!)
;; 1 = script-defined. 2 = built-in
(priority target-rule-get-priority
target-rule-set-priority!))
(define-record-type <suffix-rule>
(make-suffix-rule source-suffix target-suffix recipes priority)
suffix-rule?
;; A string, usually like ".c". Or a string->string proc.
(source-suffix suffix-rule-get-source
suffix-rule-set-source)
;; A string, usually like ".o". Or a string->bool proc.
(target-suffix suffix-rule-get-target
suffix-rule-set-suffix!)
;; A list of strings or procedures
(recipes suffix-rule-get-recipes
suffix-rule-set-recipes!)
;; 1 = script-defined. 2 = built-in
(priority suffix-rule-get-priority
suffix-rule-set-priority!))
(define-record-type <node>
(make-node name parent status)
node?
;; For a real target, this is a filename. For a phony target it is
;; 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!)
;; 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 'success, 'failure, or 'undetermined
(status node-get-status node-set-status!)
;; A list of rules to evaluate to try to c
(rules node-get-rules node-set-rules!)
(children node-get-children node-set-children!)
;; Determines how many children must pass for the parent
;; to be evaluated. Either 'or or 'and.
(logic node-get-logic node-set-logic!)
)
(define %node-cur #f)
(define target-name
(lambda ()
(if %node-cur
(node-get-name %node-cur)
#f)))
(define $@ target-name)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPER FUNCTIONS
(define (basename str)
"Strip off the '.ext' part of a filename string."
(let ((idx (string-index-right str #\.)))
(if idx
(substring str 0 idx)
str)))
(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 (first-target-rule-name)
(if (null? %target-rules)
#f
;; else
(target-rule-get-name (car %target-rules))))
;; target-name $@
;; target-basename $*
;; newer-prerequisites $?
;; prerequisites $^
;; primary-prerequisite $<
;; There are two priorities of rules
;; 1. rules defined in the script have higher priority than built-in rules
;; 2. later-defined rules have higher priority earlier defined-rules
;; 3. a target rule will have higher priority than a suffix rule for the same
;; target
(define %target-rules '())
(define %suffix-rules '())
(define %debug? #f)
(define (string-compose . args)
(define (base-compose . args)
"Returns a lambda that appends args together as a string,
adding intermediate spaces. If an arg is a procedure,
it is evaluated."
@ -150,7 +55,7 @@ it is evaluated."
(set! effective-arg (arg))
#;(unless (string? effective-arg)
(bad-proc-output "~" arg))
(bad-proc-output "~" arg))
)
((string? arg)
(set! effective-arg arg))
@ -171,38 +76,25 @@ it is evaluated."
(if need-a-space? " " "")
effective-arg)))))))))
(define (string-compose . args)
(cons 'default (apply base-compose args)))
(define ~ string-compose)
(define (initialize-rules no-builtins? debug?)
(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)))
)
(define (ignore-error-compose . args)
(cons 'ignore-error (apply base-compose args)))
(define* (target-rule name #:optional (prerequisites '()) #:rest recipes)
;; FIXME: Typecheck
(let ((rule (make-target-rule name prerequisites recipes 1)))
;; Add to %target-rules
(set! %target-rules (cons rule %target-rules))))
(define ~- ignore-error-compose)
;; Alias
(define : target-rule)
(define (silent-compose . args)
(cons 'silent (apply base-compose args)))
(define (suffix-rule source target . recipes)
;; FIXME: Typecheck
(let ((rule (make-suffix-rule source target recipes 1)))
(set! %suffix-rules (cons rule %suffix-rules))))
(define ~@ silent-compose)
;; Alias
(define -> suffix-rule)
(define (always-execute-compose . args)
(cons 'always-execute (apply base-compose args)))
(define ~@ always-execute-compose)
(define (regular-file? filename)
(let ((st (stat filename #f)))
@ -213,85 +105,149 @@ it is evaluated."
(+ (* 1000000000 (stat:mtime st))
(stat:mtimensec st))))
(define (create-node name parent)
"Constructs a tree of nodes, with name as the root node."
(let ((node (make-node name parent 'untested)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TARGET STRUCT AND METHODS
;; FIXME: here check that this name differs from all ancenstor's
;; names
(define-record-type <target-rule>
(make-target-rule name prerequisites recipes priority)
target-rule?
;; A filename, for real targets, or just a name for phony targets
(name target-rule-get-name target-rule-set-name!)
;; A list of filenames and/or phony targets that have target rules
(prerequisites target-rule-get-prerequisites
target-rule-set-prerequisites!)
;; A list of strings or procedures
(recipes target-rule-get-recipes
target-rule-set-recipes!)
;; 1 = script-defined. 2 = built-in
(priority target-rule-get-priority
target-rule-set-priority!))
;; 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)))
;; List of all target rules in order of importance
(define %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.
(define* (target-rule name #:optional (prerequisites '()) #:rest recipes)
"Register a new target rule"
;; FIXME: Typecheck
(let ((rule (make-target-rule name prerequisites recipes 1)))
;; Add to %target-rules
(set! %target-rules (cons rule %target-rules))))
;; 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 '())))))
;; Alias
(define : target-rule)
#|
;; 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))
(define (first-target-rule-name)
(if (null? %target-rules)
#f
;; else
(target-rule-get-name (car %target-rules))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SUFFIX STRUCT AND METHODS
(define-record-type <suffix-rule>
(make-suffix-rule source-suffix target-suffix recipes priority)
suffix-rule?
;; A string, usually like ".c". Or a string->string proc.
(source-suffix suffix-rule-get-source
suffix-rule-set-source)
;; A string, usually like ".o". Or a string->bool proc.
(target-suffix suffix-rule-get-target
suffix-rule-set-suffix!)
;; A list of strings or procedures
(recipes suffix-rule-get-recipes
suffix-rule-set-recipes!)
;; 1 = script-defined. 2 = built-in
(priority suffix-rule-get-priority
suffix-rule-set-priority!))
;; The list of all registered suffix rules in order of importance
(define %suffix-rules '())
(define (suffix-rule source target . recipes)
"Register a suffix rule"
;; FIXME: Typecheck
(let ((rule (make-suffix-rule source target recipes 1)))
(set! %suffix-rules (cons rule %suffix-rules))))
;; Alias
(define -> suffix-rule)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; NODE STRUCT AND METHODS
(define-record-type <node>
(make-node name parent status)
node?
;; For a real target, this is a filename. For a phony target it is
;; 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!)
;; 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
(rules node-get-rules node-set-rules!)
(children node-get-children node-set-children!)
;; Determines how many children must pass for the parent
;; to be evaluated. Either 'or or 'and.
(logic node-get-logic node-set-logic!)
)
;;;;;;;;;
;; Automatic variables
;; target-name $@
;; target-basename $*
;; newer-prerequisites $?
;; prerequisites $^
;; primary-prerequisite $<
;; This is set in the builder to make automatic variables work.
(define %node-cur #f)
(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)
;; 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 (undetermined? node)
(eq? (node-get-status node) 'undetermined))
@ -320,61 +276,288 @@ it is evaluated."
(else
#f)))
(define (build root)
"Give a tree of <node>, this executes the recipes therein."
(let ((tree (create-node root #f)))
(let ((node root))
(while #t
(if (undetermined? node)
(if (children-complete? node)
(if (children-passed? node)
(if (has-recipe? node)
(run-recipe! 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)))
;; else, this node is determined
(if (and abort-on-error (failed? node))
(break)
;; else not failed
(if (has-parent? node)
(set! node (get-parent node))
;; else, there is no parent to this node
(break))))))))
(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 (eqv? (node-get-status child) 'undetermined)
child
#f))
children)))
(define (failed? node)
(eqv? (node-get-status node) 'fail))
(define (has-parent? node)
(if (node-get-parent node)
#t
#f))
(define (up-to-date? node)
"Checks if node is up to date:
- it has an mtime
- all its children have mtimes
- its mtime is older than the mtime of its children"
(let ((children (map node-get-mtime (node-get-children node)))
(parent (node-get-mtime node)))
(if (every (lambda (child)
(and (integer? parent)
(integer? child)
(>= parent child)))
children)
#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)))
(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)
"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)
(node-set-mtime! node (compute-mtime name)))
;; else
(node-set-status! node 'fail))))
;; Start at root
;; If cur is UNDETERMINED, find a leaf that is UNDETERMINED.
;; Descent to first leaf.
;; 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.
;; Else self has no mtime or rules, so mark self FAIL.
;; Go to parent.
;; IF PASS or FAIL, go to parent
;; IF UNDETERMINED do these...
;; Are we done with the children?
;; If AND rule and one child is FAIL, stop
;; If OR rule and one child is PASS, stop
;; 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 %debug? #f)
(define (initialize-rules no-builtins? debug?)
(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)))
)
(define (create-node name parent)
"Constructs a tree of nodes, with name as the root node."
(let ((node (make-node name parent 'untested)))
;; 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)))
;; Start at root
;; Search for matching target rule.
(when (not (null? %target-rules))
(let loop ((rule (car %target-rules))
(rest (cdr %target-rules)))
;; If cur is UNDETERMINED, find a leaf that is UNDETERMINED.
;; Descent to first leaf.
;; 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.
;; Else self has no mtime or rules, so mark self FAIL.
;; Go to parent.
;; 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.
;; IF PASS or FAIL, go to parent
;; 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 UNDETERMINED do these...
#|
;; 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))
;; Are we done with the children?
;; If AND rule and one child is FAIL, stop
;; If OR rule and one child is PASS, stop
;; If no children left, stop
;; Else keep going
;; 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))
;; 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
(define (build root)
"Give a tree of <node>, this executes the recipes therein."
(let ((tree (create-node root #f)))
(let ((node root))
(while #t
(if (undetermined? node)
(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)
;; 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)))
;; else, this node is determined
(if (and abort-on-error (failed? node))
(break)
;; else not failed
(if (has-parent? node)
(set! node (get-parent node))
;; else, there is no parent to this node
(break))))))))
|#

101
potato/text.scm Normal file
View File

@ -0,0 +1,101 @@
(define-module (potato text)
#:export (underline
default
right-arrow
ellipses
C0
red
initialize-text))
(define %fancy #t)
(define (initialize-text ascii)
(set! %fancy (not ascii)))
(define (default)
(if %fancy
(string #\escape #\[ #\0 #\m)
""))
(define (bold)
(if %fancy
(string #\escape #\[ #\1 #\m)
""))
(define (underline)
(if %fancy
(string #\escape #\[ #\4 #\m)
""))
(define (red)
(if %fancy
(string #\escape #\[ #\3 #\1 #\m)
""))
(define (green)
(if %fancy
(string #\escape #\[ #\3 #\2 #\m)
""))
(define (blue)
(if %fancy
(string #\escape #\[ #\3 #\4 #\m)
""))
(define (important)
(if %fancy
"⚠" ; U+26A0 WARNING SIGN
"!!!"))
(define (stop)
(if %fancy
"🛑" ; U+26A0 WARNING SIGN
"XXX"))
(define (right-arrow)
(if %fancy
"→" "->"))
(define (ellipses)
(if %fancy "…" "..."))
(define (QED)
(if %fancy "∎" "QED")) ; U+220E END OF PROOF
(define (C0 c)
(if %fancy
;; Replace control codes with control pictures
(string (integer->char (+ #x2400 (char->integer c))))
(list-ref '("<NUL>" "<SOH>" "<STX>" "<ETX>" "<EOT>" "<ENQ>"
"<ACK>" "<BEL>" "<BS>" "<HT>" "<LF>"
"<VT>" "<FF>" "<CR>" "<SO>" "<SI>"
"<DLE>" "<DC1>" "<DC2>" "<DC3>" "<DC4>"
"<NAK>" "<SYN>" "<ETB>" "<CAN>" "<EM>"
"<SUB>" "<ESC>" "<FS>" "<GS>" "<RS>"
"<US>")
(char->integer c))))
(define (lquo)
(if %fancy (string #\“) (string #\")))
(define (rquo)
(if %fancy (string #\”) (string #\")))
(define (BOL)
"go to beginning of line"
(if %fancy (string #\escape #\[ #\G) "\n"))
#|
in quiet mode it is just
☐ target -> parent (when building)
☒ target -> parent (on pass)
⚠ target -> parent (on fail but continue)
🛑 target -> parent (on stop)
∎ (on successful completion)
in normal mode it is
? target -> parent
☐ recipe truncated to 70 cols, using C0 control pics
etc
then
☒ target -> parent (on pass)
|#

110
studious-potato.scm
View File

@ -7,6 +7,7 @@
#:use-module (potato exceptions)
#:use-module (potato makevars)
#:use-module (potato rules)
#:use-module (potato text)
#:export (initialize
execute
)
@ -74,29 +75,39 @@
(apply format (append (list #t spec) args))))
(define option-spec
'((help (single-char #\h) (value #f))
(version (single-char #\v) (value #f))
(quiet (single-char #\q) (value #f))
(verbose (single-char #\V) (value #f))
(ignore-environment (value #f))
(no-builtins (single-char #\r) (value #f))
(elevate-environment (single-char #\e) (value #f))
(ignore-errors (single-char #\i) (value #f))
'((help (single-char #\h) (value #f))
(version (single-char #\v) (value #f))
(quiet (single-char #\q) (value #f))
(verbose (single-char #\V) (value #f))
(environment (single-char #\e) (value #f))
(elevate-environment (single-char #\E) (value #f))
(builtins (single-char #\b) (value #f))
(ignore-errors (value #f))
(continue-on-error (single-char #\k) (value #f))
;;(dump-macros (single-char #\p) (value #f))
;;(no-builtins (single-char #\r) (value #f))
;;(silent (single-char #\s) (value #f))
(no-execution (single-char #\n) (value #f))
(ascii (single-char #\A) (value #f))
))
(define (display-help-and-exit argv0)
(format #t "~A [-hvVr] [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 " --ignore-environment~%")
(format #t " ignore environment variables~%")
(format #t " -r, --no-builtins no default or built-in rules~%")
(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 " -e, --environment use environment variables~%")
(format #t " -E, --elevate-environment~%")
(format #t " use environment variables and let~%")
(format #t " them override script variables~%")
(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 " -k, --continue-on-error~%")
(format #t " keep building even if commands fail~%")
(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~%")
(exit 0))
(define (display-version-and-exit argv0)
@ -130,36 +141,38 @@ return them in a list."
lst))
(define* (initialize #:optional
(arguments '())
(ignore-environment 'unknown))
"Set up the options, built-in rules, and built-in makevars. If
IGNORE_ENVIRONMENT is #t or #f, don't parse environment variables,
despite the setting of any ignore-environment flag."
(arguments '()))
"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."
(when (null? arguments)
(set! arguments (program-arguments)))
;; We start of with the --help and --version command-line arguments.
(let ((options (getopt-long arguments option-spec))
(%opt-builtins #f)
(%opt-environment #f)
(%opt-elevate-environment #f)
(%opt-no-builtins #f)
(%opt-ignore-environment #f))
(%opt-no-errors #f)
(%opt-continue-on-error #f)
(%opt-no-execution #f)
(%opt-ascii #f))
(when (option-ref options 'help #f)
(display-help-and-exit (car arguments)))
(when (option-ref options 'version #f)
(display-version-and-exit (car arguments)))
;; Then, we do --ignore-environment, because we need to know that
;; Then, we do --environment, because we need to know that
;; before we start parsing MAKEFLAGS
(if (eqv? ignore-environment 'unknown)
(set! %opt-ignore-environment
(option-ref options 'ignore-environment #f))
;; else
(set! %opt-ignore-environment ignore-environment))
(set! %opt-environment
(option-ref options 'environment #f))
;; Parse MAKEFLAGS before the command-line, because we want
;; command-line options to override MAKEFLAGS options.
(unless %opt-ignore-environment
(when %opt-environment
(let ((mf (getenv "MAKEFLAGS")))
(when mf
(let ((tokens (string-tokenize mf)))
@ -169,8 +182,16 @@ despite the setting of any ignore-environment flag."
(when (member "verbose" tokens)
(set! %opt-verbose #t)
(set! %opt-quiet #f))
(when (member "no-builtins" tokens)
(set! %opt-no-builtins #t))))))
(when (member "builtins" tokens)
(set! %opt-builtins #t))
(when (member "ascii" tokens)
(set! %opt-ascii #t))
(when (member "ignore-errors" tokens)
(set! %opt-ignore-errors #t))
(when (member "continue-on-error" tokens)
(set! %opt-continue-on-error #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)
@ -179,25 +200,30 @@ despite the setting of any ignore-environment flag."
(when (option-ref options 'verbose #f)
(set! %opt-verbose #t)
(set! %opt-quiet #f))
(set! %opt-no-builtins
(option-ref options 'no-builtins #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))
;; Now that all the options are set, we can set up
;; the build environment.
(let ((extra (option-ref options '() '())))
(initialize-text %opt-ascii)
(initialize-makevars (parse-macros extra)
%opt-environment
%opt-elevate-environment
%opt-ignore-environment
%opt-no-builtins
%opt-verbose)
(initialize-rules %opt-no-builtins
%opt-builtins
%opt-verbose
%opt-ascii)
#;(initialize-rules %opt-no-builtins
%opt-verbose)
;; The remaining command-line words are the build targets that