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 12:46:29 +02:00
parent fc6e1016ec
commit 66772f99e8
Signed by: kreyren
GPG Key ID: 667F0DAFAF09BA2B
17 changed files with 262 additions and 252 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pmake
View File

@ -1,3 +0,0 @@
#!/usr/bin/env sh
exec guile -L . -e '(@ (pmake main) main)' -s "$0" "$@"
!#

20
pman Executable file
View File

@ -0,0 +1,20 @@
#!/usr/bin/env sh
# shellcheck shell=sh # Written to comply with IEEE Std 1003.1-2017 (POSIX)
# The Project Manager ("pman") -- GNU Guile-based solution for project management
# Copyright (C) 2022 Jacob Hrbek <kreyren@rixotstudio.cz>
#
# This file is Free/Libre Open-Source Software; you may copy, redistribute and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version.
# This file is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public license along with this project. If not, see <http://www.gnu.org/licenses>
#
# This file incorporates work covered by the following copyright and permission notice:
#
# Copyright (C) 2017-2021 Mike Gran <spk121@yahoo.com>
#
# Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
exec guile -L . -e '(@ (pmake main) main)' -s "$0" "$@"
!#

3
make/main.scm → src/pmake/main.scm
View File

@ -20,11 +20,10 @@
;;; Commentary: ;;; Commentary:
;;; ;;;
;;; Backend for the `pmake` command to process the command line arguments using the standardized 'getopts-long' as described in the GNU Guile reference manual <https://www.gnu.org/software/guile/manual/html_node/getopt_002dlong.html>. ;;; Backend for the `pman` command to process the command line arguments using the standardized 'getopts-long' as described in the GNU Guile reference manual <https://www.gnu.org/software/guile/manual/html_node/getopt_002dlong.html>.
;;; ;;;
;;; Code: ;;; Code:
;; FIXME-QA(Krey): Is this even needed?
;; Declare exit codes ;; Declare exit codes
(define EXIT_SUCCESS 0) (define EXIT_SUCCESS 0)
(define EXIT_NOT_UP_TO_DATE 1) (define EXIT_NOT_UP_TO_DATE 1)

0
make/zz-README.org → src/pmake/zz-README.org
View File

0
potato/zz-README.org~ → src/pmake/zz-README.org~
View File

45
potato/builtins.scm → src/potato/builtins.scm
View File

