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

Sync

Browse Source 
Signed-off-by: Jacob Hrbek <kreyren@rixotstudio.cz>
This commit is contained in:
Jacob Hrbek 2022-08-30 16:53:18 +02:00
parent 66772f99e8
commit ddb3640fb8
Signed by: kreyren
GPG Key ID: 667F0DAFAF09BA2B
4 changed files with 191 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
.gitignore vendored
View File

@ -1,7 +1,3 @@
*.ss~ # Emacs teporary files
*.ss#* **~
.#*.ss **\#
*.scm~
*.scm#*
.#*.scm

64
src/potato/makevars.scm
View File

@ -278,15 +278,14 @@ priority."
(makevars-add-makeflags)) (makevars-add-makeflags))
(makevars-add-keyvals keyvals)) (makevars-add-keyvals keyvals))
;; API ;;; API
(define* (lazy-assign key #:optional (val "")) (define* (lazy-assign key #:optional (val ""))
"This procedure sets an entry in the %makevars hash table. "This procedure sets an entry in the %makevars hash table.
KEY must be a string or a thunk that evaluates to a string. Likewise KEY must be a string or a thunk that evaluates to a string. Likewise
VAL. VAL.
If KEY is a thunk, it is immediately evaluated to a string to use as If KEY is a thunk, it is immediately evaluated to a string to use as the key in the hash table entry.
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 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. referenced.
If VAL is not given, the empty string will be used." If VAL is not given, the empty string will be used."
(when (procedure? key) (when (procedure? key)
@ -307,8 +306,7 @@ referenced.
"This procedure sets an entry in the %makevars hash table. "This procedure sets an entry in the %makevars hash table.
KEY must be a string or a thunk that evaluates to a string. Likewise KEY must be a string or a thunk that evaluates to a string. Likewise
VAL. VAL.
If KEY and/or VAL is a thunk, it is immediately evaluated to a 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.
string to use as the key in the hash table entry.
If VAL is not given, the empty string will be used." If VAL is not given, the empty string will be used."
(when (procedure? key) (when (procedure? key)
(set! key (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)) (define* (reference key quoted? #:optional (transformer #f))
"Looks up KEY in the %makevars hash table. KEY may be a string "Looks up KEY in the %makevars hash table. KEY may be a string
or a procedure that evaluates to a string. or a procedure that evaluates to a string.
If the value of the key If the value of the key in the hash table was a *promise* it will be forced, evaluated, and set to that result.
in the hash table was a *promise* it will be forced, If no transformer is supplied, the looked up value will be returned.
evaluated, and set to that result. 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 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)) (when (and (not (string? key))
(not (procedure? key))) (not (procedure? key)))
(bad-key-type "reference" (list key))) (bad-key-type "reference" (list key)))
@ -387,6 +379,7 @@ space-separated token in the looked-up value."
(string-append "\"" val "\"") (string-append "\"" val "\"")
val))))) val)))))
;; FIXME-DOCS(Krey)
(define-syntax $ (define-syntax $
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
@ -395,6 +388,7 @@ space-separated token in the looked-up value."
((_ key) ((_ key)
#'(reference (symbol->string (syntax->datum #'key)) #f))))) #'(reference (symbol->string (syntax->datum #'key)) #f)))))
;; FIXME-DOCS(Krey)
(define-syntax Q (define-syntax Q
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
@ -404,38 +398,36 @@ space-separated token in the looked-up value."
#'(reference (symbol->string (syntax->datum #'key)) #t))))) #'(reference (symbol->string (syntax->datum #'key)) #t)))))
(define (reference-func key) (define (reference-func key)
"Looks up KEY in the %makevars hash table. KEY shall be a string "Looks up KEY in the %makevars hash table. KEY shall be a string or a procedure that evaluates to 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 If the value of the key is a string, a procedure will be returned that, when called, returns that string."
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)) (when (and (not (string? key))
(not (procedure? key))) (not (procedure? key)))
(bad-key-type "reference" (list key))) (bad-key-type "reference" (list key)))
(when (procedure? key) (when (procedure? key)
(set! key (key)) (set! key (key))
(unless (string? key) (unless (string? key)
(bad-proc-output "reference" key)) (bad-proc-output "reference" key))
(let* ((val&priority (hash-ref %makevars 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) (if (not val)
#f #f
;; else ;; else
(begin (begin
(if (promise? val) (if (promise? val)
(lambda () (lambda ()
(let ((VAL (force val))) (let ((VAL (force val)))
;; FIXME: put verbose print here? ;; FIXME(spk121): put verbose print here?
VAL)) VAL))
;; else ;; else
(lambda () (lambda ()
val))))))) val)))))))
;; FIXME-DOCS(Krey)
(define-syntax $$ (define-syntax $$
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
((_ key) ((_ key)
#'(reference-func (symbol->string (syntax->datum #'key))))))) #'(reference-func (symbol->string (syntax->datum #'key)))))))
;; makevards.scm ends here

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

@ -24,18 +24,23 @@
#:use-module (potato rules) #:use-module (potato rules)
#:use-module (potato text) #:use-module (potato text)
#:export( #:export(
read-line-handle-escaped-newline read-line-handle-escaped-newline
string-collapse-continuations string-collapse-continuations
string-count-backslashes-at-end string-count-backslashes-at-end
string-count-matching-chars-at-end string-count-matching-chars-at-end
string-find-char-unquote string-find-char-unquote
string-find-preceding-backslashes string-find-preceding-backslashes
string-find-repeated-chars string-find-repeated-chars
string-next-token string-next-token
string-remove-comments string-remove-comments
string-starts-with? string-starts-with?
string-shrink-whitespace string-shrink-whitespace))
))
;;; Commentary:
;;;
;;; DOCS
;;;
;;; Code:
(define (read-line-handle-escaped-newline) (define (read-line-handle-escaped-newline)
"Reads a line of text from the current input port. "Reads a line of text from the current input port.
@ -48,16 +53,16 @@ It returns two values
- the string containing the one or more lines read - the string containing the one or more lines read
- the number of lines read." - the number of lines read."
(let loop ((output "") (let loop ((output "")
(nline 0)) (nline 0))
(let ((line (read-line))) (let ((line (read-line)))
(if (eof-object? line) (if (eof-object? line)
(values output nline) (values output nline)
;; else ;; else
(if (odd? (string-count-backslashes-at-end line)) (if (odd? (string-count-backslashes-at-end line))
(loop (string-append output (string-drop-right line 1) "\n") (loop (string-append output (string-drop-right line 1) "\n")
(1+ nline)) (1+ nline))
;; else ;; else
(values (string-append output line "\n") (1+ nline))))))) (values (string-append output line "\n") (1+ nline)))))))
(define* (string-collapse-continuations str #:optional (squash-whitespace? #f)) (define* (string-collapse-continuations str #:optional (squash-whitespace? #f))
"Returns a new string where backslash+newline is discarded, and "Returns a new string where backslash+newline is discarded, and
@ -65,61 +70,60 @@ backslash+backslash+newline becomes backslash+newline. Any whitespace
after the newline may be squashed to a single space, if after the newline may be squashed to a single space, if
squash-whitespace? is #t." squash-whitespace? is #t."
(let loop ((str str) (let loop ((str str)
(newline-index (string-rindex str #\newline))) (newline-index (string-rindex str #\newline)))
(if (not newline-index) (if (not newline-index)
(string-copy str) (string-copy str)
;; else ;; else
(let* ((backslash-index (string-find-preceding-backslashes str newline-index)) (let* ((backslash-index (string-find-preceding-backslashes str newline-index))
(backslash-count (- newline-index backslash-index))) (backslash-count (- newline-index backslash-index)))
(cond (cond
((even? backslash-count) ((even? backslash-count)
;; We cut the number of backslashes in half, but, keep the newline. ;; We cut the number of backslashes in half, but, keep the newline.
(loop (loop
(string-append (string-append
(substring str 0 backslash-index) (substring str 0 backslash-index)
(make-string (quotient backslash-count 2) #\\) (make-string (quotient backslash-count 2) #\\)
(substring str newline-index)) (substring str newline-index))
(string-rindex str #\newline 0 backslash-index))) (string-rindex str #\newline 0 backslash-index)))
(else (else
;; We cut the number of backslashes in half, remove a backslash ;; We cut the number of backslashes in half, remove a backslash and newline, maybe squash any following whitespace.
;; and newline, maybe squash any following whitespace. (loop
(loop (string-append
(string-append (substring str 0 backslash-index)
(substring str 0 backslash-index) (make-string (quotient backslash-count 2) #\\)
(make-string (quotient backslash-count 2) #\\) (if squash-whitespace?
(if squash-whitespace? (string-shrink-whitespace
(string-shrink-whitespace (substring str (1+ newline-index))
(substring str (1+ newline-index)) 0)
0) (substring str (1+ newline-index))))
(substring str (1+ newline-index)))) (string-rindex str #\newline 0 backslash-index))))))))
(string-rindex str #\newline 0 backslash-index))))))))
;; FIXME-DOCS(Krey)
(define (string-count-backslashes-at-end str) (define (string-count-backslashes-at-end str)
(string-count-matching-chars-at-end str #\\)) (string-count-matching-chars-at-end str #\\))
;; FIXME-DOCS(Krey)
(define (string-count-matching-chars-at-end str c) (define (string-count-matching-chars-at-end str c)
(if (not (string? str)) (if (not (string? str))
0 0
;; else ;; else
(let ((len (string-length str))) (let ((len (string-length str)))
(if (zero? len) (if (zero? len)
0 0
;; else ;; else
(let loop ((i (1- len)) (let loop ((i (1- len))
(n 0)) (n 0))
(if (char=? (string-ref str i) c) (if (char=? (string-ref str i) c)
(if (zero? i) (if (zero? i)
(1+ n) (1+ n)
;; else ;; else
(loop (1- i) (1+ n))) (loop (1- i) (1+ n)))
;; else ;; else
n)))))) n))))))
(define* (string-find-char-unquote str #:optional (stop1 #f) (stop2 #f) #:key (blank #f) (ignorevars #f)) (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 "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.
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. 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 - A string with the quoting backslashes removed
- The position of the first unquoted stopchar, or #f" - The position of the first unquoted stopchar, or #f"
(let ((i 0) (let ((i 0)
(str2 (string-copy str)) (str2 (string-copy str))
(ret #f)) (ret #f))
(while #t (while #t
(while (and (< i (string-length str)) (while (and (< i (string-length str))
(not (or (not (or
(and stop1 (eqv? (string-ref str i) stop1)) (and stop1 (eqv? (string-ref str i) stop1))
(and stop2 (eqv? (string-ref str i) stop2)) (and stop2 (eqv? (string-ref str i) stop2))
(and ignorevars (eqv? (string-ref str i) #\$)) (and ignorevars (eqv? (string-ref str i) #\$))
(and blank (char-set-contains? char-set:blank (string-ref str i)))))) (and blank (char-set-contains? char-set:blank (string-ref str i))))))
(set! i (1+ i))) (set! i (1+ i)))
(when (>= i (string-length str)) (when (>= i (string-length str))
(break)) (break))
;; If we stopped due to a variable reference, skip its contents ;; If we stopped due to a variable reference, skip its contents
(when (and ignorevars (eqv? (string-ref str i) #\$)) (when (and ignorevars (eqv? (string-ref str i) #\$))
(let ((openparen (false-if-exception (string-ref str (1+ i))))) (let ((openparen (false-if-exception (string-ref str (1+ i)))))
(set! i (+ i 2)) (set! i (+ i 2))
(when (or (eqv? openparen #\() (eqv? openparen #\{)) (when (or (eqv? openparen #\() (eqv? openparen #\{))
(let ((pcount 1) (let ((pcount 1)
(closeparen (if (eqv? openparen #\() (closeparen (if (eqv? openparen #\()
#\) #\)
#\}))) #\})))
(while (< i (string-length str)) (while (< i (string-length str))
(cond (cond
((eqv? (string-ref str i) openparen) ((eqv? (string-ref str i) openparen)
(set! pcount (1+ pcount))) (set! pcount (1+ pcount)))
((eqv? (string-ref str i) closeparen) ((eqv? (string-ref str i) closeparen)
(set! pcount (1- pcount)) (set! pcount (1- pcount))
(when (zero? pcount) (when (zero? pcount)
(set! i (1+ i)) (set! i (1+ i))
(break)))) (break))))
(set! i (1+ i))))) (set! i (1+ i)))))
;; Skipped the variable reference: look for STOPCHARS again ;; Skipped the variable reference: look for STOPCHARS again
(continue))) (continue)))
(if (and (> i 0) (eqv? (string-ref str (1- i)) #\\)) (if (and (> i 0) (eqv? (string-ref str (1- i)) #\\))
;; Search for more backslashes ;; Search for more backslashes
(let ((j 2)) (let ((j 2))
(while (and (>= (- i j) 0) (while (and (>= (- i j) 0)
(eqv? (string-ref str (- i j)) #\\)) (eqv? (string-ref str (- i j)) #\\))
(set! j (1+ j))) (set! j (1+ j)))
(set! j (1- j)) (set! j (1- j))
;; Copy the string to swallow half the backslashes ;; Copy the string to swallow half the backslashes
(set! str2 (set! str2
(string-append (string-append
(string-take str (- i j)) (string-take str (- i j))
(string-drop str (- i (quotient j 2))))) (string-drop str (- i (quotient j 2)))))
(set! i (- i (quotient j 2))) (set! i (- i (quotient j 2)))
(when (even? j) (when (even? j)
;; All the backslashes quoted each other; the stopchar ;; All the backslashes quoted each other; the stopchar was unquoted
;; was unquoted (set! ret #t)
(set! ret #t) (break))
(break)) (set! str str2))
(set! str str2)) ;; else
;; else ;; no backslash in sight
;; no backslash in sight (begin
(begin (set! ret #t)
(set! ret #t) (break))))
(break))))
(if ret (if ret
(values i str2) (values i str2)
(values #f #f)))) (values #f #f))))
(define (string-find-preceding-backslashes str i) (define (string-find-preceding-backslashes str i)
"Given I, a position in a string, this returns a position, "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."
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)) (let loop ((j i))
(cond (cond
((= j 0) ((= j 0)
@ -211,60 +211,55 @@ I is returned."
j)))) j))))
(define (string-find-repeated-chars str c) (define (string-find-repeated-chars str c)
"Given a character c, this finds the position of of first instance "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"
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))) (let ((i (string-index str c)))
(if (not i) (if (not i)
#f #f
;; else ;; else
(let ((len (string-length str))) (let ((len (string-length str)))
(if (= (1+ i) len) (if (= (1+ i) len)
(cons i (1+ i)) (cons i (1+ i))
;; else ;; else
(let loop ((j (1+ i))) (let loop ((j (1+ i)))
(if (false-if-exception (char=? (string-ref str j) c)) (if (false-if-exception (char=? (string-ref str j) c))
(loop (1+ j)) (loop (1+ j))
;; else ;; else
(cons i j)))))))) (cons i j))))))))
(define (string-next-token str i) (define (string-next-token str i)
"Given a position i, this returns the position of the first "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."
non-whitespace character after i. If the end of line is reached,
it returns the length of the string."
(or (or
(string-index str (string-index str
(lambda (c) (lambda (c)
(char-set-contains? char-set:blank c)) (char-set-contains? char-set:blank c))
i) i)
(string-length str))) (string-length str)))
(define (string-remove-comments str) (define (string-remove-comments str)
"Returns a copy of str with any '#' comments removed" "Returns a copy of str with any '#' comments removed"
(let ((i (string-find-char-unquote str #\#))) (let ((i (string-find-char-unquote str #\#)))
(if i (if i
(string-take str i) (string-take str i)
(string-copy str)))) (string-copy str))))
(define (string-shrink-whitespace str start) (define (string-shrink-whitespace str start)
"Given a string, and a location in a string, this returns a new copy "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"
of string where all the whitespace beginning at location i is replaced
by a single space"
(let ((len (string-length str))) (let ((len (string-length str)))
(if (or (>= start len) (if (or (>= start len)
(not (char-set-contains? char-set:blank (string-ref str start)))) (not (char-set-contains? char-set:blank (string-ref str start))))
(string-copy str) (string-copy str)
;; else ;; else
(let loop ((end start)) (let loop ((end start))
(cond (cond
((>= end len) ((>= end len)
(string-append (substring str 0 start) " ")) (string-append (substring str 0 start) " "))
((char-set-contains? char-set:blank (string-ref str end)) ((char-set-contains? char-set:blank (string-ref str end))
(loop (1+ end))) (loop (1+ end)))
(else (else
(string-append (substring str 0 start) " " (substring str end)))))))) (string-append (substring str 0 start) " " (substring str end))))))))
(define (string-starts-with? str c) (define (string-starts-with? str c)
(char=? (string-ref str 0) c)) (char=? (string-ref str 0) c))
;;; parse-libs.scm ends here

9
src/potato/parse.scm
View File

@ -25,8 +25,13 @@
#:use-module (potato parse-lib) #:use-module (potato parse-lib)
#:export (parse _readline)) #:export (parse _readline))
;; A makefile can contain rules, macro definitions, include lines, ;;; Commentary:
;; and comments. ;;;
;;; DOCS
;;;
;;; Code:
;; A makefile can contain rules, macro definitions, include lines, and comments.
(define (parse filename) (define (parse filename)
(with-input-from-file filename _eval #:guess-encoding #t)) (with-input-from-file filename _eval #:guess-encoding #t))