From ddb3640fb8349217ab90e229574f9c4fdea6997d Mon Sep 17 00:00:00 2001 From: Jacob Hrbek Date: Tue, 30 Aug 2022 16:53:18 +0200 Subject: [PATCH] Sync Signed-off-by: Jacob Hrbek --- .gitignore | 10 +- src/potato/makevars.scm | 64 ++++---- src/potato/parse-lib.scm | 311 +++++++++++++++++++-------------------- src/potato/parse.scm | 9 +- 4 files changed, 191 insertions(+), 203 deletions(-) diff --git a/.gitignore b/.gitignore index cbb89d7..0ff00a7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,3 @@ -*.ss~ -*.ss#* -.#*.ss - -*.scm~ -*.scm#* -.#*.scm +# Emacs teporary files +**~ +**\# \ No newline at end of file diff --git a/src/potato/makevars.scm b/src/potato/makevars.scm index 0d1a725..2d9b89e 100644 --- a/src/potato/makevars.scm +++ b/src/potato/makevars.scm @@ -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 diff --git a/src/potato/parse-lib.scm b/src/potato/parse-lib.scm index b4d9a3e..2540f9e 100644 --- a/src/potato/parse-lib.scm +++ b/src/potato/parse-lib.scm @@ -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)) - - (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))) + (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))))) + + ;; 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 diff --git a/src/potato/parse.scm b/src/potato/parse.scm index e07e160..7fbe634 100644 --- a/src/potato/parse.scm +++ b/src/potato/parse.scm @@ -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))