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

Sync

Browse Source 
Signed-off-by: Jacob Hrbek <kreyren@rixotstudio.cz>
This commit is contained in:
Jacob Hrbek 2022-08-31 19:55:56 +02:00
parent ddb3640fb8
commit 6a8b09699e
Signed by: kreyren
GPG Key ID: 667F0DAFAF09BA2B
5 changed files with 457 additions and 406 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
TAGS.org Normal file
View File

@ -0,0 +1,23 @@
#+TITLE: TAGS
This project is tagging code using the following syntax:
#+BEGIN_SRC scheme-mode
;; MAIN_TAG-SUB_TAG(Tag Author Signature): Comment
#+END_SRC
Which in practice might be used as:
#+BEGIN_SRC scheme-mode
;; FIXME-QA(Krey): This code needs to be improved for whatever reason
(some (scheme (code)))
#+END_SRC
** List of Tags
- FIXME = Used to tag code that needs attention
- FIXME-QA = Used to tag code with Quality Assurance issues
- FIXME-DOCS = Tags code that needs documentation
- DNR = Do Not Release - Usage prevents new version release, used to tag code that needs to be addressed prior
- DNM = Do Not Merge - Usage in merge/pull requests blocks syncing the code, used to tag code that needs to be addressed before merge can happen
- PROD/PRODUCTION = Code that should be considered prior to it's usage in production environment

11
src/potato/parse-lib.scm
View File