@ -16,13 +16,11 @@
(define-module (potato builtins) (define-module (potato builtins)
#:export (builtin-makevars #:export (builtin-makevars))
; builtin-rules
))
;;; Commentary: ;;; Commentary:
;;; ;;;
;;; Declaration of the built-in functionality such as variables and helper rules ;;; Dedicated to the declaration of built-in functionality such as variables, rules, tasks, etc..
;;; ;;;
;;; Code: ;;; Code:
@ -43,43 +41,4 @@
("GUILD" . "guild") ("GUILD" . "guild")
("GFLAGS" . "-W2"))) ("GFLAGS" . "-W2")))
;; FIXME(Krey): This was commented out by the original author and it's use needs to be abstracted and re-implemented
#;(define builtin-rules
`((".c"
""
(,~ ,($ CC) ,($ CFLAGS) ,($ LDFLAGS) "-o" ,$@ ,$<))
(".f"
""
(,~ ,($ FC) ,($ FFLAGS) ,($ LDFLAGS) "-o" ,$@ ,$<))
(".sh"
""
(,~ "cp" ,$< ,$@)
(,~ "chmod a+x" ,$@))
(".c"
".o"
(,~ ,($ CC) ,($ CFLAGS) -c ,$<))
(".f"
".o"
(,~ ,($ FC) ,($ FFLAGS) -c ,$<))
(".y"
".o"
(,~ ,($ YACC) ,($ YFLAGS) ,$<))
(".l"
".o"
(,~ ,($ LEX) ,($ LFLAGS) ,$<)
(,~ ,($ CC) ,($ CFLAGS) "-c" lex.yy.c)
"rm -f lex.yy.c"
(,~ "mv lex.yy.o" ,$@))
(".y"
".c"
(,~ ,($ YACC) ,($ YFLAGS) ,$<)
(,~ "mv y.tab.c" ,$@))
(".l"
".c"
(,~ ,($ LEX) ,($ LDFLAGS) ,$<)
("mv lex.yy.c" ,$@))
(".scm"
".go"
(,~ ,($ GUILD) "compile" ,($ GFLAGS) ,$<))))
;;; builtins.scm ends here ;;; builtins.scm ends here

31
potato/exceptions.scm → src/potato/exceptions.scm
View File

@ -14,7 +14,7 @@
;;; ;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE
-(define-module (potato exceptions) (define-module (potato exceptions)
#:use-module (ice-9 exceptions) #:use-module (ice-9 exceptions)
#:export (bad-key-type #:export (bad-key-type
bad-value-type bad-value-type
@ -22,30 +22,44 @@
invalid-macro invalid-macro
not-a-regular-file not-a-regular-file
not-a-procedure not-a-procedure
no-read-access-to-file no-read-access-to-file))
))
;;; Commentary:
;;;
;;; Dedicated to handling 'exceptions' as in termination of the program
;;;
;;; Code:
;; FIXME-QA(Krey): This code is using 'bad' which is hard to understand without context, thus should be changed on 'unexpected'
(define (make-bad-key-type origin irritants) (define (make-bad-key-type origin irritants)
"Exception used when bad key is parsed to 'make' functionality"
(make-exception (make-exception
(make-programming-error) (make-programming-error)
(make-exception-with-origin origin) (make-exception-with-origin origin)
;; FIXME-TRANSLATE(Krey)
(make-exception-with-message "Wrong type for key. Expecting string or procedure.") (make-exception-with-message "Wrong type for key. Expecting string or procedure.")
(make-exception-with-irritants irritants))) (make-exception-with-irritants irritants)))
(define (bad-key-type origin irritant) (define (bad-key-type origin irritant)
"Generic exception for unexpected key"
(raise-exception (make-bad-key-type origin irritant))) (raise-exception (make-bad-key-type origin irritant)))
(define (make-bad-value-type origin irritants) (define (make-bad-value-type origin irritants)
"Exception for unexpected value in the 'make' functionality"
(make-exception (make-exception
(make-programming-error) (make-programming-error)
(make-exception-with-origin origin) (make-exception-with-origin origin)
;; FIXME-TRANSLATE(Krey)
(make-exception-with-message "Wrong type for value. Expecting string or procedure.") (make-exception-with-message "Wrong type for value. Expecting string or procedure.")
(make-exception-with-irritants irritants))) (make-exception-with-irritants irritants)))
(define (bad-value-type origin irritant) (define (bad-value-type origin irritant)
"Generic exception for unexpected value"
(raise-exception (make-bad-value-type origin irritant))) (raise-exception (make-bad-value-type origin irritant)))
(define (make-bad-proc-output origin irritants) (define (make-bad-proc-output origin irritants)
"Exception for unexpected process output in 'make' functionality"
(make-exception (make-exception
(make-programming-error) (make-programming-error)
(make-exception-with-origin origin) (make-exception-with-origin origin)
@ -53,9 +67,11 @@
(make-exception-with-irritants irritants))) (make-exception-with-irritants irritants)))
(define (bad-proc-output origin irritant) (define (bad-proc-output origin irritant)
"Generic exception for unexpected process output"
(raise-exception (make-bad-proc-output origin irritant))) (raise-exception (make-bad-proc-output origin irritant)))
(define (make-invalid-macro origin irritants) (define (make-invalid-macro origin irritants)
"Exception for invalid macro in 'make' functionality"
(make-exception (make-exception
(make-programming-error) (make-programming-error)
(make-exception-with-origin origin) (make-exception-with-origin origin)
@ -63,9 +79,11 @@
(make-exception-with-irritants irritants))) (make-exception-with-irritants irritants)))
(define (invalid-macro origin irritant) (define (invalid-macro origin irritant)
"Generic exception for invalid macro"
(raise-exception (make-invalid-macro origin irritant))) (raise-exception (make-invalid-macro origin irritant)))
(define (make-not-a-regular-file origin irritants) (define (make-not-a-regular-file origin irritants)
"Exception for not regular file in 'make' functionality"
(make-exception (make-exception
(make-programming-error) (make-programming-error)
(make-exception-with-origin origin) (make-exception-with-origin origin)
@ -73,9 +91,11 @@
(make-exception-with-irritants irritants))) (make-exception-with-irritants irritants)))
(define (not-a-regular-file origin irritant) (define (not-a-regular-file origin irritant)
"Generic exception for when regular file is not parsed"
(raise-exception (make-not-a-regular-file origin irritant))) (raise-exception (make-not-a-regular-file origin irritant)))
(define (make-not-a-procedure origin irritants) (define (make-not-a-procedure origin irritants)
"Exception for when regular file is not parsed in the 'make' functionality"
(make-exception (make-exception
(make-programming-error) (make-programming-error)
(make-exception-with-origin origin) (make-exception-with-origin origin)
@ -83,9 +103,11 @@
(make-exception-with-irritants irritants))) (make-exception-with-irritants irritants)))
(define (not-a-procedure origin irritant) (define (not-a-procedure origin irritant)
"Generic exception for when procedure is not parsed"
(raise-exception (make-not-a-procedure origin irritant))) (raise-exception (make-not-a-procedure origin irritant)))
(define (make-no-read-access-to-file origin irritants) (define (make-no-read-access-to-file origin irritants)
"Exception for when we don't have the expected read access to the file in 'make' functionality"
(make-exception (make-exception
(make-programming-error) (make-programming-error)
(make-exception-with-origin origin) (make-exception-with-origin origin)
@ -93,4 +115,7 @@
(make-exception-with-irritants irritants))) (make-exception-with-irritants irritants)))
(define (no-read-access-to-file origin irritant) (define (no-read-access-to-file origin irritant)
"Generic exception for when we don't have the excepted read access to the file"
(raise-exception (make-no-read-access-to-file origin irritant))) (raise-exception (make-no-read-access-to-file origin irritant)))
;;; exceptions.scm end here

54
potato/make.scm → src/potato/make.scm
View File

@ -29,7 +29,6 @@
#:re-export (%suffix-rules #:re-export (%suffix-rules
lazy-assign ?= lazy-assign ?=
assign := assign :=
;; WTF(Krey): Why is the 'Q' here?
reference $ Q reference $ Q
reference-func $$ reference-func $$
target-rule : target-rule :
@ -47,26 +46,21 @@
;;; Commentary: ;;; Commentary:
;;; ;;;
;;; TBD ;;; Entry file to the project, designed for handling the functionality
;;; ;;;
;;; Code: ;;; Code:
;; FIXME-QA(Krey): This file includes debugging utilities that should be exported into a standalone library to make this software more maintainable
;; FIXME-QA(Krey): Needs refactor
;; FIXME-QA(Krey): Why is this here?
;; Project version ;; Project version
(define %version "1.0") (define %version "1.0")
;; WTF(Krey) ;; WTF(Krey)
(define %debug-argv0 #f) (define %debug-argv0 #f)
;; WTF(Krey): Was commented out by the original author.. no idea why ;; FIXME-DOCS(Krey): Lacks context
;; #:re-export (
;; lazy-assign ?=
;; assign :=
;; ref $
;; target-rule :
;; suffix-rule ->
;; compose ~
;; ))
;;; Asynchronous events. ;;; Asynchronous events.
;;; SIGHUP, SIGTERM, SIGINT and SIGQUIT remove the current target ;;; SIGHUP, SIGTERM, SIGINT and SIGQUIT remove the current target
;;; unless that target is a directory or the target is a prerequisite ;;; unless that target is a directory or the target is a prerequisite
@ -88,27 +82,31 @@
;;; If the -t option was specified, make shall write to standard ;;; If the -t option was specified, make shall write to standard
;;; output a message for each file that was touched. ;;; output a message for each file that was touched.
;;; Output handlers
;;; These handlers are designed to be used for debug management
;; Verbosity is 0 = silent, 1 = terse, 2 = default, 3 = verbose ;; Verbosity is 0 = silent, 1 = terse, 2 = default, 3 = verbose
(define %verbosity 2) (define %verbosity 2)
;; WTF(Krey) ;; WTF(Krey): Option to set verbose output and %verbosity defining the "deepness" of output?
(define %opt-verbose #f) (define %opt-verbose #f)
;; WTF(Krey) ;; WTF(Krey): Option to ignore errors?
(define %opt-ignore-errors #f) (define %opt-ignore-errors #f)
;; WTF(Krey) ;; WTF(Krey): Option to continue on errors?
(define %opt-continue-on-error #f) (define %opt-continue-on-error #f)
;; WTF(Krey) ;; WTF(Krey): Generic definition of targets for appending?
(define %targets '()) (define %targets '())
;; WTF(Krey) ;; WTF(Krey): No idea
(define %initialized #f) (define %initialized #f)
;; Output handlers
(define (critical spec . args) (define (critical spec . args)
"Output to handle 'cricital' output messages"
(apply format (append (list #t spec) args))) (apply format (append (list #t spec) args)))
;; FIXME-QA(Krey): The 'print' is too generic, should we rename it? ;; FIXME-QA(Krey): The 'print' is too generic, should we rename it?
(define (print spec . args) (define (print spec . args)
"Output to handle printing of output. Only works when verbosity is set to 2 and higher"
(when (>= %verbosity 2) (when (>= %verbosity 2)
(apply format (append (list #t spec) args)))) (apply format (append (list #t spec) args))))
(define (debug spec . args) (define (debug spec . args)
"Output to handle level 3 debug messages"
(when (>= %verbosity 3) (when (>= %verbosity 3)
(apply format (append (list #t spec) args)))) (apply format (append (list #t spec) args))))
@ -127,6 +125,7 @@
;; FIXME-QA(Krey): This is calling `format` multiple times to print one line which is resource inefficient ;; FIXME-QA(Krey): This is calling `format` multiple times to print one line which is resource inefficient
(define (display-help-and-exit argv0) (define (display-help-and-exit argv0)
"Function used to output help message and exit"
(format #t "~A [-hvqVeEbn] [KEY=VALUE ...] [targets ...]~%" argv0) (format #t "~A [-hvqVeEbn] [KEY=VALUE ...] [targets ...]~%" argv0)
(format #t " -h, --help print help and exit~%") (format #t " -h, --help print help and exit~%")
(format #t " -v, --version print version and exit~%") (format #t " -v, --version print version and exit~%")
@ -148,11 +147,11 @@
(format #t " ASCII only output and no colors~%") (format #t " ASCII only output and no colors~%")
(format #t " -S, --strict~%") (format #t " -S, --strict~%")
(format #t " causes some behaviours to throw errors~%") (format #t " causes some behaviours to throw errors~%")
;; FIXME-QA(Krey): 'exit'? It should be using 'throw'
(exit 0)) (exit 0))
;; FIXME-QA(Krey): Why is this accepting input?
(define (display-version-and-exit argv0) (define (display-version-and-exit argv0)
"Procedure to output the project version and exit" "Function to output the project version and exit"
(format #t "~a~%" argv0) (format #t "~a~%" argv0)
(format #t " using potato make~a~%" %version) (format #t " using potato make~a~%" %version)
(exit 0)) (exit 0))
@ -173,8 +172,7 @@ of pairs of KEY VAL"
lst)) lst))
(define (parse-targets lst) (define (parse-targets lst)
"Search the list for strings that don't have equals signs, and "Search the list for strings that don't have equals signs, and return them in a list."
return them in a list."
(filter-map (filter-map
(lambda (str) (lambda (str)
(if (string-index str #\=) (if (string-index str #\=)
@ -184,13 +182,7 @@ return them in a list."
(define* (initialize #:optional (define* (initialize #:optional
(arguments #f)) (arguments #f))
"Set up the options, rules, and makevars. If ARGUMENTS "Set up the options, rules, and makevars. If ARGUMENTS is not set, it will use options, makevars, and targets as specified by the command line. If it is set, it is expected to be a list of strings that are command-line arguments." ;; If left unset, assume user want all the command line arguments.
is not set, it will use options, makevars, and targets as
specified by the command line. If it is set, it is
expected to be a list of strings that are command-line
arguments."
;; If left unset, assume user want all the command line arguments.
(when (not arguments) (when (not arguments)
(set! arguments (command-line))) (set! arguments (command-line)))
;; If the user has set it to '(), expecting a null environment, add ;; If the user has set it to '(), expecting a null environment, add
@ -284,9 +276,7 @@ arguments."
%opt-no-execution %opt-no-execution
%verbosity %verbosity
%opt-ascii) %opt-ascii)
(set! %initialized #t) (set! %initialized #t) %targets)))
%targets
)))
(define* (execute #:key (targets '())) (define* (execute #:key (targets '()))
"This function runs build actions. TARGETS, if provided, is a list "This function runs build actions. TARGETS, if provided, is a list

357
potato/makevars.scm → src/potato/makevars.scm
View File

@ -21,46 +21,66 @@
#:use-module (potato builtins) #:use-module (potato builtins)
#:use-module (potato text) #:use-module (potato text)
#:export (initialize-makevars #:export (initialize-makevars
%makevars %makevars
%elevate-environment? %elevate-environment?
lazy-assign ?= lazy-assign ?=
assign := assign :=
reference $ Q reference $ Q
reference-func $$ reference-func $$
dump-makevars dump-makevars))
))
;;; Commentary:
;;;
;;; Used to handle the 'makevars' functionality meaning assigning and managing environmental variables into variables used by guile
;;;
;;; Code:
;; Defines the priority level
;; There are five priority levels ;; There are five priority levels
;; 1. defined - in the script itself ;; 1. defined - in the script itself
;; 2. command-line ;; 2. command-line
;; 3. makeflags - in the MAKEFLAGS environment variable ;; 3. makeflags - in the MAKEFLAGS environment variable
;; 4. env - specified in the environment ;; 4. env - specified in the environment
;; 5. built-in - one of the built-in macros ;; 5. built-in - one of the built-in macros
;;
;; The lower priority level always win, unless the '-e' flag was set ;; The lower priority level always win, unless the '-e' flag was set
;; If the '-e' flag is set level 1 doesn't override level 3 and 4. ;; If the '-e' flag is set level 1 doesn't override level 3 and 4.
(define %level-name '("unknown"
"script"
"command-line"
"makeflags"
"environment"
"built-in"))
(define %level-name '("unknown" "script" "command-line" "makeflags" "environment" "built-in")) ;; WTF(Krey): No fucking idea.. something with ASCII? If ASCII is supported?
(define %ascii? #f) (define %ascii? #f)
;; WTF(Krey)
(define %makevars (make-hash-table)) (define %makevars (make-hash-table))
;; WTF(Krey)
(define %elevate-environment? #f) (define %elevate-environment? #f)
;; WTF(Krey)
(define %strict #f) (define %strict #f)
;; WTF(Krey)
(define %verbose? #t) (define %verbose? #t)
;; WTF(Krey)
(define (debug spec . args) (define (debug spec . args)
"Output to handle debugging messages"
(when %verbose? (when %verbose?
(apply format (append (list #t spec) args)))) (apply format (append (list #t spec) args))))
(define (split-at-equals str) (define (split-at-equals str)
"Splits the string at the first equals sign, ignoring "Splits the string at the first equals sign, ignoring later equals signs."
later equals signs."
(let ((idx (string-index str #\=))) (let ((idx (string-index str #\=)))
(if (and idx (> idx 0)) (if (and idx (> idx 0))
(cons (substring str 0 idx) (cons (substring str 0 idx)
(substring str (1+ idx))) (substring str (1+ idx)))
;; else ;; else
#f))) #f)))
(define (string-append-with-spaces lst) (define (string-append-with-spaces lst)
"Appends the strings in lst, adding spaces in between." "Appends the strings in lst, adding spaces in between."
@ -75,69 +95,66 @@ later equals signs."
others." others."
(if %elevate-environment? (if %elevate-environment?
(if (and (or (= old-priority 2) (= old-priority 3) (= old-priority 4)) (if (and (or (= old-priority 2) (= old-priority 3) (= old-priority 4))
(= new-priority 1)) (= new-priority 1))
#f #f
;; else ;; else
(<= new-priority old-priority)) (<= new-priority old-priority))
;; else ;; else
(<= new-priority old-priority))) (<= new-priority old-priority)))
(define* (makevars-set key (define* (makevars-set key
#:optional (new-val "") (new-priority 1)) #:optional (new-val "") (new-priority 1))
"Maybe add key / val to %makevars hash table, if there is sufficient "Maybe add key / val to %makevars hash table, if there is sufficient
priority." priority."
;; Note that VAL can be either a string or a procedure. If it is a ;; Note that VAL can be either a string or a procedure. If it is a
;; procedure, it is converted into a promise to be evaluated later. ;; procedure, it is converted into a promise to be evaluated later.
(let* ((val&priority (hash-ref %makevars key)) (let* ((val&priority (hash-ref %makevars key))
(old-val (if (pair? val&priority) (cdr val&priority) #f)) (old-val (if (pair? val&priority) (cdr val&priority) #f))
(old-priority (if (pair? val&priority) (cdr val&priority) #f))) (old-priority (if (pair? val&priority) (cdr val&priority) #f)))
(when (or (not old-val) (when (or (not old-val)
(override? old-priority new-priority)) (override? old-priority new-priority))
(if (procedure? new-val) (if (procedure? new-val)
(hash-set! %makevars key (cons (delay new-val) new-priority)) (hash-set! %makevars key (cons (delay new-val) new-priority))
(hash-set! %makevars key (cons new-val new-priority))) (hash-set! %makevars key (cons new-val new-priority)))
(when %verbose? (print-makevar key)))) (when %verbose? (print-makevar key))))
*unspecified*) *unspecified*)
(define (makevars-add-keyvals keyvals) (define (makevars-add-keyvals keyvals)
"Adds any suitable macros passed in from the command line, which "Adds any suitable macros passed in from the command line, which here are expected to be a list of key / val string pairs."
here are expected to be a list of key / val string pairs."
(for-each (for-each
(lambda (entry) (lambda (entry)
(let ((key (car entry)) (let ((key (car entry))
(val (cdr entry))) (val (cdr entry)))
(unless (or (string=? key "SHELL") (unless (or (string=? key "SHELL")
(string=? key "MAKEFLAGS")) (string=? key "MAKEFLAGS"))
(makevars-set key val 2)))) (makevars-set key val 2))))
keyvals)) keyvals))
(define (makevars-add-makeflags) (define (makevars-add-makeflags)
"Adds any suitable environment variables found in the MAKEFLAGS "Adds any suitable environment variables found in the MAKEFLAGS environment variable to the macro store"
environment variable to the macro store"
(let ((makeflags (getenv "MAKEFLAGS"))) (let ((makeflags (getenv "MAKEFLAGS")))
(when makeflags (when makeflags
(for-each (for-each
(lambda (entry) (lambda (entry)
(let* ((keyval (split-at-equals entry)) (let* ((keyval (split-at-equals entry))
(key (if keyval (car keyval) #f)) (key (if keyval (car keyval) #f))
(val (if keyval (cdr keyval) #f))) (val (if keyval (cdr keyval) #f)))
(unless (or (not (string? key)) (unless (or (not (string? key))
(string=? key "SHELL") (string=? key "SHELL")
(string=? key "MAKEFLAGS")) (string=? key "MAKEFLAGS"))
(makevars-set key val 3)))) (makevars-set key val 3))))
(string-split makeflags #\space))))) (string-split makeflags #\space)))))
(define (makevars-add-environment) (define (makevars-add-environment)
"Adds any suitable environment variables to the macro store, but not "Adds any suitable environment variables to the macro store, but not the value of MAKEFLAGS or SHELL."
the value of MAKEFLAGS or SHELL."
(for-each (for-each
(lambda (entry) (lambda (entry)
(let* ((keyval (split-at-equals entry)) (let* ((keyval (split-at-equals entry))
(key (if keyval (car keyval) #f)) (key (if keyval (car keyval) #f))
(val (if keyval (cdr keyval) #f))) (val (if keyval (cdr keyval) #f)))
(unless (or (string=? key "SHELL") (unless (or (string=? key "SHELL")
(string=? key "MAKEFLAGS")) (string=? key "MAKEFLAGS"))
(makevars-set key val 4)))) (makevars-set key val 4))))
(environ))) (environ)))
(define (makevars-add-builtins) (define (makevars-add-builtins)
@ -147,44 +164,45 @@ the value of MAKEFLAGS or SHELL."
(makevars-set (car keyval) (cdr keyval) 5)) (makevars-set (car keyval) (cdr keyval) 5))
builtin-makevars)) builtin-makevars))
;; FIXME-DOCS(Krey)
(define (print-makevar key) (define (print-makevar key)
(let ((val (hash-ref %makevars key))) (let ((val (hash-ref %makevars key)))
(let ((keyval-string (let ((keyval-string
(if (zero? (string-length (car val))) (if (zero? (string-length (car val)))
(string-copy key) (string-copy key)
(string-append key " " (right-arrow) " " (car val))))) (string-append key " " (right-arrow) " " (car val)))))
;; Replace any control characters in VAL, like newline or tab ;; Replace any control characters in VAL, like newline or tab
(set! keyval-string (set! keyval-string
(string-fold (string-fold
(lambda (c str) (lambda (c str)
(string-append str (string-append str
(if (char<? c #\space) (if (char<? c #\space)
(C0 c) (C0 c)
(string c)))) (string c))))
"" ""
keyval-string)) keyval-string))
;; Truncate ;; Truncate
(if (> (string-length keyval-string) 60) (if (> (string-length keyval-string) 60)
(if %ascii? (if %ascii?
(set! keyval-string (set! keyval-string
(string-append (substring keyval-string 0 57) "...")) (string-append (substring keyval-string 0 57) "..."))
(set! keyval-string (set! keyval-string
(string-append (substring keyval-string 0 59) "…")))) (string-append (substring keyval-string 0 59) "…"))))
(let* ((space (make-string (- 64 (string-length keyval-string)) (let* ((space (make-string (- 64 (string-length keyval-string))
#\space)) #\space))
(priority (cdr val)) (priority (cdr val))
(source-string (list-ref '("unknown" (source-string (list-ref '("unknown"
"script" "script"
"command line" "command line"
"MAKEFLAGS" "MAKEFLAGS"
"environment" "environment"
"built-in") "built-in")
priority))) priority)))
(display "Var: ") (display "Var: ")
(display keyval-string) (display keyval-string)
(display space) (display space)
(display source-string) (display source-string)
(newline))))) (newline)))))
(define (dump-makevars) (define (dump-makevars)
"Write out a list of the current makevars." "Write out a list of the current makevars."
@ -194,59 +212,60 @@ the value of MAKEFLAGS or SHELL."
(display (default)) (display (default))
(newline) (newline)
(let ((keyvals (let ((keyvals
(sort (sort
(hash-map->list cons %makevars) (hash-map->list cons %makevars)
(lambda (a b) (lambda (a b)
(string<? (car a) (car b)))))) (string<? (car a) (car b))))))
(for-each (for-each
(lambda (keyval) (lambda (keyval)
(let ((key (car keyval)) (let ((key (car keyval))
(val (cdr keyval))) (val (cdr keyval)))
(let ((keyval-string (let ((keyval-string
(if (zero? (string-length (car val))) (if (zero? (string-length (car val)))
(string-copy key) (string-copy key)
(string-append key " " (right-arrow) " " (car val))))) (string-append key " " (right-arrow) " " (car val)))))
;; Replace any control characters in VAL, like newline or tab ;; Replace any control characters in VAL, like newline or tab
(set! keyval-string (set! keyval-string
(string-fold (string-fold
(lambda (c str) (lambda (c str)
(string-append str (string-append str
(if (char<? c #\space) (if (char<? c #\space)
(C0 c) (C0 c)
(string c)))) (string c))))
"" ""
keyval-string)) keyval-string))
;; Truncate ;; Truncate
(if (> (string-length keyval-string) 60) (if (> (string-length keyval-string) 60)
(if %ascii? (if %ascii?
(set! keyval-string (set! keyval-string
(string-append (substring keyval-string 0 57) "...")) (string-append (substring keyval-string 0 57) "..."))
(set! keyval-string (set! keyval-string
(string-append (substring keyval-string 0 59) "…")))) (string-append (substring keyval-string 0 59) "…"))))
(let* ((space (make-string (- 64 (string-length keyval-string)) (let* ((space (make-string (- 64 (string-length keyval-string))
#\space)) #\space))
(priority (cdr val)) (priority (cdr val))
(source-string (list-ref '("unknown" (source-string (list-ref '("unknown"
"script" "script"
"command line" "command line"
"MAKEFLAGS" "MAKEFLAGS"
"environment" "environment"
"built-in") "built-in")
priority))) priority)))
(display " ") (display " ")
(display keyval-string) (display keyval-string)
(display space) (display space)
(display source-string) (display source-string)
(newline))))) (newline)))))
keyvals)))) keyvals))))
;; FIXME-DOCS(Krey)
(define (initialize-makevars keyvals (define (initialize-makevars keyvals
environment? environment?
elevate-environment? elevate-environment?
builtins? builtins?
strict? strict?
verbosity verbosity
ascii?) ascii?)
(set! %elevate-environment? elevate-environment?) (set! %elevate-environment? elevate-environment?)
(hash-clear! %makevars) (hash-clear! %makevars)
(set! %strict strict?) (set! %strict strict?)
@ -316,13 +335,13 @@ or a procedure that evaluates to a string.
in the hash table was a *promise* it will be forced, in the hash table was a *promise* it will be forced,
evaluated, and set to that result. evaluated, and set to that result.
If no transformer is supplied, the looked up value will be If no transformer is supplied, the looked up value will be
returned. returned.
TRANSFORMER, if TRANSFORMER, if
supplied, should be a procedure of one string argument that returns a supplied, should be a procedure of one string argument that returns a
string. If a transformer is supplied, it will be applied to every string. If a transformer is supplied, it will be applied to every
space-separated token in the looked-up value." 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)))
(when (procedure? key) (when (procedure? key)
(set! key (key)) (set! key (key))
@ -331,42 +350,42 @@ space-separated token in the looked-up value."
(when (not (string? key)) (when (not (string? key))
(set! key (format #t "~a" key))) (set! key (format #t "~a" key)))
(let* ((val&priority (hash-ref %makevars key)) (let* ((val&priority (hash-ref %makevars key))
(val (if (pair? val&priority) (car val&priority) #f)) (val (if (pair? val&priority) (car val&priority) #f))
(priority (if (pair? val&priority) (cdr val&priority) #f))) (priority (if (pair? val&priority) (cdr val&priority) #f)))
(if (not val) (if (not val)
(if %strict (if %strict
(error (format #t "There is no makevar for key ~a~%~!" key)) (error (format #t "There is no makevar for key ~a~%~!" key))
;; else ;; else
(if quoted? (if quoted?
"\"\"" "\"\""
"")) ""))
;; else ;; else
(begin (begin
(cond (cond
((promise? val) ((promise? val)
(set! val (force val)) (set! val (force val))
(cond (cond
((string? val) ((string? val)
;; noop ;; noop
#t) #t)
((procedure? val) ((procedure? val)
(set! val (val))) (set! val (val)))
(else (else
(set! val (format #f "~a" val))))) (set! val (format #f "~a" val)))))
((string? val) ((string? val)
;; noop ;; noop
#f) #f)
(else (else
(set! val (format #f "~a" val)))) (set! val (format #f "~a" val))))
(hash-set! %makevars key (cons val priority)) (hash-set! %makevars key (cons val priority))
(when %verbose? (print-makevar key)) (when %verbose? (print-makevar key))
(when (procedure? transformer) (when (procedure? transformer)
(set! val (string-append-with-spaces (set! val (string-append-with-spaces
(map transformer (map transformer
(string-tokenize val))))) (string-tokenize val)))))
(if quoted? (if quoted?
(string-append "\"" val "\"") (string-append "\"" val "\"")
val))))) val)))))
(define-syntax $ (define-syntax $
(lambda (stx) (lambda (stx)

0
potato/parse-lib.scm → src/potato/parse-lib.scm
View File

0
potato/parse.scm → src/potato/parse.scm
View File

0
potato/parser.scm → src/potato/parser.scm
View File

0
potato/rules.scm → src/potato/rules.scm
View File

0
potato/text.scm → src/potato/text.scm
View File

0
potato/zz-README.org → src/potato/zz-README.org
View File

0
src/potato/zz-README.org~ Normal file
View File

1
src/zz-README.org Normal file
View File

@ -0,0 +1 @@
Source code of the project