Sync
Signed-off-by: Jacob Hrbek <kreyren@rixotstudio.cz>
This commit is contained in:
parent
ddb3640fb8
commit
6a8b09699e
GPG Key ID:
667F0DAFAF09BA2B
23
TAGS.org
Normal file
23
TAGS.org
Normal 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
|
||||
@ -38,16 +38,14 @@
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; DOCS
|
||||
;;; Backend code used for the parsing of non-guile makefiles
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define (read-line-handle-escaped-newline)
|
||||
"Reads a line of text from the current input port.
|
||||
|
||||
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.
|
||||
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.
|
||||
|
||||
It returns two values
|
||||
- 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)))))))
|
||||
|
||||
(define* (string-collapse-continuations str #:optional (squash-whitespace? #f))
|
||||
"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."
|
||||
"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."
|
||||
(let loop ((str str)
|
||||
(newline-index (string-rindex str #\newline)))
|
||||
(if (not newline-index)
|
||||
|
||||
@ -27,42 +27,45 @@
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; DOCS
|
||||
;;; Functionality to parse non-guile makefiles
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
;; A makefile can contain rules, macro definitions, include lines, and comments.
|
||||
|
||||
;; FIXME-DOCS(Krey)
|
||||
(define (parse filename)
|
||||
(with-input-from-file filename _eval #:guess-encoding #t))
|
||||
|
||||
;; DNM-SECURITY(Krey): Check very carefully
|
||||
;; FIXME-DOCS(Krey)
|
||||
(define (_eval)
|
||||
(let ((filenames #f)
|
||||
(ignoring #f)
|
||||
(commands '()))
|
||||
(ignoring #f)
|
||||
(commands '()))
|
||||
(while #t
|
||||
(receive (line nlines)
|
||||
(read-line-handle-escaped-newline)
|
||||
(cond
|
||||
((zero? nlines)
|
||||
(break))
|
||||
(read-line-handle-escaped-newline)
|
||||
(cond
|
||||
((zero? nlines)
|
||||
(break))
|
||||
|
||||
((string-starts-with? line #\tab)
|
||||
;; Shell-command lines
|
||||
(when filenames
|
||||
(when ignoring
|
||||
(continue))
|
||||
(set! commands (append commands (list line)))))
|
||||
((string-starts-with? line #\tab)
|
||||
;; Shell-command lines
|
||||
(when filenames
|
||||
(when ignoring
|
||||
(continue))
|
||||
(set! commands (append commands (list line)))))
|
||||
|
||||
(else
|
||||
(display
|
||||
(string-trim-both
|
||||
(string-remove-comments
|
||||
(string-collapse-continuations line #t))))
|
||||
(newline)))))))
|
||||
(else
|
||||
(display
|
||||
(string-trim-both
|
||||
(string-remove-comments
|
||||
(string-collapse-continuations line #t))))
|
||||
(newline)))))))
|
||||
|
||||
(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)))
|
||||
(cond
|
||||
((= i (string-length str))
|
||||
@ -75,54 +78,57 @@
|
||||
((char=? (string-ref str i) #\$)
|
||||
;; This begins a variable expansion reference.
|
||||
(let* ((openparen (false-if-exception (string-ref str (1+ i))))
|
||||
(closeparen (if (eqv? openparen #\()
|
||||
#\)
|
||||
(if (eqv? openparen #\{)
|
||||
#\}
|
||||
#f))))
|
||||
(if (not closeparen)
|
||||
(values i 'null)
|
||||
(closeparen (if (eqv? openparen #\()
|
||||
#\)
|
||||
(if (eqv? openparen #\{)
|
||||
#\}
|
||||
#f))))
|
||||
(if (not closeparen)
|
||||
(values i 'null)
|
||||
|
||||
;; else, skip over the matching closeparen
|
||||
(begin
|
||||
(let ((count 0))
|
||||
(while #t
|
||||
(set! i (1+ i))
|
||||
(when (char=? (string-ref str i) openparen)
|
||||
(set! count (1+ count)))
|
||||
(when (char=? (string-ref str i) closeparen)
|
||||
(set! count (1- count))
|
||||
(when (zero? count)
|
||||
(set! i (1+ i))
|
||||
(break)))))
|
||||
;; else, skip over the matching closeparen
|
||||
(begin
|
||||
(let ((count 0))
|
||||
(while #t
|
||||
(set! i (1+ i))
|
||||
(when (char=? (string-ref str i) openparen)
|
||||
(set! count (1+ count)))
|
||||
(when (char=? (string-ref str i) closeparen)
|
||||
(set! count (1- count))
|
||||
(when (zero? count)
|
||||
(set! i (1+ i))
|
||||
(break)))))
|
||||
|
||||
;; Any whitespace before the operator?
|
||||
(when (char-set-contains? char-set:blank (string-ref str i))
|
||||
(set! wspace #t)
|
||||
(set! i (string-next-token str i)))
|
||||
;; Any whitespace before the operator?
|
||||
(when (char-set-contains? char-set:blank (string-ref str i))
|
||||
(set! wspace #t)
|
||||
(set! i (string-next-token str i)))
|
||||
|
||||
(cond
|
||||
((eqv? (string-ref str i) #\=)
|
||||
(values (1+ i) 'recursive))
|
||||
((and (eqv? (string-ref str i) #\:)
|
||||
(eqv? (string-ref str (1+ i)) #\=))
|
||||
(values (+ i 2) 'simple))
|
||||
((and (eqv? (string-ref str i) #\+)
|
||||
(eqv? (string-ref str (1+ i)) #\=))
|
||||
(values (+ i 2) 'append))
|
||||
((and (eqv? (string-ref str i) #\?)
|
||||
(eqv? (string-ref str (1+ i)) #\=))
|
||||
(values (+ i 2) 'conditional))
|
||||
(else
|
||||
(values i 'null)))))))
|
||||
(cond
|
||||
((eqv? (string-ref str i) #\=)
|
||||
(values (1+ i) 'recursive))
|
||||
((and (eqv? (string-ref str i) #\:)
|
||||
(eqv? (string-ref str (1+ i)) #\=))
|
||||
(values (+ i 2) 'simple))
|
||||
((and (eqv? (string-ref str i) #\+)
|
||||
(eqv? (string-ref str (1+ i)) #\=))
|
||||
(values (+ i 2) 'append))
|
||||
((and (eqv? (string-ref str i) #\?)
|
||||
(eqv? (string-ref str (1+ i)) #\=))
|
||||
(values (+ i 2) 'conditional))
|
||||
(else
|
||||
(values i 'null)))))))
|
||||
(else
|
||||
(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)
|
||||
(let ((i (string-next-token line 0)))
|
||||
(if (= i (string-length line))
|
||||
#f
|
||||
;; else
|
||||
(while #t
|
||||
|
||||
#f
|
||||
;; else
|
||||
(while #t
|
||||
|#
|
||||
|
||||
;;; parse.scm ends here
|
||||
|
||||
@ -25,51 +25,60 @@
|
||||
#:use-module (potato text)
|
||||
#:export (parse))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; Core functionality of the parsed for non-guile makefiles
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
;; A makefile can contain rules, macro definitions, include lines,
|
||||
;; and comments.
|
||||
|
||||
(define (parse filename)
|
||||
"FIXME-DOCS"
|
||||
(with-input-from-file filename parse-input #:guess-encoding #t))
|
||||
|
||||
(define (last-char str)
|
||||
"FIXME-DOCS"
|
||||
(string-ref str (1- (string-length str))))
|
||||
|
||||
(define (parse-input)
|
||||
"FIXME-DOCS"
|
||||
(while #t
|
||||
(let loop ((line "")
|
||||
(str (read-line)))
|
||||
(str (read-line)))
|
||||
(cond
|
||||
((eof-object? str)
|
||||
(break))
|
||||
(break))
|
||||
((char=? (last-char str) #\\)
|
||||
(loop (string-append line str) (read-line)))
|
||||
(loop (string-append line str) (read-line)))
|
||||
(else
|
||||
(parse-line (string-append line str)))))))
|
||||
(parse-line (string-append line str)))))))
|
||||
|
||||
;; For include lines
|
||||
(define-peg-pattern I_TOK none "include")
|
||||
(define-peg-pattern I_SPACE none (or " " "\t"))
|
||||
(define-peg-pattern I_FILENAME_CHAR body (or (range #\a #\z)
|
||||
(range #\A #\Z)
|
||||
(range #\0 #\9)
|
||||
"_" "-" "."))
|
||||
(range #\A #\Z)
|
||||
(range #\0 #\9)
|
||||
"_" "-" "."))
|
||||
(define-peg-pattern I_FILENAME all (+ I_FILENAME_CHAR))
|
||||
(define-peg-pattern I_NL none "\n")
|
||||
(define-peg-pattern I_COMMENT none (and "#" (* peg-any)))
|
||||
(define-peg-pattern INCLUDE all (and I_TOK
|
||||
(+ (and (* I_SPACE)
|
||||
I_FILENAME))
|
||||
(* I_SPACE)
|
||||
(? I_COMMENT)))
|
||||
(+ (and (* I_SPACE)
|
||||
I_FILENAME))
|
||||
(* I_SPACE)
|
||||
(? I_COMMENT)))
|
||||
|
||||
;; For comment lines
|
||||
(define-peg-pattern C_SPACE none (or " " "\t"))
|
||||
(define-peg-pattern C_COMMENT none (and "#" (* peg-any)))
|
||||
(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)
|
||||
"FIXME-DOCS"
|
||||
(write (peg:tree (match-pattern INCLUDE line)))
|
||||
(newline)
|
||||
(write (peg:tree (match-pattern COMMENT line)))
|
||||
@ -90,96 +99,101 @@
|
||||
(else
|
||||
(format #t "UNKNOWN: ~S~%" line))))
|
||||
|
||||
|
||||
|
||||
(define (line-is-include? line)
|
||||
"FIXME-DOCS"
|
||||
(and (> (string-length line) 8)
|
||||
(string= line "include " 0 8)))
|
||||
|
||||
(define (line-is-comment? line)
|
||||
"FIXME-DOCS"
|
||||
(or (string-null? (string-trim-both line char-set:whitespace))
|
||||
(char=? (string-ref line 0) #\#)))
|
||||
|
||||
(define (line-is-macro? line)
|
||||
"FIXME-DOCS"
|
||||
(let ((len (string-length line)))
|
||||
(let loop ((i 0))
|
||||
(if (>= i len)
|
||||
#f
|
||||
;; else
|
||||
(let ((c (string-ref line i)))
|
||||
(cond
|
||||
((and (zero? i)
|
||||
(not (char-is-pcs? c)))
|
||||
#f)
|
||||
((and (not (zero? i))
|
||||
(char=? #\= c))
|
||||
#t)
|
||||
((not (char-is-pcs-or-space? c))
|
||||
#f)
|
||||
(else
|
||||
(loop (+ i 1)))))))))
|
||||
#f
|
||||
;; else
|
||||
(let ((c (string-ref line i)))
|
||||
(cond
|
||||
((and (zero? i)
|
||||
(not (char-is-pcs? c)))
|
||||
#f)
|
||||
((and (not (zero? i))
|
||||
(char=? #\= c))
|
||||
#t)
|
||||
((not (char-is-pcs-or-space? c))
|
||||
#f)
|
||||
(else
|
||||
(loop (+ i 1)))))))))
|
||||
|
||||
(define (line-is-special-target? line)
|
||||
"FIXME-DOCS"
|
||||
(or (and (>= (string-length line) 8)
|
||||
(string= line ".DEFAULT" 0 8))
|
||||
(string= line ".DEFAULT" 0 8))
|
||||
(and (>= (string-length line) 8)
|
||||
(string= line ".IGNORE" 0 7))
|
||||
(string= line ".IGNORE" 0 7))
|
||||
(and (>= (string-length line) 6)
|
||||
(string= line ".POSIX"))
|
||||
(string= line ".POSIX"))
|
||||
(and (>= (string-length line) 9)
|
||||
(string= line ".PRECIOUS" 0 9))
|
||||
(string= line ".PRECIOUS" 0 9))
|
||||
(and (>= (string-length line) 9)
|
||||
(string= line ".SCCS_GET" 0 9))
|
||||
(string= line ".SCCS_GET" 0 9))
|
||||
(and (>= (string-length line) 7)
|
||||
(string= line ".SILENT" 0 7))))
|
||||
(string= line ".SILENT" 0 7))))
|
||||
|
||||
(define (line-is-rule? line)
|
||||
"FIXME-DOCS"
|
||||
(let ((len (string-length line)))
|
||||
(let loop ((i 0))
|
||||
(if (>= i len)
|
||||
#f
|
||||
;; else
|
||||
(let ((c (string-ref line i)))
|
||||
(cond
|
||||
((and (zero? i)
|
||||
(not (char-is-pcs? c)))
|
||||
#f)
|
||||
((and (not (zero? i))
|
||||
(char=? #\: c))
|
||||
#t)
|
||||
((not (char-is-pcs-or-space? c))
|
||||
#f)
|
||||
(else
|
||||
(loop (+ i 1)))))))))
|
||||
#f
|
||||
;; else
|
||||
(let ((c (string-ref line i)))
|
||||
(cond
|
||||
((and (zero? i)
|
||||
(not (char-is-pcs? c)))
|
||||
#f)
|
||||
((and (not (zero? i))
|
||||
(char=? #\: c))
|
||||
#t)
|
||||
((not (char-is-pcs-or-space? c))
|
||||
#f)
|
||||
(else
|
||||
(loop (+ i 1)))))))))
|
||||
|
||||
(define (line-is-inference-rule? line)
|
||||
"FIXME-DOCS"
|
||||
(let ((len (string-length line)))
|
||||
(let loop ((i 0)
|
||||
(dot-count 0))
|
||||
(dot-count 0))
|
||||
(if (>= i len)
|
||||
#f
|
||||
;; else
|
||||
(let ((c (string-ref line i)))
|
||||
(cond
|
||||
((and (zero? i)
|
||||
(not (char=? #\. c)))
|
||||
#f)
|
||||
((and (not (zero? i))
|
||||
(char=? #\: c))
|
||||
(if (or (= dot-count 1)
|
||||
(= dot-count 2))
|
||||
#t
|
||||
#f))
|
||||
((not (char-is-pcs? c))
|
||||
#f)
|
||||
(else
|
||||
(loop (+ i 1)
|
||||
(+ dot-count
|
||||
(if (char=? c #\.)
|
||||
1
|
||||
0))))))))))
|
||||
#f
|
||||
;; else
|
||||
(let ((c (string-ref line i)))
|
||||
(cond
|
||||
((and (zero? i)
|
||||
(not (char=? #\. c)))
|
||||
#f)
|
||||
((and (not (zero? i))
|
||||
(char=? #\: c))
|
||||
(if (or (= dot-count 1)
|
||||
(= dot-count 2))
|
||||
#t
|
||||
#f))
|
||||
((not (char-is-pcs? c))
|
||||
#f)
|
||||
(else
|
||||
(loop (+ i 1)
|
||||
(+ dot-count
|
||||
(if (char=? c #\.)
|
||||
1
|
||||
0))))))))))
|
||||
|
||||
(define (char-is-pcs? c)
|
||||
"FIXME-DOCS"
|
||||
(or (and (char<=? #\a c) (char>=? #\z c))
|
||||
(and (char<=? #\A c) (char>=? #\Z c))
|
||||
(and (char<=? #\0 c) (char>=? #\9 c))
|
||||
@ -187,6 +201,8 @@
|
||||
(char=? #\_ c)))
|
||||
|
||||
(define (char-is-pcs-or-space? c)
|
||||
"FIXME-DOCS"
|
||||
(or (char-is-pcs? c)
|
||||
(char=? #\space c)))
|
||||
|
||||
;;; parser.scm ends here
|
||||
|
||||
@ -24,42 +24,44 @@
|
||||
#:use-module (potato makevars)
|
||||
#:use-module (potato text)
|
||||
#:export(<target-rule>
|
||||
<suffix-rule>
|
||||
<node>
|
||||
%target-rules
|
||||
%suffix-rules
|
||||
initialize-rules
|
||||
first-target-rule-name
|
||||
install-alternate-system-driver
|
||||
target-rule :
|
||||
suffix-rule ->
|
||||
target-name $@
|
||||
newer-prerequisites $? $$?
|
||||
primary-prerequisite $<
|
||||
target-basename $*
|
||||
prerequisites $^ $$^
|
||||
build
|
||||
string-compose ~
|
||||
silent-compose ~@
|
||||
always-execute-compose ~+
|
||||
ignore-error-compose ~-
|
||||
))
|
||||
<suffix-rule>
|
||||
<node>
|
||||
%target-rules
|
||||
%suffix-rules
|
||||
initialize-rules
|
||||
first-target-rule-name
|
||||
install-alternate-system-driver
|
||||
target-rule :
|
||||
suffix-rule ->
|
||||
target-name $@
|
||||
newer-prerequisites $? $$?
|
||||
primary-prerequisite $<
|
||||
target-basename $*
|
||||
prerequisites $^ $$^
|
||||
build
|
||||
string-compose ~
|
||||
silent-compose ~@
|
||||
always-execute-compose ~+
|
||||
ignore-error-compose ~-))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; Dedicated to logic processing of rules/tasks
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; GLOBALS
|
||||
|
||||
(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
|
||||
;; 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
|
||||
;; 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
|
||||
|
||||
;;; 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)
|
||||
"Strip off the '.ext' part of a filename string."
|
||||
(unless (string? str)
|
||||
@ -67,71 +69,72 @@
|
||||
|
||||
(let ((idx (string-index-right str #\.)))
|
||||
(if idx
|
||||
(substring str 0 idx)
|
||||
str)))
|
||||
(substring str 0 idx)
|
||||
str)))
|
||||
|
||||
(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."
|
||||
"Returns a lambda that appends args together as a string, adding intermediate spaces. If an arg is a procedure, it is evaluated."
|
||||
(lambda ()
|
||||
;; Loop over all the args, appending them together as a
|
||||
;; string. Try to be smart about the types of args.
|
||||
;; Loop over all the args, appending them together as a string. Try to be smart about the types of args.
|
||||
(let loop ((args args)
|
||||
(result ""))
|
||||
(result ""))
|
||||
(cond
|
||||
((null? args)
|
||||
result)
|
||||
result)
|
||||
(else
|
||||
(let ((arg (car args))
|
||||
(effective-arg #f))
|
||||
(cond
|
||||
((procedure? arg)
|
||||
(set! effective-arg (arg))
|
||||
(let ((arg (car args))
|
||||
(effective-arg #f))
|
||||
(cond
|
||||
((procedure? arg)
|
||||
(set! effective-arg (arg))
|
||||
|
||||
(unless (string? effective-arg)
|
||||
(bad-proc-output "~" arg)))
|
||||
(unless (string? effective-arg)
|
||||
(bad-proc-output "~" arg)))
|
||||
|
||||
((string? arg)
|
||||
(set! effective-arg arg))
|
||||
(else
|
||||
;; Not a string or procedure?
|
||||
;; Let's just write it, I guess. YOLO!
|
||||
(set! effective-arg
|
||||
(format #f "~a" arg))))
|
||||
((string? arg)
|
||||
(set! effective-arg arg))
|
||||
(else
|
||||
;; NOTE(spk121): Not a string or procedure? Let's just write it, I guess. YOLO!
|
||||
(set! effective-arg
|
||||
(format #f "~a" arg))))
|
||||
|
||||
;; Loop, only adding spaces as necessary
|
||||
(let ((need-a-space?
|
||||
(and (not (string-null? result))
|
||||
(not (string-null? effective-arg)))))
|
||||
(loop
|
||||
(cdr args)
|
||||
(string-append
|
||||
result
|
||||
(if need-a-space? " " "")
|
||||
effective-arg)))))))))
|
||||
;; Loop, only adding spaces as necessary
|
||||
(let ((need-a-space?
|
||||
(and (not (string-null? result))
|
||||
(not (string-null? effective-arg)))))
|
||||
(loop
|
||||
(cdr args)
|
||||
(string-append
|
||||
result
|
||||
(if need-a-space? " " "")
|
||||
effective-arg)))))))))
|
||||
|
||||
(define (string-compose . args)
|
||||
"FIXME-DOCS"
|
||||
(cons 'default (apply base-compose args)))
|
||||
|
||||
(define ~ string-compose)
|
||||
|
||||
(define (ignore-error-compose . args)
|
||||
"FIXME-DOCS"
|
||||
(cons 'ignore-error (apply base-compose args)))
|
||||
|
||||
(define ~- ignore-error-compose)
|
||||
|
||||
(define (silent-compose . args)
|
||||
"FIXME-DOCS"
|
||||
(cons 'silent (apply base-compose args)))
|
||||
|
||||
(define ~@ silent-compose)
|
||||
|
||||
(define (always-execute-compose . args)
|
||||
"FIXME-DOCS"
|
||||
(cons 'always-execute (apply base-compose args)))
|
||||
|
||||
(define ~+ always-execute-compose)
|
||||
|
||||
(define (regular-file? filename)
|
||||
"FIXME-DOCS"
|
||||
(unless (string? filename)
|
||||
(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)))
|
||||
|
||||
(define (compute-mtime filename)
|
||||
"FIXME-DOCS"
|
||||
(unless (string? filename)
|
||||
(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))
|
||||
(stat:mtimensec st))))
|
||||
|
||||
;; FIXME-DOCS/QA(Krey): What is this doing?
|
||||
(define %system-proc system)
|
||||
|
||||
(define (install-alternate-system-driver proc)
|
||||
"Give a procure to use rather than the standard 'system' procedure,
|
||||
installs it as the system driver. Returns the old system driver."
|
||||
"Give a procure to use rather than the standard 'system' procedure, installs it as the system driver. Returns the old system driver."
|
||||
(unless (procedure? proc)
|
||||
(scm-error 'wrong-type-arg "install-alternate-system-driver" "Not a procedure: ~S" (list proc) #f))
|
||||
(let ((old-proc %system-proc))
|
||||
(set! %system-proc proc)
|
||||
old-proc))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; TARGET STRUCT AND METHODS
|
||||
;;; TARGET STRUCT AND METHODS
|
||||
|
||||
(define-record-type <target-rule>
|
||||
(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!)
|
||||
;; A list of filenames and/or phony targets that have target rules
|
||||
(prerequisites target-rule-get-prerequisites
|
||||
target-rule-set-prerequisites!)
|
||||
target-rule-set-prerequisites!)
|
||||
;; A list of strings or procedures
|
||||
(recipes target-rule-get-recipes
|
||||
target-rule-set-recipes!)
|
||||
target-rule-set-recipes!)
|
||||
;; 1 = script-defined. 2 = built-in
|
||||
(priority target-rule-get-priority
|
||||
target-rule-set-priority!))
|
||||
target-rule-set-priority!))
|
||||
|
||||
;; List of all target rules in order of importance
|
||||
(define %target-rules '())
|
||||
@ -183,23 +186,22 @@ installs it as the system driver. Returns the old system driver."
|
||||
|
||||
(when (>= %verbosity 3)
|
||||
(if (null? prerequisites)
|
||||
(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~%~!" (lquo) name (rquo))
|
||||
(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.
|
||||
(when (null? recipes)
|
||||
(set! recipes (list #t)))
|
||||
|
||||
;; If any recipes are raw strings, we need to make them into
|
||||
;; (cons 'default string)
|
||||
;; NOTE(spk121): If any recipes are raw strings, we need to make them into `(cons 'default string)`
|
||||
(let ((recipes2
|
||||
(map (lambda (recipe)
|
||||
(cond
|
||||
((pair? recipe)
|
||||
recipe)
|
||||
(else
|
||||
(cons 'default recipe))))
|
||||
recipes)))
|
||||
(map (lambda (recipe)
|
||||
(cond
|
||||
((pair? recipe)
|
||||
recipe)
|
||||
(else
|
||||
(cons 'default recipe))))
|
||||
recipes)))
|
||||
|
||||
(let ((rule (make-target-rule name prerequisites recipes2 1)))
|
||||
;; Add to %target-rules
|
||||
@ -214,24 +216,23 @@ installs it as the system driver. Returns the old system driver."
|
||||
;; else
|
||||
(target-rule-get-name (last %target-rules))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; SUFFIX STRUCT AND METHODS
|
||||
;;; 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)
|
||||
suffix-rule-set-source)
|
||||
;; A string, usually like ".o". Or a string->bool proc.
|
||||
(target-suffix suffix-rule-get-target
|
||||
suffix-rule-set-suffix!)
|
||||
suffix-rule-set-suffix!)
|
||||
;; A list of strings or procedures
|
||||
(recipes suffix-rule-get-recipes
|
||||
suffix-rule-set-recipes!)
|
||||
suffix-rule-set-recipes!)
|
||||
;; 1 = script-defined. 2 = built-in
|
||||
(priority suffix-rule-get-priority
|
||||
suffix-rule-set-priority!))
|
||||
suffix-rule-set-priority!))
|
||||
|
||||
;; The list of all registered suffix rules in order of importance
|
||||
(define %suffix-rules '())
|
||||
@ -239,21 +240,20 @@ installs it as the system driver. Returns the old system driver."
|
||||
(define (suffix-rule source target . recipes)
|
||||
"Register a suffix rule"
|
||||
|
||||
;; FIXME: Typecheck
|
||||
;; FIXME(spk121): Typecheck
|
||||
(when (>= %verbosity 3)
|
||||
(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
|
||||
;; (cons 'default string)
|
||||
;; NOTE(spk121): If any recipes are raw strings, we need to make them into `(cons 'default string)`
|
||||
(let ((recipes2
|
||||
(map (lambda (recipe)
|
||||
(cond
|
||||
((pair? recipe)
|
||||
recipe)
|
||||
(else
|
||||
(cons 'default recipe))))
|
||||
recipes)))
|
||||
(map (lambda (recipe)
|
||||
(cond
|
||||
((pair? recipe)
|
||||
recipe)
|
||||
(else
|
||||
(cons 'default recipe))))
|
||||
recipes)))
|
||||
|
||||
(let ((rule (make-suffix-rule source target recipes2 1)))
|
||||
(set! %suffix-rules (cons rule %suffix-rules)))))
|
||||
@ -261,8 +261,7 @@ installs it as the system driver. Returns the old system driver."
|
||||
;; Alias
|
||||
(define -> suffix-rule)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; NODE STRUCT AND METHODS
|
||||
;;; NODE STRUCT AND METHODS
|
||||
|
||||
(define-record-type <node>
|
||||
(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!)
|
||||
;; A list of 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)
|
||||
"FIXME-DOCS"
|
||||
(eq? 'target (node-get-rule-type node)))
|
||||
(define (using-suffix-rules? node)
|
||||
"FIXME-DOCS"
|
||||
(eq? 'suffix (node-get-rule-type node)))
|
||||
(define (using-default-rule? node)
|
||||
"FIXME-DOCS"
|
||||
(eq? 'default (node-get-rule-type node)))
|
||||
|
||||
(define (set-fail! node)
|
||||
"FIXME-DOCS"
|
||||
(node-set-status! node 'fail))
|
||||
|
||||
(define (set-pass! node)
|
||||
"FIXME-DOCS"
|
||||
(node-set-status! node 'pass))
|
||||
|
||||
(define (failed? node)
|
||||
"FIXME-DOCS"
|
||||
(eqv? (node-get-status node) 'fail))
|
||||
|
||||
(define (passed? node)
|
||||
"FIXME-DOCS"
|
||||
(eqv? (node-get-status node) 'pass))
|
||||
|
||||
(define (leaf-node? node)
|
||||
"FIXME-DOCS"
|
||||
(null? (node-get-children node)))
|
||||
|
||||
(define (undetermined? node)
|
||||
"FIXME-DOCS"
|
||||
(eq? (node-get-status node) 'undetermined))
|
||||
|
||||
(define (any-child-has-passed? node)
|
||||
"FIXME-DOCS"
|
||||
(unless (node? node)
|
||||
(scm-error 'wrong-type-arg "any-child-has-passed?" "Not a node: ~S" (list node) #f))
|
||||
(when (null? (node-get-children node))
|
||||
(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)))
|
||||
(any passed? children)))
|
||||
|
||||
(define (every-child-has-passed? node)
|
||||
"FIXME-DOCS"
|
||||
(unless (node? node)
|
||||
(scm-error 'wrong-type-arg "every-child-has-passed?" "Not a node: ~S" (list node) #f))
|
||||
(when (null? (node-get-children node))
|
||||
(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)))
|
||||
(every passed? children)))
|
||||
|
||||
(define (any-child-has-failed? node)
|
||||
"FIXME-DOCS"
|
||||
(unless (node? node)
|
||||
(scm-error 'wrong-type-arg "any-child-has-failed?" "Not a node: ~S" (list node) #f))
|
||||
(when (null? (node-get-children node))
|
||||
(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)))
|
||||
(any failed? children)))
|
||||
|
||||
(define (every-child-has-failed? node)
|
||||
"FIXME-DOCS"
|
||||
(unless (node? node)
|
||||
(scm-error 'wrong-type-arg "every-child-has-failed?" "Not a node: ~S" (list node) #f))
|
||||
(when (null? (node-get-children node))
|
||||
(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)))
|
||||
(every failed? children)))
|
||||
|
||||
(define (children-complete? node)
|
||||
"FIXME-DOCS"
|
||||
(cond
|
||||
((leaf-node? node)
|
||||
#t)
|
||||
((eqv? 'target (node-get-rule-type node))
|
||||
(or (every-child-has-passed? node)
|
||||
(any-child-has-failed? node)))
|
||||
(any-child-has-failed? node)))
|
||||
((eqv? 'suffix (node-get-rule-type node))
|
||||
(or (every-child-has-failed? node)
|
||||
(any-child-has-passed? node)))
|
||||
(any-child-has-passed? node)))
|
||||
(else
|
||||
#f)))
|
||||
|
||||
(define (children-passed? node)
|
||||
"FIXME-DOCS"
|
||||
(cond
|
||||
((null? (node-get-children node))
|
||||
#t)
|
||||
@ -382,22 +395,25 @@ installs it as the system driver. Returns the old system driver."
|
||||
#f)
|
||||
(else
|
||||
(any (lambda (child)
|
||||
(if (eqv? (node-get-status child) 'undetermined)
|
||||
child
|
||||
#f))
|
||||
children)))))
|
||||
(if (eqv? (node-get-status child) 'undetermined)
|
||||
child
|
||||
#f))
|
||||
children)))))
|
||||
|
||||
(define (has-parent? node)
|
||||
"FIXME-DOCS"
|
||||
(if (node-get-parent node)
|
||||
#t
|
||||
#f))
|
||||
|
||||
(define (has-children? node)
|
||||
"FIXME-DOCS"
|
||||
(if (null? (node-get-children node))
|
||||
#f
|
||||
#t))
|
||||
|
||||
(define (get-parent node)
|
||||
"FIXME-DOCS"
|
||||
(node-get-parent 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
|
||||
- its mtime is older than the mtime of its children"
|
||||
(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)))
|
||||
;; 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)))))
|
||||
;; 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)))))
|
||||
|
||||
(define (node-depth node)
|
||||
"FIXME-DOCS"
|
||||
(let loop ((depth 0)
|
||||
(cur node))
|
||||
(cur node))
|
||||
(if (has-parent? cur)
|
||||
(loop (1+ depth) (get-parent cur))
|
||||
;;
|
||||
depth)))
|
||||
(loop (1+ depth) (get-parent cur))
|
||||
;;
|
||||
depth)))
|
||||
|
||||
(define (node-depth-string node)
|
||||
(make-string (* 2 (node-depth node)) #\space))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; AUTOMATIC VARIABLES
|
||||
|
||||
(define target-name 'unspecified)
|
||||
(define target-basename 'unspecified)
|
||||
(define prerequisites '())
|
||||
(define primary-prerequisite 'unspecified)
|
||||
(define newer-prerequisites '())
|
||||
(define target-name 'unspecified) ;; FIXME-DOCS(Krey): What is this variable doing?
|
||||
(define target-basename 'unspecified) ;; FIXME-DOCS(Krey): What is this variable doing?
|
||||
(define prerequisites '()) ;; FIXME-DOCS(Krey): What is this variable doing?
|
||||
(define primary-prerequisite 'unspecified) ;; FIXME-DOCS(Krey): What is this variable doing?
|
||||
(define newer-prerequisites '()) ;; FIXME-DOCS(Krey): What is this variable doing?
|
||||
|
||||
(define (string-append-with-spaces lst)
|
||||
"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
|
||||
(fold
|
||||
(lambda (elem prev)
|
||||
(string-append prev " " elem))
|
||||
(string-append prev " " elem))
|
||||
(car lst)
|
||||
(cdr lst))))
|
||||
|
||||
;; Aliases
|
||||
(define $@ (lambda () target-name))
|
||||
(define $* (lambda () target-basename))
|
||||
(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 (target-rule-prep-automatic-variables node rule)
|
||||
"FIXME-DOCS"
|
||||
(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) "" (car prerequisites)))
|
||||
(set! newer-prerequisites
|
||||
;; If this node doesn't have a real file attached, then all
|
||||
;; prerequistes are "newer".
|
||||
;; If this node doesn't have a real file attached, then all prerequistes are "newer"
|
||||
(if (not (node-get-mtime node))
|
||||
prerequisites
|
||||
;; Prerequisites that have no mtime or a higher mtime are
|
||||
;; "newer".
|
||||
(filter-map
|
||||
(lambda (name)
|
||||
(cond
|
||||
((and (file-exists? name)
|
||||
(regular-file? name)
|
||||
(>= (node-get-mtime node) (compute-mtime name)))
|
||||
name)
|
||||
((not (file-exists? name))
|
||||
name)
|
||||
(else
|
||||
#f)))
|
||||
prerequisites))))
|
||||
prerequisites
|
||||
;; Prerequisites that have no mtime or a higher mtime are "newer"
|
||||
(filter-map
|
||||
(lambda (name)
|
||||
(cond
|
||||
((and (file-exists? name)
|
||||
(regular-file? name)
|
||||
(>= (node-get-mtime node) (compute-mtime name)))
|
||||
name)
|
||||
((not (file-exists? name))
|
||||
name)
|
||||
(else
|
||||
#f)))
|
||||
prerequisites))))
|
||||
|
||||
(define (suffix-rule-prep-automatic-variables node rule)
|
||||
"FIXME-DOCS"
|
||||
(set! target-name (node-get-name node))
|
||||
(set! target-basename (basename target-name))
|
||||
(set! primary-prerequisite (string-append target-basename (suffix-rule-get-source rule)))
|
||||
(set! prerequisites (list primary-prerequisite))
|
||||
(set! newer-prerequisites
|
||||
;; If this node doesn't have a real file attached, then the
|
||||
;; prerequisite is newer.
|
||||
;; If this node doesn't have a real file attached, then the prerequisite is newer
|
||||
(if (not (node-get-mtime node))
|
||||
(list primary-prerequisite)
|
||||
;; Prerequisites that have no mtime or a higher mtime are
|
||||
;; "newer".
|
||||
(cond
|
||||
((and (file-exists? primary-prerequisite)
|
||||
(regular-file? primary-prerequisite)
|
||||
(> (node-get-mtime node) (compute-mtime primary-prerequisite)))
|
||||
(list primary-prerequisite))
|
||||
(else
|
||||
'())))))
|
||||
(list primary-prerequisite)
|
||||
;; Prerequisites that have no mtime or a higher mtime are "newer"
|
||||
(cond
|
||||
((and (file-exists? primary-prerequisite)
|
||||
(regular-file? primary-prerequisite)
|
||||
(> (node-get-mtime node) (compute-mtime primary-prerequisite)))
|
||||
(list primary-prerequisite))
|
||||
(else
|
||||
'())))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; MIXED METHODS
|
||||
;; requiring more than one of node, automatic variables, suffix rules
|
||||
;; and target rules
|
||||
;;; MIXED METHODS
|
||||
;;; requiring more than one of node, automatic variables, suffix rules and target rules
|
||||
|
||||
(define (add-builtins)
|
||||
"FIXME-DOCS"
|
||||
;; FIXME(Krey): Commented out by the original author, figure out what we want to do with it
|
||||
#|
|
||||
(-> ".c" ""
|
||||
(~ ($ CC) ($ CFLAGS) ($ LDFLAGS) "-o" $@ $<))
|
||||
@ -539,163 +554,159 @@ installs it as the system driver. Returns the old system driver."
|
||||
(~ ($ GUILD) "compile" ($ GFLAGS) $<)))
|
||||
|
||||
(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)
|
||||
(scm-error 'wrong-type-arg "run-target-rule!" "Not a node: ~S" (list node) #f))
|
||||
|
||||
(let ((rules (node-get-rules node)))
|
||||
(when (null? 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))
|
||||
(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))
|
||||
(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)))
|
||||
(target-rule-prep-automatic-variables node rule)
|
||||
(run-recipes! node (target-rule-get-recipes rule))
|
||||
(let ((status (node-get-status node)))
|
||||
status))))
|
||||
status))))
|
||||
|
||||
(define (run-suffix-rules! node)
|
||||
"Runs the one-or-more suffix rules associated with this node. It
|
||||
runs them one-by-one, quitting on the first success."
|
||||
"Runs the one-or-more suffix rules associated with this node. It runs them one-by-one, quitting on the first success"
|
||||
(unless (node? node)
|
||||
(scm-error 'wrong-type'arg "run-suffix-rules!" "Not a node: ~S" (list node) #f))
|
||||
|
||||
(let ((rules (node-get-rules node))
|
||||
(children (node-get-children node)))
|
||||
(children (node-get-children node)))
|
||||
(when (null? 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)
|
||||
(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)
|
||||
(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))
|
||||
(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)
|
||||
(len (length children)))
|
||||
(len (length children)))
|
||||
(while (< i len)
|
||||
(let ((rule (list-ref rules i))
|
||||
(child (list-ref children i)))
|
||||
(when (passed? child)
|
||||
(when (>= %verbosity 3)
|
||||
(format #t "~A: attempting to make using ~a~A~a ~a ~a~A~a rule"
|
||||
(node-get-name node)
|
||||
(lquo) (suffix-rule-get-source rule) (rquo)
|
||||
(right-arrow)
|
||||
(lquo) (suffix-rule-get-target rule) (rquo)))
|
||||
(suffix-rule-prep-automatic-variables node rule)
|
||||
(run-recipes! node (suffix-rule-get-recipes rule)))
|
||||
(let ((rule (list-ref rules i))
|
||||
(child (list-ref children i)))
|
||||
(when (passed? child)
|
||||
(when (>= %verbosity 3)
|
||||
(format #t "~A: attempting to make using ~a~A~a ~a ~a~A~a rule"
|
||||
(node-get-name node)
|
||||
(lquo) (suffix-rule-get-source rule) (rquo)
|
||||
(right-arrow)
|
||||
(lquo) (suffix-rule-get-target rule) (rquo)))
|
||||
(suffix-rule-prep-automatic-variables node rule)
|
||||
(run-recipes! node (suffix-rule-get-recipes rule)))
|
||||
|
||||
(when (passed? node)
|
||||
(break))
|
||||
(set! i (1+ i)))))
|
||||
(when (passed? node)
|
||||
(break))
|
||||
(set! i (1+ i)))))
|
||||
|
||||
(when (>= %verbosity 3)
|
||||
(if (passed? node)
|
||||
(format #t "PASS: ~a~%~!" (node-get-name node))
|
||||
(format #t "FAIL: ~a~%~!" (node-get-name node))))
|
||||
(format #t "PASS: ~a~%~!" (node-get-name node))
|
||||
(format #t "FAIL: ~a~%~!" (node-get-name node))))
|
||||
(node-get-status node)))
|
||||
|
||||
(define (run-recipes! node recipes)
|
||||
"Runs the recipes on this node, one by one. Recipes are either
|
||||
strings, procedures that return strings, or generic procedures. If a
|
||||
"Runs the recipes on this node, one by one. Recipes are either strings, procedures that return strings, or generic procedures. If a
|
||||
failure condition happens, mark the node as having failed."
|
||||
(unless (node? node)
|
||||
(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)))
|
||||
;; (scm-error 'wrong-type-arg "run-recipes!" "Not a non-null list: ~S" (list recipes) #f))
|
||||
|
||||
(let ((i 0)
|
||||
(len (length recipes)))
|
||||
(len (length recipes)))
|
||||
(while (< i len)
|
||||
(let* ((opt/recipe (list-ref recipes i))
|
||||
(opt (car opt/recipe))
|
||||
(recipe (cdr opt/recipe)))
|
||||
;; Recipes are either
|
||||
;; - strings to pass to system
|
||||
;; - procedures that return a string which is passed
|
||||
;; to system
|
||||
;; - procedures (that don't return a string) that are executed
|
||||
;; that pass unless they return #f
|
||||
;; OPT is one of 'default, 'ignore, 'silent
|
||||
(opt (car opt/recipe))
|
||||
(recipe (cdr opt/recipe)))
|
||||
;; Recipes are either
|
||||
;; - strings to pass to system
|
||||
;; - procedures that return a string which is passed to system
|
||||
;; - procedures (that don't return a string) that are executed that pass unless they return #f
|
||||
|
||||
(cond
|
||||
((eq? recipe #t)
|
||||
(set-pass! node))
|
||||
;; OPT is one of 'default, 'ignore, 'silent
|
||||
|
||||
((eq? recipe #f)
|
||||
(set-fail! node))
|
||||
(cond
|
||||
((eq? recipe #t)
|
||||
(set-pass! node))
|
||||
|
||||
((string? recipe)
|
||||
(when (= %verbosity 1)
|
||||
(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))))
|
||||
((eq? recipe #f)
|
||||
(set-fail! node))
|
||||
|
||||
((procedure? recipe)
|
||||
(let ((retval (recipe)))
|
||||
(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))))
|
||||
((string? recipe)
|
||||
(when (= %verbosity 1)
|
||||
(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))))
|
||||
|
||||
;; A scheme procedure recipe that returns false.
|
||||
((eqv? retval #f)
|
||||
(set-fail! node))
|
||||
((procedure? recipe)
|
||||
(let ((retval (recipe)))
|
||||
(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
|
||||
;; Otherwise, this was a procedure that didn't return
|
||||
;; #f or a string, so it gets a pass.
|
||||
(set-pass! node)))))
|
||||
;; A scheme procedure recipe that returns false.
|
||||
((eqv? retval #f)
|
||||
(set-fail! node))
|
||||
|
||||
(else
|
||||
;; Can't be converted to a viable string or procedure
|
||||
(scm-error 'misc-error "run-recipes!" "bad recipe: ~S" (list recipe) #f)))
|
||||
(else
|
||||
;; Otherwise, this was a procedure that didn't return #f or a string, so it gets a pass.
|
||||
(set-pass! node)))))
|
||||
|
||||
(when (failed? node) (break))
|
||||
(set! i (1+ i))))
|
||||
(else
|
||||
;; 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)
|
||||
(let ((name (node-get-name node)))
|
||||
(when (and (file-exists? name)
|
||||
(regular-file? name))
|
||||
(node-set-mtime! node (compute-mtime name)))))))
|
||||
(when (and (file-exists? name)
|
||||
(regular-file? name))
|
||||
(node-set-mtime! node (compute-mtime name)))))))
|
||||
|
||||
(define (run-default-rule! node)
|
||||
"The default rule if not other rule exists. It just passes if the
|
||||
file exists."
|
||||
"The default rule if not other rule exists. It just passes if the file exists"
|
||||
(let ((name (node-get-name node)))
|
||||
(if (and (file-exists? name)
|
||||
(regular-file? name))
|
||||
(begin
|
||||
(set-pass! node)
|
||||
(node-set-mtime! node (compute-mtime name)))
|
||||
;; else
|
||||
(set-fail! node))))
|
||||
(regular-file? name))
|
||||
(begin
|
||||
(set-pass! node)
|
||||
(node-set-mtime! node (compute-mtime name)))
|
||||
;; else
|
||||
(set-fail! node))))
|
||||
|
||||
;; Start at root
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user