make sextest's (compilation ...) form work

1. Look for `compilation', not `compile' among the source
2. Read the file with provided --features from the (compilation ...)
form, then handle resulting file to sexc
This commit is contained in:
2026-09-16 17:41:31 +03:00
parent 294a275905
commit 6e4cb80424
3 changed files with 50 additions and 18 deletions

2
.gitignore vendored
View File

@@ -3,3 +3,5 @@
*.link *.link
sexc sexc
sex-tests sex-tests
sextest
tools/sextest/sextest

View File

@@ -1,3 +1,6 @@
(module reader (read-from-file (module reader (read-from-file
read-raw-forms) read-raw-forms
current-features
platform-features)
"../../reader.scm") "../../reader.scm")

View File

@@ -7,36 +7,63 @@
(chicken port) (chicken port)
(chicken process) (chicken process)
(chicken process-context) (chicken process-context)
(chicken string) ; string-split
fmt fmt
getopt-long getopt-long
reader ; read-raw-forms, shared with sexc reader ; read-raw-forms, shared with sexc
srfi-1) srfi-1
srfi-13) ; string-prefix?
(define (print-help) (define (print-help)
(fmt #t "Usage: sextest [options] filename" nl (fmt #t "Usage: sextest [options] filename" nl
"Options:" nl "Options:" nl
(usage opts-grammar) nl)) (usage opts-grammar) nl))
(define (process-file target-path) (define (split-settings contents)
(let ((contents (read-raw-forms target-path))) (foldl (lambda (acc elt)
(foldl (lambda (acc elt) (case (car elt)
(case (car elt) ((compilation input output return)
((compilation input output return) (cons
(cons (append (car acc) (list elt))
(append (car acc) (list elt)) (cdr acc)))
(cdr acc))) (else
(else (cons
(cons (car acc)
(car acc) (append (cdr acc) (list elt))))))
(append (cdr acc) (list elt)))))) (cons (list) (list))
(cons (list) (list)) contents))
contents)))
(define (compile src flags sexc) ;;; --features from the (compilation ...) form, which we have to honour
;;; ourselves: the program is read here and printed back out for sexc,
;;; so #+ and #- are resolved on this side
(define (compilation-features settings)
(let ((compilation (assoc 'compilation settings)))
(if compilation
(append-map (lambda (flag)
(if (string-prefix? "--features=" flag)
(map string->symbol
(string-split (substring flag 11) ","))
(list)))
(string-split (cadr compilation)))
(list))))
(define (process-file target-path)
(let* ((first-pass (split-settings (read-raw-forms target-path)))
(features (compilation-features (car first-pass))))
(if (null? features)
first-pass
(parameterize ((current-features (append (platform-features) features)))
(split-settings (read-raw-forms target-path))))))
(define (compile src compilation sexc)
(let ((compiler (or (let ((compiler (or
(and sexc (cdr sexc)) (and sexc (cdr sexc))
(get-environment-variable "SEXC") (get-environment-variable "SEXC")
"sexc")) "sexc"))
;; (compilation "--features=x -- -O2") -- one string
(flags (if compilation
(string-split (cadr compilation))
(list)))
(compiled-file (create-temporary-file))) (compiled-file (create-temporary-file)))
;; `process' returns one record; `process-input-port' is named from ;; `process' returns one record; `process-input-port' is named from
;; the child's side, so it is the port we write to. ;; the child's side, so it is the port we write to.
@@ -110,7 +137,7 @@
(let* ((settings-and-src (process-file path)) (let* ((settings-and-src (process-file path))
(settings (car settings-and-src)) (settings (car settings-and-src))
(src (cdr settings-and-src)) (src (cdr settings-and-src))
(compiled-file (compile src (assoc 'compile settings) sexc))) (compiled-file (compile src (assoc 'compilation settings) sexc)))
(if (not compiled-file) (if (not compiled-file)
(begin (fmt #t "Failed to compile " path nl) (begin (fmt #t "Failed to compile " path nl)
#f) #f)