116 lines
4.3 KiB
Scheme
116 lines
4.3 KiB
Scheme
#!r6rs
|
|
;; Scheme includes pre-processor.
|
|
;;
|
|
;; All include/resolve statements are replaced with scheme data contained in the referenced file.
|
|
;; File content is placed within a (begin) block.
|
|
;;
|
|
;; TODO Remove headers print HACK in replace-source. Maybe via a (values) return?
|
|
;;
|
|
;; Written by Akce 2020.
|
|
;; SPDX-License-Identifier: Unlicense
|
|
|
|
(library (private install sipp)
|
|
(export
|
|
directory-separator-string
|
|
join-string
|
|
replace-source)
|
|
(import
|
|
(rnrs)
|
|
(only (chezscheme) directory-separator))
|
|
|
|
;; [proc] replace-source: opens a scheme file, replacing all instances of (include/resolve) with contents of file.
|
|
;; [return] scheme list object with forms embedded.
|
|
;; HACK ALERT: this also prints the header lines to (current-output-port) assuming that callers will print the
|
|
;; HACK ALERT: returned object to this same port. It's an easy way to get all headers followed by code/data.
|
|
(define replace-source
|
|
(case-lambda
|
|
[(path)
|
|
(replace-source path #f)]
|
|
[(path print-sipp-header)
|
|
(with-input-from-file path
|
|
(lambda ()
|
|
(when print-sipp-header
|
|
(display ";; DO NOT EDIT THIS FILE!!")(newline)
|
|
(display ";; This inlined chez-srfi library code is autogenerated using command:")(newline)
|
|
(display ";; $ ")(display (apply join-string " " (command-line)))(newline)
|
|
(display ";; Source origin: https://github.com/arcfide/chez-srfi")(newline)
|
|
(display ";; Please refer to project site for full credits and original code.")(newline))
|
|
;; Print initial header block. Hopefully that's a language tag and copyright info.
|
|
;; ie, print lines till we hit the first scheme statement or empty line.
|
|
;; NOTE: multiline comments are *not* handled.
|
|
(display ";;;;;; File header: ")(display path)(newline)
|
|
(let loop ()
|
|
(case (peek-char)
|
|
[(#\# #\;)
|
|
(display (get-line (current-input-port)))
|
|
(newline)
|
|
(loop)]))
|
|
(let loop ([obj (read)] [acc '()])
|
|
(cond
|
|
[(eof-object? obj)
|
|
(reverse acc)]
|
|
[else
|
|
(loop (read) (cons (replace-object obj) acc))]))))]))
|
|
|
|
;; [proc] replace-object: recurses through a scheme list object, replacing all (include/resolve) calls with the
|
|
;; contents of the referred to file.
|
|
(define replace-object
|
|
(lambda (obj)
|
|
(cond
|
|
[(pair? obj)
|
|
(case (car obj)
|
|
[(include/resolve)
|
|
`(begin
|
|
,@(include/resolve (cdr obj)))
|
|
]
|
|
[else
|
|
(imap replace-object obj)])]
|
|
[else
|
|
obj])))
|
|
|
|
(define directory-separator-string (list->string `(,(directory-separator))))
|
|
|
|
;; (include/resolve ((?dir ?dirn ...) ?filename))
|
|
(define include/resolve
|
|
(lambda (args)
|
|
(let ([dir-args (car args)]
|
|
[filename (cadr args)])
|
|
;; construct the path and let replace-source earn its keep.
|
|
(replace-source (apply join-string directory-separator-string (append (cdr dir-args) (list filename)))))))
|
|
|
|
;; [proc] imap: simple map that handles improper lists.
|
|
(define imap
|
|
(lambda (proc ilist)
|
|
(let loop ([i ilist])
|
|
(cond
|
|
[(null? i)
|
|
i]
|
|
[else #;(pair? i)
|
|
(cons* (proc (car i))
|
|
(cond
|
|
[(list? (cdr i))
|
|
(loop (cdr i))]
|
|
[else
|
|
(proc (cdr i))]))]))))
|
|
|
|
;; [proc] string-join: join all string parts together using separator.
|
|
;;
|
|
;; Note that the signature to this version of join-string differs to string-join in SRFI-13.
|
|
;; The separator is the first arg and therefore always explicit which allows for the string
|
|
;; parts as regular arguments, rather than a list of strings.
|
|
;;
|
|
;; Naive implementation that uses (potentially) multiple calls to string-append.
|
|
(define join-string
|
|
(lambda (sep . str-parts)
|
|
(cond
|
|
[(null? str-parts)
|
|
""]
|
|
[else
|
|
(let loop ([acc (car str-parts)] [rest (cdr str-parts)])
|
|
(cond
|
|
[(null? rest)
|
|
acc]
|
|
[else
|
|
(loop (string-append acc sep (car rest)) (cdr rest))]))])))
|
|
)
|