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-13 23:42:16 -08:00
parent e401dc59ca
commit f75e5e8f4b
5 changed files with 124 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
CHEATSHEET.md
View File

@ -69,18 +69,25 @@ have filenames or phony names.
#t
#f))))
Recipe as a procedure returning a string to be evaluated by the system
Recipe as a procedure returning a string to be evaluated by the
system
(: "foo.o" '("foo.c")
(lambda ()
(format #f "cc ~A -c foo.c" some-flags))
Recipe using recipe helper procedures, which create a string to be
evaluated by the system
Recipe using recipe helper procedures, which create a string to
be evaluated by the system
(: "foo.c" '("foo.c")
(~ ($ CC) ($ CFLAGS) "-c" $<))
Recipe as a boolean to indicate pass or failure without doing any
processing. For example, the rule below tells Potato Make that
the file "foo.c" exists without actually testing for it.
(: "foo.c" '() #t)
The *suffix rule* is a generic rule to convert one source file to
a target file, based on the filename extensions.
@ -89,7 +96,9 @@ a target file, based on the filename extensions.
## Recipe Helpers
Concatenate elements with `~`. `~` inserts spaces between the elements.
Concatenate elements with `~`. `~` inserts spaces between the
elements.
Elements can be
- strings
- procedures that return strings

24
potato/make.scm
View File

@ -19,8 +19,8 @@
suffix-rule ->
target-name $@
target-basename $*
newer-prerequisites $?
prerequisites $^
newer-prerequisites $? $$?
prerequisites $^ $$^
primary-prerequisite $<
string-compose ~
silent-compose ~@
@ -189,6 +189,8 @@ arguments."
(let ((mf (getenv "MAKEFLAGS")))
(when mf
(let ((tokens (string-tokenize mf)))
(when (member "silent" tokens)
(set! %verbosity 0))
(when (member "terse" tokens)
(set! %verbosity 1))
(when (member "verbose" tokens)
@ -263,28 +265,32 @@ targets listed on the parsed command-line are used."
(when (null? targets)
(set! targets %targets))
(when (null? targets)
(debug "No target was specified.~%")
(debug "No build target was explicitely specified.~%")
(let ((rule (first-target-rule-name)))
(if rule
(begin
(debug "Using first rule ~A as target.~%" rule)
(set! targets (list rule))
(debug "Using first rule ~a~A~a as the build target.~%" (lquo) rule (rquo))
(set! targets (list rule)))
;; else
(debug "There are no target rules in the recipe.~%")))))
(debug "There are no target rules in the recipe.~%"))))
;; Build each target in order.
(when (not (null? targets))
(let loop ((target (car targets))
(rest (cdr targets)))
(print "Attempting to run target “~A”.~%" target)
(when (>= %verbosity 3)
(format #t "Considering target file ~A~A~A.~%" (lquo) target (rquo)))
(if (not (build target))
(begin
(print "The recipe for “~A” has failed.~%" target))
(print "The recipe for “~A” has failed.~%" target)
#f)
;; else
(begin
(print "The recipe for “~A” has succeeded.~%" target)
(if (not (null? rest))
(loop (car rest) (cdr rest))))))))
(loop (car rest) (cdr rest))
;; True if all targets are built successfully.
#t))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

4
potato/makevars.scm
View File

@ -25,7 +25,7 @@
;; If the '-e' flag is set level 1 doesn't override level 3 and 4.
(define %ascii? #f)
(define %makevars #f)
(define %makevars (make-hash-table))
(define %elevate-environment? #f)
(define %strict #f)
(define %verbose? #t)
@ -190,7 +190,7 @@ the value of MAKEFLAGS or SHELL."
verbosity
ascii?)
(set! %elevate-environment? elevate-environment?)
(set! %makevars (make-hash-table))
(hash-clear! %makevars)
(set! %strict strict?)
(set! %verbose? (= verbosity 3))
(set! %ascii? ascii?)

85
potato/rules.scm
View File

@ -17,10 +17,10 @@
target-rule :
suffix-rule ->
target-name $@
newer-prerequisites $?
newer-prerequisites $? $$?
primary-prerequisite $<
target-basename $*
prerequisites $^
prerequisites $^ $$^
build
string-compose ~
silent-compose ~@
@ -215,13 +215,11 @@ it is evaluated."
(cond
((pair? recipe)
recipe)
((string? recipe)
(cons 'default recipe))
(else
(error "bad recipe for target rule"))))
(cons 'default recipe))))
recipes)))
(let ((rule (make-suffix-rule source target recipes 1)))
(let ((rule (make-suffix-rule source target recipes2 1)))
(set! %suffix-rules (cons rule %suffix-rules)))))
;; Alias
@ -346,15 +344,19 @@ it is evaluated."
- 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)
(let ((children (node-get-children node))
(parent-mtime (node-get-mtime node)))
(if (or (null? children) (not (integer? parent-mtime)))
;; Targets without children are always rebuilt.
;; Targets without mtimes are always rebuilt.
#f
(let ((children-mtime (map node-get-mtime children)))
(if (every (lambda (child-mtime)
(and (integer? child-mtime)
(>= parent-mtime child-mtime)))
children-mtime)
#t
#f)))
#f)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; AUTOMATIC VARIABLES
@ -365,19 +367,30 @@ it is evaluated."
(define primary-prerequisite 'unspecified)
(define newer-prerequisites '())
(define (string-append-with-spaces lst)
"Appends the strings in lst, adding spaces in between."
(if (null? lst)
""
;; else
(fold
(lambda (elem prev)
(string-append prev " " elem))
(car lst)
(cdr lst))))
(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 () (string-append-with-spaces newer-prerequisites)))
(define $$^ (lambda () prerequisites))
(define $^ (lambda () (apply string-compose prerequisites)))
(define $^ (lambda () (string-append-with-spaces 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! primary-prerequisite (if (null? prerequisites) "" (car prerequisites)))
(set! newer-prerequisites
;; If this node doesn't have a real file attached, then all
;; prerequistes are "newer".
@ -651,19 +664,13 @@ failure condition happens, mark the node as having failed."
;; else, no matching rule found
(node-set-rules! node '())))))
#|
;; If no rule found so far, search for suffix rules.
(when (null? (node-get-rules node))
(for-each
(lambda (rule)
(let ((targ (suffix-rule-get-target rule)))
(when (or
;; string suffix
(and (string? targ)
(string-suffix? targ name))
;; procedure suffix
(and (procedure? targ)
(targ name)))
(format #t "possible suffix rule ~S~%" rule)
(when (string-suffix? targ name)
;; For suffix rules, there will be exactly one child per
;; rule and the name of the child is constructed from a
;; suffix and the parent's name.
@ -671,32 +678,35 @@ failure condition happens, mark the node as having failed."
(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))))
src)))
;; Note the recursion here.
(node-set-children! node
(cons (create-node prereq node)
(node-get-children node)))))))
%suffix-rules))
;; First matching rule has highest priority
;; FIXME: First matching rule has highest priority? Or is last better?
(node-set-rules! node (reverse (node-get-rules node)))
(node-set-children! node (reverse (node-get-children node)))
|#
;;(format #t "matching suffix rules ~S~%" (node-get-rules node))
;;(format #t "matching children rules ~S~%" (node-get-children node))
;; And node is ready to go
node))
(define (build root)
"Give a tree of <node>, this executes the recipes therein."
(format #t "BLAMMO 1 ~S~%" root)
(let ((tree (create-node root #f)))
(let ((node tree))
(while #t
(when (>= %verbosity 2) (format #t "PRocessing ~S~%" (node-get-name node)))
(if (undetermined? node)
(begin
(when (>= %verbosity 3) (format #t "~S is undetermined~%" (node-get-name node)))
(if (children-complete? node)
(if (children-passed? node)
(if (up-to-date? node)
@ -712,12 +722,15 @@ failure condition happens, mark the node as having failed."
(set! node (get-next-child node))))
;; else, this node is determined
(begin
(if (and (not %ignore-errors?) (failed? node))
(break)
(when (>= %verbosity 2) (format #t "~S is determined ~S~%" (node-get-name node) (node-get-status node)))
#| (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))
;; )
))))
;; Return the command output of the root node
(passed? tree)))

3
potato/text.scm
View File

@ -2,9 +2,12 @@
#:export (underline
default
right-arrow
left-arrow
ellipses
C0
red
lquo
rquo
initialize-text))
(define %fancy #t)