From f75e5e8f4b7efb4f1a6e78e1ac0b86cb2360162c Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Sat, 13 Feb 2021 23:42:16 -0800 Subject: [PATCH] stash --- CHEATSHEET.md | 53 ++++++++++-------- potato/make.scm | 26 +++++---- potato/makevars.scm | 4 +- potato/rules.scm | 131 ++++++++++++++++++++++++-------------------- potato/text.scm | 3 + 5 files changed, 124 insertions(+), 93 deletions(-) diff --git a/CHEATSHEET.md b/CHEATSHEET.md index 2715af2..3b26be9 100644 --- a/CHEATSHEET.md +++ b/CHEATSHEET.md @@ -14,7 +14,7 @@ Add this at the top of your build script. Add this at the bottom of your build script (execute) - + The rules go in between `initialize` and `build` ## MAKEVARS @@ -46,50 +46,59 @@ have filenames or phony names. recipe-1 recipe-2 ...) - + `target-name` is a string which is either a filename to be created or an phony name like "all" or "clean". - + Recipe as a string to be evaluated by the system - + (: "foo.o" '("foo.c") "cc -c foo.o") - + Recipe as a procedure - + (: "clean-foo" '() (lambda () (delete-file "foo.o"))) - + Recipe as a procedure that returns #f to indicate failure - + (: "recent" '() (lambda () (if condition #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. (-> ".c" ".o" (~ ($ CC) ($ CFLAGS) "-c" $< "-o" $@)) - + ## 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 @@ -97,11 +106,11 @@ a target file, based on the filename extensions. - automatic variables - anything whose string representation as created by (format #f "~A" ...) make sense - + Any procedures are applied lazily, when the rule is executed. - + (~ "string" (lambda () "string") ($ KEY) $@ 100 ) - + Three versions of `~` with special effects (~- ...) ignores any errors (~@ ...) doesn't print recipe to console @@ -110,7 +119,7 @@ a target file, based on the filename extensions. ## Automatic Variables Recipes can contain the following automatic variables - + $@ the target $* the target w/o a filename suffix $< the first prerequisite diff --git a/potato/make.scm b/potato/make.scm index 94598b3..c48f6f1 100644 --- a/potato/make.scm +++ b/potato/make.scm @@ -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)) - ;; else - (debug "There are no target rules in the recipe.~%"))))) + (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.~%")))) ;; 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)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/potato/makevars.scm b/potato/makevars.scm index c092bf6..d71c149 100644 --- a/potato/makevars.scm +++ b/potato/makevars.scm @@ -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?) diff --git a/potato/rules.scm b/potato/rules.scm index d58147d..9e1cb12 100644 --- a/potato/rules.scm +++ b/potato/rules.scm @@ -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) - #t - #f))) + (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))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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". @@ -596,7 +609,7 @@ failure condition happens, mark the node as having failed." ;; - Ignore errors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; LET'S GO! +;; LET'S GO! (define (initialize-rules targets builtins? ignore-errors? continue-on-error? no-execution? verbosity ascii?) (set! %target-rules '()) @@ -616,7 +629,7 @@ failure condition happens, mark the node as having failed." (node-set-children! node '()) ;; FIXME: here check that this name differs from all ancenstor's ;; names - + ;; Try to the file's modification time. (when (file-exists? name) (when (not (regular-file? name)) @@ -624,12 +637,12 @@ failure condition happens, mark the node as having failed." (when (not (access? name R_OK)) (no-read-access-to-file "create-node" name)) (node-set-mtime! node (compute-mtime name))) - + ;; Search for matching target rule. (when (not (null? %target-rules)) (let loop ((rule (car %target-rules)) (rest (cdr %target-rules))) - + ;; N.B: here we assume target rule names and ;; predicates are exclusively strings. (if (string=? name (target-rule-get-name rule)) @@ -639,7 +652,7 @@ failure condition happens, mark the node as having failed." (node-set-logic! node 'and) ;; For target-rules, the prerequisites comes from the ;; rule itself. - + ;; Oooh, recursion! (node-set-children! node (map (lambda (prereq) @@ -651,52 +664,49 @@ 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))) - ;; 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)) + (for-each + (lambda (rule) + (let ((targ (suffix-rule-get-target rule))) + (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. + (node-set-rules! node (cons rule (node-get-rules node))) + (node-set-logic! node 'or) + (let* ((src (suffix-rule-get-source rule)) + (prereq + (string-append + (string-drop-right name (string-length src)) + src))) - ;; First matching rule has highest priority + ;; Note the recursion here. + (node-set-children! node + (cons (create-node prereq node) + (node-get-children node))))))) + %suffix-rules)) + + ;; 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 , 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))) diff --git a/potato/text.scm b/potato/text.scm index 99ce44b..82825b4 100644 --- a/potato/text.scm +++ b/potato/text.scm @@ -2,9 +2,12 @@ #:export (underline default right-arrow + left-arrow ellipses C0 red + lquo + rquo initialize-text)) (define %fancy #t)