From 6a8b09699e49bd6748071937445ff04f60be81bb Mon Sep 17 00:00:00 2001 From: Jacob Hrbek Date: Wed, 31 Aug 2022 19:55:56 +0200 Subject: [PATCH] Sync Signed-off-by: Jacob Hrbek --- TAGS.org | 23 ++ src/potato/parse-lib.scm | 11 +- src/potato/parse.scm | 128 ++++----- src/potato/parser.scm | 160 ++++++------ src/potato/rules.scm | 541 ++++++++++++++++++++------------------- 5 files changed, 457 insertions(+), 406 deletions(-) create mode 100644 TAGS.org diff --git a/TAGS.org b/TAGS.org new file mode 100644 index 0000000..79cb19c --- /dev/null +++ b/TAGS.org @@ -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 diff --git a/src/potato/parse-lib.scm b/src/potato/parse-lib.scm index 2540f9e..eeda22d 100644 --- a/src/potato/parse-lib.scm +++ b/src/potato/parse-lib.scm @@ -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) diff --git a/src/potato/parse.scm b/src/potato/parse.scm index 7fbe634..b5011fe 100644 --- a/src/potato/parse.scm +++ b/src/potato/parse.scm @@ -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 diff --git a/src/potato/parser.scm b/src/potato/parser.scm index 83d5dfd..3bca42a 100644 --- a/src/potato/parser.scm +++ b/src/potato/parser.scm @@ -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))) + (char=? #\space c))) +;;; parser.scm ends here diff --git a/src/potato/rules.scm b/src/potato/rules.scm index f0e9d72..d85409e 100644 --- a/src/potato/rules.scm +++ b/src/potato/rules.scm @@ -24,42 +24,44 @@ #:use-module (potato makevars) #:use-module (potato text) #:export( - - - %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 ~- - )) + + + %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 (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 (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))) - - ;; If any recipes are raw strings, we need to make them into - ;; (cons 'default string) + (lquo) source (rquo) (right-arrow) (lquo) target (rquo))) + + ;; 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 (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