@ -38,16 +38,14 @@
;;; Commentary: ;;; Commentary:
;;; ;;;
;;; DOCS ;;; Backend code used for the parsing of non-guile makefiles
;;; ;;;
;;; Code: ;;; Code:
(define (read-line-handle-escaped-newline) (define (read-line-handle-escaped-newline)
"Reads a line of text from the current input port. "Reads a line of text from the current input port.
If the line ends with an odd number of backslashes, the following line If the line ends with an odd number of backslashes, the following line is read and appended. The output string has newlines as line terminators.
is read and appended. The output string has newlines as line
terminators.
It returns two values It returns two values
- the string containing the one or more lines read - the string containing the one or more lines read
@ -65,10 +63,7 @@ It returns two values
(values (string-append output line "\n") (1+ nline))))))) (values (string-append output line "\n") (1+ nline)))))))
(define* (string-collapse-continuations str #:optional (squash-whitespace? #f)) (define* (string-collapse-continuations str #:optional (squash-whitespace? #f))
"Returns a new string where backslash+newline is discarded, and "Returns a new string where backslash+newline is discarded, and backslash+backslash+newline becomes backslash+newline. Any whitespace after the newline may be squashed to a single space, if squash-whitespace? is #t."
backslash+backslash+newline becomes backslash+newline. Any whitespace
after the newline may be squashed to a single space, if
squash-whitespace? is #t."
(let loop ((str str) (let loop ((str str)
(newline-index (string-rindex str #\newline))) (newline-index (string-rindex str #\newline)))
(if (not newline-index) (if (not newline-index)

128
src/potato/parse.scm
View File

@ -27,42 +27,45 @@
;;; Commentary: ;;; Commentary:
;;; ;;;
;;; DOCS ;;; Functionality to parse non-guile makefiles
;;; ;;;
;;; Code: ;;; Code:
;; A makefile can contain rules, macro definitions, include lines, and comments. ;; A makefile can contain rules, macro definitions, include lines, and comments.
;; FIXME-DOCS(Krey)
(define (parse filename) (define (parse filename)
(with-input-from-file filename _eval #:guess-encoding #t)) (with-input-from-file filename _eval #:guess-encoding #t))
;; DNM-SECURITY(Krey): Check very carefully
;; FIXME-DOCS(Krey)
(define (_eval) (define (_eval)
(let ((filenames #f) (let ((filenames #f)
(ignoring #f) (ignoring #f)
(commands '())) (commands '()))
(while #t (while #t
(receive (line nlines) (receive (line nlines)
(read-line-handle-escaped-newline) (read-line-handle-escaped-newline)
(cond (cond
((zero? nlines) ((zero? nlines)
(break)) (break))
((string-starts-with? line #\tab) ((string-starts-with? line #\tab)
;; Shell-command lines ;; Shell-command lines
(when filenames (when filenames
(when ignoring (when ignoring
(continue)) (continue))
(set! commands (append commands (list line))))) (set! commands (append commands (list line)))))
(else (else
(display (display
(string-trim-both (string-trim-both
(string-remove-comments (string-remove-comments
(string-collapse-continuations line #t)))) (string-collapse-continuations line #t))))
(newline))))))) (newline)))))))
(define (string-parse-variable-definition str i) (define (string-parse-variable-definition str i)
"Parse a string as a variable definition." "Parse a string as a variable definition"
(let loop ((i (string-next-token str))) (let loop ((i (string-next-token str)))
(cond (cond
((= i (string-length str)) ((= i (string-length str))
@ -75,54 +78,57 @@
((char=? (string-ref str i) #\$) ((char=? (string-ref str i) #\$)
;; This begins a variable expansion reference. ;; This begins a variable expansion reference.
(let* ((openparen (false-if-exception (string-ref str (1+ i)))) (let* ((openparen (false-if-exception (string-ref str (1+ i))))
(closeparen (if (eqv? openparen #\() (closeparen (if (eqv? openparen #\()
#\) #\)
(if (eqv? openparen #\{) (if (eqv? openparen #\{)
#\} #\}
#f)))) #f))))
(if (not closeparen) (if (not closeparen)
(values i 'null) (values i 'null)
;; else, skip over the matching closeparen ;; else, skip over the matching closeparen
(begin (begin
(let ((count 0)) (let ((count 0))
(while #t (while #t
(set! i (1+ i)) (set! i (1+ i))
(when (char=? (string-ref str i) openparen) (when (char=? (string-ref str i) openparen)
(set! count (1+ count))) (set! count (1+ count)))
(when (char=? (string-ref str i) closeparen) (when (char=? (string-ref str i) closeparen)
(set! count (1- count)) (set! count (1- count))
(when (zero? count) (when (zero? count)
(set! i (1+ i)) (set! i (1+ i))
(break))))) (break)))))
;; Any whitespace before the operator? ;; Any whitespace before the operator?
(when (char-set-contains? char-set:blank (string-ref str i)) (when (char-set-contains? char-set:blank (string-ref str i))
(set! wspace #t) (set! wspace #t)
(set! i (string-next-token str i))) (set! i (string-next-token str i)))
(cond (cond
((eqv? (string-ref str i) #\=) ((eqv? (string-ref str i) #\=)
(values (1+ i) 'recursive)) (values (1+ i) 'recursive))
((and (eqv? (string-ref str i) #\:) ((and (eqv? (string-ref str i) #\:)
(eqv? (string-ref str (1+ i)) #\=)) (eqv? (string-ref str (1+ i)) #\=))
(values (+ i 2) 'simple)) (values (+ i 2) 'simple))
((and (eqv? (string-ref str i) #\+) ((and (eqv? (string-ref str i) #\+)
(eqv? (string-ref str (1+ i)) #\=)) (eqv? (string-ref str (1+ i)) #\=))
(values (+ i 2) 'append)) (values (+ i 2) 'append))
((and (eqv? (string-ref str i) #\?) ((and (eqv? (string-ref str i) #\?)
(eqv? (string-ref str (1+ i)) #\=)) (eqv? (string-ref str (1+ i)) #\=))
(values (+ i 2) 'conditional)) (values (+ i 2) 'conditional))
(else (else
(values i 'null))))))) (values i 'null)))))))
(else (else
(values i 'null))))) (values i 'null)))))
;; STUB(Krey): Unfinished code by original author, kept here in case we need to finish it in the future
#| #|
(define (parse-var-assignment line) (define (parse-var-assignment line)
(let ((i (string-next-token line 0))) (let ((i (string-next-token line 0)))
(if (= i (string-length line)) (if (= i (string-length line))
#f #f
;; else ;; else
(while #t (while #t
|# |#
;;; parse.scm ends here

160
src/potato/parser.scm
View File

@ -25,51 +25,60 @@
#:use-module (potato text) #:use-module (potato text)
#:export (parse)) #:export (parse))
;;; Commentary:
;;;
;;; Core functionality of the parsed for non-guile makefiles
;;;
;;; Code:
;; A makefile can contain rules, macro definitions, include lines, ;; A makefile can contain rules, macro definitions, include lines,
;; and comments. ;; and comments.
(define (parse filename) (define (parse filename)
"FIXME-DOCS"
(with-input-from-file filename parse-input #:guess-encoding #t)) (with-input-from-file filename parse-input #:guess-encoding #t))
(define (last-char str) (define (last-char str)
"FIXME-DOCS"
(string-ref str (1- (string-length str)))) (string-ref str (1- (string-length str))))
(define (parse-input) (define (parse-input)
"FIXME-DOCS"
(while #t (while #t
(let loop ((line "") (let loop ((line "")
(str (read-line))) (str (read-line)))
(cond (cond
((eof-object? str) ((eof-object? str)
(break)) (break))
((char=? (last-char str) #\\) ((char=? (last-char str) #\\)
(loop (string-append line str) (read-line))) (loop (string-append line str) (read-line)))
(else (else
(parse-line (string-append line str))))))) (parse-line (string-append line str)))))))
;; For include lines ;; For include lines
(define-peg-pattern I_TOK none "include") (define-peg-pattern I_TOK none "include")
(define-peg-pattern I_SPACE none (or " " "\t")) (define-peg-pattern I_SPACE none (or " " "\t"))
(define-peg-pattern I_FILENAME_CHAR body (or (range #\a #\z) (define-peg-pattern I_FILENAME_CHAR body (or (range #\a #\z)
(range #\A #\Z) (range #\A #\Z)
(range #\0 #\9) (range #\0 #\9)
"_" "-" ".")) "_" "-" "."))
(define-peg-pattern I_FILENAME all (+ I_FILENAME_CHAR)) (define-peg-pattern I_FILENAME all (+ I_FILENAME_CHAR))
(define-peg-pattern I_NL none "\n") (define-peg-pattern I_NL none "\n")
(define-peg-pattern I_COMMENT none (and "#" (* peg-any))) (define-peg-pattern I_COMMENT none (and "#" (* peg-any)))
(define-peg-pattern INCLUDE all (and I_TOK (define-peg-pattern INCLUDE all (and I_TOK
(+ (and (* I_SPACE) (+ (and (* I_SPACE)
I_FILENAME)) I_FILENAME))
(* I_SPACE) (* I_SPACE)
(? I_COMMENT))) (? I_COMMENT)))
;; For comment lines ;; For comment lines
(define-peg-pattern C_SPACE none (or " " "\t")) (define-peg-pattern C_SPACE none (or " " "\t"))
(define-peg-pattern C_COMMENT none (and "#" (* peg-any))) (define-peg-pattern C_COMMENT none (and "#" (* peg-any)))
(define-peg-pattern COMMENT none (or C_COMMENT (define-peg-pattern COMMENT none (or C_COMMENT
(and (+ C_SPACE) (not-followed-by peg-any)))) (and (+ C_SPACE) (not-followed-by peg-any))))
(define (parse-line line) (define (parse-line line)
"FIXME-DOCS"
(write (peg:tree (match-pattern INCLUDE line))) (write (peg:tree (match-pattern INCLUDE line)))
(newline) (newline)
(write (peg:tree (match-pattern COMMENT line))) (write (peg:tree (match-pattern COMMENT line)))
@ -90,96 +99,101 @@
(else (else
(format #t "UNKNOWN: ~S~%" line)))) (format #t "UNKNOWN: ~S~%" line))))
(define (line-is-include? line) (define (line-is-include? line)
"FIXME-DOCS"
(and (> (string-length line) 8) (and (> (string-length line) 8)
(string= line "include " 0 8))) (string= line "include " 0 8)))
(define (line-is-comment? line) (define (line-is-comment? line)
"FIXME-DOCS"
(or (string-null? (string-trim-both line char-set:whitespace)) (or (string-null? (string-trim-both line char-set:whitespace))
(char=? (string-ref line 0) #\#))) (char=? (string-ref line 0) #\#)))
(define (line-is-macro? line) (define (line-is-macro? line)
"FIXME-DOCS"
(let ((len (string-length line))) (let ((len (string-length line)))
(let loop ((i 0)) (let loop ((i 0))
(if (>= i len) (if (>= i len)
#f #f
;; else ;; else
(let ((c (string-ref line i))) (let ((c (string-ref line i)))
(cond (cond
((and (zero? i) ((and (zero? i)
(not (char-is-pcs? c))) (not (char-is-pcs? c)))
#f) #f)
((and (not (zero? i)) ((and (not (zero? i))
(char=? #\= c)) (char=? #\= c))
#t) #t)
((not (char-is-pcs-or-space? c)) ((not (char-is-pcs-or-space? c))
#f) #f)
(else (else
(loop (+ i 1))))))))) (loop (+ i 1)))))))))
(define (line-is-special-target? line) (define (line-is-special-target? line)
"FIXME-DOCS"
(or (and (>= (string-length line) 8) (or (and (>= (string-length line) 8)
(string= line ".DEFAULT" 0 8)) (string= line ".DEFAULT" 0 8))
(and (>= (string-length line) 8) (and (>= (string-length line) 8)
(string= line ".IGNORE" 0 7)) (string= line ".IGNORE" 0 7))
(and (>= (string-length line) 6) (and (>= (string-length line) 6)
(string= line ".POSIX")) (string= line ".POSIX"))
(and (>= (string-length line) 9) (and (>= (string-length line) 9)
(string= line ".PRECIOUS" 0 9)) (string= line ".PRECIOUS" 0 9))
(and (>= (string-length line) 9) (and (>= (string-length line) 9)
(string= line ".SCCS_GET" 0 9)) (string= line ".SCCS_GET" 0 9))
(and (>= (string-length line) 7) (and (>= (string-length line) 7)
(string= line ".SILENT" 0 7)))) (string= line ".SILENT" 0 7))))
(define (line-is-rule? line) (define (line-is-rule? line)
"FIXME-DOCS"
(let ((len (string-length line))) (let ((len (string-length line)))
(let loop ((i 0)) (let loop ((i 0))
(if (>= i len) (if (>= i len)
#f #f
;; else ;; else
(let ((c (string-ref line i))) (let ((c (string-ref line i)))
(cond (cond
((and (zero? i) ((and (zero? i)
(not (char-is-pcs? c))) (not (char-is-pcs? c)))
#f) #f)
((and (not (zero? i)) ((and (not (zero? i))
(char=? #\: c)) (char=? #\: c))
#t) #t)
((not (char-is-pcs-or-space? c)) ((not (char-is-pcs-or-space? c))
#f) #f)
(else (else
(loop (+ i 1))))))))) (loop (+ i 1)))))))))
(define (line-is-inference-rule? line) (define (line-is-inference-rule? line)
"FIXME-DOCS"
(let ((len (string-length line))) (let ((len (string-length line)))
(let loop ((i 0) (let loop ((i 0)
(dot-count 0)) (dot-count 0))
(if (>= i len) (if (>= i len)
#f #f
;; else ;; else
(let ((c (string-ref line i))) (let ((c (string-ref line i)))
(cond (cond
((and (zero? i) ((and (zero? i)
(not (char=? #\. c))) (not (char=? #\. c)))
#f) #f)
((and (not (zero? i)) ((and (not (zero? i))
(char=? #\: c)) (char=? #\: c))
(if (or (= dot-count 1) (if (or (= dot-count 1)
(= dot-count 2)) (= dot-count 2))
#t #t
#f)) #f))
((not (char-is-pcs? c)) ((not (char-is-pcs? c))
#f) #f)
(else (else
(loop (+ i 1) (loop (+ i 1)
(+ dot-count (+ dot-count
(if (char=? c #\.) (if (char=? c #\.)
1 1
0)))))))))) 0))))))))))
(define (char-is-pcs? c) (define (char-is-pcs? c)
"FIXME-DOCS"
(or (and (char<=? #\a c) (char>=? #\z c)) (or (and (char<=? #\a c) (char>=? #\z c))
(and (char<=? #\A c) (char>=? #\Z c)) (and (char<=? #\A c) (char>=? #\Z c))
(and (char<=? #\0 c) (char>=? #\9 c)) (and (char<=? #\0 c) (char>=? #\9 c))
@ -187,6 +201,8 @@
(char=? #\_ c))) (char=? #\_ c)))
(define (char-is-pcs-or-space? c) (define (char-is-pcs-or-space? c)
"FIXME-DOCS"
(or (char-is-pcs? c) (or (char-is-pcs? c)
(char=? #\space c))) (char=? #\space c)))
;;; parser.scm ends here

541
src/potato/rules.scm
View File

@ -24,42 +24,44 @@
#:use-module (potato makevars) #:use-module (potato makevars)
#:use-module (potato text) #:use-module (potato text)
#:export(<target-rule> #:export(<target-rule>
<suffix-rule> <suffix-rule>
<node> <node>
%target-rules %target-rules
%suffix-rules %suffix-rules
initialize-rules initialize-rules
first-target-rule-name first-target-rule-name
install-alternate-system-driver install-alternate-system-driver
target-rule : target-rule :
suffix-rule -> suffix-rule ->
target-name $@ target-name $@
newer-prerequisites $? $$? newer-prerequisites $? $$?
primary-prerequisite $< primary-prerequisite $<
target-basename $* target-basename $*
prerequisites $^ $$^ prerequisites $^ $$^
build build
string-compose ~ string-compose ~
silent-compose ~@ silent-compose ~@
always-execute-compose ~+ always-execute-compose ~+
ignore-error-compose ~- ignore-error-compose ~-))
))
;;; Commentary:
;;;
;;; Dedicated to logic processing of rules/tasks
;;;
;;; Code:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; FIXME-QA(Krey): Should be re-structured so that the function that are just making aliases to procedures have their own section for easier navigation
;; GLOBALS ;; FIXME-QA/PROD(Krey): Doesn't seem to have a robust code and is using lot of functions that have potential for infinite loops, should be considered prior to deployment into a production environment
(define %ignore-errors? #f)
(define %continue-on-error? #f)
(define %no-execution? #f)
(define %verbosity 2)
(define %ascii? #f)
(define %top-level-targets '())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPER FUNCTIONS
;;; GLOBALS
(define %ignore-errors? #f) ;; FIXME-QA/DOCS(Krey): What is this variable used for?
(define %continue-on-error? #f) ;; FIXME-QA/DOCS(Krey): What is this variable used for?
(define %no-execution? #f) ;; FIXME-QA/DOCS(Krey): What is this variable used for?
(define %verbosity 2) ;; FIXME-QA/DOCS(Krey): What is this variable used for?
(define %ascii? #f) ;; FIXME-QA/DOCS(Krey): What is this variable used for?
(define %top-level-targets '()) ;; FIXME-QA/DOCS(Krey): What is this variable used for?
;;; HELPER FUNCTIONS
(define (basename str) (define (basename str)
"Strip off the '.ext' part of a filename string." "Strip off the '.ext' part of a filename string."
(unless (string? str) (unless (string? str)
@ -67,71 +69,72 @@
(let ((idx (string-index-right str #\.))) (let ((idx (string-index-right str #\.)))
(if idx (if idx
(substring str 0 idx) (substring str 0 idx)
str))) str)))
(define (base-compose . args) (define (base-compose . args)
"Returns a lambda that appends args together as a string, "Returns a lambda that appends args together as a string, adding intermediate spaces. If an arg is a procedure, it is evaluated."
adding intermediate spaces. If an arg is a procedure,
it is evaluated."
(lambda () (lambda ()
;; Loop over all the args, appending them together as a ;; Loop over all the args, appending them together as a string. Try to be smart about the types of args.
;; string. Try to be smart about the types of args.
(let loop ((args args) (let loop ((args args)
(result "")) (result ""))
(cond (cond
((null? args) ((null? args)
result) result)
(else (else
(let ((arg (car args)) (let ((arg (car args))
(effective-arg #f)) (effective-arg #f))
(cond (cond
((procedure? arg) ((procedure? arg)
(set! effective-arg (arg)) (set! effective-arg (arg))
(unless (string? effective-arg) (unless (string? effective-arg)
(bad-proc-output "~" arg))) (bad-proc-output "~" arg)))
((string? arg) ((string? arg)
(set! effective-arg arg)) (set! effective-arg arg))
(else (else
;; Not a string or procedure? ;; NOTE(spk121): Not a string or procedure? Let's just write it, I guess. YOLO!
;; Let's just write it, I guess. YOLO! (set! effective-arg
(set! effective-arg (format #f "~a" arg))))
(format #f "~a" arg))))
;; Loop, only adding spaces as necessary ;; Loop, only adding spaces as necessary
(let ((need-a-space? (let ((need-a-space?
(and (not (string-null? result)) (and (not (string-null? result))
(not (string-null? effective-arg))))) (not (string-null? effective-arg)))))
(loop (loop
(cdr args) (cdr args)
(string-append (string-append
result result
(if need-a-space? " " "") (if need-a-space? " " "")
effective-arg))))))))) effective-arg)))))))))
(define (string-compose . args) (define (string-compose . args)
"FIXME-DOCS"
(cons 'default (apply base-compose args))) (cons 'default (apply base-compose args)))
(define ~ string-compose) (define ~ string-compose)
(define (ignore-error-compose . args) (define (ignore-error-compose . args)
"FIXME-DOCS"
(cons 'ignore-error (apply base-compose args))) (cons 'ignore-error (apply base-compose args)))
(define ~- ignore-error-compose) (define ~- ignore-error-compose)
(define (silent-compose . args) (define (silent-compose . args)
"FIXME-DOCS"
(cons 'silent (apply base-compose args))) (cons 'silent (apply base-compose args)))
(define ~@ silent-compose) (define ~@ silent-compose)
(define (always-execute-compose . args) (define (always-execute-compose . args)
"FIXME-DOCS"
(cons 'always-execute (apply base-compose args))) (cons 'always-execute (apply base-compose args)))
(define ~+ always-execute-compose) (define ~+ always-execute-compose)
(define (regular-file? filename) (define (regular-file? filename)
"FIXME-DOCS"
(unless (string? filename) (unless (string? filename)
(scm-error 'wrong-type-arg "regular-file?" "Not a string: ~S" (list filename) #f)) (scm-error 'wrong-type-arg "regular-file?" "Not a string: ~S" (list filename) #f))
@ -139,6 +142,7 @@ it is evaluated."
(eq? (stat:type st) 'regular))) (eq? (stat:type st) 'regular)))
(define (compute-mtime filename) (define (compute-mtime filename)
"FIXME-DOCS"
(unless (string? filename) (unless (string? filename)
(scm-error 'wrong-type-arg "regular-file?" "Not a string: ~S" (list filename) #f)) (scm-error 'wrong-type-arg "regular-file?" "Not a string: ~S" (list filename) #f))
@ -146,19 +150,18 @@ it is evaluated."
(+ (* 1000000000 (stat:mtime st)) (+ (* 1000000000 (stat:mtime st))
(stat:mtimensec st)))) (stat:mtimensec st))))
;; FIXME-DOCS/QA(Krey): What is this doing?
(define %system-proc system) (define %system-proc system)
(define (install-alternate-system-driver proc) (define (install-alternate-system-driver proc)
"Give a procure to use rather than the standard 'system' procedure, "Give a procure to use rather than the standard 'system' procedure, installs it as the system driver. Returns the old system driver."
installs it as the system driver. Returns the old system driver."
(unless (procedure? proc) (unless (procedure? proc)
(scm-error 'wrong-type-arg "install-alternate-system-driver" "Not a procedure: ~S" (list proc) #f)) (scm-error 'wrong-type-arg "install-alternate-system-driver" "Not a procedure: ~S" (list proc) #f))
(let ((old-proc %system-proc)) (let ((old-proc %system-proc))
(set! %system-proc proc) (set! %system-proc proc)
old-proc)) old-proc))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; TARGET STRUCT AND METHODS
;; TARGET STRUCT AND METHODS
(define-record-type <target-rule> (define-record-type <target-rule>
(make-target-rule name prerequisites recipes priority) (make-target-rule name prerequisites recipes priority)
@ -167,13 +170,13 @@ installs it as the system driver. Returns the old system driver."
(name target-rule-get-name target-rule-set-name!) (name target-rule-get-name target-rule-set-name!)
;; A list of filenames and/or phony targets that have target rules ;; A list of filenames and/or phony targets that have target rules
(prerequisites target-rule-get-prerequisites (prerequisites target-rule-get-prerequisites
target-rule-set-prerequisites!) target-rule-set-prerequisites!)
;; A list of strings or procedures ;; A list of strings or procedures
(recipes target-rule-get-recipes (recipes target-rule-get-recipes
target-rule-set-recipes!) target-rule-set-recipes!)
;; 1 = script-defined. 2 = built-in ;; 1 = script-defined. 2 = built-in
(priority target-rule-get-priority (priority target-rule-get-priority
target-rule-set-priority!)) target-rule-set-priority!))
;; List of all target rules in order of importance ;; List of all target rules in order of importance
(define %target-rules '()) (define %target-rules '())
@ -183,23 +186,22 @@ installs it as the system driver. Returns the old system driver."
(when (>= %verbosity 3) (when (>= %verbosity 3)
(if (null? prerequisites) (if (null? prerequisites)
(format #t "Target rule: ~a~A~a~%~!" (lquo) name (rquo)) (format #t "Target rule: ~a~A~a~%~!" (lquo) name (rquo))
(format #t "Target rule: ~a~A~a ~A ~A~%~!" (lquo) name (rquo) (left-arrow) prerequisites))) (format #t "Target rule: ~a~A~a ~A ~A~%~!" (lquo) name (rquo) (left-arrow) prerequisites)))
;; Empty recipes is shorthand for a recipe that always passes. ;; Empty recipes is shorthand for a recipe that always passes.
(when (null? recipes) (when (null? recipes)
(set! recipes (list #t))) (set! recipes (list #t)))
;; If any recipes are raw strings, we need to make them into ;; NOTE(spk121): If any recipes are raw strings, we need to make them into `(cons 'default string)`
;; (cons 'default string)
(let ((recipes2 (let ((recipes2
(map (lambda (recipe) (map (lambda (recipe)
(cond (cond
((pair? recipe) ((pair? recipe)
recipe) recipe)
(else (else
(cons 'default recipe)))) (cons 'default recipe))))
recipes))) recipes)))
(let ((rule (make-target-rule name prerequisites recipes2 1))) (let ((rule (make-target-rule name prerequisites recipes2 1)))
;; Add to %target-rules ;; Add to %target-rules
@ -214,24 +216,23 @@ installs it as the system driver. Returns the old system driver."
;; else ;; else
(target-rule-get-name (last %target-rules)))) (target-rule-get-name (last %target-rules))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; SUFFIX STRUCT AND METHODS
;; SUFFIX STRUCT AND METHODS
(define-record-type <suffix-rule> (define-record-type <suffix-rule>
(make-suffix-rule source-suffix target-suffix recipes priority) (make-suffix-rule source-suffix target-suffix recipes priority)
suffix-rule? suffix-rule?
;; A string, usually like ".c". Or a string->string proc. ;; A string, usually like ".c". Or a string->string proc.
(source-suffix suffix-rule-get-source (source-suffix suffix-rule-get-source
suffix-rule-set-source) suffix-rule-set-source)
;; A string, usually like ".o". Or a string->bool proc. ;; A string, usually like ".o". Or a string->bool proc.
(target-suffix suffix-rule-get-target (target-suffix suffix-rule-get-target
suffix-rule-set-suffix!) suffix-rule-set-suffix!)
;; A list of strings or procedures ;; A list of strings or procedures
(recipes suffix-rule-get-recipes (recipes suffix-rule-get-recipes
suffix-rule-set-recipes!) suffix-rule-set-recipes!)
;; 1 = script-defined. 2 = built-in ;; 1 = script-defined. 2 = built-in
(priority suffix-rule-get-priority (priority suffix-rule-get-priority
suffix-rule-set-priority!)) suffix-rule-set-priority!))
;; The list of all registered suffix rules in order of importance ;; The list of all registered suffix rules in order of importance
(define %suffix-rules '()) (define %suffix-rules '())
@ -239,21 +240,20 @@ installs it as the system driver. Returns the old system driver."
(define (suffix-rule source target . recipes) (define (suffix-rule source target . recipes)
"Register a suffix rule" "Register a suffix rule"
;; FIXME: Typecheck ;; FIXME(spk121): Typecheck
(when (>= %verbosity 3) (when (>= %verbosity 3)
(format #t "Suffix rule: ~a~A~a ~A ~a~A~a~%~!" (format #t "Suffix rule: ~a~A~a ~A ~a~A~a~%~!"
(lquo) source (rquo) (right-arrow) (lquo) target (rquo))) (lquo) source (rquo) (right-arrow) (lquo) target (rquo)))
;; If any recipes are raw strings, we need to make them into ;; NOTE(spk121): If any recipes are raw strings, we need to make them into `(cons 'default string)`
;; (cons 'default string)
(let ((recipes2 (let ((recipes2
(map (lambda (recipe) (map (lambda (recipe)
(cond (cond
((pair? recipe) ((pair? recipe)
recipe) recipe)
(else (else
(cons 'default recipe)))) (cons 'default recipe))))
recipes))) recipes)))
(let ((rule (make-suffix-rule source target recipes2 1))) (let ((rule (make-suffix-rule source target recipes2 1)))
(set! %suffix-rules (cons rule %suffix-rules))))) (set! %suffix-rules (cons rule %suffix-rules)))))
@ -261,8 +261,7 @@ installs it as the system driver. Returns the old system driver."
;; Alias ;; Alias
(define -> suffix-rule) (define -> suffix-rule)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; NODE STRUCT AND METHODS
;; NODE STRUCT AND METHODS
(define-record-type <node> (define-record-type <node>
(make-node name parent status) (make-node name parent status)
@ -282,88 +281,102 @@ installs it as the system driver. Returns the old system driver."
(rule-type node-get-rule-type node-set-rule-type!) (rule-type node-get-rule-type node-set-rule-type!)
;; A list of rules ;; A list of rules
(rules node-get-rules node-set-rules!) (rules node-get-rules node-set-rules!)
(children node-get-children node-set-children!) (children node-get-children node-set-children!))
)
(define (using-target-rule? node) (define (using-target-rule? node)
"FIXME-DOCS"
(eq? 'target (node-get-rule-type node))) (eq? 'target (node-get-rule-type node)))
(define (using-suffix-rules? node) (define (using-suffix-rules? node)
"FIXME-DOCS"
(eq? 'suffix (node-get-rule-type node))) (eq? 'suffix (node-get-rule-type node)))
(define (using-default-rule? node) (define (using-default-rule? node)
"FIXME-DOCS"
(eq? 'default (node-get-rule-type node))) (eq? 'default (node-get-rule-type node)))
(define (set-fail! node) (define (set-fail! node)
"FIXME-DOCS"
(node-set-status! node 'fail)) (node-set-status! node 'fail))
(define (set-pass! node) (define (set-pass! node)
"FIXME-DOCS"
(node-set-status! node 'pass)) (node-set-status! node 'pass))
(define (failed? node) (define (failed? node)
"FIXME-DOCS"
(eqv? (node-get-status node) 'fail)) (eqv? (node-get-status node) 'fail))
(define (passed? node) (define (passed? node)
"FIXME-DOCS"
(eqv? (node-get-status node) 'pass)) (eqv? (node-get-status node) 'pass))
(define (leaf-node? node) (define (leaf-node? node)
"FIXME-DOCS"
(null? (node-get-children node))) (null? (node-get-children node)))
(define (undetermined? node) (define (undetermined? node)
"FIXME-DOCS"
(eq? (node-get-status node) 'undetermined)) (eq? (node-get-status node) 'undetermined))
(define (any-child-has-passed? node) (define (any-child-has-passed? node)
"FIXME-DOCS"
(unless (node? node) (unless (node? node)
(scm-error 'wrong-type-arg "any-child-has-passed?" "Not a node: ~S" (list node) #f)) (scm-error 'wrong-type-arg "any-child-has-passed?" "Not a node: ~S" (list node) #f))
(when (null? (node-get-children node)) (when (null? (node-get-children node))
(scm-error 'misc-error "any-child-has-passed?" "Node ~a has no children" (scm-error 'misc-error "any-child-has-passed?" "Node ~a has no children"
(list (node-get-name node)) #t)) (list (node-get-name node)) #t))
(let ((children (node-get-children node))) (let ((children (node-get-children node)))
(any passed? children))) (any passed? children)))
(define (every-child-has-passed? node) (define (every-child-has-passed? node)
"FIXME-DOCS"
(unless (node? node) (unless (node? node)
(scm-error 'wrong-type-arg "every-child-has-passed?" "Not a node: ~S" (list node) #f)) (scm-error 'wrong-type-arg "every-child-has-passed?" "Not a node: ~S" (list node) #f))
(when (null? (node-get-children node)) (when (null? (node-get-children node))
(scm-error 'misc-error "every-child-has-passed?" "Node ~a has no children" (scm-error 'misc-error "every-child-has-passed?" "Node ~a has no children"
(list (node-get-name node)) #t)) (list (node-get-name node)) #t))
(let ((children (node-get-children node))) (let ((children (node-get-children node)))
(every passed? children))) (every passed? children)))
(define (any-child-has-failed? node) (define (any-child-has-failed? node)
"FIXME-DOCS"
(unless (node? node) (unless (node? node)
(scm-error 'wrong-type-arg "any-child-has-failed?" "Not a node: ~S" (list node) #f)) (scm-error 'wrong-type-arg "any-child-has-failed?" "Not a node: ~S" (list node) #f))
(when (null? (node-get-children node)) (when (null? (node-get-children node))
(scm-error 'misc-error "any-child-has-failed?" "Node ~a has no children" (scm-error 'misc-error "any-child-has-failed?" "Node ~a has no children"
(list (node-get-name node)) #t)) (list (node-get-name node)) #t))
(let ((children (node-get-children node))) (let ((children (node-get-children node)))
(any failed? children))) (any failed? children)))
(define (every-child-has-failed? node) (define (every-child-has-failed? node)
"FIXME-DOCS"
(unless (node? node) (unless (node? node)
(scm-error 'wrong-type-arg "every-child-has-failed?" "Not a node: ~S" (list node) #f)) (scm-error 'wrong-type-arg "every-child-has-failed?" "Not a node: ~S" (list node) #f))
(when (null? (node-get-children node)) (when (null? (node-get-children node))
(scm-error 'misc-error "every-child-has-failed?" "Node ~a has no children" (scm-error 'misc-error "every-child-has-failed?" "Node ~a has no children"
(list (node-get-name node)) #t)) (list (node-get-name node)) #t))
(let ((children (node-get-children node))) (let ((children (node-get-children node)))
(every failed? children))) (every failed? children)))
(define (children-complete? node) (define (children-complete? node)
"FIXME-DOCS"
(cond (cond
((leaf-node? node) ((leaf-node? node)
#t) #t)
((eqv? 'target (node-get-rule-type node)) ((eqv? 'target (node-get-rule-type node))
(or (every-child-has-passed? node) (or (every-child-has-passed? node)
(any-child-has-failed? node))) (any-child-has-failed? node)))
((eqv? 'suffix (node-get-rule-type node)) ((eqv? 'suffix (node-get-rule-type node))
(or (every-child-has-failed? node) (or (every-child-has-failed? node)
(any-child-has-passed? node))) (any-child-has-passed? node)))
(else (else
#f))) #f)))
(define (children-passed? node) (define (children-passed? node)
"FIXME-DOCS"
(cond (cond
((null? (node-get-children node)) ((null? (node-get-children node))
#t) #t)
@ -382,22 +395,25 @@ installs it as the system driver. Returns the old system driver."
#f) #f)
(else (else
(any (lambda (child) (any (lambda (child)
(if (eqv? (node-get-status child) 'undetermined) (if (eqv? (node-get-status child) 'undetermined)
child child
#f)) #f))
children))))) children)))))
(define (has-parent? node) (define (has-parent? node)
"FIXME-DOCS"
(if (node-get-parent node) (if (node-get-parent node)
#t #t
#f)) #f))
(define (has-children? node) (define (has-children? node)
"FIXME-DOCS"
(if (null? (node-get-children node)) (if (null? (node-get-children node))
#f #f
#t)) #t))
(define (get-parent node) (define (get-parent node)
"FIXME-DOCS"
(node-get-parent node)) (node-get-parent node))
(define (up-to-date? node) (define (up-to-date? node)
@ -406,38 +422,38 @@ installs it as the system driver. Returns the old system driver."
- all its children have mtimes - all its children have mtimes
- its mtime is older than the mtime of its children" - its mtime is older than the mtime of its children"
(let ((children (node-get-children node)) (let ((children (node-get-children node))
(parent-mtime (node-get-mtime node))) (parent-mtime (node-get-mtime node)))
(if (or (null? children) (not (integer? parent-mtime))) (if (or (null? children) (not (integer? parent-mtime)))
;; Targets without children are always rebuilt. ;; Targets without children are always rebuilt.
;; Targets without mtimes are always rebuilt. ;; Targets without mtimes are always rebuilt.
#f #f
(let ((children-mtime (map node-get-mtime children))) (let ((children-mtime (map node-get-mtime children)))
(if (every (lambda (child-mtime) (if (every (lambda (child-mtime)
(and (integer? child-mtime) (and (integer? child-mtime)
(>= parent-mtime child-mtime))) (>= parent-mtime child-mtime)))
children-mtime) children-mtime)
#t #t
#f))))) #f)))))
(define (node-depth node) (define (node-depth node)
"FIXME-DOCS"
(let loop ((depth 0) (let loop ((depth 0)
(cur node)) (cur node))
(if (has-parent? cur) (if (has-parent? cur)
(loop (1+ depth) (get-parent cur)) (loop (1+ depth) (get-parent cur))
;; ;;
depth))) depth)))
(define (node-depth-string node) (define (node-depth-string node)
(make-string (* 2 (node-depth node)) #\space)) (make-string (* 2 (node-depth node)) #\space))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; AUTOMATIC VARIABLES ;; AUTOMATIC VARIABLES
(define target-name 'unspecified) (define target-name 'unspecified) ;; FIXME-DOCS(Krey): What is this variable doing?
(define target-basename 'unspecified) (define target-basename 'unspecified) ;; FIXME-DOCS(Krey): What is this variable doing?
(define prerequisites '()) (define prerequisites '()) ;; FIXME-DOCS(Krey): What is this variable doing?
(define primary-prerequisite 'unspecified) (define primary-prerequisite 'unspecified) ;; FIXME-DOCS(Krey): What is this variable doing?
(define newer-prerequisites '()) (define newer-prerequisites '()) ;; FIXME-DOCS(Krey): What is this variable doing?
(define (string-append-with-spaces lst) (define (string-append-with-spaces lst)
"Appends the strings in lst, adding spaces in between." "Appends the strings in lst, adding spaces in between."
@ -446,10 +462,11 @@ installs it as the system driver. Returns the old system driver."
;; else ;; else
(fold (fold
(lambda (elem prev) (lambda (elem prev)
(string-append prev " " elem)) (string-append prev " " elem))
(car lst) (car lst)
(cdr lst)))) (cdr lst))))
;; Aliases
(define $@ (lambda () target-name)) (define $@ (lambda () target-name))
(define $* (lambda () target-basename)) (define $* (lambda () target-basename))
(define $< (lambda () primary-prerequisite)) (define $< (lambda () primary-prerequisite))
@ -459,56 +476,54 @@ installs it as the system driver. Returns the old system driver."
(define $^ (lambda () (string-append-with-spaces prerequisites))) (define $^ (lambda () (string-append-with-spaces prerequisites)))
(define (target-rule-prep-automatic-variables node rule) (define (target-rule-prep-automatic-variables node rule)
"FIXME-DOCS"
(set! target-name (node-get-name node)) (set! target-name (node-get-name node))
(set! target-basename (basename target-name)) (set! target-basename (basename target-name))
(set! prerequisites (target-rule-get-prerequisites rule)) (set! prerequisites (target-rule-get-prerequisites rule))
(set! primary-prerequisite (if (null? prerequisites) "" (car prerequisites))) (set! primary-prerequisite (if (null? prerequisites) "" (car prerequisites)))
(set! newer-prerequisites (set! newer-prerequisites
;; If this node doesn't have a real file attached, then all ;; If this node doesn't have a real file attached, then all prerequistes are "newer"
;; prerequistes are "newer".
(if (not (node-get-mtime node)) (if (not (node-get-mtime node))
prerequisites prerequisites
;; Prerequisites that have no mtime or a higher mtime are ;; Prerequisites that have no mtime or a higher mtime are "newer"
;; "newer". (filter-map
(filter-map (lambda (name)
(lambda (name) (cond
(cond ((and (file-exists? name)
((and (file-exists? name) (regular-file? name)
(regular-file? name) (>= (node-get-mtime node) (compute-mtime name)))
(>= (node-get-mtime node) (compute-mtime name))) name)
name) ((not (file-exists? name))
((not (file-exists? name)) name)
name) (else
(else #f)))
#f))) prerequisites))))
prerequisites))))
(define (suffix-rule-prep-automatic-variables node rule) (define (suffix-rule-prep-automatic-variables node rule)
"FIXME-DOCS"
(set! target-name (node-get-name node)) (set! target-name (node-get-name node))
(set! target-basename (basename target-name)) (set! target-basename (basename target-name))
(set! primary-prerequisite (string-append target-basename (suffix-rule-get-source rule))) (set! primary-prerequisite (string-append target-basename (suffix-rule-get-source rule)))
(set! prerequisites (list primary-prerequisite)) (set! prerequisites (list primary-prerequisite))
(set! newer-prerequisites (set! newer-prerequisites
;; If this node doesn't have a real file attached, then the ;; If this node doesn't have a real file attached, then the prerequisite is newer
;; prerequisite is newer.
(if (not (node-get-mtime node)) (if (not (node-get-mtime node))
(list primary-prerequisite) (list primary-prerequisite)
;; Prerequisites that have no mtime or a higher mtime are ;; Prerequisites that have no mtime or a higher mtime are "newer"
;; "newer". (cond
(cond ((and (file-exists? primary-prerequisite)
((and (file-exists? primary-prerequisite) (regular-file? primary-prerequisite)
(regular-file? primary-prerequisite) (> (node-get-mtime node) (compute-mtime primary-prerequisite)))
(> (node-get-mtime node) (compute-mtime primary-prerequisite))) (list primary-prerequisite))
(list primary-prerequisite)) (else
(else '())))))
'())))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; MIXED METHODS
;; MIXED METHODS ;;; requiring more than one of node, automatic variables, suffix rules and target rules
;; requiring more than one of node, automatic variables, suffix rules
;; and target rules
(define (add-builtins) (define (add-builtins)
"FIXME-DOCS"
;; FIXME(Krey): Commented out by the original author, figure out what we want to do with it
#| #|
(-> ".c" "" (-> ".c" ""
(~ ($ CC) ($ CFLAGS) ($ LDFLAGS) "-o" $@ $<)) (~ ($ CC) ($ CFLAGS) ($ LDFLAGS) "-o" $@ $<))
@ -539,163 +554,159 @@ installs it as the system driver. Returns the old system driver."
(~ ($ GUILD) "compile" ($ GFLAGS) $<))) (~ ($ GUILD) "compile" ($ GFLAGS) $<)))
(define (run-target-rule! node) (define (run-target-rule! node)
"Runs the (singular) target rule associated with this node." "Runs the (singular) target rule associated with this node"
(unless (node? node) (unless (node? node)
(scm-error 'wrong-type-arg "run-target-rule!" "Not a node: ~S" (list node) #f)) (scm-error 'wrong-type-arg "run-target-rule!" "Not a node: ~S" (list node) #f))
(let ((rules (node-get-rules node))) (let ((rules (node-get-rules node)))
(when (null? rules) (when (null? rules)
(scm-error 'misc-error "run-target-rule!" "Node ~S has no target rules" (scm-error 'misc-error "run-target-rule!" "Node ~S has no target rules"
(list (node-get-name node)) #f)) (list (node-get-name node)) #f))
(unless (= 1 (length rules)) (unless (= 1 (length rules))
(scm-error 'misc-error "run-target-rule!" "Node ~S has ~A target rules" (scm-error 'misc-error "run-target-rule!" "Node ~S has ~A target rules"
(list (node-get-name node) (length rules)) #f)) (list (node-get-name node) (length rules)) #f))
(unless (or (leaf-node? node) (every-child-has-passed? node)) (unless (or (leaf-node? node) (every-child-has-passed? node))
(scm-error 'misc-error "run-target-rule!" "Node ~S: not all children have passed" (scm-error 'misc-error "run-target-rule!" "Node ~S: not all children have passed"
(list (node-get-name node)) #f)) (list (node-get-name node)) #f))
(let ((rule (car rules))) (let ((rule (car rules)))
(target-rule-prep-automatic-variables node rule) (target-rule-prep-automatic-variables node rule)
(run-recipes! node (target-rule-get-recipes rule)) (run-recipes! node (target-rule-get-recipes rule))
(let ((status (node-get-status node))) (let ((status (node-get-status node)))
status)))) status))))
(define (run-suffix-rules! node) (define (run-suffix-rules! node)
"Runs the one-or-more suffix rules associated with this node. It "Runs the one-or-more suffix rules associated with this node. It runs them one-by-one, quitting on the first success"
runs them one-by-one, quitting on the first success."
(unless (node? node) (unless (node? node)
(scm-error 'wrong-type'arg "run-suffix-rules!" "Not a node: ~S" (list node) #f)) (scm-error 'wrong-type'arg "run-suffix-rules!" "Not a node: ~S" (list node) #f))
(let ((rules (node-get-rules node)) (let ((rules (node-get-rules node))
(children (node-get-children node))) (children (node-get-children node)))
(when (null? rules) (when (null? rules)
(scm-error 'misc-error "run-suffix-rules!" "Node ~S has no rules" (scm-error 'misc-error "run-suffix-rules!" "Node ~S has no rules"
(list (node-get-name node)) #f)) (list (node-get-name node)) #f))
(when (null? children) (when (null? children)
(scm-error 'misc-error "run-suffix-rule!" "Node ~S has no children" (scm-error 'misc-error "run-suffix-rule!" "Node ~S has no children"
(list (node-get-name node)) #f)) (list (node-get-name node)) #f))
(unless (any-child-has-passed? node) (unless (any-child-has-passed? node)
(scm-error 'misc-error "run-suffix-rule!" "Node ~S: not child has passed" (scm-error 'misc-error "run-suffix-rule!" "Node ~S: not child has passed"
(list (node-get-name node)) #f)) (list (node-get-name node)) #f))
(unless (= (length rules) (length children)) (unless (= (length rules) (length children))
(scm-error 'misc-error "run-suffix-rule!" "Node ~S: must have as many children as rules" (scm-error 'misc-error "run-suffix-rule!" "Node ~S: must have as many children as rules"
(list (node-get-name node)) #f)) (list (node-get-name node)) #f))
(let ((i 0) (let ((i 0)
(len (length children))) (len (length children)))
(while (< i len) (while (< i len)
(let ((rule (list-ref rules i)) (let ((rule (list-ref rules i))
(child (list-ref children i))) (child (list-ref children i)))
(when (passed? child) (when (passed? child)
(when (>= %verbosity 3) (when (>= %verbosity 3)
(format #t "~A: attempting to make using ~a~A~a ~a ~a~A~a rule" (format #t "~A: attempting to make using ~a~A~a ~a ~a~A~a rule"
(node-get-name node) (node-get-name node)
(lquo) (suffix-rule-get-source rule) (rquo) (lquo) (suffix-rule-get-source rule) (rquo)
(right-arrow) (right-arrow)
(lquo) (suffix-rule-get-target rule) (rquo))) (lquo) (suffix-rule-get-target rule) (rquo)))
(suffix-rule-prep-automatic-variables node rule) (suffix-rule-prep-automatic-variables node rule)
(run-recipes! node (suffix-rule-get-recipes rule))) (run-recipes! node (suffix-rule-get-recipes rule)))
(when (passed? node) (when (passed? node)
(break)) (break))
(set! i (1+ i))))) (set! i (1+ i)))))
(when (>= %verbosity 3) (when (>= %verbosity 3)
(if (passed? node) (if (passed? node)
(format #t "PASS: ~a~%~!" (node-get-name node)) (format #t "PASS: ~a~%~!" (node-get-name node))
(format #t "FAIL: ~a~%~!" (node-get-name node)))) (format #t "FAIL: ~a~%~!" (node-get-name node))))
(node-get-status node))) (node-get-status node)))
(define (run-recipes! node recipes) (define (run-recipes! node recipes)
"Runs the recipes on this node, one by one. Recipes are either "Runs the recipes on this node, one by one. Recipes are either strings, procedures that return strings, or generic procedures. If a
strings, procedures that return strings, or generic procedures. If a
failure condition happens, mark the node as having failed." failure condition happens, mark the node as having failed."
(unless (node? node) (unless (node? node)
(scm-error 'wrong-type-arg "run-recipes!" "Not a node: ~S" (list node) #f)) (scm-error 'wrong-type-arg "run-recipes!" "Not a node: ~S" (list node) #f))
;; FIXME(Krey): Commented out by the original author, figure out what we want to do with it
;;(unless (and (list? recipes) (not (null? recipes))) ;;(unless (and (list? recipes) (not (null? recipes)))
;; (scm-error 'wrong-type-arg "run-recipes!" "Not a non-null list: ~S" (list recipes) #f)) ;; (scm-error 'wrong-type-arg "run-recipes!" "Not a non-null list: ~S" (list recipes) #f))
(let ((i 0) (let ((i 0)
(len (length recipes))) (len (length recipes)))
(while (< i len) (while (< i len)
(let* ((opt/recipe (list-ref recipes i)) (let* ((opt/recipe (list-ref recipes i))
(opt (car opt/recipe)) (opt (car opt/recipe))
(recipe (cdr opt/recipe))) (recipe (cdr opt/recipe)))
;; Recipes are either ;; Recipes are either
;; - strings to pass to system ;; - strings to pass to system
;; - procedures that return a string which is passed ;; - procedures that return a string which is passed to system
;; to system ;; - procedures (that don't return a string) that are executed that pass unless they return #f
;; - procedures (that don't return a string) that are executed
;; that pass unless they return #f
;; OPT is one of 'default, 'ignore, 'silent
(cond ;; OPT is one of 'default, 'ignore, 'silent
((eq? recipe #t)
(set-pass! node))
((eq? recipe #f) (cond
(set-fail! node)) ((eq? recipe #t)
(set-pass! node))
((string? recipe) ((eq? recipe #f)
(when (= %verbosity 1) (set-fail! node))
(format #t "~a~%~!" (node-get-name node)))
(when (or (and (= %verbosity 2) (not (eq? 'silent opt)))
(= %verbosity 3))
(format #t "~A~%~!" recipe))
(let ((retval (%system-proc recipe)))
(if (zero? retval)
(set-pass! node)
(set-fail! node))))
((procedure? recipe) ((string? recipe)
(let ((retval (recipe))) (when (= %verbosity 1)
(cond (format #t "~a~%~!" (node-get-name node)))
;; If a procedure returns a string, that string gets (when (or (and (= %verbosity 2) (not (eq? 'silent opt)))
;; processed by system. (= %verbosity 3))
((string? retval) (format #t "~A~%~!" recipe))
(when (= %verbosity 1) (let ((retval (%system-proc recipe)))
(format #t "~a~%~!" (node-get-name node))) (if (zero? retval)
(when (or (and (= %verbosity 2) (not (eq? 'silent opt))) (set-pass! node)
(= %verbosity 3)) (set-fail! node))))
(format #t "~A~%~!" retval))
(let ((retval2 (%system-proc retval)))
(if (zero? retval2)
(set-pass! node)
(set-fail! node))))
;; A scheme procedure recipe that returns false. ((procedure? recipe)
((eqv? retval #f) (let ((retval (recipe)))
(set-fail! node)) (cond
;; If a procedure returns a string, that string gets processed by system
((string? retval)
(when (= %verbosity 1)
(format #t "~a~%~!" (node-get-name node)))
(when (or (and (= %verbosity 2) (not (eq? 'silent opt)))
(= %verbosity 3))
(format #t "~A~%~!" retval))
(let ((retval2 (%system-proc retval)))
(if (zero? retval2)
(set-pass! node)
(set-fail! node))))
(else ;; A scheme procedure recipe that returns false.
;; Otherwise, this was a procedure that didn't return ((eqv? retval #f)
;; #f or a string, so it gets a pass. (set-fail! node))
(set-pass! node)))))
(else (else
;; Can't be converted to a viable string or procedure ;; Otherwise, this was a procedure that didn't return #f or a string, so it gets a pass.
(scm-error 'misc-error "run-recipes!" "bad recipe: ~S" (list recipe) #f))) (set-pass! node)))))
(when (failed? node) (break)) (else
(set! i (1+ i)))) ;; Can't be converted to a viable string or procedure
(scm-error 'misc-error "run-recipes!" "bad recipe: ~S" (list recipe) #f)))
(when (failed? node) (break))
(set! i (1+ i))))
(when (passed? node) (when (passed? node)
(let ((name (node-get-name node))) (let ((name (node-get-name node)))
(when (and (file-exists? name) (when (and (file-exists? name)
(regular-file? name)) (regular-file? name))
(node-set-mtime! node (compute-mtime name))))))) (node-set-mtime! node (compute-mtime name)))))))
(define (run-default-rule! node) (define (run-default-rule! node)
"The default rule if not other rule exists. It just passes if the "The default rule if not other rule exists. It just passes if the file exists"
file exists."
(let ((name (node-get-name node))) (let ((name (node-get-name node)))
(if (and (file-exists? name) (if (and (file-exists? name)
(regular-file? name)) (regular-file? name))
(begin (begin
(set-pass! node) (set-pass! node)
(node-set-mtime! node (compute-mtime name))) (node-set-mtime! node (compute-mtime name)))
;; else ;; else
(set-fail! node)))) (set-fail! node))))
;; Start at root ;; Start at root