Quality Assurance, Audit and Tags #14
10
.gitignore
vendored
10
.gitignore
vendored
@ -1,7 +1,3 @@
|
||||
*.ss~
|
||||
*.ss#*
|
||||
.#*.ss
|
||||
|
||||
*.scm~
|
||||
*.scm#*
|
||||
.#*.scm
|
||||
# Emacs teporary files
|
||||
**~
|
||||
**\#
|
||||
@ -278,15 +278,14 @@ priority."
|
||||
(makevars-add-makeflags))
|
||||
(makevars-add-keyvals keyvals))
|
||||
|
||||
;; API
|
||||
;;; API
|
||||
|
||||
(define* (lazy-assign key #:optional (val ""))
|
||||
"This procedure sets an entry in the %makevars hash table.
|
||||
KEY must be a string or a thunk that evaluates to a string. Likewise
|
||||
VAL.
|
||||
If KEY is a thunk, it is immediately evaluated to a string to use as
|
||||
the key in the hash table entry.
|
||||
If VAL is a thunk, it is stored as a *promise* to be evaluated
|
||||
later. The promise will be evaluated the first time this key is
|
||||
If KEY is a thunk, it is immediately evaluated to a string to use as the key in the hash table entry.
|
||||
If VAL is a thunk, it is stored as a *promise* to be evaluated later. The promise will be evaluated the first time this key is
|
||||
referenced.
|
||||
If VAL is not given, the empty string will be used."
|
||||
(when (procedure? key)
|
||||
@ -307,8 +306,7 @@ referenced.
|
||||
"This procedure sets an entry in the %makevars hash table.
|
||||
KEY must be a string or a thunk that evaluates to a string. Likewise
|
||||
VAL.
|
||||
If KEY and/or VAL is a thunk, it is immediately evaluated to a
|
||||
string to use as the key in the hash table entry.
|
||||
If KEY and/or VAL is a thunk, it is immediately evaluated to a string to use as the key in the hash table entry.
|
||||
If VAL is not given, the empty string will be used."
|
||||
(when (procedure? key)
|
||||
(set! key (key)))
|
||||
@ -331,15 +329,9 @@ string to use as the key in the hash table entry.
|
||||
(define* (reference key quoted? #:optional (transformer #f))
|
||||
"Looks up KEY in the %makevars hash table. KEY may be a string
|
||||
or a procedure that evaluates to a string.
|
||||
If the value of the key
|
||||
in the hash table was a *promise* it will be forced,
|
||||
evaluated, and set to that result.
|
||||
If no transformer is supplied, the looked up value will be
|
||||
returned.
|
||||
TRANSFORMER, if
|
||||
supplied, should be a procedure of one string argument that returns a
|
||||
string. If a transformer is supplied, it will be applied to every
|
||||
space-separated token in the looked-up value."
|
||||
If the value of the key in the hash table was a *promise* it will be forced, evaluated, and set to that result.
|
||||
If no transformer is supplied, the looked up value will be returned.
|
||||
TRANSFORMER, if supplied, should be a procedure of one string argument that returns a string. If a transformer is supplied, it will be applied to every space-separated token in the looked-up value."
|
||||
(when (and (not (string? key))
|
||||
(not (procedure? key)))
|
||||
(bad-key-type "reference" (list key)))
|
||||
@ -387,6 +379,7 @@ space-separated token in the looked-up value."
|
||||
(string-append "\"" val "\"")
|
||||
val)))))
|
||||
|
||||
;; FIXME-DOCS(Krey)
|
||||
(define-syntax $
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
@ -395,6 +388,7 @@ space-separated token in the looked-up value."
|
||||
((_ key)
|
||||
#'(reference (symbol->string (syntax->datum #'key)) #f)))))
|
||||
|
||||
;; FIXME-DOCS(Krey)
|
||||
(define-syntax Q
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
@ -404,38 +398,36 @@ space-separated token in the looked-up value."
|
||||
#'(reference (symbol->string (syntax->datum #'key)) #t)))))
|
||||
|
||||
(define (reference-func key)
|
||||
"Looks up KEY in the %makevars hash table. KEY shall be a string
|
||||
or a procedure that evaluates to a string.
|
||||
If the value of the key
|
||||
in the hash table was a *promise*, a procedure will be returned that,
|
||||
when called, will call that promise. If the value of the key is
|
||||
a string, a procedure will be returned that, when called, returns
|
||||
that string."
|
||||
"Looks up KEY in the %makevars hash table. KEY shall be a string or a procedure that evaluates to a string.
|
||||
If the value of the key in the hash table was a *promise*, a procedure will be returned that, when called, will call that promise.
|
||||
If the value of the key is a string, a procedure will be returned that, when called, returns that string."
|
||||
(when (and (not (string? key))
|
||||
(not (procedure? key)))
|
||||
(not (procedure? key)))
|
||||
(bad-key-type "reference" (list key)))
|
||||
(when (procedure? key)
|
||||
(set! key (key))
|
||||
(unless (string? key)
|
||||
(bad-proc-output "reference" key))
|
||||
(let* ((val&priority (hash-ref %makevars key))
|
||||
(val (if (pair? val&priority) (cdr val&priority) #f)))
|
||||
(val (if (pair? val&priority) (cdr val&priority) #f)))
|
||||
(if (not val)
|
||||
#f
|
||||
;; else
|
||||
(begin
|
||||
(if (promise? val)
|
||||
(lambda ()
|
||||
(let ((VAL (force val)))
|
||||
;; FIXME: put verbose print here?
|
||||
VAL))
|
||||
;; else
|
||||
(lambda ()
|
||||
val)))))))
|
||||
#f
|
||||
;; else
|
||||
(begin
|
||||
(if (promise? val)
|
||||
(lambda ()
|
||||
(let ((VAL (force val)))
|
||||
;; FIXME(spk121): put verbose print here?
|
||||
VAL))
|
||||
;; else
|
||||
(lambda ()
|
||||
val)))))))
|
||||
|
||||
;; FIXME-DOCS(Krey)
|
||||
(define-syntax $$
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
((_ key)
|
||||
#'(reference-func (symbol->string (syntax->datum #'key)))))))
|
||||
|
||||
;; makevards.scm ends here
|
||||
|
||||
@ -24,18 +24,23 @@
|
||||
#:use-module (potato rules)
|
||||
#:use-module (potato text)
|
||||
#:export(
|
||||
read-line-handle-escaped-newline
|
||||
string-collapse-continuations
|
||||
string-count-backslashes-at-end
|
||||
string-count-matching-chars-at-end
|
||||
string-find-char-unquote
|
||||
string-find-preceding-backslashes
|
||||
string-find-repeated-chars
|
||||
string-next-token
|
||||
string-remove-comments
|
||||
string-starts-with?
|
||||
string-shrink-whitespace
|
||||
))
|
||||
read-line-handle-escaped-newline
|
||||
string-collapse-continuations
|
||||
string-count-backslashes-at-end
|
||||
string-count-matching-chars-at-end
|
||||
string-find-char-unquote
|
||||
string-find-preceding-backslashes
|
||||
string-find-repeated-chars
|
||||
string-next-token
|
||||
string-remove-comments
|
||||
string-starts-with?
|
||||
string-shrink-whitespace))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; DOCS
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define (read-line-handle-escaped-newline)
|
||||
"Reads a line of text from the current input port.
|
||||
@ -48,16 +53,16 @@ It returns two values
|
||||
- the string containing the one or more lines read
|
||||
- the number of lines read."
|
||||
(let loop ((output "")
|
||||
(nline 0))
|
||||
(nline 0))
|
||||
(let ((line (read-line)))
|
||||
(if (eof-object? line)
|
||||
(values output nline)
|
||||
;; else
|
||||
(if (odd? (string-count-backslashes-at-end line))
|
||||
(loop (string-append output (string-drop-right line 1) "\n")
|
||||
(1+ nline))
|
||||
;; else
|
||||
(values (string-append output line "\n") (1+ nline)))))))
|
||||
(values output nline)
|
||||
;; else
|
||||
(if (odd? (string-count-backslashes-at-end line))
|
||||
(loop (string-append output (string-drop-right line 1) "\n")
|
||||
(1+ nline))
|
||||
;; else
|
||||
(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
|
||||
@ -65,61 +70,60 @@ 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)))
|
||||
(newline-index (string-rindex str #\newline)))
|
||||
(if (not newline-index)
|
||||
(string-copy str)
|
||||
;; else
|
||||
(let* ((backslash-index (string-find-preceding-backslashes str newline-index))
|
||||
(backslash-count (- newline-index backslash-index)))
|
||||
(cond
|
||||
((even? backslash-count)
|
||||
;; We cut the number of backslashes in half, but, keep the newline.
|
||||
(loop
|
||||
(string-append
|
||||
(substring str 0 backslash-index)
|
||||
(make-string (quotient backslash-count 2) #\\)
|
||||
(substring str newline-index))
|
||||
(string-rindex str #\newline 0 backslash-index)))
|
||||
(string-copy str)
|
||||
;; else
|
||||
(let* ((backslash-index (string-find-preceding-backslashes str newline-index))
|
||||
(backslash-count (- newline-index backslash-index)))
|
||||
(cond
|
||||
((even? backslash-count)
|
||||
;; We cut the number of backslashes in half, but, keep the newline.
|
||||
(loop
|
||||
(string-append
|
||||
(substring str 0 backslash-index)
|
||||
(make-string (quotient backslash-count 2) #\\)
|
||||
(substring str newline-index))
|
||||
(string-rindex str #\newline 0 backslash-index)))
|
||||
|
||||
(else
|
||||
;; We cut the number of backslashes in half, remove a backslash
|
||||
;; and newline, maybe squash any following whitespace.
|
||||
(loop
|
||||
(string-append
|
||||
(substring str 0 backslash-index)
|
||||
(make-string (quotient backslash-count 2) #\\)
|
||||
(if squash-whitespace?
|
||||
(string-shrink-whitespace
|
||||
(substring str (1+ newline-index))
|
||||
0)
|
||||
(substring str (1+ newline-index))))
|
||||
(string-rindex str #\newline 0 backslash-index))))))))
|
||||
(else
|
||||
;; We cut the number of backslashes in half, remove a backslash and newline, maybe squash any following whitespace.
|
||||
(loop
|
||||
(string-append
|
||||
(substring str 0 backslash-index)
|
||||
(make-string (quotient backslash-count 2) #\\)
|
||||
(if squash-whitespace?
|
||||
(string-shrink-whitespace
|
||||
(substring str (1+ newline-index))
|
||||
0)
|
||||
(substring str (1+ newline-index))))
|
||||
(string-rindex str #\newline 0 backslash-index))))))))
|
||||
|
||||
;; FIXME-DOCS(Krey)
|
||||
(define (string-count-backslashes-at-end str)
|
||||
(string-count-matching-chars-at-end str #\\))
|
||||
|
||||
;; FIXME-DOCS(Krey)
|
||||
(define (string-count-matching-chars-at-end str c)
|
||||
(if (not (string? str))
|
||||
0
|
||||
;; else
|
||||
(let ((len (string-length str)))
|
||||
(if (zero? len)
|
||||
0
|
||||
;; else
|
||||
(let loop ((i (1- len))
|
||||
(n 0))
|
||||
(if (char=? (string-ref str i) c)
|
||||
(if (zero? i)
|
||||
(1+ n)
|
||||
;; else
|
||||
(loop (1- i) (1+ n)))
|
||||
;; else
|
||||
n))))))
|
||||
(if (zero? len)
|
||||
0
|
||||
;; else
|
||||
(let loop ((i (1- len))
|
||||
(n 0))
|
||||
(if (char=? (string-ref str i) c)
|
||||
(if (zero? i)
|
||||
(1+ n)
|
||||
;; else
|
||||
(loop (1- i) (1+ n)))
|
||||
;; else
|
||||
n))))))
|
||||
|
||||
(define* (string-find-char-unquote str #:optional (stop1 #f) (stop2 #f) #:key (blank #f) (ignorevars #f))
|
||||
"Search string for an unquoted stopchar. Search until the end of
|
||||
line is reached or until the blank char is reached. A backslash
|
||||
quotes the stopchars and the blank.
|
||||
"Search string for an unquoted stopchar. Search until the end of line is reached or until the blank char is reached. A backslash quotes the stopchars and the blank.
|
||||
|
||||
The stopchars and blank may be #f, to ignore them in this call.
|
||||
|
||||
@ -129,78 +133,74 @@ Returns two values
|
||||
- A string with the quoting backslashes removed
|
||||
- The position of the first unquoted stopchar, or #f"
|
||||
(let ((i 0)
|
||||
(str2 (string-copy str))
|
||||
(ret #f))
|
||||
(str2 (string-copy str))
|
||||
(ret #f))
|
||||
(while #t
|
||||
(while (and (< i (string-length str))
|
||||
(not (or
|
||||
(and stop1 (eqv? (string-ref str i) stop1))
|
||||
(and stop2 (eqv? (string-ref str i) stop2))
|
||||
(and ignorevars (eqv? (string-ref str i) #\$))
|
||||
(and blank (char-set-contains? char-set:blank (string-ref str i))))))
|
||||
(set! i (1+ i)))
|
||||
(not (or
|
||||
(and stop1 (eqv? (string-ref str i) stop1))
|
||||
(and stop2 (eqv? (string-ref str i) stop2))
|
||||
(and ignorevars (eqv? (string-ref str i) #\$))
|
||||
(and blank (char-set-contains? char-set:blank (string-ref str i))))))
|
||||
(set! i (1+ i)))
|
||||
|
||||
(when (>= i (string-length str))
|
||||
(break))
|
||||
(break))
|
||||
|
||||
;; If we stopped due to a variable reference, skip its contents
|
||||
(when (and ignorevars (eqv? (string-ref str i) #\$))
|
||||
(let ((openparen (false-if-exception (string-ref str (1+ i)))))
|
||||
(set! i (+ i 2))
|
||||
(let ((openparen (false-if-exception (string-ref str (1+ i)))))
|
||||
(set! i (+ i 2))
|
||||
|
||||
(when (or (eqv? openparen #\() (eqv? openparen #\{))
|
||||
(let ((pcount 1)
|
||||
(closeparen (if (eqv? openparen #\()
|
||||
#\)
|
||||
#\})))
|
||||
(while (< i (string-length str))
|
||||
(cond
|
||||
((eqv? (string-ref str i) openparen)
|
||||
(set! pcount (1+ pcount)))
|
||||
((eqv? (string-ref str i) closeparen)
|
||||
(set! pcount (1- pcount))
|
||||
(when (zero? pcount)
|
||||
(set! i (1+ i))
|
||||
(break))))
|
||||
(set! i (1+ i)))))
|
||||
(when (or (eqv? openparen #\() (eqv? openparen #\{))
|
||||
(let ((pcount 1)
|
||||
(closeparen (if (eqv? openparen #\()
|
||||
#\)
|
||||
#\})))
|
||||
(while (< i (string-length str))
|
||||
(cond
|
||||
((eqv? (string-ref str i) openparen)
|
||||
(set! pcount (1+ pcount)))
|
||||
((eqv? (string-ref str i) closeparen)
|
||||
(set! pcount (1- pcount))
|
||||
(when (zero? pcount)
|
||||
(set! i (1+ i))
|
||||
(break))))
|
||||
(set! i (1+ i)))))
|
||||
|
||||
;; Skipped the variable reference: look for STOPCHARS again
|
||||
(continue)))
|
||||
;; Skipped the variable reference: look for STOPCHARS again
|
||||
(continue)))
|
||||
|
||||
(if (and (> i 0) (eqv? (string-ref str (1- i)) #\\))
|
||||
;; Search for more backslashes
|
||||
(let ((j 2))
|
||||
(while (and (>= (- i j) 0)
|
||||
(eqv? (string-ref str (- i j)) #\\))
|
||||
(set! j (1+ j)))
|
||||
(set! j (1- j))
|
||||
;; Copy the string to swallow half the backslashes
|
||||
(set! str2
|
||||
(string-append
|
||||
(string-take str (- i j))
|
||||
(string-drop str (- i (quotient j 2)))))
|
||||
(set! i (- i (quotient j 2)))
|
||||
(when (even? j)
|
||||
;; All the backslashes quoted each other; the stopchar
|
||||
;; was unquoted
|
||||
(set! ret #t)
|
||||
(break))
|
||||
(set! str str2))
|
||||
;; else
|
||||
;; no backslash in sight
|
||||
(begin
|
||||
(set! ret #t)
|
||||
(break))))
|
||||
;; Search for more backslashes
|
||||
(let ((j 2))
|
||||
(while (and (>= (- i j) 0)
|
||||
(eqv? (string-ref str (- i j)) #\\))
|
||||
(set! j (1+ j)))
|
||||
(set! j (1- j))
|
||||
;; Copy the string to swallow half the backslashes
|
||||
(set! str2
|
||||
(string-append
|
||||
(string-take str (- i j))
|
||||
(string-drop str (- i (quotient j 2)))))
|
||||
(set! i (- i (quotient j 2)))
|
||||
(when (even? j)
|
||||
;; All the backslashes quoted each other; the stopchar was unquoted
|
||||
(set! ret #t)
|
||||
(break))
|
||||
(set! str str2))
|
||||
;; else
|
||||
;; no backslash in sight
|
||||
(begin
|
||||
(set! ret #t)
|
||||
(break))))
|
||||
|
||||
(if ret
|
||||
(values i str2)
|
||||
(values #f #f))))
|
||||
(values i str2)
|
||||
(values #f #f))))
|
||||
|
||||
(define (string-find-preceding-backslashes str i)
|
||||
"Given I, a position in a string, this returns a position,
|
||||
of first of a range sequential backslashes that immediately precedes
|
||||
that position in the string. If no backslashes precede that position,
|
||||
I is returned."
|
||||
"Given I, a position in a string, this returns a position, of first of a range sequential backslashes that immediately precedes that position in the string. If no backslashes precede that position, I is returned."
|
||||
(let loop ((j i))
|
||||
(cond
|
||||
((= j 0)
|
||||
@ -211,60 +211,55 @@ I is returned."
|
||||
j))))
|
||||
|
||||
(define (string-find-repeated-chars str c)
|
||||
"Given a character c, this finds the position of of first instance
|
||||
of the character in the string. If the character repeats, it returns,
|
||||
as a pair, the position of the character, and the position after the
|
||||
run of characters. If the character is not present, it returns #f"
|
||||
"Given a character c, this finds the position of of first instance of the character in the string. If the character repeats, it returns, as a pair, the position of the character, and the position after the run of characters. If the character is not present, it returns #f"
|
||||
(let ((i (string-index str c)))
|
||||
(if (not i)
|
||||
#f
|
||||
;; else
|
||||
(let ((len (string-length str)))
|
||||
(if (= (1+ i) len)
|
||||
(cons i (1+ i))
|
||||
;; else
|
||||
(let loop ((j (1+ i)))
|
||||
(if (false-if-exception (char=? (string-ref str j) c))
|
||||
(loop (1+ j))
|
||||
;; else
|
||||
(cons i j))))))))
|
||||
#f
|
||||
;; else
|
||||
(let ((len (string-length str)))
|
||||
(if (= (1+ i) len)
|
||||
(cons i (1+ i))
|
||||
;; else
|
||||
(let loop ((j (1+ i)))
|
||||
(if (false-if-exception (char=? (string-ref str j) c))
|
||||
(loop (1+ j))
|
||||
;; else
|
||||
(cons i j))))))))
|
||||
|
||||
(define (string-next-token str i)
|
||||
"Given a position i, this returns the position of the first
|
||||
non-whitespace character after i. If the end of line is reached,
|
||||
it returns the length of the string."
|
||||
"Given a position i, this returns the position of the first non-whitespace character after i. If the end of line is reached, it returns the length of the string."
|
||||
(or
|
||||
(string-index str
|
||||
(lambda (c)
|
||||
(char-set-contains? char-set:blank c))
|
||||
i)
|
||||
(lambda (c)
|
||||
(char-set-contains? char-set:blank c))
|
||||
i)
|
||||
(string-length str)))
|
||||
|
||||
(define (string-remove-comments str)
|
||||
"Returns a copy of str with any '#' comments removed"
|
||||
(let ((i (string-find-char-unquote str #\#)))
|
||||
(if i
|
||||
(string-take str i)
|
||||
(string-copy str))))
|
||||
(string-take str i)
|
||||
(string-copy str))))
|
||||
|
||||
(define (string-shrink-whitespace str start)
|
||||
"Given a string, and a location in a string, this returns a new copy
|
||||
of string where all the whitespace beginning at location i is replaced
|
||||
by a single space"
|
||||
"Given a string, and a location in a string, this returns a new copy of string where all the whitespace beginning at location i is replaced by a single space"
|
||||
(let ((len (string-length str)))
|
||||
(if (or (>= start len)
|
||||
(not (char-set-contains? char-set:blank (string-ref str start))))
|
||||
(string-copy str)
|
||||
;; else
|
||||
(let loop ((end start))
|
||||
(cond
|
||||
((>= end len)
|
||||
(string-append (substring str 0 start) " "))
|
||||
((char-set-contains? char-set:blank (string-ref str end))
|
||||
(loop (1+ end)))
|
||||
(else
|
||||
(string-append (substring str 0 start) " " (substring str end))))))))
|
||||
(not (char-set-contains? char-set:blank (string-ref str start))))
|
||||
(string-copy str)
|
||||
;; else
|
||||
(let loop ((end start))
|
||||
(cond
|
||||
((>= end len)
|
||||
(string-append (substring str 0 start) " "))
|
||||
((char-set-contains? char-set:blank (string-ref str end))
|
||||
(loop (1+ end)))
|
||||
(else
|
||||
(string-append (substring str 0 start) " " (substring str end))))))))
|
||||
|
||||
|
||||
(define (string-starts-with? str c)
|
||||
(char=? (string-ref str 0) c))
|
||||
|
||||
;;; parse-libs.scm ends here
|
||||
|
||||
@ -25,8 +25,13 @@
|
||||
#:use-module (potato parse-lib)
|
||||
#:export (parse _readline))
|
||||
|
||||
;; A makefile can contain rules, macro definitions, include lines,
|
||||
;; and comments.
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; DOCS
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
;; A makefile can contain rules, macro definitions, include lines, and comments.
|
||||
|
||||
(define (parse filename)
|
||||
(with-input-from-file filename _eval #:guess-encoding #t))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user